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

Adaption of top-level imports in type Curry.Syntax.Module

parent 146865c7
......@@ -52,8 +52,8 @@ typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls
-- TODO: Which one?
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: CompilerEnv -> ([Decl], [Decl]) -> [Message]
warnCheck env = uncurry $ WC.warnCheck (moduleIdent env) (valueEnv env)
warnCheck :: CompilerEnv -> [ImportDecl] -> [Decl] -> [Message]
warnCheck env = WC.warnCheck (moduleIdent env) (valueEnv env)
......@@ -50,7 +50,7 @@ run f = reverse $ messages $ execState f emptyState
-- - idle case alternatives
-- - overlapping case alternatives
-- - function rules which are not together
warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]
warnCheck :: ModuleIdent -> ValueEnv -> [ImportDecl] -> [Decl] -> [Message]
warnCheck mid vals imports decls = run $ do
addImportedValues vals
addModuleId mid
......@@ -376,7 +376,7 @@ checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls
-- check import declarations for multiply imported modules
checkImports :: [Decl] -> CheckM ()
checkImports :: [ImportDecl] -> CheckM ()
checkImports imps = checkImps Map.empty imps
where
checkImps _ [] = return ()
......@@ -388,7 +388,6 @@ checkImports imps = checkImps Map.empty imps
(Map.lookup mid env)
| otherwise
= checkImps env imps'
checkImps env (_ : imps') = checkImps env imps'
checkImpSpec env _ mid (_,_) Nothing
= genWarning' (multiplyImportedModule mid) >> return env
......
......@@ -32,7 +32,7 @@ import Curry.Base.Ident
import Curry.Base.MessageMonad
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), Decl (..), parseHeader)
import Curry.Syntax (Module (..), ImportDecl (..), parseHeader)
import Base.ErrorMessages (errCyclicImport, errWrongModule)
import Base.SCC (scc)
......@@ -91,16 +91,16 @@ sourceDeps opts paths sEnv fn = do
-- |Retrieve the dependencies of a given module
moduleDeps :: Options -> [FilePath] -> SourceEnv -> FilePath -> Module -> IO SourceEnv
moduleDeps opts paths sEnv fn (Module m _ ds) = case Map.lookup m sEnv of
moduleDeps opts paths sEnv fn (Module m _ is _) = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
let imps = imports opts m ds
let imps = imports opts m is
sEnv' = Map.insert m (Source fn imps) sEnv
foldM (moduleIdentDeps opts paths) sEnv' imps
-- |Retrieve the imported modules and add the import of the Prelude
-- according to the compiler options.
imports :: Options -> ModuleIdent -> [Decl] -> [ModuleIdent]
imports :: Options -> ModuleIdent -> [ImportDecl] -> [ModuleIdent]
imports opts m ds = nub $
[preludeMIdent | m /= preludeMIdent && implicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- ds]
......@@ -120,7 +120,7 @@ moduleIdentDeps opts paths sEnv m = case Map.lookup m sEnv of
where
libraryPaths = optImportPaths opts
checkModuleHeader fn = do
hdr@(Module m' _ _) <- (ok . parseHeader fn) `liftM` readModule fn
hdr@(Module m' _ _ _) <- (ok . parseHeader fn) `liftM` readModule fn
unless (m == m') $ error $ errWrongModule m m'
moduleDeps opts paths sEnv fn hdr
......
......@@ -68,7 +68,7 @@ lookupTupleArity ident
constructor arities.
-}
bindArities :: ArityEnv -> Module -> ArityEnv
bindArities aEnv (Module mid _ decls)
bindArities aEnv (Module mid _ _ decls)
= foldl (visitDecl mid) aEnv decls
visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv
......
......@@ -16,11 +16,11 @@ module Env.Interface where
import qualified Data.Map as Map (Map, empty, lookup)
import Curry.Base.Ident (ModuleIdent)
import Curry.Syntax (IDecl)
import Curry.Syntax (Interface)
type InterfaceEnv = Map.Map ModuleIdent [IDecl]
type InterfaceEnv = Map.Map ModuleIdent Interface
lookupInterface :: ModuleIdent -> InterfaceEnv -> Maybe [IDecl]
lookupInterface :: ModuleIdent -> InterfaceEnv -> Maybe Interface
lookupInterface = Map.lookup
initInterfaceEnv :: InterfaceEnv
......
......@@ -26,7 +26,7 @@ import qualified Data.Map as Map (Map, empty, findWithDefault, insert, lookup)
import Data.Maybe (fromMaybe)
import Curry.Base.Ident (ModuleIdent)
import Curry.Syntax (Decl (..))
import Curry.Syntax (ImportDecl (..))
type AliasEnv = Map.Map ModuleIdent ModuleIdent
......@@ -35,13 +35,12 @@ initAliasEnv :: AliasEnv
initAliasEnv = Map.empty
-- |Create an alias environment from a list of import declarations
importAliases :: [Decl] -> AliasEnv
importAliases :: [ImportDecl] -> AliasEnv
importAliases = foldr bindAlias initAliasEnv
-- |Bind an alias for a module from a single import declaration
bindAlias :: Decl -> AliasEnv -> AliasEnv
bindAlias :: ImportDecl -> AliasEnv -> AliasEnv
bindAlias (ImportDecl _ mid _ alias _) = Map.insert mid $ fromMaybe mid alias
bindAlias _ = id
-- |Lookup the alias for a module, if existent
lookupAlias :: ModuleIdent -> AliasEnv -> Maybe ModuleIdent
......
......@@ -58,21 +58,22 @@ the interface of the module.
> expandInterface env mdl = expandInterface' mdl (tyConsEnv env) (valueEnv env)
> expandInterface' :: Module -> TCEnv -> ValueEnv -> Module
> expandInterface' (Module m es ds) tcEnv tyEnv =
> expandInterface' (Module m es is ds) tcEnv tyEnv =
> case findDouble exportedTypes of
> Just tc -> errorAt' $ ambiguousExportType tc
> Nothing -> case findDouble exportedValues of
> Just v -> errorAt' $ ambiguousExportValue v
> Nothing -> Module m (Just (Exporting NoPos exports)) ds
> Nothing -> Module m (Just (Exporting NoPos expandedExports)) is ds
> where
> exports = joinExports $ maybe (expandLocalModule tcEnv tyEnv)
> (expandSpecs importedMods m tcEnv tyEnv)
> es
> expandedExports = joinExports
> $ maybe (expandLocalModule tcEnv tyEnv)
> (expandSpecs importedMods m tcEnv tyEnv)
> es
> importedMods = Set.fromList
> [fromMaybe m' asM | ImportDecl _ m' _ asM _ <- ds]
> exportedTypes = [unqualify tc | ExportTypeWith tc _ <- exports]
> exportedValues = [c | ExportTypeWith _ cs <- exports, c <- cs]
> ++ [unqualify f | Export f <- exports]
> [fromMaybe m' asM | ImportDecl _ m' _ asM _ <- is]
> exportedTypes = [unqualify tc | ExportTypeWith tc _ <- expandedExports]
> exportedValues = [c | ExportTypeWith _ cs <- expandedExports, c <- cs]
> ++ [unqualify f | Export f <- expandedExports]
\end{verbatim}
While checking all export specifications, the compiler expands
......@@ -226,13 +227,13 @@ exported function.
> (opPrecEnv env) (tyConsEnv env) (valueEnv env)
> exportInterface' :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
> exportInterface' (Module m (Just (Exporting _ es)) _) pEnv tcEnv tyEnv
> = Interface m $ imports ++ precs ++ hidden ++ decls
> exportInterface' (Module m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
> = Interface m imports $ precs ++ hidden ++ decls
> where imports = map (IImportDecl NoPos) $ usedModules decls
> precs = foldr (infixDecl m pEnv) [] es
> hidden = map (hiddenTypeDecl m tcEnv) $ hiddenTypes decls
> decls = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
> exportInterface' (Module _ Nothing _) _ _ _
> exportInterface' (Module _ Nothing _ _) _ _ _
> = internalError "Exports.exportInterface: no export specification"
> infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
......
......@@ -45,12 +45,12 @@ genUntypedAbstract tyEnv tcEnv modul
-- |Generate an AbstractCurry program term from the syntax tree
genAbstract :: AbstractEnv -> Module -> CurryProg
genAbstract env (Module mid _ decls)
= CurryProg modname imps types (Map.elems funcs) ops
genAbstract env (Module mid _ imps decls)
= CurryProg modname imprts types (Map.elems funcs) ops
where
modname = moduleName mid
partitions = foldl partitionDecl emptyPartitions decls
(imps, _) = mapfoldl genImportDecl env (reverse (importDecls partitions))
(imprts,_) = mapfoldl genImportDecl env imps
(types, _) = mapfoldl genTypeDecl env (reverse (typeDecls partitions))
(_, funcs) = Map.mapAccumWithKey (genFuncDecl False) env
(funcDecls partitions)
......@@ -73,8 +73,7 @@ genAbstract env (Module mid _ decls)
to collect them within an association list
-}
data Partitions = Partitions
{ importDecls :: [Decl]
, typeDecls :: [Decl]
{ typeDecls :: [Decl]
, funcDecls :: Map.Map Ident [Decl]
, opDecls :: [Decl]
} deriving Show
......@@ -82,8 +81,7 @@ data Partitions = Partitions
-- |Generate initial partitions
emptyPartitions :: Partitions
emptyPartitions = Partitions
{ importDecls = []
, typeDecls = []
{ typeDecls = []
, funcDecls = Map.empty
, opDecls = []
}
......@@ -91,9 +89,6 @@ emptyPartitions = Partitions
-- Inserts a CurrySyntax top level declaration into a partition.
-- Note: declarations are collected in reverse order.
partitionDecl :: Partitions -> Decl -> Partitions
-- import decls
partitionDecl parts decl@(ImportDecl _ _ _ _ _)
= parts {importDecls = decl : importDecls parts }
-- type decls
partitionDecl parts decl@(DataDecl _ _ _ _)
= parts {typeDecls = decl : typeDecls parts }
......@@ -130,9 +125,8 @@ partitionFuncDecls genDecl parts ids
-- terms.
--
genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv)
genImportDecl :: AbstractEnv -> ImportDecl -> (String, AbstractEnv)
genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env)
genImportDecl _ _ = error "GenAbstractCurry.genImportDecl: no import declaration"
--
genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv)
......@@ -763,12 +757,12 @@ data AbstractType
-- Initializes the AbstractCurry generator environment.
genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv
genAbstractEnv absType tyEnv tcEnv (Module mid exps decls) = AbstractEnv
genAbstractEnv absType tyEnv tcEnv (Module mid exps imps decls) = AbstractEnv
{ moduleId = mid
, typeEnv = tyEnv
, tconsEnv = tcEnv
, exports = foldl (buildExportTable mid decls) Set.empty exps'
, imports = foldl buildImportTable Map.empty decls
, imports = foldl buildImportTable Map.empty imps
, varIndex = 0
, tvarIndex = 0
, varScope = [Map.empty]
......@@ -836,12 +830,10 @@ getConstrIdents _ = error "GenAbstractCurry.getConstrIdents: no pattern match"
-- Builds a table for dereferencing import aliases
buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl
-> Map.Map ModuleIdent ModuleIdent
buildImportTable :: Map.Map ModuleIdent ModuleIdent -> ImportDecl
-> Map.Map ModuleIdent ModuleIdent
buildImportTable env (ImportDecl _ mid _ malias _)
= Map.insert (fromMaybe mid malias) mid env
buildImportTable env _ = env
-- Checks whether an identifier is exported or not.
isExported :: AbstractEnv -> Ident -> Bool
......
......@@ -117,7 +117,7 @@ data FlatEnv = FlatEnv
, publicEnvE :: Map.Map Ident IdentExport
, fixitiesE :: [CS.IDecl]
, typeSynonymsE :: [CS.IDecl]
, importsE :: [CS.IDecl]
, importsE :: [CS.IImportDecl]
, exportsE :: [CS.Export]
, interfaceE :: [CS.IDecl]
, varIndexE :: Int
......@@ -214,9 +214,7 @@ visitModule (IL.Module mid imps decls) = do
(ifuncs ++ funcs)
(iops ++ ops)))
where
extractMid d = case d of
(CS.IImportDecl _ mid1) -> mid1
_ -> error "Gen.GenFlatCurry.visitModule: no IImportDecl"
extractMid (CS.IImportDecl _ mid1) = mid1
--
visitDataDecl :: IL.Decl -> FlatState TypeDecl
......@@ -522,10 +520,10 @@ genExpIDecls idecls ((mid,exps):mes)
let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_
genExpIDecls idecls' mes
where
p_genExpIDecls mid1 idecls1 exps1 intf
| null exps1 = (map (qualifyIDecl mid1) intf) ++ idecls1
p_genExpIDecls mid1 idecls1 exps1 (CS.Interface _ _ ds)
| null exps1 = (map (qualifyIDecl mid1) ds) ++ idecls1
| otherwise = (filter (isExportedIDecl exps1)
(map (qualifyIDecl mid1) intf))
(map (qualifyIDecl mid1) ds))
++ idecls1
--
......@@ -949,7 +947,7 @@ exports :: FlatState [CS.Export]
exports = gets exportsE
--
imports :: FlatState [CS.IDecl]
imports :: FlatState [CS.IImportDecl]
imports = gets importsE
--
......@@ -975,9 +973,8 @@ isPublic isConstr qid = gets (\env -> maybe False isP
isP NotOnlyConstr = True
--
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl])
lookupModuleIntf mid
= gets (Map.lookup mid . interfaceEnvE)
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe CS.Interface)
lookupModuleIntf mid = gets (Map.lookup mid . interfaceEnvE)
--
lookupIdArity :: QualIdent -> FlatState (Maybe Int)
......
......@@ -201,30 +201,29 @@ rights_sc xs = [ x | Right x <- xs]
--- @param parse-Module
--- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers' (Module moduleIdent maybeExportSpec decls)
catIdentifiers' (Module moduleIdent maybeExportSpec imports decls)
Nothing =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
ModuleName moduleIdent :
maybe [] exportSpec2codes maybeExportSpec ++ codes)
catIdentifiers' (Module moduleIdent maybeExportSpec1 _)
(Just (Module _ maybeExportSpec2 decls)) =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
maybe [] exportSpec2codes maybeExportSpec ++ impCodes ++ codes)
catIdentifiers' (Module moduleIdent maybeExportSpec1 _ _)
(Just (Module _ maybeExportSpec2 imports decls)) =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
replaceFunctionCalls $
map (addModuleIdent moduleIdent)
([ModuleName moduleIdent] ++
mergeExports2codes
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec1)
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec2) ++
codes))
impCodes ++ codes))
renamedImports :: Decl -> [(ModuleIdent,ModuleIdent)]
renamedImports decl =
case decl of
(ImportDecl _ oldName _ (Just newName) _) -> [(oldName,newName)]
_ -> []
renamedImports :: ImportDecl -> [(ModuleIdent,ModuleIdent)]
renamedImports (ImportDecl _ oldName _ (Just newName) _) = [(oldName,newName)]
renamedImports _ = []
replaceFunctionCalls :: [Code] -> [Code]
......@@ -447,7 +446,6 @@ isTokenIdentifier (Token cat _) =
-- DECL Position
getPosition :: Decl -> Position
getPosition (ImportDecl pos _ _ _ _) = pos
getPosition (InfixDecl pos _ _ _) = pos
getPosition (DataDecl pos _ _ _) = pos
getPosition (NewtypeDecl pos _ _ _) = pos
......@@ -464,6 +462,9 @@ getPosition (ExtraVariables pos _) = pos
lessDecl :: Decl -> Decl -> Bool
lessDecl = (<) `on` getPosition
lessImportDecl :: ImportDecl -> ImportDecl -> Bool
lessImportDecl = (<) `on` (\ (ImportDecl p _ _ _ _) -> p)
qsort :: (a -> a -> Bool) -> [a] -> [a]
qsort _ [] = []
qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]
......@@ -471,10 +472,8 @@ qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y |
-- DECL TO CODE --------------------------------------------------------------------
exportSpec2codes :: ExportSpec -> [Code]
exportSpec2codes (Exporting _ exports) = concatMap (export2codes []) exports
exportSpec2codes (Exporting _ exports) = concatMap (export2codes []) exports
--- @param parse-Exports
--- @param betterParse-Exports
......@@ -505,9 +504,6 @@ export2codes exports (Export qualIdent)
export2c _ =
[TypeConstructor TypeExport qualIdent]
export2codes _ (ExportTypeWith qualIdent idents) =
TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents
export2codes _ (ExportTypeAll qualIdent) =
......@@ -515,11 +511,13 @@ export2codes _ (ExportTypeAll qualIdent) =
export2codes _ (ExportModule moduleIdent) =
[ModuleName moduleIdent]
decl2codes :: Decl -> [Code]
decl2codes (ImportDecl _ moduleIdent _ mModuleIdent importSpec) =
importDecl2codes :: ImportDecl -> [Code]
importDecl2codes (ImportDecl _ moduleIdent _ mModuleIdent importSpec) =
[ModuleName moduleIdent] ++
maybe [] ((:[]) . ModuleName) mModuleIdent ++
maybe [] (importSpec2codes moduleIdent) importSpec
decl2codes :: Decl -> [Code]
decl2codes (InfixDecl _ _ _ idents) =
map (Function InfixFunction . qualify) idents
decl2codes (DataDecl _ ident idents constrDecls) =
......
......@@ -45,7 +45,8 @@ import Records (importLabels, recordExpansion1, recordExpansion2)
-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
importModules :: Options -> ModuleIdent -> InterfaceEnv -> [Decl] -> CompilerEnv
importModules :: Options -> ModuleIdent -> InterfaceEnv
-> [ImportDecl] -> CompilerEnv
importModules opts mid iEnv decls = recordExpansion1 opts
$ importUnifyData
$ foldl importModule initEnv decls
......@@ -56,20 +57,17 @@ importModules opts mid iEnv decls = recordExpansion1 opts
, interfaceEnv = iEnv -- imported interfaces
}
importModule env (ImportDecl _ m q asM is) = case Map.lookup m iEnv of
Just ds -> importInterface (fromMaybe m asM) q is (Interface m ds) env
Nothing -> internalError $ "Imports.importModules: no interface for "
++ show m
importModule env' _ = env'
Just intf -> importInterface (fromMaybe m asM) q is intf env
Nothing -> internalError $ "Imports.importModules: no interface for "
++ show m
-- |
qualifyEnv :: Options -> InterfaceEnv -> CompilerEnv -> CompilerEnv
qualifyEnv opts iEnv env = recordExpansion2 opts
$ qualifyLocal env
$ foldl import' initEnv
$ Map.toList iEnv
where
initEnv = initCompilerEnv $ moduleIdent env
import' cEnv1 (m, ds) = importInterfaceIntf (Interface m ds) cEnv1
$ foldl (flip importInterfaceIntf) initEnv
$ Map.elems iEnv
where initEnv = initCompilerEnv $ moduleIdent env
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
......@@ -152,7 +150,7 @@ importConstr isVisible' dc@(DataConstr c _ _)
intfEnv :: (ModuleIdent -> IDecl -> IdentMap a -> IdentMap a)
-> Interface -> IdentMap a
intfEnv bind (Interface m ds) = foldr (bind m) Map.empty ds
intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
-- operator precedences
bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
......@@ -415,7 +413,7 @@ qualifyLocal currentEnv initEnv = currentEnv
-- an interface.
importInterfaceIntf :: Interface -> CompilerEnv -> CompilerEnv
importInterfaceIntf i@(Interface m _) env = env
importInterfaceIntf i@(Interface m _ _) env = env
{ opPrecEnv = importEntities m True (const True) id mPEnv $ opPrecEnv env
, tyConsEnv = importEntities m True (const True) id mTCEnv $ tyConsEnv env
, valueEnv = importEntities m True (const True) id mTyEnv $ valueEnv env
......
......@@ -44,9 +44,9 @@ import Env.Interface
-- |Load the interface files into the 'InterfaceEnv'
loadInterfaces :: [FilePath] -> Module -> IO InterfaceEnv
loadInterfaces paths (Module m _ ds) =
loadInterfaces paths (Module m _ is _) =
foldM (loadInterface paths [m]) initInterfaceEnv
[(p, m') | ImportDecl p m' _ _ _ <- ds]
[(p, m') | ImportDecl p m' _ _ _ <- is]
-- If an import declaration for a module is found, the compiler first
-- checks whether an import for the module is already pending. In this
......@@ -76,12 +76,12 @@ compileInterface :: [FilePath] -> [ModuleIdent] -> InterfaceEnv
compileInterface paths ctxt mEnv m fn = do
mintf <- (fmap flatToCurryInterface) `liftM` EF.readFlatInterface fn
case mintf of
Nothing -> errorAt (first fn) $ errInterfaceNotFound m
Just (Interface m' ds) -> do
Nothing -> errorAt (first fn) $ errInterfaceNotFound m
Just intf@(Interface m' is _) -> do
unless (m' == m) $ errorAt (first fn) $ errWrongInterface m m'
let importDecls = [ (pos, imp) | IImportDecl pos imp <- ds ]
let importDecls = [ (pos, imp) | IImportDecl pos imp <- is ]
mEnv' <- foldM (loadInterface paths (m : ctxt)) mEnv importDecls
return $ Map.insert m ds mEnv'
return $ Map.insert m intf mEnv'
-- The function \texttt{flatToCurryInterface} transforms FlatInterface
-- information (type \texttt{FlatCurry.Prog} to MCC interface declarations
......@@ -91,16 +91,15 @@ compileInterface paths ctxt mEnv m fn = do
flatToCurryInterface :: EF.Prog -> Interface
flatToCurryInterface (EF.Prog m imps ts fs os)
= Interface (fromModuleName m) $ concat
[ map genIImportDecl imps
, map genITypeDecl $ filter (not . isSpecialPreludeType) ts
= Interface (fromModuleName m) (map genIImportDecl imps) $ concat
[ map genITypeDecl $ filter (not . isSpecialPreludeType) ts
, map genIFuncDecl fs
, map genIOpDecl os
]
where
pos = first m
genIImportDecl :: String -> IDecl
genIImportDecl :: String -> IImportDecl
genIImportDecl = IImportDecl pos . fromModuleName
genITypeDecl :: EF.TypeDecl -> IDecl
......
......@@ -27,13 +27,13 @@ import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
-- |A record containing data for a module 'm'
data ModuleSummary = ModuleSummary
{ moduleId :: ModuleIdent -- ^The name of 'm'
, interface :: [IDecl] -- ^all exported declarations in 'm'
-- (including exported imports)
, exports :: [Export] -- ^The export list extracted from 'm'
, imports :: [IDecl] -- ^imports
, infixDecls :: [IDecl] -- ^Interfaces of all infix declarations in 'm'
, typeSynonyms :: [IDecl] -- ^Interfaces of all type synonyms in 'm'
{ moduleId :: ModuleIdent -- ^The name of 'm'
, interface :: [IDecl] -- ^all exported declarations in 'm'
-- (including exported imports)
, exports :: [Export] -- ^The export list extracted from 'm'
, imports :: [IImportDecl] -- ^imports
, infixDecls :: [IDecl] -- ^Interfaces of all infix declarations in 'm'
, typeSynonyms :: [IDecl] -- ^Interfaces of all type synonyms in 'm'
} deriving Show
......@@ -41,12 +41,12 @@ data ModuleSummary = ModuleSummary
table of type constructors and its interface
-}
summarizeModule :: TCEnv -> Interface -> Module -> ModuleSummary
summarizeModule tcEnv (Interface iid idecls) mdl@(Module mid mExp decls)
summarizeModule tcEnv (Interface iid _ idecls) mdl@(Module mid mExp imps _)
| iid == mid = ModuleSummary
{ moduleId = mid
, interface = idecls
, exports = maybe [] (\ (Exporting _ exps) -> exps) mExp
, imports = genImports decls
, imports = genImports imps
, infixDecls = genInfixDecls mdl
, typeSynonyms = genTypeSyns tcEnv mdl
}
......@@ -55,20 +55,19 @@ summarizeModule tcEnv (Interface iid idecls) mdl@(Module mid mExp decls)
-- ---------------------------------------------------------------------------
-- |Generate interface import declarations
genImports :: [Decl] -> [IDecl]
genImports :: [ImportDecl] -> [IImportDecl]
genImports = map snd . foldr addImport []
where
addImport :: Decl -> [(ModuleIdent, IDecl)] -> [(ModuleIdent, IDecl)]
addImport :: ImportDecl -> [(ModuleIdent, IImportDecl)] -> [(ModuleIdent, IImportDecl)]
addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
addImport _ imps = imps
-- ---------------------------------------------------------------------------
-- |Generate interface infix declarations in the module
genInfixDecls :: Module -> [IDecl]
genInfixDecls (Module mident _ decls) = concatMap genInfixDecl decls
genInfixDecls (Module mident _ _ decls) = concatMap genInfixDecl decls
where
genInfixDecl :: Decl -> [IDecl]
genInfixDecl (InfixDecl pos spec prec idents)
......@@ -87,7 +86,7 @@ genInfixDecls (Module mident _ decls) = concatMap genInfixDecl decls
-- |Generate interface declarations for all type synonyms in the module.
genTypeSyns :: TCEnv -> Module -> [IDecl]
genTypeSyns tcEnv (Module mident _ decls)
genTypeSyns tcEnv (Module mident _ _ decls)
= concatMap (genTypeSynDecl mident tcEnv) $ filter isTypeSyn decls
isTypeSyn :: Decl -> Bool
......
......@@ -25,7 +25,6 @@ This module controls the compilation of modules.
> ) where
> import Control.Monad (liftM, unless, when)
> import Data.List (partition)
> import Data.Maybe (fromMaybe)
> import Text.PrettyPrint (Doc, ($$), text, vcat)
......@@ -128,7 +127,7 @@ code are obsolete and commented out.
> -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
> checkModuleId :: FilePath -> Module -> (Module, [String])