Commit c6e01c9f authored by Michael Hanus's avatar Michael Hanus
Browse files

currypp seqrules: code refactoring

parent 3b62930d
......@@ -11,6 +11,7 @@ CASS/cass
CASS/cass_worker
curry2js/Curry2JS
currypp/Main
currypp/SequentialRules/Main
currydoc/CurryDoc
currytest/CurryTest
createmakefile/CreateMakefile
......
-- Example with multiple guards:
negOrPos x | x<0 = "Neg"
| x>0 = "Pos"
\ No newline at end of file
{-# OPTIONS_CYMAKE -F --pgmF=currypp --optF=--seqrules #-}
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
{-# OPTIONS_CYMAKE -Wnone #-}
-- Reverse a list if it has exactly two elements:
rev2 [x,y] = [y,x]
......
......@@ -26,7 +26,7 @@ import List(isPrefixOf)
import PrettyAbstract(showCProg)
import System
import Sequential hiding(main,applySequential)
import Sequential
main :: IO ()
main = do
......
......@@ -134,7 +134,7 @@ translate (CPLit v) = CLit v
translate (CPAs n _) = CVar n
translate (CPFuncComb qn pl) = applyF qn (map translate pl)
translate (CPLazy p) = translate p
translate (CPRecord _ _) = error "Records are not supported in this version"
translate (CPRecord _ _) = error "Records are not supported in this version of the sequential rule translator!"
......
......@@ -9,13 +9,10 @@
module Selection where
import AbstractCurry
{- In diesem Modul ist ein Prädikat definiert, welches überprüft
ob eine Funktion deterministisch ist. Alle weiten Funktionen
sind dabei unterstützdend.
-}
import Unsafe(trace)
--Dieses Prädikat testet, ob eine Funktion deterministisch ist.
--- Test whether a function definition is non-deterministic, i.e.,
--- not defined by inductively sequential rules.
isnondeterministic :: CFuncDecl -> Bool
isnondeterministic (CFunc _ _ _ _ rulel)
| length (prefilter rulel) > 1 = checkIArgs ([],(prefilter rulel))
......@@ -31,28 +28,32 @@ checkIArgs (_,[]) = True
checkIArgs t@(i,ls@(_:_)) = if (all isCons ls)
then continue (conca ls i)
else checkIArgs (cutnext t)
where continue (x:xs) | (length (x:(filter (equal x) xs))) > 1 = checkIArgs ([],(stepin (x:(filter (equal x) xs))))
|| continue (filter (diffrent x) xs)
| otherwise = continue xs
continue [] = False
stepin l = map stepin' l
stepin' ((CPComb _ x):xs) = x ++ xs
stepin' ((CPLit _) :xs) = xs
equal ((CPComb a _) : _) ((CPComb b _) : _) | a == b = True
| otherwise = False
equal ((CPLit a) : _) ((CPLit b) : _) | a == b = True
| otherwise = False
diffrent a b = not (equal a b)
isCons [] = False
isCons (x:_) = case x of CPComb _ _ -> True
CPLit _ -> True
_ -> False
where
continue (x:xs) | (length (x:(filter (equal x) xs))) > 1
= checkIArgs ([],(stepin (x:(filter (equal x) xs))))
|| continue (filter (\y -> not (equal x y)) xs)
| otherwise = continue xs
continue [] = False
stepin xs = map stepin' xs
stepin' ((CPComb _ x):xs) = x ++ xs
stepin' ((CPLit _) :xs) = xs
equal ((CPComb a _) : _) ((CPComb b _) : _) | a == b = True
| otherwise = False
equal ((CPLit a) : _) ((CPLit b) : _) | a == b = True
| otherwise = False
isCons [] = False
isCons (x:_) = case x of CPComb _ _ -> True
CPLit _ -> True
_ -> False
--Zusammenführung von Listen von Listen.
conca :: [[a]] -> [[a]] -> [[a]]
conca (a:as) (l:ls) = (a ++ l) : (conca as ls)
conca [] ls@(_:_) = ls
conca as@(_:_) [] = as
conca (x:xs) (y:ys) = (x ++ y) : (conca xs ys)
conca [] ys@(_:_) = ys
conca xs@(_:_) [] = xs
conca [] [] = []
--Das jeweils erste Element der "rechten" Listen wird an die
......@@ -73,10 +74,8 @@ prefilter patl = map (map removeAsP) (map prefilter' patl)
prefilter' (CRule pl _) = pl
removeAsP x = case x of (CPAs _ p) -> p
(CPLazy p) -> p
(CPLazy p) -> warnLazyPattern p
_ -> x
warnLazyPattern =
trace "WARNING: lazy patterns not supported in sequential rule translator!"
------------------------------------------------------------------------------
--- Module defining main operations to transform programs.
--- Module defining main operations to transform programs in order to
--- implement a sequential rule selection strategy.
---
--- @author Lasse Folger (with changes by Michael Hanus)
--- @version June 2015
......@@ -8,127 +9,111 @@
import Reduction
import AbstractCurry
import AbstractCurryGoodies
import List(partition)
import PrettyAbstract
import Translation
import Selection
import System
{-In diesem Modul sind die Hauptfunktionalitäten der anderen Module zusammen geführt.
Zudem findet hier die Umbenennung des Moduls statt, d.h. alle qualifizierten Namen werden,
sofern nötig, umbenannt. Es wird mittel der Kommandozeilen Argumente ein Modul eingelesen,
die Umbenennung durchgeführt, anschließend die Übersetzung und zuletzt wird das Programm
mit dem Prettyprinter wieder ausgegeben.
-}
main :: Prelude.IO ()
main = do
args <- getArgs
applySequential args
--Hier wird das zu übersetzende Modul eingelesen weitergerecht und das übersetze
--Modul wieder ausgegeben.
applySequential :: [String] -> IO ()
applySequential args = do
inputProg <- (AbstractCurry.readCurry input)
writeFile (outputName ++ ".curry") (showCProg (translate inputProg outputName))
where input = head args
outputName = head (tail args)
--Die Funktion ist für die Übersetzung des Moduls zuständig, dazu zählt zunächst
--die Umbenennung, dann die drei Schritte der Übersetzung, Selektion, Reduktion und
--die eigentlich Übersetzung.
--- Main operation to translate a Curry module into a new one implementing
--- a sequential rule selection strategy. It consists of the selection
--- of operations defined by non-deterministic patterns, reduce patterns
--- to a normalized structure, and renaming qualified names to the
--- name of the output module.
translate :: CurryProg -> String -> CurryProg
translate inputProg outputName = outputProg
where (CurryProg a b c funcs d) = inputProg
(det,ndet) = filterFunc newfuncs
simpleProg = Reduction.newprog (CurryProg a b c ndet d)
(CurryProg a' b' _ d' e) = Translation.newprog simpleProg outputName
outputProg = CurryProg a' b' newtypes (d' ++ det) e
newtypes = renameT a outputName c
newfuncs = renameF a outputName funcs
--Eine Funktionsliste wird aufgeteilt in deterministische und nicht-deterministische
--Funktionen.
filterFunc :: [CFuncDecl] -> ([CFuncDecl],[CFuncDecl])
filterFunc x = filterFunc' (reverse x) ([],[])
where filterFunc' [] ft = ft
filterFunc' (f:fs) (d,nd)
| isnondeterministic f = filterFunc' fs (d,f:nd)
| otherwise = filterFunc' fs (f:d,nd)
--Funktionen die durch alle Strukturen des Moduls laufen
--und qualifizierte Namen ersetzen
where
(CurryProg a b c funcs d) = inputProg
renamedtypes = renameT a outputName c
renamedfuncs = renameF a outputName funcs
(ndet,det) = partition isnondeterministic renamedfuncs
simpleProg = Reduction.newprog (CurryProg a b c ndet d)
(CurryProg a' b' _ d' e) = Translation.newprog simpleProg outputName
outputProg = CurryProg a' b' renamedtypes (d' ++ det) e
-- Operations to rename qualified names to new module name.
-- Rename qualified name.
renameQN :: String -> String -> QName -> QName
renameQN iname oname (a,b) = if a == iname then (oname,b) else (a,b)
-- Rename type declarations.
renameT :: String -> String -> [CTypeDecl] -> [CTypeDecl]
renameT iname oname x = map renameTD' x
where rename' n = rename iname oname n
renameTD' (CType n a b c) = CType (rename' n) a b (map renameC c)
renameTD' (CTypeSyn n a b t) = CTypeSyn (rename' n) a b (renameTE t)
renameTD' (CNewType n a b t) = CNewType (rename' n) a b (renameC t)
renameC (CCons n v t) = CCons (rename' n) v (map renameTE t)
renameC (CRecord n v fs) = CRecord (rename' n) v (map renameFD fs)
renameFD (CField n v te) = CField (rename' n) v (renameTE te)
renameTE v@(CTVar _) = v
renameTE (CFuncType i o) = CFuncType (renameTE i) (renameTE o)
renameTE (CTCons n t) = CTCons (rename' n) (map renameTE t)
renameRec t = map renameRec' t
renameRec' (n,te) = (n, renameTE te)
rename :: String -> String -> (String,String) -> (String,String)
rename iname oname (a,b) = if a == iname then (oname,b) else (a,b)
renameT iname oname x = map renameTD x
where
rename n = renameQN iname oname n
renameTD (CType n a b c) = CType (rename n) a b (map renameC c)
renameTD (CTypeSyn n a b t) = CTypeSyn (rename n) a b (renameTE t)
renameTD (CNewType n a b t) = CNewType (rename n) a b (renameC t)
renameC (CCons n v t) = CCons (rename n) v (map renameTE t)
renameC (CRecord n v fs) = CRecord (rename n) v (map renameFD fs)
renameFD (CField n v te) = CField (rename n) v (renameTE te)
renameTE v@(CTVar _) = v
renameTE (CFuncType i o) = CFuncType (renameTE i) (renameTE o)
renameTE (CTCons n t) = CTCons (rename n) (map renameTE t)
-- Rename function declarations.
renameF :: String -> String -> [CFuncDecl] -> [CFuncDecl]
renameF iname oname fl = map renameF' fl
where rename' n = rename iname oname n
renameF' (CFunc n a v te r) = CFunc (rename' n) a v (renameTE te) (map renameR r)
renameF' (CmtFunc c n a v te r) = CmtFunc c (rename' n) a v (renameTE te) (map renameR r)
renameTE te = case te of
(CTVar _) -> te
(CFuncType i o) -> CFuncType (renameTE i) (renameTE o)
(CTCons n t) -> CTCons (rename' n) (map renameTE t)
renameRec t = map renameRec' t
renameRec' (n,te) = (n, renameTE te)
renameR (CRule p rhs) = CRule (renameP p) (renameRhs rhs)
renameRhs (CSimpleRhs exp ld) = CSimpleRhs (renameE exp) (renameLD ld)
renameRhs (CGuardedRhs gs ld) = CGuardedRhs (renameG gs) (renameLD ld)
renameP p = map renameP' p
renameP' pat = case pat of
(CPComb n pa) -> CPComb (rename' n) (renameP pa)
(CPAs id p) -> CPAs id (renameP' p)
(CPFuncComb n pa) -> CPFuncComb (rename' n) (renameP pa)
(CPLazy p) -> CPLazy (renameP' p)
(CPRecord m t) -> CPRecord m (map renamePRec t)
_ -> pat
renamePRec (n,te) = (n, renameP' te)
renameG x = map renameG' x
renameG' (e1,e2) = (renameE e1, renameE e2)
renameE exp = case exp of
(CVar _) -> exp
(CLit _) -> exp
(CSymbol n) -> CSymbol (rename' n)
(CApply e1 e2) -> CApply (renameE e1) (renameE e2)
(CLambda pa e) -> CLambda (renameP pa) (renameE e)
(CLetDecl ld e) -> CLetDecl (renameLD ld) (renameE e)
(CDoExpr s) -> CDoExpr (renameS s)
(CListComp e s) -> CListComp (renameE e) (renameS s)
(CCase ct e b) -> CCase ct (renameE e) (map renameB b)
(CTyped e t) -> CTyped (renameE e) (renameTE t)
(CRecConstr n re) -> CRecConstr (rename' n) (renameRC re)
(CRecUpdate e re) -> CRecUpdate (renameE e) (renameRC re)
renameLD x = map renameLD' x
renameLD' locd = case locd of
(CLocalFunc fd) -> CLocalFunc (renameF' fd)
(CLocalPat p rhs) -> CLocalPat (renameP' p) (renameRhs rhs)
(CLocalVars _) -> locd
renameS x = map renameS' x
renameS' sta = case sta of
(CSExpr e) -> CSExpr (renameE e)
(CSPat p e) -> CSPat (renameP' p) (renameE e)
(CSLet ld) -> CSLet (renameLD ld)
renameB (p,rhs) = (renameP' p, renameRhs rhs)
renameRC x = map renameRC' x
renameRC' (s,e) = (rename' s, renameE e)
where
rename n = renameQN iname oname n
renameF' (CFunc n a v te r) =
CFunc (rename n) a v (renameTE te) (map renameR r)
renameF' (CmtFunc c n a v te r) =
CmtFunc c (rename n) a v (renameTE te) (map renameR r)
renameTE te = case te of
(CTVar _) -> te
(CFuncType i o) -> CFuncType (renameTE i) (renameTE o)
(CTCons n t) -> CTCons (rename n) (map renameTE t)
renameR (CRule p rhs) = CRule (map renameP p) (renameRhs rhs)
renameRhs (CSimpleRhs exp ld) = CSimpleRhs (renameE exp) (map renameLD ld)
renameRhs (CGuardedRhs gs ld) = CGuardedRhs (map renameG gs) (map renameLD ld)
renameP pat@(CPVar _) = pat
renameP pat@(CPLit _) = pat
renameP (CPComb n pa) = CPComb (rename n) (map renameP pa)
renameP (CPAs id p) = CPAs id (renameP p)
renameP (CPFuncComb n pa) = CPFuncComb (rename n) (map renameP pa)
renameP (CPLazy p) = CPLazy (renameP p)
renameP (CPRecord m t) = CPRecord m (map renamePRec t)
renamePRec (n,te) = (n, renameP te)
renameG (e1,e2) = (renameE e1, renameE e2)
renameE exp@(CVar _) = exp
renameE exp@(CLit _) = exp
renameE (CSymbol n) = CSymbol (rename n)
renameE (CApply e1 e2) = CApply (renameE e1) (renameE e2)
renameE (CLambda pa e) = CLambda (map renameP pa) (renameE e)
renameE (CLetDecl ld e) = CLetDecl (map renameLD ld) (renameE e)
renameE (CDoExpr s) = CDoExpr (map renameS s)
renameE (CListComp e s) = CListComp (renameE e) (map renameS s)
renameE (CCase ct e b) = CCase ct (renameE e) (map renameB b)
renameE (CTyped e t) = CTyped (renameE e) (renameTE t)
renameE (CRecConstr n re) = CRecConstr (rename n) (map renameRC re)
renameE (CRecUpdate e re) = CRecUpdate (renameE e) (map renameRC re)
renameLD locd = case locd of
(CLocalFunc fd) -> CLocalFunc (renameF' fd)
(CLocalPat p rhs) -> CLocalPat (renameP p) (renameRhs rhs)
(CLocalVars _) -> locd
renameS sta = case sta of
(CSExpr e) -> CSExpr (renameE e)
(CSPat p e) -> CSPat (renameP p) (renameE e)
(CSLet ld) -> CSLet (map renameLD ld)
renameB (p,rhs) = (renameP p, renameRhs rhs)
renameRC (s,e) = (rename s, renameE e)
......
......@@ -53,44 +53,47 @@ buildexp :: [(String,String)] -> [([CPattern],CExpr,CExpr,[CLocalDecl])] -> Stri
buildexp _ [] _ _ _ = (constF (pre "failed"),[])
buildexp ((cn,en):ns) ((ps,c,e,ld):rs) mN nv te
| alwaysTrue c && all isVar ps = (doexpr,[exloc])
| otherwise = (applyF (pre "if_then_else") [check, doexpr, re], [cloc, exloc] ++ rloc)
where isVar p = case p of
(CPVar _) -> True
_ -> False
(re,rloc) = buildexp ns rs mN nv te
cte = redefte te
ld' = removedouble ld ps
redefte texpr = case texpr of
(CFuncType x y) -> CFuncType x (redefte y)
_ -> (CTCons (pre "Success") [])
cloc = CLocalFunc (cfunc (mN,cn) arity Private cte clocrule)
clocrule = [guardedRule ps [(c,(CSymbol (pre "success")))] ld']
exloc = CLocalFunc (cfunc (mN,en) arity Private te explocrule)
explocrule = [guardedRule ps [(c,e)] ld']
newvars [] = []
newvars (x:xs) = (CVar x) : (newvars xs)
nva = newvars nv
doexpr = applyF (mN,en) nva
arity = length ps
check = applyF ("SetFunctions","notEmpty") [check']
check'
| arity == 0 = applyF ("SetFunctions","set0") [constF (mN,cn)]
| arity <= 7 = applyF ("SetFunctions","set" ++ (show(length ps))) ([constF (mN,cn)] ++ nva)
| otherwise = error "only functions with an arity with 7 or less are supported"
| otherwise = (applyF (pre "if_then_else") [check, doexpr, re],
[cloc, exloc] ++ rloc)
where
isVar p = case p of
(CPVar _) -> True
_ -> False
(re,rloc) = buildexp ns rs mN nv te
cte = redefte te
ld' = removedouble ld ps
redefte texpr = case texpr of
(CFuncType x y) -> CFuncType x (redefte y)
_ -> (CTCons (pre "Success") [])
cloc = CLocalFunc (cfunc (mN,cn) arity Private cte clocrule)
clocrule = [guardedRule ps [(c,(CSymbol (pre "success")))] ld']
exloc = CLocalFunc (cfunc (mN,en) arity Private te explocrule)
explocrule = [guardedRule ps [(c,e)] ld']
newvars [] = []
newvars (x:xs) = (CVar x) : (newvars xs)
nva = newvars nv
doexpr = applyF (mN,en) nva
arity = length ps
check = applyF ("SetFunctions","notEmpty") [check']
check' | arity == 0 = applyF ("SetFunctions","set0") [constF (mN,cn)]
| arity <= 7 = applyF ("SetFunctions","set" ++ show (length ps))
([constF (mN,cn)] ++ nva)
| otherwise = error "only functions with arity <= 7 are supported"
--Hilfsfunktion, um Namenskonflikte (zwischen Pattern
--und freien Variablen) zu vermeiden
removedouble :: [CLocalDecl] -> [CPattern] -> [CLocalDecl]
removedouble ld ps = filter (notin patvars) ld
where patvars = getPVars ps
getPVars [] = []
getPVars (x:xs) = (getPVars' x) ++ (getPVars xs)
getPVars' pat = case pat of
(CPVar (_,n)) -> [n]
_ -> []
notin pl locd = case locd of
(CLocalVars lvars) -> all (`notElem` pl) (map snd lvars) --notElem n pl
_ -> True
where
patvars = getPVars ps
getPVars [] = []
getPVars (x:xs) = (getPVars' x) ++ (getPVars xs)
getPVars' pat = case pat of
(CPVar (_,n)) -> [n]
_ -> []
notin pl locd = case locd of
(CLocalVars lvars) -> all (`notElem` pl) (map snd lvars)
_ -> True
--Erzeugt bei Bedarf eine Abstractcurry LetDecl
letDecl :: [CLocalDecl] -> CExpr -> CExpr
......@@ -135,63 +138,53 @@ gather (CRule p (CGuardedRhs gs ld)) = build gs
getNames :: [([CPattern],CExpr,CExpr,[CLocalDecl])] -> [String]
getNames [] = []
getNames ((p,g,e,l):rs) =
getPNames p ++ getENames g ++ getENames e ++ getLNames l ++ getNames rs
where getPNames [] = []
getPNames (pa:pas) = (getPNames' pa) ++ (getPNames pas)
getPNames' pa = case pa of
(CPVar (_,n)) -> [n]
(CPComb (_,n) ps) -> n : (getPNames ps)
(CPAs (_,n) pat) -> n : (getPNames' pat)
(CPFuncComb (_,n) ps) -> n : (getPNames ps)
(CPLazy pat) -> (getPNames' pat)
_ -> []
getENames expr = case expr of
(CVar (_,n)) -> [n]
(CSymbol (_,n)) -> [n]
(CApply e1 e2) -> (getENames e1) ++ (getENames e2)
(CLambda ps e1) -> (getPNames ps) ++ (getENames e1)
(CLetDecl ld e1) -> (getLNames ld) ++ (getENames e1)
(CDoExpr sl) -> getSNames sl
(CListComp e1 sl) -> (getENames e1) ++ (getSNames sl)
(CCase _ e1 be) -> (getENames e1) ++ (getBNames be)
_ -> []
getLNames [] = []
getLNames (lo:los) = (getLNames' lo) ++ (getLNames los)
getLNames' lo = case lo of
(CLocalFunc fd) -> getFNames fd
(CLocalPat pa rhs) -> getPNames' pa ++ getRhsNames rhs
(CLocalVars lvars) -> map snd lvars
getSNames [] = []
getSNames (s:sl) = (getSNames' s) ++ (getSNames sl)
getSNames' s = case s of
(CSExpr e1) -> getENames e1
(CSPat pa e1) -> (getPNames' pa) ++ (getENames e1)
(CSLet ld) -> getLNames ld
getBNames [] = []
getBNames ((pa,e1):bs) = getPNames' pa ++ getRhsNames e1 ++ getBNames bs
getGNames [] = []
getGNames ((g1,e1):gs) = (getENames g1) ++ (getENames e1) ++ (getGNames gs)
getFNames f = case f of
(CFunc (_,n) _ _ _ r) -> n : (getRSNames r)
(CmtFunc _ (_,n) _ _ _r) -> n : (getRSNames r)
getRhsNames (CSimpleRhs re ls) = getENames re ++ getLNames ls
getRhsNames (CGuardedRhs gs ls) = getGNames gs ++ getLNames ls
getRSNames [] = []
getRSNames (ru:rus) = (getRSNames' ru) ++ (getRSNames rus)
getRSNames' (CRule pas rhs) = getPNames pas ++ getRhsNames rhs
concatMap getPNames p ++ getENames g ++ getENames e ++
concatMap getLNames l ++ getNames rs
where
getPNames (CPVar (_,n)) = [n]
getPNames (CPLit _) = []
getPNames (CPComb (_,n) ps) = n : (concatMap getPNames ps)
getPNames (CPAs (_,n) pat) = n : (getPNames pat)
getPNames (CPFuncComb (_,n) ps) = n : (concatMap getPNames ps)
getPNames (CPLazy pat) = (getPNames pat)
getPNames (CPRecord (_,n) fds) = n : concatMap getFdPNames fds
getFdPNames ((_,n),pat) = n : getPNames pat
getFdENames ((_,n),pat) = n : getENames pat
getENames (CVar (_,n)) = [n]
getENames (CLit _) = []
getENames (CSymbol (_,n)) = [n]
getENames (CApply e1 e2) = getENames e1 ++ getENames e2
getENames (CLambda ps e1) = concatMap getPNames ps ++ getENames e1
getENames (CLetDecl ld e1) = concatMap getLNames ld ++ getENames e1
getENames (CDoExpr sl) = concatMap getSNames sl
getENames (CListComp e1 sl) = getENames e1 ++ concatMap getSNames sl
getENames (CCase _ e1 be) = getENames e1 ++ concatMap getBNames be
getENames (CTyped te _) = getENames te
getENames (CRecConstr (_,n) fds) = n : concatMap getFdENames fds
getENames (CRecUpdate re fds) = getENames re ++ concatMap getFdENames fds
getLNames (CLocalFunc fd) = getFNames fd
getLNames (CLocalPat pa rhs) = getPNames pa ++ getRhsNames rhs
getLNames (CLocalVars lvars) = map snd lvars
getSNames (CSExpr e1) = getENames e1
getSNames (CSPat pa e1) = getPNames pa ++ getENames e1
getSNames (CSLet ld) = concatMap getLNames ld
getBNames (pa,be) = getPNames pa ++ getRhsNames be
getGNames (gd,ge) = getENames gd ++ getENames ge
getFNames (CFunc (_,n) _ _ _ r) = n : concatMap getRSNames r
getFNames (CmtFunc _ (_,n) _ _ _r) = n : concatMap getRSNames r
getRhsNames (CSimpleRhs re ls) = getENames re ++ concatMap getLNames ls
getRhsNames (CGuardedRhs gs ls) = concatMap getGNames gs ++
concatMap getLNames ls
getRSNames (CRule pas rhs) = concatMap getPNames pas ++ getRhsNames rhs
......@@ -11,66 +11,62 @@ import AbstractCurry
import List
--gathers the used variablenames
-- gathers the used variable names
varsInRule:: CRule -> [String]
varsInRule rule = nub (getRVars rule)
where getPVars [] = []
getPVars (x:xs) = (getPVars' x) ++ (getPVars xs)
getPVars' p = case p of
(CPVar (_,n)) -> [n]
(CPFuncComb _ pl) -> getPVars pl
(CPComb _ pl) -> getPVars pl
(CPAs (_,n) pa) -> n : (getPVars' pa)
(CPLazy lp) -> getPVars' lp
_ -> []
getGVars [] = []
getGVars ((x,y):xs) = getEVars x ++ getEVars y ++ getGVars xs
where
getPVars (CPVar (_,n)) = [n]
getPVars (CPLit _) = []
getPVars (CPFuncComb _ pl) = concatMap getPVars pl
getPVars (CPComb _ pl) = concatMap getPVars pl
getPVars (CPAs (_,n) pa) = n : getPVars pa
getPVars (CPLazy lp) = getPVars lp
getPVars (CPRecord _ fds) = concatMap (getPVars . snd) fds
getGVars (x,y) = getEVars x ++ getEVars y
getRhsVars (CSimpleRhs rhs ldecls) = getEVars rhs ++ getLVars ldecls
getRhsVars (CGuardedRhs gs ldecls) = getGVars gs ++ getLVars ldecls
getEVars e = case e of
(CVar (_,n)) -> [n]
(CApply _ ae) -> getEVars ae
(CLambda pl le) -> (getPVars pl) ++ (getEVars le)
(CLetDecl ld le) -> (getLVars ld) ++ (getEVars le)
-- nur in main? (CDoExpr _) -> ?
(CListComp le sl) -> (getEVars le) ++ (getSVars sl)
(CCase _ ce bl) -> (getEVars ce) ++ (getBVars bl)
_ -> []
getSVars [] = []
getSVars (x:xs) = (getSVars' x) ++ (getSVars xs)
getSVars' s = case s of
(CSExpr e) -> getEVars e
(CSPat p e) -> (getPVars' p) ++ (getEVars e)
(CSLet ld) -> getLVars ld
getBVars [] = []
getBVars ((p,rhs):xs) = getPVars' p ++ getRhsVars rhs ++ getBVars xs
getRhsVars (CSimpleRhs rhs ldecls) = getEVars rhs ++ concatMap getLVars ldecls
getRhsVars (CGuardedRhs gs ldecls) = concatMap getGVars gs ++
concatMap getLVars ldecls
getEVars (CVar (_,n)) = [n]
getEVars (CLit _) = []
getEVars (CSymbol _) = []
getEVars (CApply e1 e2) = getEVars e1 ++ getEVars e2
getEVars (CLambda pl le) = concatMap getPVars pl ++ getEVars le
getEVars (CLetDecl ld le) = concatMap getLVars ld ++ getEVars le
getEVars (CDoExpr sl) = concatMap getSVars sl
getEVars (CListComp le sl) = getEVars le ++ concatMap getSVars sl
getEVars (CCase _ ce bl) = getEVars ce ++ concatMap getBVars bl
getEVars (CTyped te _) = getEVars te
getEVars (CRecConstr _ upds) = concatMap (getEVars . snd) upds
getEVars (CRecUpdate re upds) = getEVars re ++ concatMap (getEVars . snd) upds
getSVars (CSExpr e) = getEVars e
getSVars (CSPat p e) = getPVars p ++ getEVars e
getSVars (CSLet ld) = concatMap getLVars ld
getBVars (p,rhs) = getPVars p ++ getRhsVars rhs
getLVars [] = []
getLVars (x:xs) = getLVars' x ++ getLVars xs
getLVars' ld = case ld of
(CLocalFunc f) -> getFVars f
(CLocalPat p rhs) -> getPVars' p ++ getRhsVars rhs
(CLocalVars lvars) -> map snd lvars
getFVars (CFunc _ _ _ _ r) = concatMap getRVars r
getFVars (CmtFunc _ _ _ _ _ r) = concatMap getRVars r
getLVars (CLocalFunc f) = getFVars f
getLVars (CLocalPat p rhs) = getPVars p ++ getRhsVars rhs
getLVars (CLocalVars lvars) = map snd lvars