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

Made frontend compile again

parent c799a5ac
......@@ -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,8 +53,8 @@ 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 (Module ps m es is ds)
| null msgs = right (env, Module ps m es is ds')
| otherwise = left msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
......@@ -65,8 +65,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 +74,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 +82,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
......
......@@ -80,16 +80,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 +101,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
......@@ -990,7 +990,7 @@ Miscellaneous functions.
> checkAnonFreeVarsExtension p = checkExtension p
> "Anonymous free variables" AnonFreeVars
> checkExtension :: Position -> String -> Extension -> SCM ()
> checkExtension :: Position -> String -> KnownExtension -> SCM ()
> checkExtension pos msg ext = do
> enabled <- hasExtension ext
> unless enabled $ do
......@@ -1122,7 +1122,7 @@ Error messages.
> [ "Expexting", escName anonId, "after", escName (mkIdent "|")
> , "in the record pattern" ]
> errMissingLanguageExtension :: Position -> String -> Extension -> Message
> 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
......
......@@ -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
......
......@@ -33,7 +33,7 @@ import Curry.Syntax
import Base.Messages
import Base.SCC (scc)
import CompilerOpts (Options (..), Extension (..))
import CompilerOpts (Options (..), KnownExtension (..))
-- |Different types of source files
data Source
......@@ -90,7 +90,7 @@ 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 (Module _ m _ is _) = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
let imps = imports opts m is
......@@ -118,7 +118,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,7 +45,7 @@ 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 (Module _ mid _ imps _) iEnv
= case foldl importModule (initEnv, []) imps of
(e, [] ) -> right $ expandTCValueEnv opts $ importUnifyData e
(_, errs) -> left errs
......
......@@ -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?
Nothing -- no alias
......
......@@ -57,7 +57,7 @@ lift mdl env = (mdl', env { valueEnv = tyEnv' })
-- |Fully qualify used constructors and functions
qual :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
qual opts env (Module m es is ds) = (qualifyEnv opts env, Module m es is ds')
qual opts env (Module ps m es is ds) = (qualifyEnv opts env, Module ps m es is ds')
where ds' = Q.qual (moduleIdent env) (tyConsEnv env) (valueEnv env) ds
-- |Simplify the source code
......
......@@ -43,7 +43,7 @@ data structures, we can use only a qualified import for the
> import qualified IL as IL
> ilTrans :: Bool -> ValueEnv -> TCEnv -> Module -> IL.Module
> ilTrans flat tyEnv tcEnv (Module m _ _ ds) = IL.Module m (imports m ds') ds'
> ilTrans flat tyEnv tcEnv (Module _ m _ _ ds) = IL.Module m (imports m ds') ds'
> where ds' = R.runReader (concatMapM trDecl ds)
> (TransEnv flat m tyEnv tcEnv)
......
......@@ -160,7 +160,7 @@ as it allows value declarations at the top-level of a module.
\begin{verbatim}
> desugar :: ValueEnv -> TCEnv -> Module -> (Module, ValueEnv)
> desugar tyEnv tcEnv (Module m es is ds) = (Module m es is ds', valueEnv s')
> desugar tyEnv tcEnv (Module ps m es is ds) = (Module ps m es is ds', valueEnv s')
> where (ds', s') = S.runState (desugarModuleDecls ds)
> (DesugarState m tcEnv tyEnv 1)
......
......@@ -35,11 +35,11 @@ top-level.
> import Env.Value
> lift :: ValueEnv -> Module -> (Module, ValueEnv)
> lift tyEnv (Module m es is ds) = (lifted, valueEnv s')
> lift tyEnv (Module ps m es is ds) = (lifted, valueEnv s')
> where
> (ds', s') = S.runState (mapM (abstractDecl "" []) ds) initState
> initState = LiftState m tyEnv Map.empty
> lifted = Module m es is $ concatMap liftFunDecl ds'
> lifted = Module ps m es is $ concatMap liftFunDecl ds'
\end{verbatim}
\paragraph{Abstraction}
......
......@@ -71,13 +71,13 @@ Currently, the following optimizations are implemented:
> isFlat = S.gets flat
> simplify :: Bool -> ValueEnv ->Module -> (Module, ValueEnv)
> simplify flags tyEnv mdl@(Module m _ _ _) = (mdl', valueEnv s')
> simplify flags tyEnv mdl@(Module _ m _ _ _) = (mdl', valueEnv s')
> where (mdl', s') = S.runState (simModule mdl)
> (SimplifyState m tyEnv 1 flags)
> simModule :: Module -> SIM (Module)
> simModule (Module m es is ds)
> = Module m es is `liftM` mapM (simDecl Map.empty) ds
> simModule (Module ps m es is ds)
> = Module ps m es is `liftM` mapM (simDecl Map.empty) ds
> simDecl :: InlineEnv -> Decl -> SIM Decl
> simDecl env (FunctionDecl p f eqs) =
......
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