------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- -- GenAbstractCurry - Generates an AbstractCurry program term -- (type 'CurryProg') -- -- July 2005, -- Martin Engelke (men@informatik.uni-kiel.de) -- module GenAbstractCurry (genTypedAbstract, genUntypedAbstract) where import Data.Maybe import Data.List import Data.Char import AbstractCurry import Base import Types import Ident import Position import TopEnv import Env ------------------------------------------------------------------------------- -- Generates standard (type infered) AbstractCurry code from a CurrySyntax -- module. The function needs the type environment 'tyEnv' to determin the -- infered function types. genTypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg genTypedAbstract tyEnv tcEnv mod = genAbstract (genAbstractEnv TypedAcy tyEnv tcEnv mod) mod -- Generates untyped AbstractCurry code from a CurrySyntax module. The type -- signature takes place in every function type annotation, if it exists, -- otherwise the dummy type "Prelude.untyped" is used. genUntypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg genUntypedAbstract tyEnv tcEnv mod = genAbstract (genAbstractEnv UntypedAcy tyEnv tcEnv mod) mod ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Private... -- Generates an AbstractCurry program term from the syntax tree genAbstract :: AbstractEnv -> Module -> CurryProg genAbstract env (Module mid exp decls) = let partitions = foldl partitionDecl emptyPartitions decls modname = moduleName mid (imps, _) = mapfoldl genImportDecl env (reverse (importDecls partitions)) (types, _) = mapfoldl genTypeDecl env (reverse (typeDecls partitions)) (funcs, _) = mapfoldl (genFuncDecl False) env (funcDecls partitions) (ops, _) = mapfoldl genOpDecl env (reverse (opDecls partitions)) in CurryProg modname imps types funcs ops ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- The following types and functions can be used to spread a list of -- CurrySyntax declarations into four parts: a list of imports, a list of -- type declarations (data types and type synonyms), a table of function -- declarations and a list of fixity declarations. -- Inserts a CurrySyntax top level declaration into a partition. -- Note: declarations are collected in reverse order. partitionDecl :: Partitions -> Decl -> Partitions partitionDecl partitions (TypeSig pos ids typeexpr) = partitionFuncDecls (\id -> TypeSig pos [id] typeexpr) partitions ids partitionDecl partitions (EvalAnnot pos ids annot) = partitionFuncDecls (\id -> EvalAnnot pos [id] annot) partitions ids partitionDecl partitions (FunctionDecl pos id equs) = partitionFuncDecls (const (FunctionDecl pos id equs)) partitions [id] partitionDecl partitions (ExternalDecl pos conv name id typeexpr) = partitionFuncDecls (const (ExternalDecl pos conv name id typeexpr)) partitions [id] partitionDecl partitions (FlatExternalDecl pos ids) = partitionFuncDecls (\id -> FlatExternalDecl pos [id]) partitions ids partitionDecl partitions (InfixDecl pos fix prec idents) = partitions {opDecls = (map (\id -> (InfixDecl pos fix prec [id])) idents) ++ (opDecls partitions)} partitionDecl partitions decl = case decl of ImportDecl _ _ _ _ _ -> partitions {importDecls = decl:(importDecls partitions)} DataDecl _ _ _ _ -> partitions {typeDecls = decl:(typeDecls partitions)} TypeDecl _ _ _ _ -> partitions {typeDecls = decl:(typeDecls partitions)} _ -> partitions -- partitionFuncDecls :: (Ident -> Decl) -> Partitions -> [Ident] -> Partitions partitionFuncDecls genDecl partitions ids = partitions {funcDecls = foldl partitionFuncDecl (funcDecls partitions) ids} where partitionFuncDecl funcs' id = insertEntry id ((genDecl id):(fromMaybe [] (lookup id funcs'))) funcs' -- Data type for representing partitions of CurrySyntax declarations -- (according to the definition of the AbstractCurry program -- representation; type 'CurryProg'). -- Since a complete function declaration usually consist of more than one -- declaration (e.g. rules, type signature etc.), it is necessary -- to collect them within an association list data Partitions = Partitions {importDecls :: [Decl], typeDecls :: [Decl], funcDecls :: [(Ident,[Decl])], opDecls :: [Decl] } deriving Show -- Generates initial partitions. emptyPartitions = Partitions {importDecls = [], typeDecls = [], funcDecls = [], opDecls = [] } ------------------------------------------------------------------------------- -- The following functions convert CurrySyntax terms to AbstractCurry -- terms. -- genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv) genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env) -- genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv) genTypeDecl env (DataDecl _ ident params cdecls) = let (idxs, env1) = mapfoldl genTVarIndex env params (cdecls', env2) = mapfoldl genConsDecl env1 cdecls in (CType (genQName True env2 (qualifyWith (moduleId env) ident)) (genVisibility env2 ident) (zip idxs (map name params)) cdecls', resetScope env2) genTypeDecl env (TypeDecl _ ident params typeexpr) = let (idxs, env1) = mapfoldl genTVarIndex env params (typeexpr', env2) = genTypeExpr env1 typeexpr in (CTypeSyn (genQName True env2 (qualifyWith (moduleId env) ident)) (genVisibility env2 ident) (zip idxs (map name params)) typeexpr', resetScope env2) genTypeDecl env (NewtypeDecl pos ident _ _) = errorAt pos "'newtype' declarations are not supported in AbstractCurry" genTypeDecl env _ = internalError "unexpected declaration" -- genConsDecl :: AbstractEnv -> ConstrDecl -> (CConsDecl, AbstractEnv) genConsDecl env (ConstrDecl _ _ ident params) = let (params', env') = mapfoldl genTypeExpr env params in (CCons (genQName False env' (qualifyWith (moduleId env) ident)) (length params) (genVisibility env' ident) params', env') genConsDecl env (ConOpDecl pos ids ltype ident rtype) = genConsDecl env (ConstrDecl pos ids ident [ltype, rtype]) -- genTypeExpr :: AbstractEnv -> TypeExpr -> (CTypeExpr, AbstractEnv) genTypeExpr env (ConstructorType qident targs) = let (targs', env') = mapfoldl genTypeExpr env targs in (CTCons (genQName True env' qident) targs', env') genTypeExpr env (VariableType ident) | isJust midx = (CTVar (fromJust midx, name ident), env) | otherwise = (CTVar (idx, name ident), env') where midx = getTVarIndex env ident (idx, env') = genTVarIndex env ident genTypeExpr env (TupleType targs) | len > 1 = genTypeExpr env (ConstructorType (qTupleId len) targs) | len == 0 = genTypeExpr env (ConstructorType qUnitId targs) | len == 1 = genTypeExpr env (head targs) where len = length targs genTypeExpr env (ListType typeexpr) = genTypeExpr env (ConstructorType qListId [typeexpr]) genTypeExpr env (ArrowType texpr1 texpr2) = let (texpr1', env1) = genTypeExpr env texpr1 (texpr2', env2) = genTypeExpr env1 texpr2 in (CFuncType texpr1' texpr2', env2) genTypeExpr env (RecordType fss mr) = let fs = concatMap (\ (ls,typeexpr) -> map (\l -> (l,typeexpr)) ls) fss (ls,ts) = unzip fs (ts',env1) = mapfoldl genTypeExpr env ts ls' = map name ls in case mr of Nothing -> (CRecordType (zip ls' ts') Nothing, env1) Just tvar@(VariableType _) -> let (CTVar iname, env2) = genTypeExpr env1 tvar in (CRecordType (zip ls' ts') (Just iname), env2) Just rec@(RecordType _ _) -> let (CRecordType fields rbase, env2) = genTypeExpr env1 rec fields' = foldr (\ (l,t) -> insertEntry l t) fields (zip ls' ts') in (CRecordType fields' rbase, env2) _ -> internalError "illegal record base" -- NOTE: every infix declaration must declare exactly one operator. genOpDecl :: AbstractEnv -> Decl -> (COpDecl, AbstractEnv) genOpDecl env (InfixDecl _ fix prec [ident]) = (COp (genQName False env (qualifyWith (moduleId env) ident)) (genFixity fix) prec, env) -- genFixity :: Infix -> CFixity genFixity InfixL = CInfixlOp genFixity InfixR = CInfixrOp genFixity Infix = CInfixOp -- Generate an AbstractCurry function declaration from a list of CurrySyntax -- function declarations. -- NOTES: -- - every declaration in 'decls' must declare exactly one function. -- - since infered types are internally represented in flat style, -- all type variables are renamed with generated symbols when -- generating typed AbstractCurry. genFuncDecl :: Bool -> AbstractEnv -> (Ident, [Decl]) -> (CFuncDecl, AbstractEnv) genFuncDecl isLocal env (ident, decls) | not (null decls) = let name = genQName False env (qualify ident) visibility = genVisibility env ident evalannot = maybe CFlex (\ (EvalAnnot _ _ ea) -> genEvalAnnot ea) (find isEvalAnnot decls) (mtype, env1) = maybe (Nothing, env) (\ (t, env') -> (Just t, env')) (genFuncType env decls) (rules, env2) = maybe ([], env1) (\ (FunctionDecl _ _ equs) -> mapfoldl genRule env1 equs) (find isFunctionDecl decls) mexternal = applyMaybe genExternal (find isExternal decls) arity = compArity mtype rules typeexpr = fromMaybe (CTCons ("Prelude","untyped") []) mtype rule = compRule evalannot rules mexternal env3 = if isLocal then env1 else resetScope env2 in (CFunc name arity visibility typeexpr rule, env3) | otherwise = internalError ("missing declaration for function \"" ++ show ident ++ "\"") where genFuncType env decls | acytype == UntypedAcy = applyMaybe (genTypeSig env) (find isTypeSig decls) | acytype == TypedAcy = applyMaybe (genTypeExpr env) mftype | otherwise = Nothing where acytype = acyType env mftype | isLocal = lookupType ident (typeEnv env) | otherwise = qualLookupType (qualifyWith (moduleId env) ident) (typeEnv env) genTypeSig env (TypeSig _ _ ts) = genTypeExpr env ts genTypeSig env (ExternalDecl _ _ _ _ ts) = genTypeExpr env ts genExternal (ExternalDecl _ _ mname ident _) = CExternal (fromMaybe (name ident) mname) genExternal (FlatExternalDecl _ [ident]) = CExternal (name ident) genExternal _ = internalError "illegal external declaration occured" compArity mtypeexpr rules | not (null rules) = let (CRule patts _ _) = head rules in length patts | otherwise = maybe (internalError ("unable to compute arity for function \"" ++ show ident ++ "\"")) compArityFromType mtypeexpr compArityFromType (CTVar _) = 0 compArityFromType (CFuncType _ t2) = 1 + (compArityFromType t2) compArityFromType (CTCons _ _) = 0 compRule evalannot rules mexternal | not (null rules) = CRules evalannot rules | otherwise = fromMaybe (internalError ("missing rule for function \"" ++ show ident ++ "\"")) mexternal -- genRule :: AbstractEnv -> Equation -> (CRule, AbstractEnv) genRule env (Equation pos lhs rhs) = let (patts, env1) = mapfoldl (genPattern pos) (beginScope env) (simplifyLhs lhs) (locals, env2) = genLocalDecls env1 (simplifyRhsLocals rhs) (crhss, env3) = mapfoldl (genCrhs pos) env2 (simplifyRhsExpr rhs) in (CRule patts crhss locals, endScope env3) -- genCrhs :: Position -> AbstractEnv -> (Expression, Expression) -> ((CExpr, CExpr), AbstractEnv) genCrhs pos env (cond, expr) = let (cond', env1) = genExpr pos env cond (expr', env2) = genExpr pos env1 expr in ((cond', expr'), env2) -- NOTE: guarded expressions and 'where' declarations in local pattern -- declarations are not supported in PAKCS genLocalDecls :: AbstractEnv -> [Decl] -> ([CLocalDecl], AbstractEnv) genLocalDecls env decls = genLocals (foldl genLocalIndex env decls) (funcDecls (foldl partitionDecl emptyPartitions decls)) decls where genLocalIndex env (PatternDecl _ constr _) = genLocalPatternIndex env constr genLocalIndex env (ExtraVariables _ idents) = let (_, env') = mapfoldl genVarIndex env idents in env' genLocalIndex env _ = env genLocalPatternIndex env (VariablePattern ident) = snd (genVarIndex env ident) genLocalPatternIndex env (ConstructorPattern _ args) = foldl genLocalPatternIndex env args genLocalPatternIndex env (InfixPattern c1 _ c2) = foldl genLocalPatternIndex env [c1,c2] genLocalPatternIndex env (ParenPattern c) = genLocalPatternIndex env c genLocalPatternIndex env (TuplePattern _ args) = foldl genLocalPatternIndex env args genLocalPatternIndex env (ListPattern _ args) = foldl genLocalPatternIndex env args genLocalPatternIndex env (AsPattern ident c) = genLocalPatternIndex (snd (genVarIndex env ident)) c genLocalPatternIndex env (LazyPattern _ c) = genLocalPatternIndex env c genLocalPatternIndex env (RecordPattern fields mc) = let env' = foldl genLocalPatternIndex env (map fieldTerm fields) in maybe env' (genLocalPatternIndex env') mc genLocalPatternIndex env _ = env -- The association list 'fdecls' is necessary because function -- rules may not be together in the declaration list genLocals :: AbstractEnv -> [(Ident,[Decl])] -> [Decl] -> ([CLocalDecl], AbstractEnv) genLocals env _ [] = ([], env) genLocals env fdecls ((FunctionDecl _ ident _):decls) = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident (locals, env2) = genLocals (endScope env1) fdecls decls in (funcdecl:locals, env2) genLocals env fdecls ((ExternalDecl _ _ _ ident _):decls) = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident (locals, env2) = genLocals (endScope env1) fdecls decls in (funcdecl:locals, env2) genLocals env fdecls ((FlatExternalDecl pos idents):decls) | null idents = genLocals env fdecls decls | otherwise = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls (head idents) (locals, env2) = genLocals (endScope env1) fdecls ((FlatExternalDecl pos (tail idents)):decls) in (funcdecl:locals, env2) genLocals env fdecls ((PatternDecl pos constr rhs):decls) = let (patt, env1) = genLocalPattern pos env constr (plocals, env2) = genLocalDecls (beginScope env1) (simplifyRhsLocals rhs) (expr, env3) = genLocalPattRhs pos env2 (simplifyRhsExpr rhs) (locals, env4) = genLocals (endScope env3) fdecls decls in ((CLocalPat patt expr plocals):locals, env4) genLocals env fdecls ((ExtraVariables pos idents):decls) | null idents = genLocals env fdecls decls | otherwise = let ident = head idents idx = fromMaybe (internalError ("cannot find index" ++ " for free variable \"" ++ show ident ++ "\"")) (getVarIndex env ident) decls' = (ExtraVariables pos (tail idents)):decls (locals, env') = genLocals env fdecls decls' in ((CLocalVar (idx, name ident)):locals, env') genLocals env fdecls ((TypeSig _ _ _):decls) = genLocals env fdecls decls genLocals _ _ decl = internalError ("unexpected local declaration: \n" ++ show (head decl)) genLocalFuncDecl :: AbstractEnv -> [(Ident,[Decl])] -> Ident -> (CLocalDecl, AbstractEnv) genLocalFuncDecl env fdecls ident = let fdecl = fromMaybe (internalError ("missing declaration" ++ " for local function \"" ++ show ident ++ "\"")) (lookup ident fdecls) (funcdecl, _) = genFuncDecl True env (ident,fdecl) in (CLocalFunc funcdecl, env) genLocalPattern pos env (LiteralPattern lit) = case lit of String _ cs -> genLocalPattern pos env (ListPattern [] (map (LiteralPattern . Char noRef) cs)) _ -> (CPLit (genLiteral lit), env) genLocalPattern pos env (VariablePattern ident) = let idx = fromMaybe (internalError ("cannot find index" ++ " for pattern variable \"" ++ show ident ++ "\"")) (getVarIndex env ident) in (CPVar (idx, name ident), env) genLocalPattern pos env (ConstructorPattern qident args) = let (args', env') = mapfoldl (genLocalPattern pos) env args in (CPComb (genQName False env qident) args', env') genLocalPattern pos env (InfixPattern larg qident rarg) = genLocalPattern pos env (ConstructorPattern qident [larg, rarg]) genLocalPattern pos env (ParenPattern patt) = genLocalPattern pos env patt genLocalPattern pos env (TuplePattern _ args) | len > 1 = genLocalPattern pos env (ConstructorPattern (qTupleId len) args) | len == 1 = genLocalPattern pos env (head args) | len == 0 = genLocalPattern pos env (ConstructorPattern qUnitId []) where len = length args genLocalPattern pos env (ListPattern _ args) = genLocalPattern pos env (foldr (\p1 p2 -> ConstructorPattern qConsId [p1,p2]) (ConstructorPattern qNilId []) args) genLocalPattern pos _ (NegativePattern _ _) = errorAt pos "negative patterns are not supported in AbstractCurry" genLocalPattern pos env (AsPattern ident cterm) = let (patt, env1) = genLocalPattern pos env cterm idx = fromMaybe (internalError ("cannot find index" ++ " for alias variable \"" ++ show ident ++ "\"")) (getVarIndex env1 ident) in (CPAs (idx, name ident) patt, env1) genLocalPattern pos env (LazyPattern _ cterm) = let (patt, env') = genLocalPattern pos env cterm in (CPLazy patt, env') genLocalPattern pos env (RecordPattern fields mr) = let (fields', env1) = mapfoldl (genField genLocalPattern) env fields (mr', env2) = maybe (Nothing, env1) ((applyFst Just) . (genLocalPattern pos env1)) mr in (CPRecord fields' mr', env2) genLocalPattRhs pos env [(Variable qSuccessFunId, expr)] = genExpr pos env expr genLocalPattRhs pos _ _ = errorAt pos ("guarded expressions in pattern declarations" ++ " are not supported in AbstractCurry") -- genExpr :: Position -> AbstractEnv -> Expression -> (CExpr, AbstractEnv) genExpr pos env (Literal lit) = case lit of String _ cs -> genExpr pos env (List [] (map (Literal . Char noRef) cs)) _ -> (CLit (genLiteral lit), env) genExpr _ env (Variable qident) | isJust midx = (CVar (fromJust midx, name ident), env) | qident == qSuccessId = (CSymbol (genQName False env qSuccessFunId), env) | otherwise = (CSymbol (genQName False env qident), env) where ident = unqualify qident midx = getVarIndex env ident genExpr _ env (Constructor qident) = (CSymbol (genQName False env qident), env) genExpr pos env (Paren expr) = genExpr pos env expr genExpr pos env (Typed expr _) = genExpr pos env expr genExpr pos env (Tuple _ args) | len > 1 = genExpr pos env (foldl Apply (Variable (qTupleId (length args))) args) | len == 1 = genExpr pos env (head args) | len == 0 = genExpr pos env (Variable qUnitId) where len = length args genExpr pos env (List _ args) = let cons = Constructor qConsId nil = Constructor qNilId in genExpr pos env (foldr (\e1 e2 -> Apply (Apply cons e1) e2) nil args) genExpr pos env (ListCompr _ expr stmts) = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts (expr', env2) = genExpr pos env1 expr in (CListComp expr' stmts', endScope env2) genExpr pos env (EnumFrom expr) = genExpr pos env (Apply (Variable qEnumFromId) expr) genExpr pos env (EnumFromThen expr1 expr2) = genExpr pos env (Apply (Apply (Variable qEnumFromThenId) expr1) expr2) genExpr pos env (EnumFromTo expr1 expr2) = genExpr pos env (Apply (Apply (Variable qEnumFromToId) expr1) expr2) genExpr pos env (EnumFromThenTo expr1 expr2 expr3) = genExpr pos env (Apply (Apply (Apply (Variable qEnumFromThenToId) expr1) expr2) expr3) genExpr pos env (UnaryMinus _ expr) = genExpr pos env (Apply (Variable qNegateId) expr) genExpr pos env (Apply expr1 expr2) = let (expr1', env1) = genExpr pos env expr1 (expr2', env2) = genExpr pos env1 expr2 in (CApply expr1' expr2', env2) genExpr pos env (InfixApply expr1 op expr2) = genExpr pos env (Apply (Apply (opToExpr op) expr1) expr2) genExpr pos env (LeftSection expr op) = let ident = freshVar env "x" patt = VariablePattern ident var = Variable (qualify ident) applic = Apply (Apply (opToExpr op) expr) var in genExpr pos env (Lambda noRef [patt] applic) genExpr pos env (RightSection op expr) = let ident = freshVar env "x" patt = VariablePattern ident var = Variable (qualify ident) applic = Apply (Apply (opToExpr op) var) expr in genExpr pos env (Lambda noRef [patt] applic) genExpr pos env (Lambda _ params expr) = let (params', env1) = mapfoldl (genPattern pos) (beginScope env) params (expr', env2) = genExpr pos env1 expr in (CLambda params' expr', endScope env2) genExpr pos env (Let decls expr) = let (decls', env1) = genLocalDecls (beginScope env) decls (expr', env2) = genExpr pos env1 expr in (CLetDecl decls' expr', endScope env2) genExpr pos env (Do stmts expr) = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts (expr', env2) = genExpr pos env1 expr in (CDoExpr (stmts' ++ [CSExpr expr']), endScope env2) genExpr pos env (IfThenElse _ expr1 expr2 expr3) = genExpr pos env (Apply (Apply (Apply (Variable qIfThenElseId) expr1) expr2) expr3) genExpr pos env (Case _ expr alts) = let (expr', env1) = genExpr pos env expr (alts', env2) = mapfoldl genBranchExpr env1 alts in (CCase expr' alts', env2) genExpr pos env (RecordConstr fields) = let (fields', env1) = mapfoldl (genField genExpr) env fields in (CRecConstr fields', env1) genExpr pos env (RecordSelection expr label) = let (expr', env1) = genExpr pos env expr in (CRecSelect expr' (name label), env1) genExpr pos env (RecordUpdate fields expr) = let (fields', env1) = mapfoldl (genField genExpr) env fields (expr', env2) = genExpr pos env1 expr in (CRecUpdate fields' expr', env2) -- genStatement :: Position -> AbstractEnv -> Statement -> (CStatement, AbstractEnv) genStatement pos env (StmtExpr _ expr) = let (expr', env') = genExpr pos env expr in (CSExpr expr', env') genStatement _ env (StmtDecl decls) = let (decls', env') = genLocalDecls env decls in (CSLet decls', env') genStatement pos env (StmtBind _ patt expr) = let (expr', env1) = genExpr pos env expr (patt', env2) = genPattern pos env1 patt in (CSPat patt' expr', env2) -- NOTE: guarded expressions and local declarations in case branches -- are not supported in PAKCS genBranchExpr :: AbstractEnv -> Alt -> (CBranchExpr, AbstractEnv) genBranchExpr env (Alt pos patt rhs) = let (patt', env1) = genPattern pos (beginScope env) patt (expr', env2) = genBranchRhs pos env1 (simplifyRhsExpr rhs) in (CBranch patt' expr', endScope env2) where genBranchRhs pos env [(Variable qSuccessFunId, expr)] = genExpr pos env expr genBranchRhs pos _ _ = errorAt pos ("guarded expressions in case alternatives" ++ " are not supported in AbstractCurry") -- genPattern :: Position -> AbstractEnv -> ConstrTerm -> (CPattern, AbstractEnv) genPattern pos env (LiteralPattern lit) = case lit of String _ cs -> genPattern pos env (ListPattern [] (map (LiteralPattern . Char noRef) cs)) _ -> (CPLit (genLiteral lit), env) genPattern _ env (VariablePattern ident) = let (idx, env') = genVarIndex env ident in (CPVar (idx, name ident), env') genPattern pos env (ConstructorPattern qident args) = let (args', env') = mapfoldl (genPattern pos) env args in (CPComb (genQName False env qident) args', env') genPattern pos env (InfixPattern larg qident rarg) = genPattern pos env (ConstructorPattern qident [larg, rarg]) genPattern pos env (ParenPattern patt) = genPattern pos env patt genPattern pos env (TuplePattern _ args) | len > 1 = genPattern pos env (ConstructorPattern (qTupleId len) args) | len == 1 = genPattern pos env (head args) | len == 0 = genPattern pos env (ConstructorPattern qUnitId []) where len = length args genPattern pos env (ListPattern _ args) = genPattern pos env (foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2]) (ConstructorPattern qNilId []) args) genPattern pos _ (NegativePattern _ _) = errorAt pos "negative patterns are not supported in AbstractCurry" genPattern pos env (AsPattern ident cterm) = let (patt, env1) = genPattern pos env cterm (idx, env2) = genVarIndex env1 ident in (CPAs (idx, name ident) patt, env2) genPattern pos env (LazyPattern _ cterm) = let (patt, env') = genPattern pos env cterm in (CPLazy patt, env') genPattern pos env (FunctionPattern qident cterms) = let (patts, env') = mapfoldl (genPattern pos) env cterms in (CPFuncComb (genQName False env qident) patts, env') genPattern pos env (InfixFuncPattern cterm1 qident cterm2) = genPattern pos env (FunctionPattern qident [cterm1, cterm2]) genPattern pos env (RecordPattern fields mr) = let (fields', env1) = mapfoldl (genField genPattern) env fields (mr', env2) = maybe (Nothing, env1) ((applyFst Just) . (genPattern pos env1)) mr in (CPRecord fields' mr', env2) -- genField :: (Position -> AbstractEnv -> a -> (b, AbstractEnv)) -> AbstractEnv -> Field a -> (CField b, AbstractEnv) genField genTerm env (Field pos label term) = let (term',env1) = genTerm pos env term in ((name label, term'), env1) -- genLiteral :: Literal -> CLiteral genLiteral (Char _ c) = CCharc c genLiteral (Int _ i) = CIntc i genLiteral (Float _ f) = CFloatc f genLiteral _ = internalError "unsupported literal" -- Notes: -- - Some prelude identifiers are not quialified. The first check ensures -- that they get a correct qualifier. -- - The test for unqualified identifiers is necessary to qualify -- them correctly in the untyped AbstractCurry representation. genQName :: Bool -> AbstractEnv -> QualIdent -> QName genQName isTypeCons env qident | isPreludeSymbol qident = genQualName (qualQualify preludeMIdent qident) | not (isQualified qident) = genQualName (getQualIdent (unqualify qident)) | otherwise = genQualName qident where ident = unqualify qident genQualName qid = let (mmid, id) = splitQualIdent qid mid = maybe (moduleId env) (\mid' -> fromMaybe mid' (lookupEnv mid' (imports env))) mmid in (moduleName mid, name id) getQualIdent id | isTypeCons = case (lookupTC id (tconsEnv env)) of --[DataType qid _ _] -> qid --[RenamingType qid _ _] -> qid --[AliasType qid _ _] -> qid [info] -> origName info _ -> qualifyWith (moduleId env) id | otherwise = case (lookupValue id (typeEnv env)) of --[DataConstructor qid _] -> qid --[NewtypeConstructor qid _] -> qid --[Value qid _] -> qid [info] -> origName info _ -> qualifyWith (moduleId env) id -- genVisibility :: AbstractEnv -> Ident -> CVisibility genVisibility env ident | isExported env ident = Public | otherwise = Private -- genEvalAnnot :: EvalAnnotation -> CEvalAnnot genEvalAnnot EvalRigid = CRigid genEvalAnnot EvalChoice = CChoice ------------------------------------------------------------------------------- -- This part defines an environment containing all necessary information -- for generating the AbstractCurry representation of a CurrySyntax term. -- Data type for representing an AbstractCurry generator environment. -- -- moduleName - name of the module -- typeEnv - table of all known types -- exports - table of all exported symbols from the module -- imports - table of import aliases -- varIndex - index counter for generating variable indices -- tvarIndex - index counter for generating type variable indices -- varScope - stack of variable tables -- tvarScope - stack of type variable tables -- acyType - type of AbstractCurry code to be generated data AbstractEnv = AbstractEnv {moduleId :: ModuleIdent, typeEnv :: ValueEnv, tconsEnv :: TCEnv, exports :: Env Ident (), imports :: Env ModuleIdent ModuleIdent, varIndex :: Int, tvarIndex :: Int, varScope :: [Env Ident Int], tvarScope :: [Env Ident Int], acyType :: AbstractType } deriving Show -- Data type representing the type of AbstractCurry code to be generated -- (typed infered or untyped (i.e. type signated)) data AbstractType = TypedAcy | UntypedAcy deriving (Eq, Show) -- Initializes the AbstractCurry generator environment. genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv genAbstractEnv absType tyEnv tcEnv (Module mid exps decls) = AbstractEnv {moduleId = mid, typeEnv = tyEnv, tconsEnv = tcEnv, exports = foldl (buildExportTable mid decls) emptyEnv exps', imports = foldl buildImportTable emptyEnv decls, varIndex = 0, tvarIndex = 0, varScope = [emptyEnv], tvarScope = [emptyEnv], acyType = absType } where exps' = maybe (buildExports mid decls) (\ (Exporting _ es) -> es) exps -- Generates a list of exports for all specified top level declarations buildExports :: ModuleIdent -> [Decl] -> [Export] buildExports _ [] = [] buildExports mid ((DataDecl _ ident _ _):ds) = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds) buildExports mid ((NewtypeDecl _ ident _ _):ds) = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds) buildExports mid ((TypeDecl _ ident _ _):ds) = (Export (qualifyWith mid ident)):(buildExports mid ds) buildExports mid ((FunctionDecl _ ident _):ds) = (Export (qualifyWith mid ident)):(buildExports mid ds) buildExports mid ((ExternalDecl _ _ _ ident _):ds) = (Export (qualifyWith mid ident)):(buildExports mid ds) buildExports mid ((FlatExternalDecl _ idents):ds) = (map (Export . (qualifyWith mid)) idents) ++ (buildExports mid ds) buildExports mid (_:ds) = buildExports mid ds -- Builds a table containing all exported (i.e. public) identifiers -- from a module. buildExportTable :: ModuleIdent -> [Decl] -> Env Ident () -> Export -> Env Ident () buildExportTable mid _ exptab (Export qident) | isJust (localIdent mid qident) = insertExportedIdent exptab (unqualify qident) | otherwise = exptab buildExportTable mid _ exptab (ExportTypeWith qident ids) | isJust (localIdent mid qident) = foldl insertExportedIdent (insertExportedIdent exptab (unqualify qident)) ids | otherwise = exptab buildExportTable mid decls exptab (ExportTypeAll qident) | isJust ident' = foldl insertExportedIdent (insertExportedIdent exptab ident) (maybe [] getConstrIdents (find (isDataDeclOf ident) decls)) | otherwise = exptab where ident' = localIdent mid qident ident = fromJust ident' buildExportTable _ _ exptab (ExportModule _) = exptab -- insertExportedIdent :: Env Ident () -> Ident -> Env Ident () insertExportedIdent env ident = bindEnv ident () env -- getConstrIdents :: Decl -> [Ident] getConstrIdents (DataDecl _ _ _ constrs) = map getConstrIdent constrs where getConstrIdent (ConstrDecl _ _ ident _) = ident getConstrIdent (ConOpDecl _ _ _ ident _) = ident -- Builds a table for dereferencing import aliases buildImportTable :: Env ModuleIdent ModuleIdent -> Decl -> Env ModuleIdent ModuleIdent buildImportTable env (ImportDecl _ mid _ malias _) = bindEnv (fromMaybe mid malias) mid env buildImportTable env _ = env -- Checks whether an identifier is exported or not. isExported :: AbstractEnv -> Ident -> Bool isExported env ident = isJust (lookupEnv ident (exports env)) -- Generates an unique index for the variable 'ident' and inserts it -- into the variable table of the current scope. genVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv) genVarIndex env ident = let idx = varIndex env vtabs = varScope env vtab = head vtabs --if null vtabs then emptyEnv else head vtabs in (idx, env {varIndex = idx + 1, varScope = (bindEnv ident idx vtab):(sureTail vtabs)}) -- Generates an unique index for the type variable 'ident' and inserts it -- into the type variable table of the current scope. genTVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv) genTVarIndex env ident = let idx = tvarIndex env vtabs = tvarScope env vtab = head vtabs --if null vtabs then emptyEnv else head vtabs in (idx, env {tvarIndex = idx + 1, tvarScope = (bindEnv ident idx vtab):(sureTail vtabs)}) -- Looks up the unique index for the variable 'ident' in the -- variable table of the current scope. getVarIndex :: AbstractEnv -> Ident -> Maybe Int getVarIndex env ident = lookupEnv ident (head (varScope env)) -- Looks up the unique index for the type variable 'ident' in the type -- variable table of the current scope. getTVarIndex :: AbstractEnv -> Ident -> Maybe Int getTVarIndex env ident = lookupEnv ident (head (tvarScope env)) -- Generates an indentifier which doesn't occur in the variable table -- of the current scope. freshVar :: AbstractEnv -> String -> Ident freshVar env name = genFreshVar env name 0 where genFreshVar env name idx | isJust (getVarIndex env ident) = genFreshVar env name (idx + 1) | otherwise = ident where ident = mkIdent (name ++ show idx) -- Generates an indentifier which doesn't occur in the type variable table -- of the current scope. freshTVar :: AbstractEnv -> String -> Ident freshTVar env name = genFreshTVar env name 0 where genFreshTVar env name idx | isJust (getTVarIndex env ident) = genFreshTVar env name (idx + 1) | otherwise = ident where ident = mkIdent (name ++ show idx) -- Sets the index counter back to zero and deletes all stack entries. resetScope :: AbstractEnv -> AbstractEnv resetScope env = env {varIndex = 0, tvarIndex = 0, varScope = [emptyEnv], tvarScope = [emptyEnv]} -- Starts a new scope, i.e. copies and pushes the variable table of the current -- scope onto the top of the stack beginScope :: AbstractEnv -> AbstractEnv beginScope env = env {varScope = (head vs):vs, tvarScope = (head tvs):tvs} where vs = varScope env tvs = tvarScope env -- End the current scope, i.e. pops and deletes the variable table of the -- current scope from the top of the stack. endScope :: AbstractEnv -> AbstractEnv endScope env = env {varScope = if oneElement vs then vs else tail vs, tvarScope = if oneElement tvs then tvs else tail tvs} where vs = varScope env tvs = tvarScope env ------------------------------------------------------------------------------- -- Miscellaneous... -- Some identifiers... qEnumFromId = qualifyWith preludeMIdent (mkIdent "enumFrom") qEnumFromThenId = qualifyWith preludeMIdent (mkIdent "enumFromThen") qEnumFromToId = qualifyWith preludeMIdent (mkIdent "enumFromTo") qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo") qNegateId = qualifyWith preludeMIdent (mkIdent "negate") qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else") qSuccessFunId = qualifyWith preludeMIdent (mkIdent "success") -- The following functions check whether a declaration is of a certain kind isFunctionDecl :: Decl -> Bool isFunctionDecl (FunctionDecl _ _ _) = True isFunctionDecl _ = False isExternal :: Decl -> Bool isExternal (ExternalDecl _ _ _ _ _) = True isExternal (FlatExternalDecl _ _) = True isExternal _ = False -- Checks, whether a declaration is the data declaration of 'ident'. isDataDeclOf :: Ident -> Decl -> Bool isDataDeclOf ident (DataDecl _ ident' _ _) = ident == ident' isDataDeclOf _ _ = False -- Checks, whether a symbol is defined in the Prelude. isPreludeSymbol :: QualIdent -> Bool isPreludeSymbol qident = let (mmid, ident) = splitQualIdent qident in (isJust mmid && preludeMIdent == fromJust mmid) || elem ident [unitId, listId, nilId, consId] || isTupleId ident -- Converts an infix operator to an expression opToExpr :: InfixOp -> Expression opToExpr (InfixOp qident) = Variable qident opToExpr (InfixConstr qident) = Constructor qident -- Looks up the type of a qualified symbol in the type environment and -- converts it to a CurrySyntax type term. qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr qualLookupType qident tyEnv = case (qualLookupValue qident tyEnv) of [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts _ -> Nothing -- Looks up the type of a symbol in the type environment and -- converts it to a CurrySyntax type term. lookupType :: Ident -> ValueEnv -> Maybe TypeExpr lookupType ident tyEnv = case (lookupValue ident tyEnv) of [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts _ -> Nothing -- Converts the internal representation of the types from the type -- envorinment to CurrySyntax representation toCSType :: Type -> TypeExpr toCSType = fromType {- toCSType (TypeConstructor qident types) = ConstructorType qident (map toCSType types) toCSType (TypeVariable idx) = VariableType (mkVarIdent idx) toCSType (TypeConstrained types _) = toCSType (head types) toCSType (TypeArrow type1 type2) = ArrowType (toCSType type1) (toCSType type2) toCSType (TypeSkolem idx) = VariableType (mkVarIdent idx) -} {- -- solveTypeSyn :: TCEnv -> QualIdent -> [TypeExpr] -> Maybe TypeExpr solveTypeSyn tcEnv qident args = case (qualLookupTC qident tcEnv) of [AliasType _ _ t] -> Just (adaptType args t) _ -> case (lookupTC (unqualify qident) tcEnv) of [AliasType _ _ t] -> Just (adaptType args t) _ -> Nothing -- adaptType :: [TypeExpr] -> Type -> TypeExpr adaptType args texpr = adapt (zip [0 .. ((length args) - 1)] args) texpr where adapt its (TypeConstructor qident types) = ConstructorType qident (map (adapt its) types) adapt its (TypeVariable idx) = fromMaybe (internalError "cannot adapt type variable") (lookup idx its) adapt its (TypeConstrained types _) = adapt its (head types) adapt its (TypeArrow type1 type2) = ArrowType (adapt its type1) (adapt its type2) adapt its (TypeSkolem idx) = adapt its (TypeVariable idx) -} -- Generates a variable name from an index. mkVarIdent :: Int -> Ident mkVarIdent i | i < 0 = mkIdent ('b':(show (i * (-1)))) | i < 26 = mkIdent [chr (i + ord 'a')] | otherwise = mkIdent ('a':(show i)) -- The following functions transform left-hand-side and right-hand-side terms -- for a better handling simplifyLhs :: Lhs -> [ConstrTerm] simplifyLhs lhs = snd (flatLhs lhs) simplifyRhsExpr :: Rhs -> [(Expression, Expression)] simplifyRhsExpr (SimpleRhs _ expr _) = [(Variable qSuccessId, expr)] simplifyRhsExpr (GuardedRhs crhs _) = map (\ (CondExpr _ cond expr) -> (cond, expr)) crhs simplifyRhsLocals :: Rhs -> [Decl] simplifyRhsLocals (SimpleRhs _ _ locals) = locals simplifyRhsLocals (GuardedRhs _ locals) = locals -- Applies the function 'f' on the value which is wrapped in 'Just'. applyMaybe :: (a -> b) -> Maybe a -> Maybe b applyMaybe f (Just x) = Just (f x) applyMaybe _ Nothing = Nothing -- A combination of 'map' and 'foldl'. It maps a function to a list -- from left to right while updating the argument 'e' continously. mapfoldl :: (a -> b -> (c,a)) -> a -> [b] -> ([c], a) mapfoldl _ e [] = ([], e) mapfoldl f e (x:xs) = let (x', e') = f e x (xs', e'') = mapfoldl f e' xs in (x':xs', e'') -- Inserts an element under a key into an association list insertEntry :: Eq a => a -> b -> [(a,b)] -> [(a,b)] insertEntry k e [] = [(k,e)] insertEntry k e ((x,y):xys) | k == x = (k,e):xys | otherwise = (x,y):(insertEntry k e xys) -- Returns the list without the first element. If the list is empty, an -- empty list will be returned. sureTail :: [a] -> [a] sureTail [] = [] sureTail (_:xs) = xs -- Returns 'True', if a list contains exactly one element oneElement :: [a] -> Bool oneElement [_] = True oneElement _ = False -- Applies 'f' on the first value in a tuple applyFst :: (a -> c) -> (a,b) -> (c,b) applyFst f (x,y) = (f x, y) ------------------------------------------------------------------------------- -------------------------------------------------------------------------------