Commit f5499f5f authored by Björn Peemöller 's avatar Björn Peemöller

Merged implementation of module pragmas

parents c799a5ac 351dbd78
......@@ -42,8 +42,8 @@ interfaceCheck _ env intf
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: Monad m => Check m Module
kindCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
kindCheck _ env (Module ps m es is ds)
| null msgs = right (env, Module ps m es is ds')
| otherwise = left msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
......@@ -53,11 +53,10 @@ kindCheck _ env (Module m es is ds)
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
syntaxCheck opts env mdl
| null msgs = right (env, mdl')
| otherwise = left msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
where (mdl', msgs) = SC.syntaxCheck opts (valueEnv env) (tyConsEnv env) mdl
-- |Check the precedences of infix operators.
--
......@@ -65,8 +64,8 @@ syntaxCheck opts env (Module m es is ds)
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: Monad m => Check m Module
precCheck _ env (Module m es is ds)
| null msgs = right (env { opPrecEnv = pEnv' }, Module m es is ds')
precCheck _ env (Module ps m es is ds)
| null msgs = right (env { opPrecEnv = pEnv' }, Module ps m es is ds')
| otherwise = left msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
......@@ -74,7 +73,7 @@ precCheck _ env (Module m es is ds)
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: Monad m => Check m Module
typeCheck _ env mdl@(Module _ _ _ ds)
typeCheck _ env mdl@(Module _ _ _ _ ds)
| null msgs = right (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = left msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
......@@ -82,8 +81,8 @@ typeCheck _ env mdl@(Module _ _ _ ds)
-- |Check the export specification
exportCheck :: Monad m => Check m Module
exportCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es' is ds)
exportCheck _ env (Module ps m es is ds)
| null msgs = right (env, Module ps m es' is ds)
| otherwise = left msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
......
......@@ -56,14 +56,13 @@ generated. Finally, all declarations are checked within the resulting
environment. In addition, this process will also rename the local variables.
\begin{verbatim}
> syntaxCheck :: Options -> ModuleIdent -> ValueEnv -> TCEnv -> [Decl]
> -> ([Decl], [Message])
> syntaxCheck opts m tyEnv tcEnv decls =
> syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module -> (Module, [Message])
> syntaxCheck opts tyEnv tcEnv mdl@(Module _ m _ _ ds) =
> case findMultiples $ concatMap constrs typeDecls of
> [] -> runSC (checkModule decls) state
> css -> (decls, map errMultipleDataConstructor css)
> [] -> runSC (checkModule mdl) state
> css -> (mdl, map errMultipleDataConstructor css)
> where
> typeDecls = filter isTypeDecl decls
> typeDecls = filter isTypeDecl ds
> rEnv = globalEnv $ fmap (renameInfo tcEnv) tyEnv
> state = initState (optExtensions opts) m rEnv
......@@ -80,16 +79,16 @@ renaming literals and underscore to disambiguate them.
> -- |Internal state of the syntax check
> data SCState = SCState
> { extensions :: [Extension] -- ^ Enabled language extensions
> , moduleIdent :: ModuleIdent -- ^ 'ModuleIdent' of the current module
> , renameEnv :: RenameEnv -- ^ Information store
> , scopeId :: Integer -- ^ Identifier for the current scope
> , nextId :: Integer -- ^ Next fresh identifier
> , errors :: [Message] -- ^ Syntactic errors in the module
> { extensions :: [KnownExtension] -- ^ Enabled language extensions
> , moduleIdent :: ModuleIdent -- ^ 'ModuleIdent' of the current module
> , renameEnv :: RenameEnv -- ^ Information store
> , scopeId :: Integer -- ^ Identifier for the current scope
> , nextId :: Integer -- ^ Next fresh identifier
> , errors :: [Message] -- ^ Syntactic errors in the module
> }
> -- |Initial syntax check state
> initState :: [Extension] -> ModuleIdent -> RenameEnv -> SCState
> initState :: [KnownExtension] -> ModuleIdent -> RenameEnv -> SCState
> initState exts m rEnv = SCState exts m rEnv globalScopeId 1 []
> -- |Identifier for global (top-level) declarations
......@@ -101,12 +100,12 @@ renaming literals and underscore to disambiguate them.
> runSC scm s = let (a, s') = S.runState scm s in (a, reverse $ errors s')
> -- |Check for an enabled extension
> hasExtension :: Extension -> SCM Bool
> hasExtension :: KnownExtension -> SCM Bool
> hasExtension ext = S.gets (elem ext . extensions)
> -- |Enable an additional 'Extension' to avoid redundant complaints about
> -- missing extensions
> enableExtension :: Extension -> SCM ()
> enableExtension :: KnownExtension -> SCM ()
> enableExtension e = S.modify $ \ s -> s { extensions = e : extensions s }
> -- |Retrieve the 'ModuleIdent' of the current module
......@@ -316,13 +315,23 @@ a goal. Note that all declarations in the goal must be considered as
local declarations.
\begin{verbatim}
> checkModule :: [Decl] -> SCM [Decl]
> checkModule decls = do
> checkModule :: Module -> SCM Module
> checkModule (Module ps m es is decls) = do
> mapM_ checkPragma ps
> mapM_ bindTypeDecl (rds ++ dds)
> liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> decls' <- liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> return $ Module ps m es is decls'
> where (tds, vds) = partition isTypeDecl decls
> (rds, dds) = partition isRecordDecl tds
> checkPragma :: ModulePragma -> SCM ()
> checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
> checkPragma (OptionsPragma _ _ _) = ok
> checkExtension :: Extension -> SCM ()
> checkExtension (KnownExtension _ e) = enableExtension e
> checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e
> checkTypeDecl :: Decl -> SCM Decl
> checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
> checkRecordExtension $ idPosition r
......@@ -980,22 +989,22 @@ Miscellaneous functions.
\begin{verbatim}
> checkFuncPatsExtension :: Position -> SCM ()
> checkFuncPatsExtension p = checkExtension p
> checkFuncPatsExtension p = checkUsedExtension p
> "Functional Patterns" FunctionalPatterns
> checkRecordExtension :: Position -> SCM ()
> checkRecordExtension p = checkExtension p "Records" Records
> checkRecordExtension p = checkUsedExtension p "Records" Records
> checkAnonFreeVarsExtension :: Position -> SCM ()
> checkAnonFreeVarsExtension p = checkExtension p
> checkAnonFreeVarsExtension p = checkUsedExtension p
> "Anonymous free variables" AnonFreeVars
> checkExtension :: Position -> String -> Extension -> SCM ()
> checkExtension pos msg ext = do
> checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
> checkUsedExtension pos msg ext = do
> enabled <- hasExtension ext
> unless enabled $ do
> report $ errMissingLanguageExtension pos msg ext
> enableExtension ext
> enableExtension ext -- to avoid multiple warnings
> typeArity :: TypeExpr -> Int
> typeArity (ArrowType _ t2) = 1 + typeArity t2
......@@ -1122,7 +1131,11 @@ Error messages.
> [ "Expexting", escName anonId, "after", escName (mkIdent "|")
> , "in the record pattern" ]
> errMissingLanguageExtension :: Position -> String -> Extension -> Message
> errUnknownExtension :: Position -> String -> Message
> errUnknownExtension p e = posMessage p $
> text "Unknown language extension:" <+> text e
> errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message
> errMissingLanguageExtension p what ext = posMessage p $
> text what <+> text "are not supported in standard Curry." $+$
> nest 2 (text "Use flag -e or -X" <> text (show ext)
......
......@@ -48,7 +48,7 @@ import CompilerOpts
-- - overlapping case alternatives
-- - non-adjacent function rules
warnCheck :: Options -> ValueEnv -> TCEnv -> Module -> [Message]
warnCheck opts valEnv tcEnv (Module mid es is ds)
warnCheck opts valEnv tcEnv (Module _ mid es is ds)
= runOn (initWcState mid valEnv tcEnv (optWarnFlags opts)) $ do
checkExports es
checkImports is
......
......@@ -17,6 +17,7 @@ import qualified Data.Map as Map (Map, keys, toList)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Pretty
import Curry.Syntax
import Base.TopEnv (allLocalBindings)
......@@ -30,18 +31,20 @@ import Env.Value
-- compiled. The information is updated during the different stages of
-- compilation.
data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, extensions :: [KnownExtension] -- ^ enabled language extensions
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
}
-- |Initial 'CompilerEnv'
initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv
{ moduleIdent = mid
, extensions = []
, interfaceEnv = initInterfaceEnv
, aliasEnv = initAliasEnv
, tyConsEnv = initTCEnv
......@@ -52,13 +55,14 @@ initCompilerEnv mid = CompilerEnv
-- |Show the 'CompilerEnv'
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = show $ vcat
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors" $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Language Etensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors " $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
]
where
header hdr content = hang (text hdr <+> colon) 4 content
......
......@@ -16,7 +16,7 @@
-}
module CompilerOpts
( Options (..), CymakeMode (..), Verbosity (..), TargetType (..)
, WarnFlag (..), Extension (..), DumpLevel (..)
, WarnFlag (..), KnownExtension (..), DumpLevel (..)
, dumpLevel, defaultOptions, getCompilerOpts, usage
) where
......@@ -26,6 +26,7 @@ import System.Environment (getArgs, getProgName)
import System.FilePath (splitSearchPath)
import Curry.Files.Filenames (currySubdir)
import Curry.Syntax.Extension
-- -----------------------------------------------------------------------------
-- Option data structures
......@@ -34,22 +35,22 @@ import Curry.Files.Filenames (currySubdir)
-- |Data type for recording compiler options
data Options = Options
-- general
{ optMode :: CymakeMode -- ^ modus operandi
, optVerbosity :: Verbosity -- ^ verbosity level
{ optMode :: CymakeMode -- ^ modus operandi
, optVerbosity :: Verbosity -- ^ verbosity level
-- compilation
, optForce :: Bool -- ^ force (re-)compilation of target
, optLibraryPaths :: [FilePath] -- ^ directories to search in for libraries
, optImportPaths :: [FilePath] -- ^ directories to search in for imports
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ create a FlatCurry interface file?
, optWarn :: Bool -- ^ show warnings? (legacy option)
, optWarnFlags :: [WarnFlag] -- ^ Warnings flags (see below)
, optWarnAsError :: Bool -- ^ Should warnings be treated as errors?
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [Extension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dump levels
, optDumpEnv :: Bool -- ^ dump compilation environment
, optDumpRaw :: Bool -- ^ dump data structure
, optForce :: Bool -- ^ force (re-)compilation of target
, optLibraryPaths :: [FilePath] -- ^ directories to search in for libraries
, optImportPaths :: [FilePath] -- ^ directories to search in for imports
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ create a FlatCurry interface file?
, optWarn :: Bool -- ^ show warnings? (legacy option)
, optWarnFlags :: [WarnFlag] -- ^ Warnings flags (see below)
, optWarnAsError :: Bool -- ^ Should warnings be treated as errors?
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [KnownExtension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dump levels
, optDumpEnv :: Bool -- ^ dump compilation environment
, optDumpRaw :: Bool -- ^ dump data structure
} deriving Show
-- | Default compiler options
......@@ -166,31 +167,19 @@ dumpLevel = [ (DumpParsed , "dump-parse", "parse tree" )
, (DumpCaseCompleted, "dump-cc" , "case completed output" )
]
-- |Language extensions
data Extension
= Records
| FunctionalPatterns
| AnonFreeVars
| NoImplicitPrelude
deriving (Eq, Read, Show)
-- |Description and flag of language extensions
extensions :: [(Extension, String, String)]
extensions :: [(KnownExtension, String, String)]
extensions =
[ ( Records , "Records"
, "enable record syntax" )
[ ( AnonFreeVars , "AnonFreeVars"
, "enable anonymous free variables" )
, ( FunctionalPatterns, "FunctionalPatterns"
, "enable functional patterns" )
, ( AnonFreeVars , "AnonFreeVars"
, "enable anonymous free variables" )
, ( NoImplicitPrelude , "NoImplicitPrelude"
, "do not implicitly import the Prelude")
, ( Records , "Records"
, "enable record syntax" )
]
-- |Language 'Extension's enabled by @-e@ flag
curryExtensions :: [Extension]
curryExtensions = [Records, FunctionalPatterns, AnonFreeVars]
-- -----------------------------------------------------------------------------
-- Parsing of the command line options.
--
......@@ -310,7 +299,7 @@ options =
-- extensions
, Option "e" ["extended"]
(NoArg (onOpts $ \ opts -> opts { optExtensions =
nub $ curryExtensions ++ optExtensions opts }))
nub $ kielExtensions ++ optExtensions opts }))
"enable extended Curry functionalities"
, mkOptErrOption "X" [] "ext" "language extension" extDescriptions
, mkOptErrOption "W" [] "opt" "warning option" warnDescriptions
......
......@@ -29,11 +29,12 @@ import Curry.Base.Pretty
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax
(Module (..), ImportDecl (..), parseHeader, patchModuleId)
( Module (..), ImportDecl (..), parseHeader, patchModuleId
, hasLanguageExtension)
import Base.Messages
import Base.SCC (scc)
import CompilerOpts (Options (..), Extension (..))
import CompilerOpts (Options (..), KnownExtension (..))
-- |Different types of source files
data Source
......@@ -90,20 +91,21 @@ sourceDeps opts sEnv fn = readHeader fn >>= moduleDeps opts sEnv fn
-- |Retrieve the dependencies of a given module
moduleDeps :: Options -> SourceEnv -> FilePath -> Module -> CYIO SourceEnv
moduleDeps opts sEnv fn (Module m _ is _) = case Map.lookup m sEnv of
moduleDeps opts sEnv fn mdl@(Module _ m _ _ _) = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
let imps = imports opts m is
let imps = imports opts mdl
sEnv' = Map.insert m (Source fn imps) sEnv
foldM (moduleIdentDeps opts) sEnv' imps
-- |Retrieve the imported modules and add the import of the Prelude
-- according to the compiler options.
imports :: Options -> ModuleIdent -> [ImportDecl] -> [ModuleIdent]
imports opts m ds = nub $
[preludeMIdent | m /= preludeMIdent && implicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- ds]
where implicitPrelude = NoImplicitPrelude `notElem` optExtensions opts
imports :: Options -> Module -> [ModuleIdent]
imports opts mdl@(Module _ m _ is _) = nub $
[preludeMIdent | m /= preludeMIdent && not noImplicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- is]
where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts
|| mdl `hasLanguageExtension` NoImplicitPrelude
-- |Retrieve the dependencies for a given 'ModuleIdent'
moduleIdentDeps :: Options -> SourceEnv -> ModuleIdent -> CYIO SourceEnv
......@@ -118,7 +120,7 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
| icurryExt `isSuffixOf` fn ->
return $ Map.insert m (Interface fn) sEnv
| otherwise -> do
hdr@(Module m' _ _ _) <- readHeader fn
hdr@(Module _ m' _ _ _) <- readHeader fn
if (m == m') then moduleDeps opts sEnv fn hdr
else left [errWrongModule m m']
......
......@@ -55,14 +55,14 @@ exportInterface env mdl = exportInterface' mdl
(opPrecEnv env) (tyConsEnv env) (valueEnv env)
exportInterface' :: Module -> OpPrecEnv -> 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
where
imports = map (IImportDecl NoPos) $ usedModules decls
precs = foldr (infixDecl m pEnv) [] es
hidden = map (hiddenTypeDecl m tcEnv) $ hiddenTypes m 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 -> OpPrecEnv -> Export -> [IDecl] -> [IDecl]
......
......@@ -53,7 +53,7 @@ genUntypedAbstract = genAbstract UntypedAcy
-- |Generate an AbstractCurry program term from the syntax tree
genAbstract :: AbstractType -> CompilerEnv -> Module -> CurryProg
genAbstract ty env mdl@(Module mid _ imps decls)
genAbstract ty env mdl@(Module _ mid _ imps decls)
= CurryProg mid' imps' types funcs ops
where
aEnv = abstractEnv ty env mdl
......@@ -566,7 +566,7 @@ genBranchExpr env (Alt p pat rhs)
in (env2, CGuardedBranch pat' bs')
--
genPattern :: Position -> AbstractEnv -> Pattern{--} -> (AbstractEnv, CPattern)
genPattern :: Position -> AbstractEnv -> Pattern -> (AbstractEnv, CPattern)
genPattern pos env (LiteralPattern l) = case l of
String _ cs -> genPattern pos env $ ListPattern [] $ map (LiteralPattern . Char noRef) cs
_ -> (env, CPLit $ genLiteral l)
......@@ -685,7 +685,7 @@ data AbstractType
-- |Initialize the AbstractCurry generator environment
abstractEnv :: AbstractType -> CompilerEnv -> Module -> AbstractEnv
abstractEnv absType env (Module mid exps _ decls) = AbstractEnv
abstractEnv absType env (Module _ mid exps _ decls) = AbstractEnv
{ moduleId = mid
, typeEnv = valueEnv env
, tconsEnv = tyConsEnv env
......
......@@ -188,15 +188,15 @@ rights_sc es = [ x | Right x <- es]
--- @param parse-Module
--- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers' (Module mid maybeExportSpec is decls)
catIdentifiers' (Module _ mid maybeExportSpec is decls)
Nothing =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl is)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports is,
ModuleName mid :
maybe [] exportSpec2codes maybeExportSpec ++ impCodes ++ codes)
catIdentifiers' (Module mid maybeExportSpec1 _ _)
(Just (Module _ maybeExportSpec2 is decls)) =
catIdentifiers' (Module _ mid maybeExportSpec1 _ _)
(Just (Module _ _ maybeExportSpec2 is decls)) =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl is)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports is,
......@@ -648,18 +648,26 @@ showToken (Token Id_interface _) = "interface"
showToken (Token Id_primitive _) = "primitive"
showToken (Token Id_qualified _) = "qualified"
showToken (Token EOF _) = ""
showToken (Token PragmaLanguage _) = "{-# LANGUAGE"
showToken (Token PragmaOptions a) = "{-# OPTIONS" ++ showAttr a
showToken (Token PragmaEnd _) = "#-}"
showToken (Token LineComment (StringAttributes sv _)) = sv
showToken (Token LineComment a ) = showAttr a
showToken (Token NestedComment (StringAttributes sv _)) = sv
showToken (Token NestedComment a) = showAttr a
showAttr :: Attributes -> [Char]
showAttr NoAttributes = ""
showAttr (CharAttributes cv _) = showCharacter cv
showAttr (IntAttributes iv _) = show iv
showAttr (FloatAttributes fv _) = show fv
showAttr (StringAttributes sv _) = showSt sv
showAttr (IdentAttributes mid i) = intercalate "." $ mid ++ [i]
showAttr NoAttributes = ""
showAttr (CharAttributes cv _) = showCharacter cv
showAttr (IntAttributes iv _) = show iv
showAttr (FloatAttributes fv _) = show fv
showAttr (StringAttributes sv _) = showSt sv
showAttr (IdentAttributes mid i) = intercalate "." $ mid ++ [i]
showAttr (OptionsAttributes mt s) = showTool mt ++ ' ' : s
showTool :: Maybe String -> String
showTool Nothing = ""
showTool (Just t) = '_' : t
showCharacter :: Char -> [Char]
showCharacter c
......
......@@ -45,14 +45,15 @@ import CompilerOpts
-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
importModules :: Monad m => Options -> Module -> InterfaceEnv -> CYT m CompilerEnv
importModules opts (Module mid _ imps _) iEnv
importModules opts mdl@(Module _ mid _ imps _) iEnv
= case foldl importModule (initEnv, []) imps of
(e, [] ) -> right $ expandTCValueEnv opts $ importUnifyData e
(_, errs) -> left errs
where
initEnv = (initCompilerEnv mid)
{ aliasEnv = importAliases imps -- import module aliases
, interfaceEnv = iEnv -- imported interfaces
{ aliasEnv = importAliases imps -- import module aliases
, interfaceEnv = iEnv -- imported interfaces
, extensions = knownExtensions mdl
}
importModule (env, msgs) (ImportDecl _ m q asM is) =
case Map.lookup m iEnv of
......@@ -74,7 +75,6 @@ importInterfaces opts (Interface m is _) iEnv
Nothing -> internalError $ "Imports.importInterfaces: no interface for "
++ show m
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------
......@@ -497,7 +497,7 @@ expandTCValueEnv opts env
| enabled = env' { tyConsEnv = tcEnv' }
| otherwise = env
where
enabled = Records `elem` optExtensions opts
enabled = Records `elem` (optExtensions opts ++ extensions env)
tcEnv' = fmap (expandRecordTC tcEnv) tcEnv
tcEnv = tyConsEnv env'
env' = expandValueEnv opts env
......@@ -520,11 +520,11 @@ expandValueEnv opts env
| enabled = env { valueEnv = tyEnv' }
| otherwise = env
where
tcEnv = tyConsEnv env
tyEnv = valueEnv env
enabled = Records `elem` optExtensions opts
tyEnv' = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
m = moduleIdent env
tcEnv = tyConsEnv env
tyEnv = valueEnv env
enabled = Records `elem` (optExtensions opts ++ extensions env)
tyEnv' = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
m = moduleIdent env
-- TODO: This is necessary as currently labels are unqualified.
-- Without this additional import the labels would no longer be known.
......
......@@ -71,7 +71,7 @@ addInterface m intf = S.modify $ \ s -> s { iEnv = M.insert m intf $ iEnv s }
loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces
-> Module -- ^ 'Module' header with import declarations
-> CYIO InterfaceEnv
loadInterfaces paths (Module m _ is _) = do
loadInterfaces paths (Module _ m _ is _) = do
res <- liftIO $ S.execStateT load (LoaderState initInterfaceEnv paths [])
if null (errs res) then right (iEnv res) else left (reverse $ errs res)
where load = mapM_ (loadInterface [m]) [(p, m') | ImportDecl p m' _ _ _ <- is]
......
......@@ -38,7 +38,7 @@ data ModuleSummary = ModuleSummary
-- |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)
summarizeModule tcEnv (Interface iid _ idecls) (Module _ mid mExp imps decls)
| iid == mid = ModuleSummary
{ moduleId = mid
, interface = idecls
......
......@@ -112,7 +112,7 @@ checkModuleHeader opts fn = checkModuleId fn
-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: Monad m => FilePath -> CS.Module
-> CYT m CS.Module
checkModuleId fn m@(CS.Module mid _ _ _)
checkModuleId fn m@(CS.Module _ mid _ _ _)
| last (midQualifiers mid) == takeBaseName fn
= right m
| otherwise
......@@ -124,7 +124,7 @@ checkModuleId fn m@(CS.Module mid _ _ _)
-- the prelude is imported unqualified, otherwise a qualified import is added.
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
importPrelude opts fn m@(CS.Module mid es is ds)
importPrelude opts fn m@(CS.Module ps mid es is ds)
-- the Prelude itself
| mid == preludeMIdent = m
-- disabled by compiler option
......@@ -132,9 +132,10 @@ importPrelude opts fn m@(CS.Module mid es is ds)
-- already imported
| preludeMIdent `elem` imported = m
-- let's add it!
| otherwise = CS.Module mid es (preludeImp : is) ds
| otherwise = CS.Module ps mid es (preludeImp : is) ds
where
noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
|| m `CS.hasLanguageExtension` NoImplicitPrelude
preludeImp = CS.ImportDecl (first fn) preludeMIdent
False -- qualified?