---------------------------------------------------------------------------- --- This library provides transformation and update operations --- on AbstractCurry programs. --- Since the transformations are defined recursively on structured types, --- they are useful to construct specific transformations on AbstractCurry --- programs. --- In particular, this library contains the transformation --- `renameCurryModule` to rename an AbstractCurry module. --- --- @author Michael Hanus --- @version April 2016 --- @category meta ---------------------------------------------------------------------------- module ACSpans.Transform where import ACSpans.AbstractCurrySpan import ACSpans.Select import List (nub, union) import ACSpans.Span -- CurryProg --- Transforms an AbstractCurry program. trCProg :: (String -> [String] -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> a) -> CurryProg -> a trCProg prog (CurryProg _ name imps types funcs ops) = prog name imps types funcs ops ---------------------------------------------------------------------------- -- CTypeDecl --- Transforms a type declaration. trCTypeDecl :: (QName -> CVisibility -> [CTVarIName] -> [CConsDecl] -> a) -> (QName -> CVisibility -> [CTVarIName] -> CTypeExpr -> a) -> (QName -> CVisibility -> [CTVarIName] -> CConsDecl -> a) -> CTypeDecl -> a trCTypeDecl typ _ _ (CType _ name vis params cs) = typ name vis params cs trCTypeDecl _ tsyn _ (CTypeSyn _ name vis params syn) = tsyn name vis params syn trCTypeDecl _ _ tntyp (CNewType _ name vis params nt) = tntyp name vis params nt ---------------------------------------------------------------------------- -- CConsDecl --- Transforms a constructor declaration. trCConsDecl :: (QName -> CVisibility -> [CTypeExpr] -> a) -> (QName -> CVisibility -> [CFieldDecl] -> a) -> CConsDecl -> a trCConsDecl cons _ (CCons _ name vis args) = cons name vis args trCConsDecl _ rec (CRecord _ name vis args) = rec name vis args ---------------------------------------------------------------------------- -- CFieldDecl --- Transforms a constructor declaration. trCFieldDecl :: (QName -> CVisibility -> CTypeExpr -> a) -> CFieldDecl -> a trCFieldDecl field (CField _ name vis texp) = field name vis texp ---------------------------------------------------------------------------- -- CTypeExpr --- Transforms a type expression. trCTypeExpr :: (CTVarIName -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> CTypeExpr -> a trCTypeExpr tvar tcons functype texp = trTE texp where trTE (CTVar _ n) = tvar n trTE (CTCons _ name args) = tcons name (map trTE args) trTE (CFuncType _ from to) = functype (trTE from) (trTE to) ---------------------------------------------------------------------------- -- COpDecl --- Transforms an operator declaration. trCOpDecl :: (QName -> CFixity -> Int -> a) -> COpDecl -> a trCOpDecl op (COp _ name fix prec) = op name fix prec ---------------------------------------------------------------------------- -- CFuncDecl --- Transforms a function declaration trCFuncDecl :: (String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> a) -> CFuncDecl -> a trCFuncDecl func (CFunc _ name arity vis t rs) = func "" name arity vis t rs trCFuncDecl func (CmtFunc _ cm name arity vis t rs) = func cm name arity vis t rs -- ---------------------------------------------------------------------------- -- CRule --- Transform a rule. trCRule :: ([CPattern] -> CRhs -> a) -> CRule -> a trCRule rule (CRule _ pats rhs) = rule pats rhs ---------------------------------------------------------------------------- -- CRhs --- Transforms a right-hand side (of a rule or case expression). trCRhs :: (CExpr -> [CLocalDecl] -> a) -> ([(Span,CExpr, CExpr)] -> [CLocalDecl] -> a) -> CRhs -> a trCRhs srhs _ (CSimpleRhs _ exp locals) = srhs exp locals trCRhs _ grhs (CGuardedRhs _ gexps locals) = grhs gexps locals ---------------------------------------------------------------------------- --- Transforms a local declaration. trCLocalDecl :: (CFuncDecl -> a) -> (CPattern -> CRhs -> a) -> ([CVarIName] -> a) -> CLocalDecl -> a trCLocalDecl lfun _ _ (CLocalFunc _ fdecl) = lfun fdecl trCLocalDecl _ lpat _ (CLocalPat _ pat rhs) = lpat pat rhs trCLocalDecl _ _ vars (CLocalVars _ vs) = vars vs ---------------------------------------------------------------------------- -- CPattern --- Transforms a pattern. trCPattern :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> [a] -> a) -> (CVarIName -> a -> a) -> (QName -> [a] -> a) -> (QName -> [CField a] -> a) -> CPattern -> a trCPattern fv fl fc fa ff fr pattern = trP pattern where trP (CPVar _ pvar) = fv pvar trP (CPLit _ lit) = fl lit trP (CPComb _ c pats) = fc c (map trP pats) trP (CPAs _ v pat) = fa v (trP pat) trP (CPFuncComb _ fn pats) = ff fn (map trP pats) trP (CPLazy _ pat) = trP pat trP (CPRecord _ r fs) = fr r (map (\(n,p) -> (n,trP p)) fs) ---------------------------------------------------------------------------- -- CExpr --- Transforms an expression. trExpr :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> a) -> (a -> a -> a) -> ([CPattern] -> a -> a) -> ([CLocalDecl] -> a -> a) -> ([CStatement] -> a) -> (a -> [CStatement] -> a) -> (CCaseType -> a -> [(CPattern, CRhs)] -> a) -> (a -> CTypeExpr -> a) -> (QName -> [CField a] -> a) -> (a -> [CField a] -> a) -> CExpr -> a trExpr var lit sym app lam clet cdo lcomp cas typ rcon rupd exp = trE exp where trE (CVar _ n) = var n trE (CLit _ l) = lit l trE (CSymbol _ n) = sym n trE (CApply _ e1 e2) = app (trE e1) (trE e2) trE (CLambda _ pats e) = lam pats (trE e) trE (CLetDecl _ ls e) = clet ls (trE e) trE (CDoExpr _ stm) = cdo stm trE (CListComp _ e stm) = lcomp (trE e) stm trE (CCase _ ct e branches) = cas ct (trE e) branches trE (CTyped _ e te) = typ (trE e) te trE (CRecConstr _ rn fds) = rcon rn (map (\ (lb,e) -> (lb, trE e)) fds) trE (CRecUpdate _ e fds) = rupd (trE e) (map (\ (lb,v) -> (lb, trE v)) fds) ---------------------------------------------------------------------------- -- CStatement --- Transforms a statement (occuring in do expressions or list comprehensions). trCStatement :: (CExpr -> a) -> (CPattern -> CExpr -> a) -> ([CLocalDecl] -> a) -> CStatement -> a trCStatement sexp _ _ (CSExpr _ exp) = sexp exp trCStatement _ spat _ (CSPat _ pat exp) = spat pat exp trCStatement _ _ slet (CSLet _ locals) = slet locals ------------------------------------------------------------------------- --- Extracts all type names occurring in a program. typesOfCurryProg :: CurryProg -> [QName] typesOfCurryProg = trCProg (\_ _ types funcs _ -> foldr union [] (map (nub . typesOfCTypeDecl) types) ++ foldr union [] (map (nub . typesOfCFuncDecl) funcs)) --- Extracts all type names occurring in a type declaration. typesOfCTypeDecl :: CTypeDecl -> [QName] typesOfCTypeDecl = trCTypeDecl (\qn _ _ cdecls -> qn : concatMap typesOfConsDecl cdecls) (\qn _ _ texp -> qn : typesOfTypeExpr texp) (\qn _ _ cdecl -> qn : typesOfConsDecl cdecl) typesOfConsDecl :: CConsDecl -> [QName] typesOfConsDecl = trCConsDecl (\_ _ texps -> concatMap typesOfTypeExpr texps) (\_ _ fddecls -> concatMap typesOfFieldDecl fddecls) typesOfFieldDecl :: CFieldDecl -> [QName] typesOfFieldDecl = trCFieldDecl (\_ _ texp -> typesOfTypeExpr texp) typesOfTypeExpr :: CTypeExpr -> [QName] typesOfTypeExpr = trCTypeExpr (\_ -> []) (\qn targs -> qn : concat targs) (++) typesOfCFuncDecl :: CFuncDecl -> [QName] typesOfCFuncDecl = trCFuncDecl (\_ _ _ _ texp _ -> typesOfTypeExpr texp) -- type annotations in expressions are currently ignored ---------------------------------------------------------------------------- --- Extracts all function (and constructor) names occurring in a program. funcsOfCurryProg :: CurryProg -> [QName] funcsOfCurryProg = trCProg (\_ _ types funcs _ -> foldr union [] (map (nub . funcsOfCTypeDecl) types) ++ foldr union [] (map (nub . funcsOfCFuncDecl) funcs)) funcsOfCTypeDecl :: CTypeDecl -> [QName] funcsOfCTypeDecl = trCTypeDecl (\_ _ _ cdecls -> concatMap funcsOfConsDecl cdecls) (\_ _ _ _ -> []) (\_ _ _ cdecl -> funcsOfConsDecl cdecl) funcsOfConsDecl :: CConsDecl -> [QName] funcsOfConsDecl = trCConsDecl (\qn _ _ -> [qn]) (\qn _ fddecls -> qn : concatMap funcsOfFieldDecl fddecls) funcsOfFieldDecl :: CFieldDecl -> [QName] funcsOfFieldDecl = trCFieldDecl (\qn _ _ -> [qn]) --- Extracts all function (and constructor) names occurring in a function --- declaration. funcsOfCFuncDecl :: CFuncDecl -> [QName] funcsOfCFuncDecl = trCFuncDecl (\_ _ _ _ _ rules -> concatMap funcsOfCRule rules) funcsOfCRule :: CRule -> [QName] funcsOfCRule = trCRule (\_ rhs -> funcsOfCRhs rhs) funcsOfCRhs :: CRhs -> [QName] funcsOfCRhs = trCRhs (\e ldecls -> funcsOfExpr e ++ concatMap funcsOfLDecl ldecls) (\gs ldecls -> concatMap (\ (_,g,e) -> funcsOfExpr g ++ funcsOfExpr e) gs ++ concatMap funcsOfLDecl ldecls) funcsOfLDecl :: CLocalDecl -> [QName] funcsOfLDecl = trCLocalDecl funcsOfCFuncDecl (const funcsOfCRhs) (const []) funcsOfExpr :: CExpr -> [QName] funcsOfExpr = trExpr (const []) (const []) (\n -> [n]) (++) (const id) (\ldecls e -> concatMap funcsOfLDecl ldecls ++ e) (concatMap funcsOfStat) (\e stats -> e ++ concatMap funcsOfStat stats) (\_ e brs -> e ++ concatMap (funcsOfCRhs . snd) brs) (\e _ -> e) (\_ fields -> concatMap snd fields) (\e fields -> e ++ concatMap snd fields) funcsOfStat :: CStatement -> [QName] funcsOfStat = trCStatement funcsOfExpr (const funcsOfExpr) (concatMap funcsOfLDecl) ---------------------------------------------------------------------------- --- Renames a Curry module, i.e., updates the module name and all qualified --- names in a program. type Update a b = (b -> b) -> a -> a renameCurryModule :: String -> CurryProg -> CurryProg renameCurryModule newname prog = updCProgName (const newname) (updQNamesInCProg rnm prog) where rnm mn@(p,mod,n) | mod == progName prog = (p,newname,n) | otherwise = mn -- ---------------------------------------------------------------------------- --- Updates an AbstractCurry program. updCProg :: (String -> String) -> ([String] -> [String]) -> ([CTypeDecl] -> [CTypeDecl]) -> ([CFuncDecl] -> [CFuncDecl]) -> ([COpDecl] -> [COpDecl]) -> CurryProg -> CurryProg updCProg fn fi ft ff fo f@(CurryProg pos _ _ _ _ _) = trCProg prog f where prog name imps types funcs ops = CurryProg pos (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- Updates the name of a Curry program. updCProgName :: Update CurryProg String updCProgName f = updCProg f id id id id --- update type declaration updCTypeDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTVarIName] -> [CTVarIName]) -> ([CConsDecl] -> [CConsDecl]) -> (CTypeExpr -> CTypeExpr) -> (CConsDecl -> CConsDecl) -> CTypeDecl -> CTypeDecl updCTypeDecl fn fv fp fc fs ft f = trCTypeDecl typ tsyn tntyp f where pos = getPosType f typ name vis params cs = CType pos (fn name) (fv vis) (fp params) (fc cs) tsyn name vis params syn = CTypeSyn pos (fn name) (fv vis) (fp params) (fs syn) tntyp name vis params ntyp = CNewType pos (fn name) (fv vis) (fp params) (ft ntyp) getPosType:: CTypeDecl -> Span getPosType (CType pos _ _ _ _) = pos getPosType (CTypeSyn pos _ _ _ _) = pos getPosType (CNewType pos _ _ _ _) = pos --- Updates the name of a type declaration. updCTypeDeclName :: Update CTypeDecl QName updCTypeDeclName f = updCTypeDecl f id id id id id --- Updates a constructor declaration. updCConsDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTypeExpr] -> [CTypeExpr]) -> ([CFieldDecl] -> [CFieldDecl]) -> CConsDecl -> CConsDecl updCConsDecl fn fv fts ffs f = trCConsDecl cons rec f where pos = getPosCons f cons name vis args = CCons pos (fn name) (fv vis) (fts args) rec name vis args = CRecord pos (fn name) (fv vis) (ffs args) getPosCons:: CConsDecl -> Span getPosCons (CCons pos _ _ _) = pos getPosCons (CRecord pos _ _ _) = pos --- Updates the name of a constructor declaration. updCConsDeclName :: Update CConsDecl QName updCConsDeclName f = updCConsDecl f id id id --- update constructor declaration updCFieldDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> (CTypeExpr -> CTypeExpr) -> CFieldDecl -> CFieldDecl updCFieldDecl fn fv ft f@(CField pos _ _ _) = trCFieldDecl field f where field name vis texp = CField pos (fn name) (fv vis) (ft texp) --- Updates the name of a constructor declaration. updCFieldDeclName :: Update CFieldDecl QName updCFieldDeclName f = updCFieldDecl f id id --- Updates all type constructor applications in a type expression. updTConsApp :: (QName -> [CTypeExpr] -> CTypeExpr) -> CTypeExpr -> CTypeExpr updTConsApp tcons ctexp = trCTypeExpr (CTVar posi) tcons (CFuncType posi) ctexp where posi = getPosTExpr ctexp getPosTExpr (CTVar pos _) = pos getPosTExpr (CFuncType pos _ _) = pos getPosTExpr (CTCons pos _ _) = pos---- WHAT --- Updates an operator declaration. updCOpDecl :: (QName -> QName) -> (CFixity -> CFixity) -> (Int -> Int) -> COpDecl -> COpDecl updCOpDecl fn ff fp c@(COp pos _ _ _) = trCOpDecl op c where op name fix prec = COp pos (fn name) (ff fix) (fp prec) --- Updates the name of an operator declaration. updCOpName :: Update COpDecl QName updCOpName f = updCOpDecl f id id --- Updates a function declaration. updCFuncDecl :: (String -> String) -> (QName -> QName) -> (Int -> Int) -> (CVisibility -> CVisibility) -> (CTypeExpr -> CTypeExpr) -> ([CRule] -> [CRule]) -> CFuncDecl -> CFuncDecl updCFuncDecl fc fn fa fv ft fr f = trCFuncDecl func f where func cmt name arity vis t rules = if null cmt then CFunc (getPosFunc f) (fn name) (fa arity) (fv vis) (ft t) (fr rules) else CmtFunc (getPosFunc f) (fc cmt) (fn name) (fa arity) (fv vis) (ft t) (fr rules) getPosFunc:: CFuncDecl -> (Maybe Span) getPosFunc (CFunc pos _ _ _ _ _) = pos getPosFunc (CmtFunc pos _ _ _ _ _ _) = pos --- Update a rule. updCRule :: ([CPattern] -> [CPattern]) -> (CRhs -> CRhs) -> CRule -> CRule updCRule fp fr r@(CRule pos _ _) = trCRule rule r where rule pats rhs = CRule pos (fp pats) (fr rhs) --- Updates right-hand side. updCRhs :: (CExpr -> CExpr) -> ([(Span,CExpr, CExpr)] -> [(Span,CExpr, CExpr)]) -> ([CLocalDecl] -> [CLocalDecl]) -> CRhs -> CRhs updCRhs fe fg fl r@(CSimpleRhs pos _ _) = trCRhs srhs grhs r where srhs exp locals = CSimpleRhs pos (fe exp) (fl locals) grhs gexps locals = CGuardedRhs pos (fg gexps) (fl locals) updCRhs fe fg fl r@(CGuardedRhs pos _ _) = trCRhs srhs grhs r where srhs exp locals = CSimpleRhs pos (fe exp) (fl locals) grhs gexps locals = CGuardedRhs pos (fg gexps) (fl locals) --- Updates a local declaration. updCLocalDecl :: (CFuncDecl -> CFuncDecl) -> (CPattern -> CPattern) -> (CRhs -> CRhs) -> ([CVarIName] -> [CVarIName]) -> CLocalDecl -> CLocalDecl updCLocalDecl ff fp fr fv f = trCLocalDecl lfun lpat lvars f where pos = getPos f lfun fdecl = CLocalFunc pos (ff fdecl) lpat pat rhs = CLocalPat pos (fp pat) (fr rhs) lvars vars = CLocalVars pos (fv vars) getPos:: CLocalDecl -> Span getPos (CLocalFunc pos _ ) = pos getPos (CLocalPat pos _ _) = pos getPos (CLocalVars pos _ ) = pos --- Updates a pattern. updCPattern :: (CVarIName -> CVarIName) -> (CLiteral -> CLiteral) -> (QName -> QName) -> CPattern -> CPattern updCPattern fv fl fn pati = trCPattern pvar plit pcomb pas pfcomb prec pati where pos = getPosPat pati pvar var = CPVar pos (fv var) plit lit = CPLit pos (fl lit) pcomb c pats = CPComb pos (fn c) (map (updCPattern fv fl fn) pats) pas v pat = CPAs pos (fv v) (updCPattern fv fl fn pat) pfcomb f pats = CPFuncComb pos (fn f) (map (updCPattern fv fl fn) pats) prec r fields = CPRecord pos (fn r) (map (\ (n,p) -> (fn n, updCPattern fv fl fn p)) fields) getPosPat:: CPattern -> Span getPosPat (CPVar pos _ ) = pos getPosPat (CPLit pos _) = pos getPosPat (CPComb pos _ _) = pos getPosPat (CPAs pos _ _) = pos getPosPat (CPFuncComb pos _ _) = pos getPosPat (CPRecord pos _ _) = pos getPosPat (CPLazy pos _) = pos --- Updates a statement (occuring in do expressions or list comprehensions). updCStatement :: (CExpr -> CExpr) -> (CPattern -> CPattern) -> (CLocalDecl -> CLocalDecl) -> CStatement -> CStatement updCStatement fe fp fd f = trCStatement sexp spat slet f where pos = getPosStat f sexp exp = CSExpr pos (fe exp) spat pat exp = CSPat pos (fp pat) (fe exp) slet locals = CSLet pos (map fd locals) getPosStat:: CStatement -> Span getPosStat (CSExpr pos _) = pos getPosStat (CSPat pos _ _) = pos getPosStat (CSLet pos _) = pos ---------------------------------------------------------------------------- --- Updates all qualified names in a Curry program. updQNamesInCProg :: Update CurryProg QName updQNamesInCProg f = updCProg id id (map (updQNamesInCTypeDecl f)) (map (updQNamesInCFuncDecl f)) (map (updCOpName f)) --- Updates all qualified names in a type declaration. updQNamesInCTypeDecl :: Update CTypeDecl QName updQNamesInCTypeDecl f = updCTypeDecl f id id (map (updQNamesInCConsDecl f)) (updQNamesInCTypeExpr f) (updQNamesInCConsDecl f) --- Updates all qualified names in a constructor declaration. updQNamesInCConsDecl :: Update CConsDecl QName updQNamesInCConsDecl f = updCConsDecl f id (map (updQNamesInCTypeExpr f)) (map (updQNamesInCFieldDecl f)) --- Updates all qualified names in a record field declaration. updQNamesInCFieldDecl :: Update CFieldDecl QName updQNamesInCFieldDecl f = updCFieldDecl f id (updQNamesInCTypeExpr f) --- Updates all qualified names in a type expression. updQNamesInCTypeExpr :: (QName -> QName) -> CTypeExpr -> CTypeExpr updQNamesInCTypeExpr f c = updTConsApp (\name args -> CTCons posi (f name) args) c where posi = getPosTExpr c getPosTExpr (CTVar pos _) = pos getPosTExpr (CFuncType pos _ _) = pos getPosTExpr (CTCons pos _ _) = pos --- Updates all qualified names in a function declaration. updQNamesInCFuncDecl :: Update CFuncDecl QName updQNamesInCFuncDecl f = updCFuncDecl id f id id (updQNamesInCTypeExpr f) (map (updQNamesInCRule f)) --- Updates all qualified names in a function declaration. updQNamesInCRule :: Update CRule QName updQNamesInCRule f = updCRule (map (updQNamesInCPattern f)) (updQNamesInCRhs f) --- Updates all qualified names in a function declaration. updQNamesInCRhs :: Update CRhs QName updQNamesInCRhs f = updCRhs (updQNamesInCExpr f) (map (\ (p,g,e) -> (p,updQNamesInCExpr f g, updQNamesInCExpr f e))) (map (updQNamesInCLocalDecl f)) --- Updates all qualified names in a function declaration. updQNamesInCLocalDecl :: Update CLocalDecl QName updQNamesInCLocalDecl f = updCLocalDecl (updQNamesInCFuncDecl f) (updQNamesInCPattern f) (updQNamesInCRhs f) id --- Updates all qualified names in a function declaration. updQNamesInCPattern :: Update CPattern QName updQNamesInCPattern f = updCPattern id id f --- Updates all qualified names in a statement. updQNamesInCStatement :: Update CStatement QName updQNamesInCStatement f = updCStatement (updQNamesInCExpr f) (updQNamesInCPattern f) (updQNamesInCLocalDecl f) vir:: Span vir = ((1,1),(1,1)) updQNamesInCExpr :: Update CExpr QName updQNamesInCExpr f cexp = trExpr (CVar pos) (CLit pos) ((CSymbol pos). f) (CApply pos) lam ldecl doexp lcomp ccase ctyped reccon recupd cexp where pos = getPosExp cexp lam pats exp = CLambda pos (map (updQNamesInCPattern f) pats) exp ldecl locals exp = CLetDecl pos (map (updQNamesInCLocalDecl f) locals) exp doexp stms = CDoExpr pos (map (updQNamesInCStatement f) stms) lcomp exp stms = CListComp pos exp (map (updQNamesInCStatement f) stms) ccase ct exp bs = CCase pos ct exp (map (\ (pat,rhs) -> (updQNamesInCPattern f pat, updQNamesInCRhs f rhs)) bs) ctyped exp texp = CTyped pos exp (updQNamesInCTypeExpr f texp) reccon rec fields = CRecConstr pos (f rec) (map (\ (l,e) -> (f l,e)) fields) recupd exp fields = CRecUpdate pos exp (map (\ (l,e) -> (f l,e)) fields) getPosExp:: CExpr -> Span getPosExp (CLambda pos _ _) = pos getPosExp (CLetDecl pos _ _) = pos getPosExp (CDoExpr pos _) = pos getPosExp (CListComp pos _ _) = pos getPosExp (CCase pos _ _ _) = pos getPosExp (CTyped pos _ _) = pos getPosExp (CRecConstr pos _ _) = pos getPosExp (CRecUpdate pos _ _) = pos getPosExp (CVar pos _) = pos getPosExp (CLit pos _) = pos getPosExp (CSymbol pos _) = pos getPosExp (CApply pos _ _) = pos -------------------------------------------------------------------------