Commit ce2237ac authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Merge remote-tracking branch 'origin/new-gfc' into records

Conflicts:
	src/Generators/GenFlatCurry.hs
	src/ModuleSummary.hs
parents db2dfc03 90adc354
...@@ -9,54 +9,45 @@ ...@@ -9,54 +9,45 @@
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
-- Haskell libraries import Control.Applicative
import Control.Monad (filterM, liftM, liftM2, liftM3, mplus) import Control.Monad (filterM, mplus)
import Control.Monad.State (State, evalState, gets, modify) import Control.Monad.State (State, evalState, gets, modify)
import Data.List (mapAccumL, nub) import Data.List (mapAccumL, nub)
import qualified Data.Map as Map (Map, empty, insert, lookup, fromList, toList) import qualified Data.Map as Map (Map, empty, insert, lookup, fromList, toList)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
-- curry-base import Curry.Base.Ident
import Curry.Base.Ident as Id import Curry.ExtendedFlat.Type
import Curry.ExtendedFlat.Type
import qualified Curry.Syntax as CS import qualified Curry.Syntax as CS
-- Base
import Base.CurryTypes import Base.CurryTypes
import Base.Messages (internalError) import Base.Messages (internalError)
import Base.ScopeEnv (ScopeEnv) import Base.ScopeEnv (ScopeEnv)
import qualified Base.ScopeEnv as ScopeEnv import qualified Base.ScopeEnv as SE (new, insert, lookup, beginScope, endScope)
(new, insert, lookup, beginScope, endScope)
import Base.TopEnv (topEnvMap) import Base.TopEnv (topEnvMap)
import Base.Types import Base.Types
-- environments
import Env.Interface import Env.Interface
import Env.TypeConstructor (TCEnv, TypeInfo (..)) import Env.TypeConstructor (TCEnv, TypeInfo (..))
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- other
import qualified IL as IL import qualified IL as IL
import qualified ModuleSummary import qualified ModuleSummary
import Transformations (transType) import Transformations (transType)
trace' :: String -> a -> a
trace' _ x = x
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- transforms intermediate language code (IL) to FlatCurry code -- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry :: ModuleSummary.ModuleSummary -> InterfaceEnv genFlatCurry :: ModuleSummary.ModuleSummary -> InterfaceEnv
-> ValueEnv -> TCEnv -> IL.Module -> Prog -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatCurry modSum mEnv tyEnv tcEnv mdl = patchPrelude $ genFlatCurry modSum mEnv tyEnv tcEnv mdl = patchPrelude $
run modSum mEnv tyEnv tcEnv False (visitModule mdl) run modSum mEnv tyEnv tcEnv False (trModule mdl)
-- transforms intermediate language code (IL) to FlatCurry interfaces -- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: ModuleSummary.ModuleSummary -> InterfaceEnv genFlatInterface :: ModuleSummary.ModuleSummary -> InterfaceEnv
-> ValueEnv -> TCEnv -> IL.Module -> Prog -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatInterface modSum mEnv tyEnv tcEnv mdl = patchPrelude $ genFlatInterface modSum mEnv tyEnv tcEnv mdl = patchPrelude $
run modSum mEnv tyEnv tcEnv True (visitModule mdl) run modSum mEnv tyEnv tcEnv True (trInterface mdl)
patchPrelude :: Prog -> Prog patchPrelude :: Prog -> Prog
patchPrelude p@(Prog n _ types funcs ops) patchPrelude p@(Prog n _ types funcs ops)
...@@ -100,7 +91,6 @@ type FlatState a = State FlatEnv a ...@@ -100,7 +91,6 @@ type FlatState a = State FlatEnv a
-- for generating FlatCurry code. -- for generating FlatCurry code.
data FlatEnv = FlatEnv data FlatEnv = FlatEnv
{ moduleIdE :: ModuleIdent { moduleIdE :: ModuleIdent
, functionIdE :: (QualIdent, [(Ident, IL.Type)])
, interfaceEnvE :: InterfaceEnv , interfaceEnvE :: InterfaceEnv
, typeEnvE :: ValueEnv -- types of defined values , typeEnvE :: ValueEnv -- types of defined values
, tConsEnvE :: TCEnv , tConsEnvE :: TCEnv
...@@ -112,7 +102,6 @@ data FlatEnv = FlatEnv ...@@ -112,7 +102,6 @@ data FlatEnv = FlatEnv
, interfaceE :: [CS.IDecl] , interfaceE :: [CS.IDecl]
, varIndexE :: Int , varIndexE :: Int
, varIdsE :: ScopeEnv Ident VarIndex , varIdsE :: ScopeEnv Ident VarIndex
, tvarIndexE :: Int
, genInterfaceE :: Bool , genInterfaceE :: Bool
, localTypes :: Map.Map QualIdent IL.Type , localTypes :: Map.Map QualIdent IL.Type
, consTypes :: Map.Map QualIdent IL.Type , consTypes :: Map.Map QualIdent IL.Type
...@@ -130,7 +119,6 @@ run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0 ...@@ -130,7 +119,6 @@ run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0
where where
env0 = FlatEnv env0 = FlatEnv
{ moduleIdE = ModuleSummary.moduleId modSum { moduleIdE = ModuleSummary.moduleId modSum
, functionIdE = (qualify (mkIdent ""), [])
, interfaceEnvE = mEnv , interfaceEnvE = mEnv
, typeEnvE = tyEnv , typeEnvE = tyEnv
, tConsEnvE = tcEnv , tConsEnvE = tcEnv
...@@ -142,8 +130,7 @@ run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0 ...@@ -142,8 +130,7 @@ run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0
, exportsE = ModuleSummary.exports modSum , exportsE = ModuleSummary.exports modSum
, interfaceE = ModuleSummary.interface modSum , interfaceE = ModuleSummary.interface modSum
, varIndexE = 0 , varIndexE = 0
, varIdsE = ScopeEnv.new , varIdsE = SE.new
, tvarIndexE = 0
, genInterfaceE = genIntf , genInterfaceE = genIntf
, localTypes = Map.empty , localTypes = Map.empty
, consTypes = Map.fromList $ getConstrTypes tcEnv tyEnv , consTypes = Map.fromList $ getConstrTypes tcEnv tyEnv
...@@ -159,291 +146,227 @@ getConstrTypes tcEnv tyEnv = ...@@ -159,291 +146,227 @@ getConstrTypes tcEnv tyEnv =
mkConstrType tqid conid argtypes targnum = (conname, contype) mkConstrType tqid conid argtypes targnum = (conname, contype)
where where
conname = QualIdent (qidModule tqid) conid conname = QualIdent (qidModule tqid) conid
resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0 .. targnum - 1]) resty = IL.TypeConstructor tqid (map IL.TypeVariable [0 .. targnum - 1])
contype = foldr IL.TypeArrow resulttype $ map (ttrans tcEnv tyEnv) argtypes contype = foldr IL.TypeArrow resty $ map (ttrans tcEnv tyEnv) argtypes
-- trModule :: IL.Module -> FlatState Prog
visitModule :: IL.Module -> FlatState Prog trModule (IL.Module mid imps ds) = do
visitModule (IL.Module mid imps decls) = do
-- insert local decls into localDecls -- insert local decls into localDecls
let ts = [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ] modify $ \ s -> s { localTypes = Map.fromList [ (qn, t) | IL.FunctionDecl qn _ t _ <- ds ] }
modify $ \ s -> s { localTypes = Map.fromList ts } is <- (\is -> map moduleName $ nub $ imps ++ map extractMid is) <$> imports
types <- genTypeSynonyms
tyds <- concat <$> mapM trTypeDecl ds
funcs <- concat <$> mapM trFuncDecl ds
ops <- genOpDecls ops <- genOpDecls
whenFlatCurry return $ Prog (moduleName mid) is (types ++ tyds) funcs ops
( do
datas <- mapM visitDataDecl (filter isDataDecl decls)
newtys <- mapM visitNewtypeDecl (filter isNewtypeDecl decls)
types <- genTypeSynonyms
funcs <- mapM visitFuncDecl (filter isFuncDecl decls)
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (types ++ datas ++ newtys) funcs ops
)
( do
ds <- filterM isPublicDataDecl decls
nts <- filterM isPublicNewtypeDecl decls
datas <- mapM visitDataDecl ds
newtys <- mapM visitNewtypeDecl nts
types <- genTypeSynonyms
fs <- filterM isPublicFuncDecl decls
funcs <- mapM visitFuncDecl fs
expimps <- getExportedImports
itypes <- mapM visitTypeIDecl (filter isTypeIDecl expimps)
ifuncs <- mapM visitFuncIDecl (filter isFuncIDecl expimps)
iops <- mapM visitOpIDecl (filter isOpIDecl expimps)
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (itypes ++ types ++ datas ++ newtys) (ifuncs ++ funcs) (iops ++ ops)
)
where extractMid (CS.IImportDecl _ mid1) = mid1 where extractMid (CS.IImportDecl _ mid1) = mid1
-- trInterface :: IL.Module -> FlatState Prog
visitDataDecl :: IL.Decl -> FlatState TypeDecl trInterface (IL.Module mid imps decls) = do
visitDataDecl (IL.DataDecl qid arity constrs) = do -- insert local decls into localDecls
cdecls <- mapM visitConstrDecl constrs modify $ \ s -> s { localTypes = Map.fromList [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ] }
qname <- visitQualTypeIdent qid is <- (\is -> map moduleName $ nub $ imps ++ map extractMid is) <$> imports
vis <- getVisibility False qid expimps <- getExportedImports
return $ Type qname vis [0 .. arity - 1] (concat cdecls) itypes <- mapM trITypeDecl (filter isTypeIDecl expimps)
visitDataDecl _ = internalError "GenFlatCurry: no data declaration" types <- genTypeSynonyms
datas <- filterM isPublicDataDecl decls >>= concatMapM trTypeDecl
visitNewtypeDecl :: IL.Decl -> FlatState TypeDecl newtys <- filterM isPublicNewtypeDecl decls >>= concatMapM trTypeDecl
visitNewtypeDecl (IL.NewtypeDecl qid arity (IL.ConstrDecl _ ty)) = do ifuncs <- mapM trIFuncDecl (filter isFuncIDecl expimps)
qname <- visitQualTypeIdent qid funcs <- filterM isPublicFuncDecl decls >>= concatMapM trFuncDecl
vis <- getVisibility False qid iops <- mapM trIOpDecl (filter isOpIDecl expimps)
ty' <- visitType ty ops <- genOpDecls
return $ TypeSyn qname vis [0 .. arity - 1] ty' return $ Prog (moduleName mid) is (itypes ++ types ++ datas ++ newtys)
visitNewtypeDecl _ = internalError "GenFlatCurry: no newtype declaration" (ifuncs ++ funcs) (iops ++ ops)
where extractMid (CS.IImportDecl _ mid1) = mid1
--
visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
visitConstrDecl (IL.ConstrDecl qid types) = do
texprs <- mapM visitType types
qname <- visitQualIdent qid
vis <- getVisibility True qid
genFint <- genInterface
return $ if genFint && vis == Private
then []
else [Cons qname (length types) vis texprs]
--
visitType :: IL.Type -> FlatState TypeExpr
visitType (IL.TypeConstructor qid tys) = do
tys' <- mapM visitType tys
qn <- visitQualTypeIdent qid
return $ if qualName qid == "Identity"
then head tys'
else TCons qn tys'
visitType (IL.TypeVariable idx) = return $ TVar $ abs idx
visitType (IL.TypeArrow ty1 ty2) = liftM2 FuncType
(visitType ty1) (visitType ty2)
-- concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]
visitFuncDecl :: IL.Decl -> FlatState FuncDecl concatMapM act xs = concat <$> mapM act xs
visitFuncDecl (IL.FunctionDecl qid params typeexpr expression) = do
let argtypes = splitoffArgTypes typeexpr params trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
setFunctionId (qid, argtypes) trTypeDecl (IL.DataDecl qid arity cs) = ((:[]) <$>) $
qname <- visitQualIdent qid Type <$> trTypeIdent qid
arity <- fromMaybe (length params) `liftM` lookupIdArity qid <*> getVisibility False qid <*> return [0 .. arity - 1]
<*> (concat <$> mapM trConstrDecl cs)
trTypeDecl (IL.NewtypeDecl qid arity (IL.ConstrDecl _ ty)) = ((:[]) <$>) $
TypeSyn <$> trTypeIdent qid <*> getVisibility False qid
<*> return [0 .. arity - 1] <*> trType ty
trTypeDecl _ = return []
trConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
trConstrDecl (IL.ConstrDecl qid tys) = do
qid' <- trQualIdent qid
vis <- getVisibility True qid
tys' <- mapM trType tys
let flatCons = Cons qid' (length tys) vis tys'
whenFlatCurry (return [flatCons]) (return [flatCons | vis == Public]) -- TODO: whenFlatCurry
trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t [ty])
| qualName t == "Identity" = trType ty -- TODO: documentation
trType (IL.TypeConstructor t tys) = TCons <$> trTypeIdent t <*> mapM trType tys
trType (IL.TypeVariable idx) = return $ TVar $ abs idx
trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2
trFuncDecl :: IL.Decl -> FlatState [FuncDecl]
trFuncDecl (IL.FunctionDecl qid vs ty e) = do
qname <- trQualIdent qid
arity <- getArity qid
texpr <- trType ty
whenFlatCurry whenFlatCurry
(do is <- mapM newVarIndex params (do vis <- getVisibility False qid
texpr <- visitType typeexpr is <- mapM newVarIndex vs
expr <- visitExpression expression expr <- trExpr e
vis <- getVisibility False qid
clearVarIndices clearVarIndices
return (Func qname arity vis texpr (Rule is expr)) return [Func qname arity vis texpr (Rule is expr)]
) )
(do texpr <- visitType typeexpr (return [Func qname arity Public texpr (Rule [] (Var $ mkIdx 0))])
clearVarIndices trFuncDecl (IL.ExternalDecl qid _ extname ty) = do
return (Func qname arity Public texpr (Rule [] (Var $ mkIdx 0))) texpr <- trType ty
) qname <- trQualIdent qid
visitFuncDecl (IL.ExternalDecl qid _ extname typeexpr) = do arity <- getArity qid
setFunctionId (qid, [])
texpr <- visitType typeexpr
qname <- visitQualIdent qid
arity <- fromMaybe (typeArity typeexpr) `liftM` lookupIdArity qid
vis <- getVisibility False qid vis <- getVisibility False qid
xname <- visitExternalName extname xname <- trExternal extname
return $ Func qname arity vis texpr (External xname) return [Func qname arity vis texpr (External xname)]
visitFuncDecl (IL.NewtypeDecl _ _ _) = do trFuncDecl _ = return []
mid <- moduleId
internalError $ "\"" ++ Id.moduleName mid trExpr :: IL.Expression -> FlatState Expr
++ "\": newtype declarations are not supported" trExpr (IL.Literal l) = Lit <$> trLiteral l
visitFuncDecl _ = internalError "GenFlatCurry: no function declaration" trExpr (IL.Variable v) = Var <$> lookupVarIndex v
trExpr (IL.Function f _) = do
-- qname <- trQualIdent f
visitExpression :: IL.Expression -> FlatState Expr arity <- getArity f
visitExpression (IL.Literal l) = Lit `liftM` visitLiteral l genFuncCall qname arity []
visitExpression (IL.Variable v) = Var `liftM` lookupVarIndex v trExpr (IL.Constructor c _) = do
visitExpression (IL.Function f _) = do qname <- trQualIdent c
arity_ <- lookupIdArity f arity <- getArity c
qname <- visitQualIdent f genConsCall qname arity []
case arity_ of trExpr (IL.Apply e1 e2) = trApply e1 e2
Nothing -> internalError $ funcArity qname trExpr (IL.Case r t e bs) = Case r (cvEval t) <$> trExpr e <*> mapM trAlt bs
Just a -> genFuncCall qname a [] trExpr (IL.Or e1 e2) = Or <$> trExpr e1 <*> trExpr e2
visitExpression (IL.Constructor c _) = do trExpr (IL.Exist v e) = do
arity_ <- lookupIdArity c
qname <- visitQualIdent c
case arity_ of
Nothing -> internalError $ consArity qname
Just a -> genConsCall qname a []
visitExpression (IL.Apply e1 e2) = genFlatApplication e1 e2
visitExpression (IL.Case r ea e bs) =
liftM3 (Case r) (visitEval ea) (visitExpression e) (mapM visitAlt bs)
visitExpression (IL.Or e1 e2) = do
e1' <- visitExpression e1
e2' <- visitExpression e2
-- checkOverlapping e1' e2'
return $ Or e1' e2'
visitExpression (IL.Exist v e) = do
idx <- newVarIndex v idx <- newVarIndex v
e' <- visitExpression e e' <- trExpr e
return $ case e' of return $ case e' of
Free is e'' -> Free (idx : is) e'' Free is e'' -> Free (idx : is) e''
_ -> Free [idx] e' _ -> Free (idx : []) e'
visitExpression (IL.Let bd e) = inNewScope $ do trExpr (IL.Let (IL.Binding v b) e) = inNewScope $ do
_ <- newVarIndex $ bindingIdent bd v' <- newVarIndex v
bind <- visitBinding bd b' <- trExpr b
e' <- visitExpression e e' <- trExpr e
return $ case e' of -- TODO bjp(2011-09-21): maybe remove again return $ case e' of -- TODO bjp(2011-09-21): maybe remove again, ask @MH
(Let binds e'') -> Let (bind:binds) e'' Let bs e'' -> Let ((v', b'):bs) e''
_ -> Let [bind] e' _ -> Let ((v', b'):[]) e'
-- is it correct that there is no endScope? (hsi): bjp: Just added, but no reasoning about trExpr (IL.Letrec bs e) = inNewScope $ do
visitExpression (IL.Letrec bds e) = inNewScope $ do let (vs, es) = unzip [ (v, b) | IL.Binding v b <- bs]
mapM_ (newVarIndex . bindingIdent) bds vs' <- mapM newVarIndex vs
bds' <- mapM visitBinding bds es' <- mapM trExpr es
e' <- visitExpression e e' <- trExpr e
return $ Let bds' e' return $ Let (zip vs' es') e'
visitExpression (IL.Typed e ty) = liftM2 Typed (visitExpression e) trExpr (IL.Typed e ty) = Typed <$> trExpr e <*> trType ty
(visitType ty)
trLiteral :: IL.Literal -> FlatState Literal
-- trLiteral (IL.Char rs c) = return $ Charc rs c
visitLiteral :: IL.Literal -> FlatState Literal trLiteral (IL.Int rs i) = return $ Intc rs i
visitLiteral (IL.Char rs c) = return $ Charc rs c trLiteral (IL.Float rs f) = return $ Floatc rs f
visitLiteral (IL.Int rs i) = return $ Intc rs i
visitLiteral (IL.Float rs f) = return $ Floatc rs f trAlt :: IL.Alt -> FlatState BranchExpr
trAlt (IL.Alt p e) = Branch <$> trPat p <*> trExpr e
--
visitAlt :: IL.Alt -> FlatState BranchExpr trPat :: IL.ConstrTerm -> FlatState Pattern
visitAlt (IL.Alt p e) = liftM2 Branch (visitConstrTerm p) (visitExpression e) trPat (IL.LiteralPattern l) = LPattern <$> trLiteral l
trPat (IL.ConstructorPattern c vs) = Pattern <$> trQualIdent c
-- <*> mapM newVarIndex vs
visitConstrTerm :: IL.ConstrTerm -> FlatState Pattern trPat (IL.VariablePattern _) = internalError "GenFlatCurry.trPat"
visitConstrTerm (IL.LiteralPattern l) = LPattern `liftM` visitLiteral l
visitConstrTerm (IL.ConstructorPattern c vs) = cvEval :: IL.Eval -> CaseType
liftM2 (flip Pattern) (mapM newVarIndex vs) (visitQualIdent c) -- TODO: is this flip needed? cvEval IL.Rigid = Rigid
visitConstrTerm (IL.VariablePattern _) = do cvEval IL.Flex = Flex
mid <- moduleId
internalError $ "\"" ++ Id.moduleName mid ++ "\": variable patterns are not supported"
--
visitEval :: IL.Eval -> FlatState CaseType
visitEval IL.Rigid = return Rigid
visitEval IL.Flex = return Flex
--
visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)
visitBinding (IL.Binding v e) = liftM2 (,) (lookupVarIndex v) (visitExpression e)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- trIFuncDecl :: CS.IDecl -> FlatState FuncDecl
visitFuncIDecl :: CS.IDecl -> FlatState FuncDecl trIFuncDecl (CS.IFunctionDecl _ f a ty) = do
visitFuncIDecl (CS.IFunctionDecl _ f a ty) = do texpr <- trType $ snd $ cs2ilType [] ty
texpr <- visitType $ snd $ cs2ilType [] ty qname <- trQualIdent f
qname <- visitQualIdent f
return $ Func qname a Public texpr (Rule [] (Var $ mkIdx 0)) return $ Func qname a Public texpr (Rule [] (Var $ mkIdx 0))
visitFuncIDecl _ = internalError "GenFlatCurry: no function interface" trIFuncDecl _ = internalError "GenFlatCurry: no function interface"
-- trITypeDecl :: CS.IDecl -> FlatState TypeDecl
visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl trITypeDecl (CS.IDataDecl _ t vs cs hs) = do
visitTypeIDecl (CS.IDataDecl _ t vs cs hs) = do
let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t) let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
is = [0 .. length vs - 1] is = [0 .. length vs - 1]
cdecls <- mapM (visitConstrIDecl mid $ zip vs is) cdecls <- mapM (visitConstrIDecl mid $ zip vs is)
[c | c <- cs, CS.constrId c `notElem` hs] [c | c <- cs, CS.constrId c `notElem` hs]
qname <- visitQualTypeIdent t qname <- trTypeIdent t
return $ Type qname Public is cdecls return $ Type qname Public is cdecls
visitTypeIDecl (CS.ITypeDecl _ t vs ty) = do trITypeDecl (CS.ITypeDecl _ t vs ty) = do
let is = [0 .. length vs - 1] let is = [0 .. length vs - 1]
ty' <- visitType $ snd $ cs2ilType (zip vs is) ty ty' <- trType $ snd $ cs2ilType (zip vs is) ty
qname <- visitQualTypeIdent t qname <- trTypeIdent t
return $ TypeSyn qname Public is ty' return $ TypeSyn qname Public is ty'
visitTypeIDecl _ = internalError "GenFlatCurry: no type interface" trITypeDecl _ = internalError "GenFlatCurry: no type interface"
--
visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl
-> FlatState ConsDecl -> FlatState ConsDecl
visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs) = do visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs) = do
texprs <- mapM (visitType . (snd . cs2ilType tis)) typeexprs texprs <- mapM (trType . (snd . cs2ilType tis)) typeexprs
qname <- visitQualIdent (qualifyWith mid ident) qname <- trQualIdent (qualifyWith mid ident)
return (Cons qname (length typeexprs) Public texprs) return (Cons qname (length typeexprs) Public texprs)
visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2) visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
= visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2]) = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])
visitConstrIDecl mid tis (CS.RecordDecl _ _ ident fs) = do visitConstrIDecl mid tis (CS.RecordDecl _ _ ident fs) = do
texprs <- mapM (visitType . (snd . cs2ilType tis)) tys texprs <- mapM (trType . (snd . cs2ilType tis)) tys
qname <- visitQualIdent (qualifyWith mid ident) qname <- trQualIdent (qualifyWith mid ident)
return (Cons qname (length tys) Public texprs) return (Cons qname (length tys) Public texprs)
where tys = [ty | CS.FieldDecl _ ls ty <- fs, _ <- ls] where tys = [ty | CS.FieldDecl _ ls ty <- fs, _ <- ls]
-- trIOpDecl :: CS.IDecl -> FlatState OpDecl
visitOpIDecl :: CS.IDecl -> FlatState OpDecl trIOpDecl (CS.IInfixDecl _ fixi prec op) = do
visitOpIDecl (CS.IInfixDecl _ fixi prec op) = do op' <- trQualIdent op
op' <- visitQualIdent op
return $ Op op' (genFixity fixi) prec return $ Op op' (genFixity fixi) prec
visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match" trIOpDecl _ = internalError "GenFlatCurry.trIOpDecl: no pattern match"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- trQualIdent :: QualIdent -> FlatState QName
visitModuleIdent :: ModuleIdent -> FlatState String trQualIdent qid = do
visitModuleIdent = return . Id.moduleName mid <- getModuleIdent
--
visitQualIdent :: QualIdent -> FlatState QName
visitQualIdent qid = do
mid <- moduleId
let (mmod, ident) = (qidModule qid, qidIdent qid) let (mmod, ident) = (qidModule qid, qidIdent qid)
modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
= Id.moduleName preludeMIdent = moduleName preludeMIdent
| otherwise | otherwise
= maybe (Id.moduleName mid) Id.moduleName mmod = maybe (moduleName mid) moduleName mmod
ftype <- lookupIdType qid ftype <- lookupIdType qid
return (QName Nothing ftype modid $ idName ident) return (QName Nothing ftype modid $ idName ident)
-- This variant of visitQualIdent does not look up the type of the identifier, -- This variant of trQualIdent does not look up the type of the identifier,
-- which is wise when the identifier is bound to a type, because looking up -- which is wise when the identifier is bound to a type, because looking up
-- the type of a type via lookupIdType will get stuck in an endless loop. (hsi) -- the type of a type via lookupIdType will get stuck in an endless loop. (hsi)
visitQualTypeIdent :: QualIdent -> FlatState QName trTypeIdent :: QualIdent -> FlatState QName
visitQualTypeIdent qid = do trTypeIdent qid = do
mid <- moduleId mid <- getModuleIdent
let (mmod, ident) = (qidModule qid, qidIdent qid) let (mmod, ident) = (qidModule qid, qidIdent qid)
modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
= Id.moduleName preludeMIdent = moduleName preludeMIdent
| otherwise | otherwise
= maybe (Id.moduleName mid) Id.moduleName mmod = maybe (moduleName mid) moduleName mmod
return (QName Nothing Nothing modid $ idName ident) return (QName Nothing Nothing modid $ idName ident)