Skip to content

GitLab

Commit f5693969 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Refactorings

parent 2204448d
Hide whitespace changes
Inline Side-by-side
src/Generators/GenFlatCurry.hs
View file @ f5693969
......@@ -132,23 +132,23 @@ data IdentExport
-- Runs a 'FlatState' action and returns the result
run :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv -> ValueEnv -> TCEnv
-> Bool -> FlatState a -> (a, [Message])
run opts cEnv mEnv tyEnv tcEnv genIntf f = (result, messagesE env)
run opts modSum mEnv tyEnv tcEnv genIntf f = (result, messagesE env)
where
(result, env) = runState f env0
env0 = FlatEnv
{ moduleIdE = ModuleSummary.moduleId cEnv
{ moduleIdE = ModuleSummary.moduleId modSum
, functionIdE = (qualify (mkIdent ""), [])
, compilerOptsE = opts
, interfaceEnvE = mEnv
, typeEnvE = tyEnv
, tConsEnvE = tcEnv
, publicEnvE = genPubEnv (ModuleSummary.moduleId cEnv)
(ModuleSummary.interface cEnv)
, fixitiesE = ModuleSummary.infixDecls cEnv
, typeSynonymsE = ModuleSummary.typeSynonyms cEnv
, importsE = ModuleSummary.imports cEnv
, exportsE = ModuleSummary.exports cEnv
, interfaceE = ModuleSummary.interface cEnv
, publicEnvE = genPubEnv (ModuleSummary.moduleId modSum)
(ModuleSummary.interface modSum)
, fixitiesE = ModuleSummary.infixDecls modSum
, typeSynonymsE = ModuleSummary.typeSynonyms modSum
, importsE = ModuleSummary.imports modSum
, exportsE = ModuleSummary.exports modSum
, interfaceE = ModuleSummary.interface modSum
, varIndexE = 0
, varIdsE = ScopeEnv.new
, tvarIndexE = 0
......
src/IL/XML.lhs
View file @ f5693969
......@@ -24,22 +24,21 @@ similar to that of Flat-Curry XML representation.
> import Curry.Base.Ident
> import IL.Type
TODO: The following two imports should be avoided if possible as they make
TODO: The following import should be avoided if possible as it makes
the program structure less clear.
> import qualified Curry.Syntax as CS
> import ModuleSummary
> -- identation level
> level::Int
> level = 3
> xmlModule :: ModuleSummary -> Module -> Doc
> xmlModule modSum m
> = text "<prog>" $$ nest level (xmlBody modSum m) $$ text "</prog>"
> xmlModule :: [CS.IDecl] -> [CS.IDecl] -> Module -> Doc
> xmlModule intf infx m
> = text "<prog>" $$ nest level (xmlBody intf infx m) $$ text "</prog>"
> xmlBody :: ModuleSummary -> Module -> Doc
> xmlBody modSum (Module mname mimports decls) =
> xmlBody :: [CS.IDecl] -> [CS.IDecl] -> Module -> Doc
> xmlBody intf infx (Module mname mimports decls) =
> xmlElement "module" xmlModuleDecl moduleDecl $$
> xmlElement "import" xmlImportDecl importDecl $$
> xmlElement "types" xmlTypeDecl typeDecl $$
......@@ -50,8 +49,8 @@ TODO: The following two imports should be avoided if possible as they make
> moduleDecl = [mname]
> importDecl = mimports
> (funcDecl,typeDecl) = splitDecls decls
> operatorDecl = infixDecls modSum
> translationDecl = foldl (qualIDeclId (moduleId modSum)) [] (interface modSum)
> operatorDecl = infx
> translationDecl = foldl (qualIDeclId mname) [] intf
> xmlModuleDecl :: ModuleIdent -> Doc
> xmlModuleDecl = xmlModuleIdent
......
src/Imports.hs
View file @ f5693969
......@@ -336,7 +336,6 @@ expandTypeWith m tcEnv tc cs = case Map.lookup tc tcEnv of
| l `elem` ls' = l
| otherwise = errorMessage $ errUndefinedLabel tc l
expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import
expandTypeAll m tcEnv tc = case Map.lookup tc tcEnv of
Just (DataType _ _ cs) -> ImportTypeWith tc
......@@ -348,6 +347,25 @@ expandTypeAll m tcEnv tc = case Map.lookup tc tcEnv of
Just (AliasType _ _ _) -> errorMessage $ errNonDataType tc
Nothing -> errorMessage $ errUndefinedEntity m tc
errUndefinedEntity :: ModuleIdent -> Ident -> Message
errUndefinedEntity m x = posErr x $
"Module " ++ moduleName m ++ " does not export " ++ name x
errUndefinedDataConstr :: Ident -> Ident -> Message
errUndefinedDataConstr tc c = posErr c $
name c ++ " is not a data constructor of type " ++ name tc
errUndefinedLabel :: Ident -> Ident -> Message
errUndefinedLabel tc c = posErr c $
name c ++ " is not a label of record type " ++ name tc
errNonDataType :: Ident -> Message
errNonDataType tc = posErr tc $ name tc ++ " is not a data type"
errImportDataConstr :: ModuleIdent -> Ident -> Message
errImportDataConstr _ c = posErr c $
"Explicit import for data constructor " ++ name c
-- ---------------------------------------------------------------------------
-- After all modules have been imported, the compiler has to ensure that
......@@ -404,9 +422,9 @@ importInterfaceIntf i@(Interface m _ _) env = env
, valueEnv = importEntities m True (const True) id mTyEnv $ valueEnv env
}
where
mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTCHidden i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTCHidden i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
-- ---------------------------------------------------------------------------
-- Record stuff
......@@ -431,7 +449,7 @@ expandRecordTC tcEnv (DataType qid n args) =
expandRecordTC tcEnv (RenamingType qid n (DataConstr c m [ty])) =
RenamingType qid n (DataConstr c m [expandRecords tcEnv ty])
expandRecordTC _ (RenamingType _ _ (DataConstr _ _ _)) =
internalError "Records.expandRecordTC"
internalError "Imports.expandRecordTC"
expandRecordTC tcEnv (AliasType qid n ty) =
AliasType qid n (expandRecords tcEnv ty)
......@@ -516,24 +534,3 @@ expandRecords _ ty = ty
-- addLabelType (LabelType l r ty) = importTopEnv m' l lblInfo
-- where lblInfo = Label (qualify l) (qualQualify m' r) (polyType ty)
-- m' = fromMaybe m (qualidMod r)
-- Error messages:
errUndefinedEntity :: ModuleIdent -> Ident -> Message
errUndefinedEntity m x = posErr x $
"Module " ++ moduleName m ++ " does not export " ++ name x
errUndefinedDataConstr :: Ident -> Ident -> Message
errUndefinedDataConstr tc c = posErr c $
name c ++ " is not a data constructor of type " ++ name tc
errUndefinedLabel :: Ident -> Ident -> Message
errUndefinedLabel tc c = posErr c $
name c ++ " is not a label of record type " ++ name tc
errNonDataType :: Ident -> Message
errNonDataType tc = posErr tc $ name tc ++ " is not a data type"
errImportDataConstr :: ModuleIdent -> Ident -> Message
errImportDataConstr _ c = posErr c $
"Explicit import for data constructor " ++ name c
src/ModuleSummary.hs
View file @ f5693969
......@@ -36,9 +36,8 @@ data ModuleSummary = ModuleSummary
} deriving Show
{- |Return a 'ModuleSummary' for a module, its corresponding
table of type constructors and its interface
-}
-- |Return a 'ModuleSummary' for a module, its corresponding
-- table of type constructors and its interface
summarizeModule :: TCEnv -> Interface -> Module -> ModuleSummary
summarizeModule tcEnv (Interface iid _ idecls) (Module mid mExp imps decls)
| iid == mid = ModuleSummary
......@@ -49,20 +48,15 @@ summarizeModule tcEnv (Interface iid _ idecls) (Module mid mExp imps decls)
, infixDecls = genInfixDecls mid decls
, typeSynonyms = genTypeSyns tcEnv mid decls
}
| otherwise = internalError $ errInterfaceModuleMismatch iid mid
-- ---------------------------------------------------------------------------
| otherwise = internalError $
"Interface " ++ show iid ++ " does not match module " ++ show mid
-- |Generate interface import declarations
genImports :: [ImportDecl] -> [IImportDecl]
genImports = map snd . foldr addImport []
where
addImport :: ImportDecl -> [(ModuleIdent, IImportDecl)] -> [(ModuleIdent, IImportDecl)]
addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
-- ---------------------------------------------------------------------------
where addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
-- |Generate interface infix declarations in the module
genInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
......@@ -73,14 +67,6 @@ genInfixDecls mident decls = concatMap genInfixDecl decls
= map (IInfixDecl pos spec prec . qualifyWith mident) idents
genInfixDecl _ = []
-- collectIInfixDecls mident decls
-- collectIInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
-- collectIInfixDecls _ [] = []
-- collectIInfixDecls mident ((InfixDecl pos infixspec prec idents) : decls)
-- = map (IInfixDecl pos infixspec prec . qualifyWith mident) idents
-- ++ collectIInfixDecls mident decls
-- collectIInfixDecls mident (_ : decls) = collectIInfixDecls mident decls
-- ---------------------------------------------------------------------------
-- |Generate interface declarations for all type synonyms in the module.
......@@ -158,7 +144,3 @@ lookupTCId qident tcEnv = case qualLookupTC qident tcEnv of
[RenamingType qid _ _] -> Just qid
[AliasType qid _ _] -> Just qid
_ -> Nothing
errInterfaceModuleMismatch :: ModuleIdent -> ModuleIdent -> String
errInterfaceModuleMismatch mi mm =
"Interface " ++ show mi ++ " does not match module " ++ show mm
src/Modules.hs
View file @ f5693969
......@@ -258,7 +258,7 @@ writeXML opts fn modSum il = when xmlTarget $
xmlTarget = FlatXml `elem` optTargetTypes opts
useSubDir = optUseSubdir opts
targetFile = fromMaybe (xmlName fn) (optOutput opts)
curryXml = shows (IL.xmlModule modSum il) "\n"
curryXml = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"
writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
writeAbstractCurry opts fname env modul = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment