module Curry.FlatCurry.Tools (
progName, progImports, progTypes, progFuncs, progOps,
updProg, updProgName, updProgImports, updProgTypes, updProgFuncs, updProgOps,
updProgExps, rnmAllVarsProg, allVarsProg, updQNamesProg,
rnmProg,
updQNamesType,allConstructors,consQName, consArity, isTypeSyn, isDataTypeDecl,
isPublicType, isPublicCons,typeQName,isExternalType,
funcName, funcArity, funcVisibility, funcType, funcRule,
updFunc, updFuncName, updFuncArity, updFuncVisibility, updFuncType,
updFuncRule,
funcArgs, funcBody, funcRHS, isExternal, isCombFunc,
updFuncArgs, updFuncBody,
incVarsFunc, rnmAllVarsFunc, allVarsFunc, updQNamesFunc,
isRuleExternal, ruleArgs, ruleBody,
updRule, updRuleArgs, updRuleBody,
rnmAllVarsRule, allVarsRule, updQNamesRule,
isTypeVar, isFuncType, isTypeCons, typeConsName, argTypes, resultType,
isIOType,typeArity, allTVars,
rnmAllVarsTypeExpr, allTypeCons,
isVar, varNr, isLit, isComb, isFree, isOr, isCase, isLet, isGround,
literal, combType, exprFromFreeDecl, orExps,
isFuncCall, isPartCall, isConsCall, combFunc, combCons, combArgs,
missingFuncArgs, hasName, caseBranches,
rnmAllVars, allVars,
mapVar, mapLit, mapComb, mapFree, mapOr, mapCase, mapLet,
isCombFuncCall, isCombPartCall, isCombConsCall, missingArgs,
branchPattern, branchExpr, isConsPattern,
updBranch, updBranchPattern, updBranchExpr,
patCons, patArgs, patLiteral, patExpr,
rnmAllVarsBranch, allVarsBranch,
rnmAllVarsPat, allVarsPat,
opName
) where
import Data.Maybe
import Data.Char
import Data.List
import Curry.FlatCurry.Type
infixr 5 -:-
zipWith' _ [] [] = []
zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys
x -:- xs = Comb ConsCall ("Prelude",":") [x,xs]
nil = Comb ConsCall ("Prelude","[]") []
char_ :: Char -> Expr
char_ c = Lit (Charc c)
int_ :: Integer -> Expr
int_ n = Lit (Intc n)
float_ :: Double -> Expr
float_ f = Lit (Floatc f)
list_ :: [Expr] -> Expr
list_ [] = nil
list_ (x:xs) = x -:- list_ xs
string_ :: String -> Expr
string_ = list_ . map char_
updProg fn fi ft ff fo (Prog name imps types funcs ops)
= Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
progName :: Prog -> String
progName (Prog name _ _ _ _) = name
updProgName :: (String -> String) -> Prog -> Prog
updProgName f = updProg f id id id id
progImports :: Prog -> [String]
progImports (Prog _ imps _ _ _) = imps
updProgImports :: ([String] -> [String]) -> Prog -> Prog
updProgImports f = updProg id f id id id
progTypes :: Prog -> [TypeDecl]
progTypes (Prog _ _ types _ _) = types
updProgTypes :: ([TypeDecl] -> [TypeDecl]) -> Prog -> Prog
updProgTypes f = updProg id id f id id
progFuncs :: Prog -> [FuncDecl]
progFuncs (Prog _ _ _ funcs _) = funcs
updProgFuncs :: ([FuncDecl] -> [FuncDecl]) -> Prog -> Prog
updProgFuncs f = updProg id id id f id
progOps :: Prog -> [OpDecl]
progOps (Prog _ _ _ _ ops) = ops
updProgOps :: ([OpDecl] -> [OpDecl]) -> Prog -> Prog
updProgOps f = updProg id id id id f
updProgExps :: (Expr -> Expr) -> Prog -> Prog
updProgExps = updProgFuncs . map . updFuncBody
rnmAllVarsProg :: (Int -> Int) -> Prog -> Prog
rnmAllVarsProg = updProgFuncs . map . rnmAllVarsFunc
allVarsProg :: Prog -> [Int]
allVarsProg = concatMap allVarsFunc . progFuncs
updQNamesProg :: (QName -> QName) -> Prog -> Prog
updQNamesProg f
= updProg id id (map (updQNamesType f)) (map (updQNamesFunc f))
(map (\ (Op name fix prec) -> Op (f name) fix prec))
rnmProg :: String -> Prog -> Prog
rnmProg name p = updProgName (const name) (updQNamesProg rnm p)
where
rnm (mod,n) | mod==progName p = (name,n)
| otherwise = (mod,n)
allConstructors :: TypeDecl -> [ConsDecl]
allConstructors (TypeSyn _ _ _ _) = []
allConstructors (Type _ _ _ cs) = cs
consQName :: ConsDecl -> QName
consQName (Cons n _ _ _) = n
consArity :: ConsDecl -> Int
consArity (Cons _ a _ _) = a
updQNamesType :: (QName -> QName) -> TypeDecl -> TypeDecl
updQNamesType f (Type name vis vars decls)
= Type (f name) vis vars (map (updQNamesConsDecl f) decls)
updQNamesType f (TypeSyn name vis vars t)
= TypeSyn (f name) vis vars (updQNamesTypeExpr f t)
updQNamesConsDecl :: (QName -> QName) -> ConsDecl -> ConsDecl
updQNamesConsDecl f (Cons name arity vis args)
= Cons (f name) arity vis (map (updQNamesTypeExpr f) args)
isDataTypeDecl :: TypeDecl -> Bool
isDataTypeDecl (TypeSyn _ _ _ _) = False
isDataTypeDecl (Type _ _ _ cs) = not (null cs)
isExternalType :: TypeDecl -> Bool
isExternalType (TypeSyn _ _ _ _) = False
isExternalType (Type _ _ _ cs) = null cs
isTypeSyn :: TypeDecl -> Bool
isTypeSyn (Type _ _ _ _) = False
isTypeSyn (TypeSyn _ _ _ _) = True
isPublicType :: TypeDecl -> Bool
isPublicType (Type _ vis _ _) = vis==Public
isPublicType (TypeSyn _ vis _ _) = vis==Public
isPublicCons :: ConsDecl -> Bool
isPublicCons (Cons _ _ vis _) = vis==Public
typeQName :: TypeDecl -> QName
typeQName (TypeSyn n _ _ _) = n
typeQName (Type n _ _ _) = n
updFunc fn fa fv ft fr (Func name arity vis t rule)
= Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
funcName :: FuncDecl -> QName
funcName (Func name _ _ _ _) = name
updFuncName :: (QName -> QName) -> FuncDecl -> FuncDecl
updFuncName f = updFunc f id id id id
funcArity :: FuncDecl -> Int
funcArity (Func _ arity _ _ _) = arity
updFuncArity :: (Int -> Int) -> FuncDecl -> FuncDecl
updFuncArity f = updFunc id f id id id
funcVisibility :: FuncDecl -> Visibility
funcVisibility (Func _ _ vis _ _) = vis
isPublicFunc :: FuncDecl -> Bool
isPublicFunc (Func _ _ vis _ _) = vis==Public
updFuncVisibility :: (Visibility -> Visibility) -> FuncDecl -> FuncDecl
updFuncVisibility f = updFunc id id f id id
funcType :: FuncDecl -> TypeExpr
funcType (Func _ _ _ t _) = t
updFuncType :: (TypeExpr -> TypeExpr) -> FuncDecl -> FuncDecl
updFuncType f = updFunc id id id f id
funcRule :: FuncDecl -> Rule
funcRule (Func _ _ _ _ rule) = rule
updFuncRule :: (Rule -> Rule) -> FuncDecl -> FuncDecl
updFuncRule f = updFunc id id id id f
updQNamesFunc :: (QName -> QName) -> FuncDecl -> FuncDecl
updQNamesFunc f = updFunc f id id (updQNamesTypeExpr f) (updQNamesRule f)
funcArgs :: FuncDecl -> Maybe [Int]
funcArgs = ruleArgs . funcRule
updFuncArgs :: ([Int] -> [Int]) -> FuncDecl -> FuncDecl
updFuncArgs = updFuncRule . updRuleArgs
funcBody :: FuncDecl -> Maybe Expr
funcBody = ruleBody . funcRule
updFuncBody :: (Expr -> Expr) -> FuncDecl -> FuncDecl
updFuncBody = updFuncRule . updRuleBody
funcRHS :: FuncDecl -> Maybe [Expr]
funcRHS = maybe Nothing (Just . unwrapCaseOr) . funcBody
where
unwrapCaseOr e
| isCase e
= concatMap unwrapCaseOr (map branchExpr (caseBranches e))
| isOr e = concatMap unwrapCaseOr (orExps e)
| otherwise = [e]
isExternal :: FuncDecl -> Bool
isExternal = isRuleExternal . funcRule
isCombFunc :: FuncDecl -> Expr -> Bool
isCombFunc = hasName . funcName
incVarsFunc :: Int -> FuncDecl -> FuncDecl
incVarsFunc m = rnmAllVarsFunc (m+)
rnmAllVarsFunc :: (Int -> Int) -> FuncDecl -> FuncDecl
rnmAllVarsFunc f (Func name arity vis t rule)
= Func name arity vis t (rnmAllVarsRule f rule)
allVarsFunc :: FuncDecl -> [Int]
allVarsFunc = allVarsRule . funcRule
updRule fa fe _ (Rule args exp) = Rule (fa args) (fe exp)
updRule _ _ f (External s) = External (f s)
isRuleExternal :: Rule -> Bool
isRuleExternal (Rule _ _) = False
isRuleExternal (External _) = True
ruleArgs :: Rule -> Maybe [Int]
ruleArgs (Rule args _) = Just args
ruleArgs (External _) = Nothing
updRuleArgs :: ([Int] -> [Int]) -> Rule -> Rule
updRuleArgs f = updRule f id id
ruleBody :: Rule -> Maybe Expr
ruleBody (Rule _ exp) = Just exp
ruleBody (External _) = Nothing
updRuleBody :: (Expr -> Expr) -> Rule -> Rule
updRuleBody f = updRule id f id
ruleExtDecl :: Rule -> Maybe String
ruleExtDecl (Rule _ _ ) = Nothing
ruleExtDecl (External s) = Just s
updRuleExtDecl :: (String -> String) -> Rule -> Rule
updRuleExtDecl f = updRule id id f
updQNamesRule :: (QName -> QName) -> Rule -> Rule
updQNamesRule = updRuleBody . updQNames
rnmAllVarsRule :: (Int -> Int) -> Rule -> Rule
rnmAllVarsRule f (Rule args body)
= Rule (map f args) (rnmAllVars f body)
rnmAllVarsRule _ (External s) = External s
allVarsRule :: Rule -> [Int]
allVarsRule (Rule args body) = args ++ allVars body
isTypeVar :: TypeExpr -> Bool
isTypeVar t = case t of
TVar _ -> True
_ -> False
isFuncType :: TypeExpr -> Bool
isFuncType t = case t of
FuncType _ _ -> True
_ -> False
typeArity :: TypeExpr -> Int
typeArity (TVar _) = 0
typeArity (TCons _ _) = 0
typeArity (FuncType _ t2) = 1+typeArity t2
isTypeCons :: TypeExpr -> Bool
isTypeCons t = case t of
TCons _ _ -> True
_ -> False
isIOType :: TypeExpr -> Bool
isIOType t = typeConsName t==Just ("Prelude","IO")
typeConsName :: TypeExpr -> Maybe QName
typeConsName t | isTypeCons t = let TCons name _ = t in Just name
| otherwise = Nothing
argTypes :: TypeExpr -> [TypeExpr]
argTypes t = case t of
FuncType dom ran -> dom : argTypes ran
_ -> []
resultType :: TypeExpr -> TypeExpr
resultType t = case t of
FuncType _ ran -> resultType ran
_ -> t
rnmAllVarsTypeExpr :: (Int -> Int) -> TypeExpr -> TypeExpr
rnmAllVarsTypeExpr f (TVar n) = TVar (f n)
rnmAllVarsTypeExpr f (TCons name args)
= TCons name (map (rnmAllVarsTypeExpr f) args)
rnmAllVarsTypeExpr f (FuncType dom ran)
= FuncType (rnmAllVarsTypeExpr f dom) (rnmAllVarsTypeExpr f ran)
allTVars (TVar n) = [n]
allTVars (TCons _ args) = concatMap allTVars args
allTVars (FuncType t1 t2) = concatMap allTVars [t1,t2]
allTypeCons :: TypeExpr -> [QName]
allTypeCons (TVar _) = []
allTypeCons (TCons name args) = name : concatMap allTypeCons args
allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2
updQNamesTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
updQNamesTypeExpr _ (TVar n) = TVar n
updQNamesTypeExpr f (FuncType dom ran)
= FuncType (updQNamesTypeExpr f dom) (updQNamesTypeExpr f ran)
updQNamesTypeExpr f (TCons name args)
= TCons (f name) (map (updQNamesTypeExpr f) args)
isVar :: Expr -> Bool
isVar e = case e of
Var _ -> True
_ -> False
varNr :: Expr -> Int
varNr (Var n) = n
isLit :: Expr -> Bool
isLit e = case e of
Lit _ -> True
_ -> False
isComb :: Expr -> Bool
isComb e = case e of
Comb _ _ _ -> True
_ -> False
isFree :: Expr -> Bool
isFree e = case e of
Free _ _ -> True
_ -> False
isOr :: Expr -> Bool
isOr e = case e of
Or _ _ -> True
_ -> False
isCase :: Expr -> Bool
isCase e = case e of
Case _ _ _ -> True
_ -> False
isLet :: Expr -> Bool
isLet e = case e of
Let _ _ -> True
_ -> False
isGround :: Expr -> Bool
isGround exp
= case exp of
Comb ConsCall _ args -> all isGround args
_ -> isLit exp
literal :: Expr -> Maybe Literal
literal e = case e of
Lit l -> Just l
_ -> Nothing
combType :: Expr -> Maybe CombType
combType e = case e of
Comb ct _ _ -> Just ct
_ -> Nothing
exprFromFreeDecl :: Expr -> Expr
exprFromFreeDecl (Free _ e) = e
orExps :: Expr -> [Expr]
orExps (Or e1 e2) = [e1,e2]
isFuncCall :: Expr -> Bool
isFuncCall e = maybe False isCombFuncCall (combType e)
isPartCall :: Expr -> Bool
isPartCall e = maybe False isCombPartCall (combType e)
isConsCall :: Expr -> Bool
isConsCall e = maybe False isCombConsCall (combType e)
combFunc :: Expr -> Maybe QName
combFunc e
| isFuncCall e || isPartCall e = let Comb _ name _ = e in Just name
| otherwise = Nothing
combCons :: Expr -> Maybe QName
combCons e
| isConsCall e = let Comb _ name _ = e in Just name
| otherwise = Nothing
combArgs :: Expr -> Maybe [Expr]
combArgs e | isComb e = let Comb _ _ args = e in Just args
| otherwise = Nothing
missingFuncArgs :: Expr -> Maybe Int
missingFuncArgs e = combType e >>= Just . missingArgs
hasName :: QName -> Expr -> Bool
hasName name (Comb _ name' _) = name==name'
caseBranches :: Expr -> [BranchExpr]
caseBranches (Case _ _ bs) = bs
rnmAllVars :: (Int -> Int) -> Expr -> Expr
rnmAllVars f (Var n) = Var (f n)
rnmAllVars _ (Lit l) = Lit l
rnmAllVars f (Comb ct name args) = Comb ct name (map (rnmAllVars f) args)
rnmAllVars f (Free vs e) = Free (map f vs) (rnmAllVars f e)
rnmAllVars f (Or e1 e2) = Or (rnmAllVars f e1) (rnmAllVars f e2)
rnmAllVars f (Case ct e bs)
= Case ct (rnmAllVars f e) (map (rnmAllVarsBranch f) bs)
rnmAllVars f (Let bs e)
= Let (map (\ (n,e') -> (f n,rnmAllVars f e')) bs) (rnmAllVars f e)
allVars :: Expr -> [Int]
allVars (Var n) = [n]
allVars (Lit _) = []
allVars (Comb _ _ args) = concatMap allVars args
allVars (Free vs e) = vs ++ allVars e
allVars (Or e1 e2) = allVars e1 ++ allVars e2
allVars (Case _ e bs) = allVars e ++ concatMap allVarsBranch bs
allVars (Let bs e) = concatMap (\ (n,e') -> n:allVars e') bs ++ allVars e
mapVar :: (Expr -> Expr) -> Expr -> Expr
mapVar f (Var n) = f (Var n)
mapVar _ (Lit l) = Lit l
mapVar f (Comb ct name args) = Comb ct name (map (mapVar f) args)
mapVar f (Free vs e) = Free vs (mapVar f e)
mapVar f (Or e1 e2) = Or (mapVar f e1) (mapVar f e2)
mapVar f (Case ct e bs)
= Case ct (mapVar f e) (map (updBranchExpr (mapVar f)) bs)
mapVar f (Let bs e) = Let (map (\ (n,e') -> (n,mapVar f e')) bs) (mapVar f e)
mapLit :: (Expr -> Expr) -> Expr -> Expr
mapLit _ (Var n) = Var n
mapLit f (Lit l) = f (Lit l)
mapLit f (Comb ct name args) = Comb ct name (map (mapLit f) args)
mapLit f (Free vs e) = Free vs (mapLit f e)
mapLit f (Or e1 e2) = Or (mapLit f e1) (mapLit f e2)
mapLit f (Case ct e bs)
= Case ct (mapLit f e) (map (updBranchExpr (mapLit f)) bs)
mapLit f (Let bs e) = Let (map (\ (n,e') -> (n,mapLit f e')) bs) (mapLit f e)
mapComb :: (Expr -> Expr) -> Expr -> Expr
mapComb _ (Var n) = Var n
mapComb _ (Lit l) = Lit l
mapComb f (Comb ct name args) = f (Comb ct name (map (mapComb f) args))
mapComb f (Free vs e) = Free vs (mapComb f e)
mapComb f (Or e1 e2) = Or (mapComb f e1) (mapComb f e2)
mapComb f (Case ct e bs)
= Case ct (mapComb f e) (map (updBranchExpr (mapComb f)) bs)
mapComb f (Let bs e)
= Let (map (\ (n,e') -> (n,mapComb f e')) bs) (mapComb f e)
mapFree :: (Expr -> Expr) -> Expr -> Expr
mapFree _ (Var n) = Var n
mapFree _ (Lit l) = Lit l
mapFree f (Comb ct name args) = Comb ct name (map (mapFree f) args)
mapFree f (Free vs e) = f (Free vs (mapFree f e))
mapFree f (Or e1 e2) = Or (mapFree f e1) (mapFree f e2)
mapFree f (Case ct e bs)
= Case ct (mapFree f e) (map (updBranchExpr (mapFree f)) bs)
mapFree f (Let bs e)
= Let (map (\ (n,e') -> (n,mapFree f e')) bs) (mapFree f e)
mapOr :: (Expr -> Expr) -> Expr -> Expr
mapOr _ (Var n) = Var n
mapOr _ (Lit l) = Lit l
mapOr f (Comb ct name args) = Comb ct name (map (mapOr f) args)
mapOr f (Free vs e) = Free vs (mapOr f e)
mapOr f (Or e1 e2) = f (Or (mapOr f e1) (mapOr f e2))
mapOr f (Case ct e bs)
= Case ct (mapOr f e) (map (updBranchExpr (mapOr f)) bs)
mapOr f (Let bs e) = Let (map (\ (n,e') -> (n,mapOr f e')) bs) (mapOr f e)
mapCase :: (Expr -> Expr) -> Expr -> Expr
mapCase _ (Var n) = Var n
mapCase _ (Lit l) = Lit l
mapCase f (Comb ct name args) = Comb ct name (map (mapCase f) args)
mapCase f (Free vs e) = Free vs (mapCase f e)
mapCase f (Or e1 e2) = Or (mapCase f e1) (mapCase f e2)
mapCase f (Case ct e bs)
= f (Case ct (mapCase f e) (map (updBranchExpr (mapCase f)) bs))
mapCase f (Let bs e)
= Let (map (\ (n,e') -> (n,mapCase f e')) bs) (mapCase f e)
mapLet :: (Expr -> Expr) -> Expr -> Expr
mapLet _ (Var n) = Var n
mapLet _ (Lit l) = Lit l
mapLet f (Comb ct name args) = Comb ct name (map (mapLet f) args)
mapLet f (Free vs e) = Free vs (mapLet f e)
mapLet f (Or e1 e2) = Or (mapLet f e1) (mapLet f e2)
mapLet f (Case ct e bs)
= Case ct (mapLet f e) (map (updBranchExpr (mapLet f)) bs)
mapLet f (Let bs e)
= f (Let (map (\ (n,e') -> (n,mapLet f e')) bs) (mapLet f e))
updQNames :: (QName -> QName) -> Expr -> Expr
updQNames f
= mapComb (\ (Comb ct name args) -> Comb ct (f name) args)
. mapCase (\ (Case ct e bs)
-> Case ct e (map (updBranchPattern (updPatCons f)) bs))
isCombFuncCall :: CombType -> Bool
isCombFuncCall ct = case ct of
FuncCall -> True
_ -> False
isCombPartCall :: CombType -> Bool
isCombPartCall ct = case ct of
FuncPartCall _ -> True
ConsPartCall _ -> True
_ -> False
isCombConsCall :: CombType -> Bool
isCombConsCall ct = case ct of
ConsCall -> True
_ -> False
missingArgs :: CombType -> Int
missingArgs FuncCall = 0
missingArgs (FuncPartCall n) = n
missingArgs (ConsPartCall n) = n
missingArgs ConsCall = 0
updBranch fp fe (Branch pat exp) = Branch (fp pat) (fe exp)
branchPattern :: BranchExpr -> Pattern
branchPattern (Branch pat _) = pat
updBranchPattern :: (Pattern -> Pattern) -> BranchExpr -> BranchExpr
updBranchPattern f = updBranch f id
branchExpr :: BranchExpr -> Expr
branchExpr (Branch _ e) = e
updBranchExpr :: (Expr -> Expr) -> BranchExpr -> BranchExpr
updBranchExpr f = updBranch id f
isConsPattern :: Pattern -> Bool
isConsPattern (Pattern _ _) = True
isConsPattern (LPattern _) = False
updPattern fn fa _ (Pattern name args) = Pattern (fn name) (fa args)
updPattern _ _ f (LPattern l) = LPattern (f l)
patCons :: Pattern -> Maybe QName
patCons (Pattern name _) = Just name
patCons (LPattern _) = Nothing
updPatCons :: (QName -> QName) -> Pattern -> Pattern
updPatCons f = updPattern f id id
patArgs :: Pattern -> Maybe [Int]
patArgs (Pattern _ args) = Just args
patArgs (LPattern _) = Nothing
updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern
updPatArgs f = updPattern id f id
patLiteral :: Pattern -> Maybe Literal
patLiteral (Pattern _ _) = Nothing
patLiteral (LPattern l) = Just l
updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
updPatLiteral f = updPattern id id f
patExpr :: Pattern -> Expr
patExpr (Pattern name args) = Comb ConsCall name (map Var args)
patExpr (LPattern l) = Lit l
rnmAllVarsBranch :: (Int -> Int) -> BranchExpr -> BranchExpr
rnmAllVarsBranch f (Branch pat e)
= Branch (rnmAllVarsPat f pat) (rnmAllVars f e)
allVarsBranch :: BranchExpr -> [Int]
allVarsBranch (Branch pat e) = allVarsPat pat ++ allVars e
rnmAllVarsPat :: (Int -> Int) -> Pattern -> Pattern
rnmAllVarsPat f (Pattern name args) = Pattern name (map f args)
rnmAllVarsPat _ (LPattern l) = LPattern l
allVarsPat :: Pattern -> [Int]
allVarsPat = maybe [] id . patArgs
opName (Op name _ _) = name