|
sourcecode:
|
module ReadFlatTRS(readRules,readRulesAndData,readFlatCurryRules) where
import qualified TRS
import FlatCurry.Types as FC
import FlatCurry.Files (readFlatCurry)
import OrCaseLifter
----------------------------------------------------------------------------
-- Reading rules from a (Flat)Curry file:
readRules :: String -> IO [TRS.Rule]
readRules prog = do
putStrLn $ "Reading rules from Curry program " ++ prog ++ "..."
flatprog <- readFlatCurry prog
return (fst (curry2rules flatprog))
-- Reading rules and data declarations from a (Flat)Curry file:
readRulesAndData :: String -> IO ([TRS.Rule],[TypeDecl])
readRulesAndData prog = do
putStrLn $ "Reading rules from Curry program " ++ prog ++ "..."
flatprog <- readFlatCurry prog
return (curry2rules flatprog)
-- Read FlatCurry program and return it together with the rules
-- transformed into a TRS:
readFlatCurryRules :: String -> IO (Prog,[TRS.Rule])
readFlatCurryRules prog = do
putStrLn $ "Reading rules from Curry program " ++ prog ++ "..."
flatprog <- readFlatCurry prog
return (flatprog, fst $ curry2rules flatprog)
curry2rules (Prog modname _ tdecls fdecls _) =
if any TRS.containsApply crules
then (TRS.addApplyRules crules, tdecls)
else (crules, tdecls)
where
rules = concatMap fdecl2rules (liftNestedOrCase (modname,"ORCASE_") fdecls)
crules = if any TRS.containsChoice rules then TRS.addChoiceRules rules
else rules
-- translate function declaration into rules:
fdecl2rules (FC.Func (_,fname) arity _ _ (External _)) =
[TRS.Rule fname (genArgs arity) (TRS.Func TRS.Def "EXTERNAL" [])]
where
genArgs n = map TRS.Var [1..n]
fdecl2rules (FC.Func fname _ _ _ (FC.Rule lhs rhs)) =
map patternrule2rule patternrules
where
patternrules = rule2equations (Comb FuncCall fname (map Var lhs)) rhs
patternrule2rule (l,r) =
let (TRS.Func _ f args) = transExp l
in TRS.Rule f args (transExp r)
transExp (FC.Var i) = TRS.Var i
transExp (Lit (Intc i)) = TRS.Func TRS.Cons (show i) []
transExp (Lit (Floatc f)) = TRS.Func TRS.Cons (show f) []
transExp (Lit (Charc c)) = TRS.Func TRS.Cons ['\'',c,'\''] []
transExp (Comb ct (_,f) args) =
TRS.Func (if ct==FuncCall then TRS.Def else TRS.Cons) f (map transExp args)
transExp (Free _ exp) = transExp exp
transExp (Let _ _) = error "Let not yet supported"
transExp (FC.Or _ _) = error "Or not yet supported"
transExp (Case _ _ _) = error "Case not yet supported"
----------------------------------------------------------------------------
-- transform a rule consisting of a left- and a right-hand side
-- (represented as expressions) into a set of pattern matching rules:
rule2equations :: Expr -> Expr -> [(Expr,Expr)]
rule2equations lhs (FC.Or e1 e2) =
rule2equations lhs e1 ++ rule2equations lhs e2
rule2equations lhs (Case ctype e bs) =
if isVarExpr e then let Var i = e in caseIntoLhs lhs i bs
else [(lhs,Case ctype e bs)]
rule2equations lhs (Var i) = [(lhs,Var i)]
rule2equations lhs (Lit l) = [(lhs,Lit l)]
rule2equations lhs (Comb ct name args) = [(lhs,Comb ct name args)]
rule2equations lhs (Free vs e) = [(lhs,Free vs e)]
rule2equations lhs (Let bs e) = [(lhs,Let bs e)]
caseIntoLhs _ _ [] = []
caseIntoLhs lhs vi (Branch (Pattern c vs) e : bs) =
rule2equations (substitute [vi] [shallowPattern2Expr c vs] lhs) e
++ caseIntoLhs lhs vi bs
caseIntoLhs lhs vi (Branch (LPattern lit) e : bs) =
rule2equations (substitute [vi] [Lit lit] lhs) e
++ caseIntoLhs lhs vi bs
shallowPattern2Expr name vars = Comb ConsCall name (map (\i->Var i) vars)
-- (substitute vars exps expr) = expr[vars/exps]
-- i.e., replace all occurrences of vars by corresponding exps in the
-- expression expr
substitute vars exps expr = substituteAll vars exps 0 expr
-- (substituteAll vars exps base expr):
-- substitute all occurrences of variables by corresonding expressions:
-- * substitute all occurrences of var_i by exp_i in expr
-- (if vars=[var_1,...,var_n] and exps=[exp_1,...,exp_n])
-- * substitute all other variables (Var j) by (Var (base+j))
--
-- here we assume that the new variables in guards and case patterns
-- do not occur in the list "vars" of replaced variables!
substituteAll :: [Int] -> [Expr] -> Int -> Expr -> Expr
substituteAll vars exps b (Var i) = replaceVar vars exps i
where replaceVar [] [] var = Var (b+var)
replaceVar (v:vs) (e:es) var = if v==var then e
else replaceVar vs es var
substituteAll _ _ _ (Lit l) = Lit l
substituteAll vs es b (Comb combtype c exps) =
Comb combtype c (map (substituteAll vs es b) exps)
substituteAll vs es b (Let bindings exp) =
Let (map (\(x,e)->(x+b,substituteAll vs es b e)) bindings)
(substituteAll vs es b exp)
substituteAll vs es b (Free vars e) =
Free (map (+b) vars) (substituteAll vs es b e)
substituteAll vs es b (FC.Or e1 e2) =
FC.Or (substituteAll vs es b e1) (substituteAll vs es b e2)
substituteAll vs es b (Case ctype e cases) =
Case ctype (substituteAll vs es b e) (map (substituteAllCase vs es b) cases)
substituteAllCase vs es b (Branch (Pattern l pvs) e) =
Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e)
substituteAllCase vs es b (Branch (LPattern l) e) =
Branch (LPattern l) (substituteAll vs es b e)
-- Is the expression a guarded expressions?
isGuardedExpr :: Expr -> Bool
isGuardedExpr e = case e of
Comb _ f _ -> f == ("Prelude","cond")
_ -> False
-- Is the expression a variable?
isVarExpr :: Expr -> Bool
isVarExpr e = case e of
Var _ -> True
_ -> False
---------------------------------------------------------------------------
|