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' }) ...@@ -52,8 +52,8 @@ typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env) where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls (tyConsEnv env) (valueEnv env) decls
-- TODO: Which one? -- TODO: Which kind of warnings?
-- |Check for warnings. -- |Check for warnings.
warnCheck :: CompilerEnv -> ([Decl], [Decl]) -> [Message] warnCheck :: CompilerEnv -> [ImportDecl] -> [Decl] -> [Message]
warnCheck env = uncurry $ WC.warnCheck (moduleIdent env) (valueEnv env) warnCheck env = WC.warnCheck (moduleIdent env) (valueEnv env)
...@@ -50,7 +50,7 @@ run f = reverse $ messages $ execState f emptyState ...@@ -50,7 +50,7 @@ run f = reverse $ messages $ execState f emptyState
-- - idle case alternatives -- - idle case alternatives
-- - overlapping case alternatives -- - overlapping case alternatives
-- - function rules which are not together -- - 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 warnCheck mid vals imports decls = run $ do
addImportedValues vals addImportedValues vals
addModuleId mid addModuleId mid
...@@ -376,7 +376,7 @@ checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls ...@@ -376,7 +376,7 @@ checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls
-- check import declarations for multiply imported modules -- check import declarations for multiply imported modules
checkImports :: [Decl] -> CheckM () checkImports :: [ImportDecl] -> CheckM ()
checkImports imps = checkImps Map.empty imps checkImports imps = checkImps Map.empty imps
where where
checkImps _ [] = return () checkImps _ [] = return ()
...@@ -388,7 +388,6 @@ checkImports imps = checkImps Map.empty imps ...@@ -388,7 +388,6 @@ checkImports imps = checkImps Map.empty imps
(Map.lookup mid env) (Map.lookup mid env)
| otherwise | otherwise
= checkImps env imps' = checkImps env imps'
checkImps env (_ : imps') = checkImps env imps'
checkImpSpec env _ mid (_,_) Nothing checkImpSpec env _ mid (_,_) Nothing
= genWarning' (multiplyImportedModule mid) >> return env = genWarning' (multiplyImportedModule mid) >> return env
......
...@@ -32,7 +32,7 @@ import Curry.Base.Ident ...@@ -32,7 +32,7 @@ import Curry.Base.Ident
import Curry.Base.MessageMonad import Curry.Base.MessageMonad
import Curry.Files.Filenames import Curry.Files.Filenames
import Curry.Files.PathUtils import Curry.Files.PathUtils
import Curry.Syntax (Module (..), Decl (..), parseHeader) import Curry.Syntax (Module (..), ImportDecl (..), parseHeader)
import Base.ErrorMessages (errCyclicImport, errWrongModule) import Base.ErrorMessages (errCyclicImport, errWrongModule)
import Base.SCC (scc) import Base.SCC (scc)
...@@ -91,16 +91,16 @@ sourceDeps opts paths sEnv fn = do ...@@ -91,16 +91,16 @@ sourceDeps opts paths sEnv fn = do
-- |Retrieve the dependencies of a given module -- |Retrieve the dependencies of a given module
moduleDeps :: Options -> [FilePath] -> SourceEnv -> FilePath -> Module -> IO SourceEnv 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 Just _ -> return sEnv
Nothing -> do Nothing -> do
let imps = imports opts m ds let imps = imports opts m is
sEnv' = Map.insert m (Source fn imps) sEnv sEnv' = Map.insert m (Source fn imps) sEnv
foldM (moduleIdentDeps opts paths) sEnv' imps foldM (moduleIdentDeps opts paths) sEnv' imps
-- |Retrieve the imported modules and add the import of the Prelude -- |Retrieve the imported modules and add the import of the Prelude
-- according to the compiler options. -- according to the compiler options.
imports :: Options -> ModuleIdent -> [Decl] -> [ModuleIdent] imports :: Options -> ModuleIdent -> [ImportDecl] -> [ModuleIdent]
imports opts m ds = nub $ imports opts m ds = nub $
[preludeMIdent | m /= preludeMIdent && implicitPrelude] [preludeMIdent | m /= preludeMIdent && implicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- ds] ++ [m' | ImportDecl _ m' _ _ _ <- ds]
...@@ -120,7 +120,7 @@ moduleIdentDeps opts paths sEnv m = case Map.lookup m sEnv of ...@@ -120,7 +120,7 @@ moduleIdentDeps opts paths sEnv m = case Map.lookup m sEnv of
where where
libraryPaths = optImportPaths opts libraryPaths = optImportPaths opts
checkModuleHeader fn = do 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' unless (m == m') $ error $ errWrongModule m m'
moduleDeps opts paths sEnv fn hdr moduleDeps opts paths sEnv fn hdr
......
...@@ -68,7 +68,7 @@ lookupTupleArity ident ...@@ -68,7 +68,7 @@ lookupTupleArity ident
constructor arities. constructor arities.
-} -}
bindArities :: ArityEnv -> Module -> ArityEnv bindArities :: ArityEnv -> Module -> ArityEnv
bindArities aEnv (Module mid _ decls) bindArities aEnv (Module mid _ _ decls)
= foldl (visitDecl mid) aEnv decls = foldl (visitDecl mid) aEnv decls
visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv
......
...@@ -16,11 +16,11 @@ module Env.Interface where ...@@ -16,11 +16,11 @@ module Env.Interface where
import qualified Data.Map as Map (Map, empty, lookup) import qualified Data.Map as Map (Map, empty, lookup)
import Curry.Base.Ident (ModuleIdent) 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 lookupInterface = Map.lookup
initInterfaceEnv :: InterfaceEnv initInterfaceEnv :: InterfaceEnv
......
...@@ -26,7 +26,7 @@ import qualified Data.Map as Map (Map, empty, findWithDefault, insert, lookup) ...@@ -26,7 +26,7 @@ import qualified Data.Map as Map (Map, empty, findWithDefault, insert, lookup)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Curry.Base.Ident (ModuleIdent) import Curry.Base.Ident (ModuleIdent)
import Curry.Syntax (Decl (..)) import Curry.Syntax (ImportDecl (..))
type AliasEnv = Map.Map ModuleIdent ModuleIdent type AliasEnv = Map.Map ModuleIdent ModuleIdent
...@@ -35,13 +35,12 @@ initAliasEnv :: AliasEnv ...@@ -35,13 +35,12 @@ initAliasEnv :: AliasEnv
initAliasEnv = Map.empty initAliasEnv = Map.empty
-- |Create an alias environment from a list of import declarations -- |Create an alias environment from a list of import declarations
importAliases :: [Decl] -> AliasEnv importAliases :: [ImportDecl] -> AliasEnv
importAliases = foldr bindAlias initAliasEnv importAliases = foldr bindAlias initAliasEnv
-- |Bind an alias for a module from a single import declaration -- |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 (ImportDecl _ mid _ alias _) = Map.insert mid $ fromMaybe mid alias
bindAlias _ = id
-- |Lookup the alias for a module, if existent -- |Lookup the alias for a module, if existent
lookupAlias :: ModuleIdent -> AliasEnv -> Maybe ModuleIdent lookupAlias :: ModuleIdent -> AliasEnv -> Maybe ModuleIdent
......
...@@ -58,21 +58,22 @@ the interface of the module. ...@@ -58,21 +58,22 @@ the interface of the module.
> expandInterface env mdl = expandInterface' mdl (tyConsEnv env) (valueEnv env) > expandInterface env mdl = expandInterface' mdl (tyConsEnv env) (valueEnv env)
> expandInterface' :: Module -> TCEnv -> ValueEnv -> Module > expandInterface' :: Module -> TCEnv -> ValueEnv -> Module
> expandInterface' (Module m es ds) tcEnv tyEnv = > expandInterface' (Module m es is ds) tcEnv tyEnv =
> case findDouble exportedTypes of > case findDouble exportedTypes of
> Just tc -> errorAt' $ ambiguousExportType tc > Just tc -> errorAt' $ ambiguousExportType tc
> Nothing -> case findDouble exportedValues of > Nothing -> case findDouble exportedValues of
> Just v -> errorAt' $ ambiguousExportValue v > Just v -> errorAt' $ ambiguousExportValue v
> Nothing -> Module m (Just (Exporting NoPos exports)) ds > Nothing -> Module m (Just (Exporting NoPos expandedExports)) is ds
> where > where
> exports = joinExports $ maybe (expandLocalModule tcEnv tyEnv) > expandedExports = joinExports
> (expandSpecs importedMods m tcEnv tyEnv) > $ maybe (expandLocalModule tcEnv tyEnv)
> es > (expandSpecs importedMods m tcEnv tyEnv)
> es
> importedMods = Set.fromList > importedMods = Set.fromList
> [fromMaybe m' asM | ImportDecl _ m' _ asM _ <- ds] > [fromMaybe m' asM | ImportDecl _ m' _ asM _ <- is]
> exportedTypes = [unqualify tc | ExportTypeWith tc _ <- exports] > exportedTypes = [unqualify tc | ExportTypeWith tc _ <- expandedExports]
> exportedValues = [c | ExportTypeWith _ cs <- exports, c <- cs] > exportedValues = [c | ExportTypeWith _ cs <- expandedExports, c <- cs]
> ++ [unqualify f | Export f <- exports] > ++ [unqualify f | Export f <- expandedExports]
\end{verbatim} \end{verbatim}
While checking all export specifications, the compiler expands While checking all export specifications, the compiler expands
...@@ -226,13 +227,13 @@ exported function. ...@@ -226,13 +227,13 @@ exported function.
> (opPrecEnv env) (tyConsEnv env) (valueEnv env) > (opPrecEnv env) (tyConsEnv env) (valueEnv env)
> exportInterface' :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface > exportInterface' :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
> exportInterface' (Module m (Just (Exporting _ es)) _) pEnv tcEnv tyEnv > exportInterface' (Module m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
> = Interface m $ imports ++ precs ++ hidden ++ decls > = Interface m imports $ precs ++ hidden ++ decls
> where imports = map (IImportDecl NoPos) $ usedModules decls > where imports = map (IImportDecl NoPos) $ usedModules decls
> precs = foldr (infixDecl m pEnv) [] es > precs = foldr (infixDecl m pEnv) [] es
> hidden = map (hiddenTypeDecl m tcEnv) $ hiddenTypes decls > hidden = map (hiddenTypeDecl m tcEnv) $ hiddenTypes decls
> decls = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es > decls = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
> exportInterface' (Module _ Nothing _) _ _ _ > exportInterface' (Module _ Nothing _ _) _ _ _
> = internalError "Exports.exportInterface: no export specification" > = internalError "Exports.exportInterface: no export specification"
> infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl] > infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
......
...@@ -45,12 +45,12 @@ genUntypedAbstract tyEnv tcEnv modul ...@@ -45,12 +45,12 @@ genUntypedAbstract tyEnv tcEnv modul
-- |Generate an AbstractCurry program term from the syntax tree -- |Generate an AbstractCurry program term from the syntax tree
genAbstract :: AbstractEnv -> Module -> CurryProg genAbstract :: AbstractEnv -> Module -> CurryProg
genAbstract env (Module mid _ decls) genAbstract env (Module mid _ imps decls)
= CurryProg modname imps types (Map.elems funcs) ops = CurryProg modname imprts types (Map.elems funcs) ops
where where
modname = moduleName mid modname = moduleName mid
partitions = foldl partitionDecl emptyPartitions decls partitions = foldl partitionDecl emptyPartitions decls
(imps, _) = mapfoldl genImportDecl env (reverse (importDecls partitions)) (imprts,_) = mapfoldl genImportDecl env imps
(types, _) = mapfoldl genTypeDecl env (reverse (typeDecls partitions)) (types, _) = mapfoldl genTypeDecl env (reverse (typeDecls partitions))
(_, funcs) = Map.mapAccumWithKey (genFuncDecl False) env (_, funcs) = Map.mapAccumWithKey (genFuncDecl False) env
(funcDecls partitions) (funcDecls partitions)
...@@ -73,8 +73,7 @@ genAbstract env (Module mid _ decls) ...@@ -73,8 +73,7 @@ genAbstract env (Module mid _ decls)
to collect them within an association list to collect them within an association list
-} -}
data Partitions = Partitions data Partitions = Partitions
{ importDecls :: [Decl] { typeDecls :: [Decl]
, typeDecls :: [Decl]
, funcDecls :: Map.Map Ident [Decl] , funcDecls :: Map.Map Ident [Decl]
, opDecls :: [Decl] , opDecls :: [Decl]
} deriving Show } deriving Show
...@@ -82,8 +81,7 @@ data Partitions = Partitions ...@@ -82,8 +81,7 @@ data Partitions = Partitions
-- |Generate initial partitions -- |Generate initial partitions
emptyPartitions :: Partitions emptyPartitions :: Partitions
emptyPartitions = Partitions emptyPartitions = Partitions
{ importDecls = [] { typeDecls = []
, typeDecls = []
, funcDecls = Map.empty , funcDecls = Map.empty
, opDecls = [] , opDecls = []
} }
...@@ -91,9 +89,6 @@ emptyPartitions = Partitions ...@@ -91,9 +89,6 @@ emptyPartitions = Partitions
-- Inserts a CurrySyntax top level declaration into a partition. -- Inserts a CurrySyntax top level declaration into a partition.
-- Note: declarations are collected in reverse order. -- Note: declarations are collected in reverse order.
partitionDecl :: Partitions -> Decl -> Partitions partitionDecl :: Partitions -> Decl -> Partitions
-- import decls
partitionDecl parts decl@(ImportDecl _ _ _ _ _)
= parts {importDecls = decl : importDecls parts }
-- type decls -- type decls
partitionDecl parts decl@(DataDecl _ _ _ _) partitionDecl parts decl@(DataDecl _ _ _ _)
= parts {typeDecls = decl : typeDecls parts } = parts {typeDecls = decl : typeDecls parts }
...@@ -130,9 +125,8 @@ partitionFuncDecls genDecl parts ids ...@@ -130,9 +125,8 @@ partitionFuncDecls genDecl parts ids
-- terms. -- terms.
-- --
genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv) genImportDecl :: AbstractEnv -> ImportDecl -> (String, AbstractEnv)
genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env) genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env)
genImportDecl _ _ = error "GenAbstractCurry.genImportDecl: no import declaration"
-- --
genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv) genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv)
...@@ -763,12 +757,12 @@ data AbstractType ...@@ -763,12 +757,12 @@ data AbstractType
-- Initializes the AbstractCurry generator environment. -- Initializes the AbstractCurry generator environment.
genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv 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 { moduleId = mid
, typeEnv = tyEnv , typeEnv = tyEnv
, tconsEnv = tcEnv , tconsEnv = tcEnv
, exports = foldl (buildExportTable mid decls) Set.empty exps' , exports = foldl (buildExportTable mid decls) Set.empty exps'
, imports = foldl buildImportTable Map.empty decls , imports = foldl buildImportTable Map.empty imps
, varIndex = 0 , varIndex = 0
, tvarIndex = 0 , tvarIndex = 0
, varScope = [Map.empty] , varScope = [Map.empty]
...@@ -836,12 +830,10 @@ getConstrIdents _ = error "GenAbstractCurry.getConstrIdents: no pattern match" ...@@ -836,12 +830,10 @@ getConstrIdents _ = error "GenAbstractCurry.getConstrIdents: no pattern match"
-- Builds a table for dereferencing import aliases -- Builds a table for dereferencing import aliases
buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl buildImportTable :: Map.Map ModuleIdent ModuleIdent -> ImportDecl
-> Map.Map ModuleIdent ModuleIdent -> Map.Map ModuleIdent ModuleIdent
buildImportTable env (ImportDecl _ mid _ malias _) buildImportTable env (ImportDecl _ mid _ malias _)
= Map.insert (fromMaybe mid malias) mid env = Map.insert (fromMaybe mid malias) mid env
buildImportTable env _ = env
-- Checks whether an identifier is exported or not. -- Checks whether an identifier is exported or not.
isExported :: AbstractEnv -> Ident -> Bool isExported :: AbstractEnv -> Ident -> Bool
......
...@@ -117,7 +117,7 @@ data FlatEnv = FlatEnv ...@@ -117,7 +117,7 @@ data FlatEnv = FlatEnv
, publicEnvE :: Map.Map Ident IdentExport , publicEnvE :: Map.Map Ident IdentExport
, fixitiesE :: [CS.IDecl] , fixitiesE :: [CS.IDecl]
, typeSynonymsE :: [CS.IDecl] , typeSynonymsE :: [CS.IDecl]
, importsE :: [CS.IDecl] , importsE :: [CS.IImportDecl]
, exportsE :: [CS.Export] , exportsE :: [CS.Export]
, interfaceE :: [CS.IDecl] , interfaceE :: [CS.IDecl]
, varIndexE :: Int , varIndexE :: Int
...@@ -214,9 +214,7 @@ visitModule (IL.Module mid imps decls) = do ...@@ -214,9 +214,7 @@ visitModule (IL.Module mid imps decls) = do
(ifuncs ++ funcs) (ifuncs ++ funcs)
(iops ++ ops))) (iops ++ ops)))
where where
extractMid d = case d of extractMid (CS.IImportDecl _ mid1) = mid1
(CS.IImportDecl _ mid1) -> mid1
_ -> error "Gen.GenFlatCurry.visitModule: no IImportDecl"
-- --
visitDataDecl :: IL.Decl -> FlatState TypeDecl visitDataDecl :: IL.Decl -> FlatState TypeDecl
...@@ -522,10 +520,10 @@ genExpIDecls idecls ((mid,exps):mes) ...@@ -522,10 +520,10 @@ genExpIDecls idecls ((mid,exps):mes)
let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_ let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_
genExpIDecls idecls' mes genExpIDecls idecls' mes
where where
p_genExpIDecls mid1 idecls1 exps1 intf p_genExpIDecls mid1 idecls1 exps1 (CS.Interface _ _ ds)
| null exps1 = (map (qualifyIDecl mid1) intf) ++ idecls1 | null exps1 = (map (qualifyIDecl mid1) ds) ++ idecls1
| otherwise = (filter (isExportedIDecl exps1) | otherwise = (filter (isExportedIDecl exps1)
(map (qualifyIDecl mid1) intf)) (map (qualifyIDecl mid1) ds))
++ idecls1 ++ idecls1
-- --
...@@ -949,7 +947,7 @@ exports :: FlatState [CS.Export] ...@@ -949,7 +947,7 @@ exports :: FlatState [CS.Export]
exports = gets exportsE exports = gets exportsE
-- --
imports :: FlatState [CS.IDecl] imports :: FlatState [CS.IImportDecl]
imports = gets importsE imports = gets importsE
-- --
...@@ -975,9 +973,8 @@ isPublic isConstr qid = gets (\env -> maybe False isP ...@@ -975,9 +973,8 @@ isPublic isConstr qid = gets (\env -> maybe False isP
isP NotOnlyConstr = True isP NotOnlyConstr = True
-- --
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl]) lookupModuleIntf :: ModuleIdent -> FlatState (Maybe CS.Interface)
lookupModuleIntf mid lookupModuleIntf mid = gets (Map.lookup mid . interfaceEnvE)
= gets (Map.lookup mid . interfaceEnvE)
-- --
lookupIdArity :: QualIdent -> FlatState (Maybe Int) lookupIdArity :: QualIdent -> FlatState (Maybe Int)
......
...@@ -201,30 +201,29 @@ rights_sc xs = [ x | Right x <- xs] ...@@ -201,30 +201,29 @@ rights_sc xs = [ x | Right x <- xs]
--- @param parse-Module --- @param parse-Module
--- @param Maybe betterParse-Module --- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code]) catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers' (Module moduleIdent maybeExportSpec decls) catIdentifiers' (Module moduleIdent maybeExportSpec imports decls)
Nothing = Nothing =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
(concatMap renamedImports decls, codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
ModuleName moduleIdent : ModuleName moduleIdent :
maybe [] exportSpec2codes maybeExportSpec ++ codes) maybe [] exportSpec2codes maybeExportSpec ++ impCodes ++ codes)
catIdentifiers' (Module moduleIdent maybeExportSpec1 _) catIdentifiers' (Module moduleIdent maybeExportSpec1 _ _)
(Just (Module _ maybeExportSpec2 decls)) = (Just (Module _ maybeExportSpec2 imports decls)) =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
(concatMap renamedImports decls, codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
replaceFunctionCalls $ replaceFunctionCalls $
map (addModuleIdent moduleIdent) map (addModuleIdent moduleIdent)
([ModuleName moduleIdent] ++ ([ModuleName moduleIdent] ++
mergeExports2codes mergeExports2codes
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec1) (maybe [] (\(Exporting _ i) -> i) maybeExportSpec1)
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec2) ++ (maybe [] (\(Exporting _ i) -> i) maybeExportSpec2) ++
codes)) impCodes ++ codes))
renamedImports :: ImportDecl -> [(ModuleIdent,ModuleIdent)]
renamedImports :: Decl -> [(ModuleIdent,ModuleIdent)] renamedImports (ImportDecl _ oldName _ (Just newName) _) = [(oldName,newName)]
renamedImports decl = renamedImports _ = []
case decl of
(ImportDecl _ oldName _ (Just newName) _) -> [(oldName,newName)]
_ -> []
replaceFunctionCalls :: [Code] -> [Code] replaceFunctionCalls :: [Code] -> [Code]
...@@ -447,7 +446,6 @@ isTokenIdentifier (Token cat _) = ...@@ -447,7 +446,6 @@ isTokenIdentifier (Token cat _) =
-- DECL Position -- DECL Position
getPosition :: Decl -> Position getPosition :: Decl -> Position
getPosition (ImportDecl pos _ _ _ _) = pos
getPosition (InfixDecl pos _ _ _) = pos getPosition (InfixDecl pos _ _ _) = pos
getPosition (DataDecl pos _ _ _) = pos getPosition (DataDecl pos _ _ _) = pos
getPosition (NewtypeDecl pos _ _ _) = pos getPosition (NewtypeDecl pos _ _ _) = pos
...@@ -464,6 +462,9 @@ getPosition (ExtraVariables pos _) = pos ...@@ -464,6 +462,9 @@ getPosition (ExtraVariables pos _) = pos
lessDecl :: Decl -> Decl -> Bool lessDecl :: Decl -> Decl -> Bool
lessDecl = (<) `on` getPosition lessDecl = (<) `on` getPosition
lessImportDecl :: ImportDecl -> ImportDecl -> Bool
lessImportDecl = (<) `on` (\ (ImportDecl p _ _ _ _) -> p)
qsort :: (a -> a -> Bool) -> [a] -> [a] qsort :: (a -> a -> Bool) -> [a] -> [a]
qsort _ [] = [] qsort _ [] = []
qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x] 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 | ...@@ -471,10 +472,8 @@ qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y |
-- DECL TO CODE -------------------------------------------------------------------- -- DECL TO CODE --------------------------------------------------------------------
exportSpec2codes :: ExportSpec -> [Code] exportSpec2codes :: ExportSpec -> [Code]
exportSpec2codes (Exporting _ exports) = concatMap (export2codes []) exports exportSpec2codes (Exporting _ exports) = concatMap (export2codes []) exports
--- @param parse-Exports --- @param parse-Exports
--- @param betterParse-Exports --- @param betterParse-Exports
...@@ -505,9 +504,6 @@ export2codes exports (Export qualIdent) ...@@ -505,9 +504,6 @@ export2codes exports (Export qualIdent)
export2c _ = export2c _ =
[TypeConstructor TypeExport qualIdent] [TypeConstructor TypeExport qualIdent]
export2codes _ (ExportTypeWith qualIdent idents) = export2codes _ (ExportTypeWith qualIdent idents) =
TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents
export2codes _ (ExportTypeAll qualIdent) = export2codes _ (ExportTypeAll qualIdent) =
...@@ -515,11 +511,13 @@ export2codes _ (ExportTypeAll qualIdent) = ...@@ -515,11 +511,13 @@ export2codes _ (ExportTypeAll qualIdent) =
export2codes _ (ExportModule moduleIdent) = export2codes _ (ExportModule moduleIdent) =
[ModuleName moduleIdent] [ModuleName moduleIdent]
decl2codes :: Decl -> [Code] importDecl2codes :: ImportDecl -> [Code]
decl2codes (ImportDecl _ moduleIdent _ mModuleIdent importSpec) = importDecl2codes (ImportDecl _ moduleIdent _ mModuleIdent importSpec) =
[ModuleName moduleIdent] ++ [ModuleName moduleIdent] ++
maybe [] ((:[]) . ModuleName) mModuleIdent ++ maybe [] ((:[]) . ModuleName) mModuleIdent ++
maybe [] (importSpec2codes moduleIdent) importSpec maybe [] (importSpec2codes moduleIdent) importSpec
decl2codes :: Decl -> [Code]
decl2codes (InfixDecl _ _ _ idents) = decl2codes (InfixDecl _ _ _ idents) =
map (Function InfixFunction . qualify) idents map (Function InfixFunction . qualify) idents
decl2codes (DataDecl _ ident idents constrDecls) = decl2codes (DataDecl _ ident idents constrDecls) =
......
...@@ -45,7 +45,8 @@ import Records (importLabels, recordExpansion1, recordExpansion2) ...@@ -45,7 +45,8 @@ import Records (importLabels, recordExpansion1, recordExpansion2)