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