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

Replaced calls to error with calls to internalError

parent a443e8f2
......@@ -561,9 +561,9 @@ checkParen
> LazyPattern pos `liftM` checkConstrTerm p t
> checkConstrTerm p (RecordPattern fs t) =
> checkRecordPattern p fs t
> checkConstrTerm _ (FunctionPattern _ _) = error $
> checkConstrTerm _ (FunctionPattern _ _) = internalError $
> "SyntaxCheck.checkConstrTerm: function pattern not defined"
> checkConstrTerm _ (InfixFuncPattern _ _ _) = error $
> checkConstrTerm _ (InfixFuncPattern _ _ _) = internalError $
> "SyntaxCheck.checkConstrTerm: infix function pattern not defined"
> checkConstructorPattern :: Position -> QualIdent -> [ConstrTerm]
......
......@@ -34,7 +34,7 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), ImportDecl (..), parseHeader, patchModuleId)
import Base.Messages (internalError)
import Base.Messages (abortWith, internalError)
import Base.SCC (scc)
import CompilerOpts (Options (..), Extension (..))
......@@ -125,7 +125,7 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
checkModuleHeader fn = do
hdr@(Module m' _ _ _) <- patchModuleId fn `liftM` (ok . parseHeader fn)
`liftM` readFile fn
unless (m == m') $ error $ errWrongModule m m'
unless (m == m') $ abortWith [errWrongModule m m']
moduleDeps opts sEnv fn hdr
-- If we want to compile the program instead of generating Makefile
......
......@@ -46,6 +46,7 @@ import Control.Monad (mplus)
import Curry.Base.Ident
import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
......@@ -121,4 +122,4 @@ initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
where predefTC (TypeConstructor tc tys) =
predefTopEnv (qualify (unqualify tc)) .
DataType tc (length tys) . map Just
predefTC _ = error "Base.initTCEnv.predefTC: no type constructor"
predefTC _ = internalError "Base.initTCEnv.predefTC: no type constructor"
......@@ -135,7 +135,7 @@ tupleDCs = map dataInfo tupleTCs
dataInfo (DataType tc _ [Just (DataConstr _ _ tys)]) =
DataConstructor (qualUnqualify preludeMIdent tc) (length tys)
(ForAllExist (length tys) 0 $ foldr TypeArrow (tupleType tys) tys)
dataInfo _ = error "Env.Value.tupleDCs: no data constructor"
dataInfo _ = internalError "Env.Value.tupleDCs: no data constructor"
initDCEnv :: ValueEnv
initDCEnv = foldr predefDC emptyTopEnv
......
......@@ -70,7 +70,7 @@ infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds
infixDecl m pEnv (ExportTypeWith tc cs) ds =
foldr (iInfixDecl m pEnv . qualifyLike (qualidMod tc)) ds cs
where qualifyLike = maybe qualify qualifyWith
infixDecl _ _ _ _ = error "Exports.infixDecl: no pattern match"
infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
......@@ -97,7 +97,7 @@ typeDecl m tcEnv (ExportTypeWith tc cs) ds = case qualLookupTC tc tcEnv of
in iTypeDecl ITypeDecl m tc' n (fromQualType m ty') : ds
_ -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
_ -> internalError "Exports.typeDecl"
typeDecl _ _ _ _ = error "Exports.typeDecl: no pattern match"
typeDecl _ _ _ _ = internalError "Exports.typeDecl: no pattern match"
iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)
-> ModuleIdent -> QualIdent -> Int -> a -> IDecl
......
......@@ -30,7 +30,6 @@ import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Env.ModuleAlias (AliasEnv)
import Env.TypeConstructor (TCEnv, lookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
......@@ -230,14 +229,14 @@ genFuncDecl isLocal env (ident, decls)
evalannot = case find isEvalAnnot decls of
Nothing -> CFlex
Just (EvalAnnot _ _ ea) -> genEvalAnnot ea
_ -> error "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
_ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
(env1, mtype) = case genFuncType env decls of
Nothing -> (env, Nothing)
Just (env', t) -> (env', Just t)
(env2, rules) = case find isFunctionDecl decls of
Nothing -> (env1, [])
Just (FunctionDecl _ _ eqs) -> mapAccumL genRule env1 eqs
_ -> error "Gen.GenAbstractCurry.genFuncDecl: no FunctionDecl"
_ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no FunctionDecl"
mexternal = genExternal `fmap` find isExternal decls
arity = compArity mtype rules
typeexpr = fromMaybe (CTCons ("Prelude", "untyped") []) mtype
......@@ -257,7 +256,7 @@ genFuncDecl isLocal env (ident, decls)
genTypeSig env' (TypeSig _ _ ts) = genTypeExpr env' ts
genTypeSig env' (ExternalDecl _ _ _ _ ts) = genTypeExpr env' ts
genTypeSig _ _ =
error "GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"
internalError "GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"
genExternal (ExternalDecl _ _ mname ident' _)
= CExternal (fromMaybe (name ident') mname)
......@@ -277,7 +276,7 @@ genFuncDecl isLocal env (ident, decls)
compArityFromType (CFuncType _ t2) = 1 + compArityFromType t2
compArityFromType (CTCons _ _) = 0
compArityFromType (CRecordType _ _) =
error "GenAbstractCurry.genFuncDecl.compArityFromType: record type"
internalError "GenAbstractCurry.genFuncDecl.compArityFromType: record type"
compRule _ [] Nothing = internalError $ "GenAbstractCurry.compRule: "
++ "missing rule for function \""
......@@ -436,7 +435,7 @@ genLocalDecls env decls
Nothing -> (env1, Nothing)
Just r -> let (envX, patt) = genLocalPattern pos env1 r in (envX, Just patt)
in (env2, CPRecord fields' mr')
genLocalPattern _ _ _ = error "GenAbstractCurry.genLocalDecls.genLocalPattern: no pattern match"
genLocalPattern _ _ _ = internalError "GenAbstractCurry.genLocalDecls.genLocalPattern: no pattern match"
genLocalPattRhs pos env' [(Variable _, expr)]
= genExpr pos env' expr
......@@ -665,7 +664,7 @@ data AbstractEnv = AbstractEnv
, typeEnv :: ValueEnv -- ^known values
, tconsEnv :: TCEnv -- ^known type constructors
, exports :: Set.Set Ident -- ^exported symbols
, aliases :: AliasEnv -- ^module aliases
-- , aliases :: AliasEnv -- ^module aliases
, varIndex :: Int -- ^counter for variable indices
, tvarIndex :: Int -- ^counter for type variable indices
, varScope :: [Map.Map Ident Int] -- ^stack of variable tables
......@@ -687,7 +686,7 @@ abstractEnv absType env (Module mid exps _ decls) = AbstractEnv
, typeEnv = valueEnv env
, tconsEnv = tyConsEnv env
, exports = foldl (buildExportTable mid decls) Set.empty exps'
, aliases = aliasEnv env
-- , aliases = aliasEnv env
, varIndex = 0
, tvarIndex = 0
, varScope = [Map.empty]
......@@ -747,7 +746,7 @@ getConstrIdents :: Decl -> [Ident]
getConstrIdents (DataDecl _ _ _ cs) = map getConstr cs
where getConstr (ConstrDecl _ _ c _) = c
getConstr (ConOpDecl _ _ _ op _) = op
getConstrIdents _ = error "GenAbstractCurry.getConstrIdents: no data declaration"
getConstrIdents _ = internalError "GenAbstractCurry.getConstrIdents: no data declaration"
-- Checks whether an identifier is exported or not.
isExported :: AbstractEnv -> Ident -> Bool
......
......@@ -386,7 +386,7 @@ visitOpIDecl :: CS.IDecl -> FlatState OpDecl
visitOpIDecl (CS.IInfixDecl _ fixi prec op) = do
op' <- visitQualIdent op
return $ Op op' (genFixity fixi) prec
visitOpIDecl _ = error "GenFlatCurry.visitOpIDecl: no pattern match"
visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match"
-------------------------------------------------------------------------------
......@@ -665,7 +665,7 @@ genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))
(recordExtId ident))
labels <- mapM (genRecordLabel modid (zip params is)) fields
return (Type qname Public is labels)
genRecordType _ = error "GenFlatCurry.genRecordType: no pattern match"
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
--
genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr)
......@@ -678,7 +678,7 @@ genRecordLabel modid vis ([ident],typeexpr)
qname <- visitQualIdent ((maybe qualify qualifyWith modid)
(labelExtId ident))
return (Cons qname 1 Public [texpr])
genRecordLabel _ _ _ = error "GenFlatCurry.genRecordLabel: no pattern match"
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
-------------------------------------------------------------------------------
......@@ -1089,9 +1089,9 @@ bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ ident _) = bindIdentExport ident
bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport
bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo
where expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
bindEnvRecordLabel _ _ _ = error "GenFlatCurry.bindEnvRecordLabel: no pattern match"
bindEnvRecordLabel _ _ _ = internalError "GenFlatCurry.bindEnvRecordLabel: no pattern match"
splitoffArgTypes :: IL.Type -> [Ident] -> [(Ident, IL.Type)]
splitoffArgTypes (IL.TypeArrow l r) (i:is) = (i, l):splitoffArgTypes r is
splitoffArgTypes _ [] = []
splitoffArgTypes _ _ = error "internal error in splitoffArgTypes"
splitoffArgTypes _ _ = internalError "splitoffArgTypes"
......@@ -15,6 +15,8 @@ import Curry.Base.Position
import Curry.Base.MessageMonad
import Curry.Syntax hiding (infixOp)
import Base.Messages
debug :: Bool
debug = False -- mergen von Token und Codes
......@@ -29,41 +31,46 @@ trace'' s x = if debug' then trace s x else x
type Program = [(Int, Int, Code)]
data Code = Keyword String
| Space Int
| NewLine
| ConstructorName ConstructorKind QualIdent
| TypeConstructor TypeKind QualIdent
| Function FunctionKind QualIdent
| ModuleName ModuleIdent
| Commentary String
| NumberCode String
| StringCode String
| CharCode String
| Symbol String
| Identifier IdentifierKind QualIdent
| CodeWarning [Message] Code
| NotParsed String
deriving Show
data TypeKind = TypeDecla
| TypeUse
| TypeExport deriving Show
data ConstructorKind = ConstrPattern
| ConstrCall
| ConstrDecla
| OtherConstrKind deriving Show
data IdentifierKind = IdDecl
| IdOccur
| UnknownId deriving Show
data FunctionKind = InfixFunction
| TypSig
| FunDecl
| FunctionCall
| OtherFunctionKind deriving Show
data Code
= Keyword String
| Space Int
| NewLine
| ConstructorName ConstructorKind QualIdent
| TypeConstructor TypeKind QualIdent
| Function FunctionKind QualIdent
| ModuleName ModuleIdent
| Commentary String
| NumberCode String
| StringCode String
| CharCode String
| Symbol String
| Identifier IdentifierKind QualIdent
| CodeWarning [Message] Code
| NotParsed String
deriving Show
data TypeKind
= TypeDecla
| TypeUse
| TypeExport deriving Show
data ConstructorKind
= ConstrPattern
| ConstrCall
| ConstrDecla
| OtherConstrKind deriving Show
data IdentifierKind
= IdDecl
| IdOccur
| UnknownId deriving Show
data FunctionKind
= InfixFunction
| TypSig
| FunDecl
| FunctionCall
| OtherFunctionKind deriving Show
--- @param plaintext
--- @param list with parse-Results with descending quality e.g. [typingParse, fullParse, parse]
......@@ -100,7 +107,7 @@ area2codes xxs@((l,c,code):xs) p1@Position{file=f} p2
where
posBegin = Position f l c noRef
posEnd = Position f l (c + length (code2string code)) noRef
area2codes _ _ _ = error "SyntaxColoring.area2codes: no pattern match"
area2codes _ _ _ = internalError "SyntaxColoring.area2codes: no pattern match"
--- @param code
--- @return qualIdent if available
......@@ -335,7 +342,7 @@ tokenNcodes2codes nameList currLine currCol toks@((messages,Position{line=row,co
| null messages = (l,c,code):cs
| otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages)
((l,c,CodeWarning messages code): addMessage cs)
tokenNcodes2codes _ _ _ _ _ = error "SyntaxColoring.tokenNcodes2codes: no pattern match"
tokenNcodes2codes _ _ _ _ _ = internalError "SyntaxColoring.tokenNcodes2codes: no pattern match"
renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code
......@@ -368,8 +375,6 @@ getModuleIdent (Identifier _ qualIdent) = qualidMod qualIdent
getModuleIdent (TypeConstructor _ qualIdent) = qualidMod qualIdent
getModuleIdent _ = Nothing
{-
setQualIdent :: Code -> QualIdent -> Code
setQualIdent (Keyword str) _ = (Keyword str)
......@@ -392,17 +397,17 @@ code2string (Keyword str) = str
code2string (Space i)= concat (replicate i " ")
code2string NewLine = "\n"
code2string (ConstructorName _ qualIdent) = name $ unqualify qualIdent
code2string (TypeConstructor _ qualIdent) = name $ unqualify qualIdent
code2string (Function _ qualIdent) = name $ unqualify qualIdent
code2string (ModuleName moduleIdent) = moduleName moduleIdent
code2string (Commentary str) = str
code2string (NumberCode str) = str
code2string (Symbol str) = str
code2string (Identifier _ qualIdent) = name $ unqualify qualIdent
code2string (TypeConstructor _ qualIdent) = name $ unqualify qualIdent
code2string (StringCode str) = str
code2string (CharCode str) = str
code2string (Symbol str) = str
code2string (Identifier _ qualIdent) = name $ unqualify qualIdent
code2string (CodeWarning _ c) = code2string c
code2string (NotParsed str) = str
code2string _ = "" -- error / warning
code2qualString :: Code -> String
code2qualString (ConstructorName _ qualIdent) = qualName qualIdent
......@@ -411,8 +416,6 @@ code2qualString (Identifier _ qualIdent) = qualName qualIdent
code2qualString (TypeConstructor _ qualIdent) = qualName qualIdent
code2qualString x = code2string x
token2code :: Token -> Code
token2code tok@(Token cat _)
| elem cat [IntTok,FloatTok,IntegerTok]
......@@ -586,7 +589,7 @@ constrTerm2codes (FunctionPattern qualIdent constrTerms) =
constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =
constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2
constrTerm2codes (RecordPattern _ _) =
error "SyntaxColoring.constrTerm2codes: record pattern"
internalError "SyntaxColoring.constrTerm2codes: record pattern"
expression2codes :: Expression -> [Code]
expression2codes (Literal _) = []
......@@ -634,7 +637,7 @@ expression2codes (IfThenElse _ expression1 expression2 expression3) =
expression2codes expression1 ++ expression2codes expression2 ++ expression2codes expression3
expression2codes (Case _ expression alts) =
expression2codes expression ++ concatMap alt2codes alts
expression2codes _ = error "SyntaxColoring.expression2codes: no pattern match"
expression2codes _ = internalError "SyntaxColoring.expression2codes: no pattern match"
infixOp2codes :: InfixOp -> [Code]
infixOp2codes (InfixOp qualIdent) = [Function InfixFunction qualIdent]
......@@ -685,7 +688,7 @@ typeExpr2codes (ListType typeExpr) =
typeExpr2codes typeExpr
typeExpr2codes (ArrowType typeExpr1 typeExpr2) =
typeExpr2codes typeExpr1 ++ typeExpr2codes typeExpr2
typeExpr2codes (RecordType _ _) = error "SyntaxColoring.typeExpr2codes: Record pattern"
typeExpr2codes (RecordType _ _) = internalError "SyntaxColoring.typeExpr2codes: Record pattern"
-- TOKEN TO STRING ------------------------------------------------------------
token2string :: Token -> [Char]
......
......@@ -23,6 +23,7 @@ similar to that of Flat-Curry XML representation.
> import Curry.Base.Ident
> import IL.Type
> import Base.Messages (internalError)
TODO: The following import should be avoided if possible as it makes
the program structure less clear.
......@@ -71,7 +72,7 @@ TODO: The following import should be avoided if possible as it makes
> where
> beginType = text "<type name=\"" <> (xmlQualIdent tc) <> text "\">"
> endType = text "</type>"
> xmlTypeDecl _ = error "IL.XML.xmlTypeDecl: no data declaration"
> xmlTypeDecl _ = internalError "IL.XML.xmlTypeDecl: no data declaration"
> xmlTypeParams :: Int -> Doc
> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]
......@@ -132,23 +133,20 @@ TODO: The following import should be avoided if possible as it makes
> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =
> xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))
> where
> arg = mkIdent "_1"
> ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
> arg = mkIdent "_1"
> ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
> xmlFunctionDecl (FunctionDecl ident largs fType expr) =
> heading $$ nest level (xmlRule largs expr) $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (length largs) fType
> heading $$ nest level (xmlRule largs expr) $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (length largs) fType
> xmlFunctionDecl (ExternalDecl ident _callConv internalName fType) =
> heading $$ external $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
> external = text ("<external>"
> ++ xmlFormat internalName
> ++ "</external>")
> xmlFunctionDecl (DataDecl _ _ _) = error "IL.XML.xmlFunctionDecl: data declaration"
> heading $$ external $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
> external = text ("<external>"
> ++ xmlFormat internalName
> ++ "</external>")
> xmlFunctionDecl (DataDecl _ _ _) = internalError "IL.XML.xmlFunctionDecl: data declaration"
> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc
> xmlBeginFunction ident n fType = heading $$ typeDecls
......@@ -194,7 +192,6 @@ TODO: The following import should be avoided if possible as it makes
> xmlExpr d (Exist ident expr) = xmlFree d ident expr
> xmlExpr d (Let binding expr) = xmlLet d binding expr
> xmlExpr d (Letrec lBinding expr) = xmlLetrec d lBinding expr
> --error "Recursive let bindings not supported in FlatCurry"
> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
> xmlSingleApp ident arity isFunction =
......@@ -234,19 +231,18 @@ TODO: The following import should be avoided if possible as it makes
> where
> (e1,d1) = xmlExpr d expr1
> (e2,d2) = xmlExpr d1 expr2
> xmlApply _ _ _ = error "IL.XML.xmlApply: no pattern match"
> xmlApply _ _ _ = internalError "IL.XML.xmlApply: no pattern match"
> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->
> Bool -> (Doc,[(Int,Ident)])
> xmlApplyFunctor d ident arity lArgs isFunction =
> xmlCombApply d (xmlQualIdent ident) (text cTypeS) n lArgs
> where
> n = length (lArgs)
> cTypeS = if n==arity
> then if isFunction
> then "FuncCall"
> else "ConsCall"
> else "PartCall"
> xmlCombApply d (xmlQualIdent ident) (text cTypeS) n lArgs
> where
> n = length lArgs
> cTypeS
> | n /= arity = "PartCall"
> | isFunction = "FuncCall"
> | otherwise = "ConsCall"
> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
> [Expression] -> (Doc,[(Int,Ident)])
......@@ -290,7 +286,7 @@ TODO: The following import should be avoided if possible as it makes
> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])
> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)
> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident lArgs
> xmlPattern _ (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"
> xmlPattern _ (VariablePattern _) = internalError "Variable patterns not allowed in Flat Curry"
> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])
> xmlConsPattern d ident lArgs =
......
......@@ -28,7 +28,7 @@ import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Base.Messages (abortWith, errorMessages, putErrsLn)
import Base.Messages (abortWith, mposErr, putErrsLn)
import Env.Eval (evalEnv)
......@@ -74,7 +74,7 @@ compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
loaded <- loadModule opts fn
case uncurry (checkModule opts) loaded of
CheckFailed errs -> errorMessages errs
CheckFailed errs -> abortWith $ map show errs
CheckSuccess (env, modul) -> do
showWarnings opts $ uncurry warnCheck loaded
writeParsed opts fn modul
......@@ -85,14 +85,14 @@ compileModule opts fn = do
-- types of the newly introduced functions are not inferred (hsi)
let (env2, il, dumps) = transModule opts env modul
-- dump intermediate results
mapM_ (doDump opts) dumps
mapM_ (dump opts) dumps
-- generate target code
let intf = exportInterface env2 modul
let modSum = summarizeModule (tyConsEnv env2) intf modul
writeFlat opts fn env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
-- ---------------------------------------------------------------------------
-- Loading a module
......@@ -103,27 +103,27 @@ loadModule opts fn = do
-- read module
mbSrc <- readModule fn
case mbSrc of
Nothing -> abortWith ["missing file: " ++ fn]
Nothing -> abortWith ["missing file: " ++ fn] -- TODO
Just src -> do
-- parse module
let parsed = ok $ CS.parseModule True fn src
let parsed = ok $ CS.parseModule True fn src -- TODO
-- check module header
let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
unless (null hdrErrs) $ abortWith hdrErrs
unless (null hdrErrs) $ abortWith $ map show hdrErrs -- TODO
-- load the imported interfaces into an InterfaceEnv
(iEnv, intfErrs) <- loadInterfaces (optImportPaths opts) mdl
unless (null intfErrs) $ errorMessages intfErrs
unless (null intfErrs) $ abortWith $ map show intfErrs -- TODO
-- add information of imported modules
let env = importModules opts mdl iEnv
return (env, mdl)
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [String])
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
checkModuleHeader opts fn = checkModuleId fn
. importPrelude opts
. CS.patchModuleId fn
-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [String])
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [Message])
checkModuleId fn m@(CS.Module mid _ _ _)
| last (moduleQualifiers mid) == takeBaseName fn
= (m, [])
......@@ -146,12 +146,12 @@ importPrelude opts m@(CS.Module mid es is ds)
-- let's add it!
| otherwise = CS.Module mid es (preludeImp : is) ds
where
noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
preludeImp = CS.ImportDecl NoPos preludeMIdent
False -- qualified?
Nothing -- no alias
Nothing -- no selection of types, functions, etc.
imported = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
preludeImp = CS.ImportDecl NoPos preludeMIdent
False -- qualified?
Nothing -- no alias
Nothing -- no selection of types, functions, etc.
imported = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
-- ---------------------------------------------------------------------------
-- Checking a module
......@@ -178,25 +178,27 @@ checkModule opts env mdl = kindCheck env mdl -- should be only syntax checking ?
-- Translating a module
-- ---------------------------------------------------------------------------
type Dump = (DumpLevel, CompilerEnv, String)
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
-> (CompilerEnv, IL.Module, [(DumpLevel, CompilerEnv, String)])
-> (CompilerEnv, IL.Module, [Dump])
transModule opts env mdl = (env5, ilCaseComp, dumps)
where
flat' = FlatCurry `elem` optTargetTypes opts
env0 = env { evalAnnotEnv = evalEnv mdl }
(desugared , env1) = desugar mdl env0
(simplified, env2) = simplify flat' desugared env1
(lifted , env3) = lift simplified env2
(il , env4) = ilTrans flat' lifted env3
(ilCaseComp, env5) = completeCase il env4
dumps = [ (DumpRenamed , env , show $ CS.ppModule mdl )
, (DumpDesugared , env1, show $ CS.ppModule desugared )
, (DumpSimplified, env2, show $ CS.ppModule simplified)
, (DumpLifted , env3, show $ CS.ppModule lifted )
, (DumpIL , env4, show $ IL.ppModule il )
, (DumpCase , env5, show $ IL.ppModule ilCaseComp)
]
flat' = FlatCurry `elem` optTargetTypes opts
env0 = env { evalAnnotEnv = evalEnv mdl }
(desugared , env1) = desugar mdl env0
(simplified, env2) = simplify flat' desugared env1
(lifted , env3) = lift simplified env2
(il , env4) = ilTrans flat' lifted env3
(ilCaseComp, env5) = completeCase il env4
dumps = [ (DumpRenamed , env , show $ CS.ppModule mdl )
, (DumpDesugared , env1, show $ CS.ppModule desugared )
, (DumpSimplified, env2, show $ CS.ppModule simplified)
, (DumpLifted , env3, show $ CS.ppModule lifted )
, (DumpIL , env4, show $ IL.ppModule il )
, (DumpCase , env5, show $ IL.ppModule ilCaseComp)
]
-- ---------------------------------------------------------------------------
-- Writing output
......@@ -214,10 +216,10 @@ writeParsed :: Options -> FilePath -> CS.Module -> IO ()
writeParsed opts fn modul = when srcTarget $
writeModule useSubDir targetFile source
where
srcTarget = Parsed `elem` optTargetTypes opts
useSubDir = optUseSubdir opts
targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
source = CS.showModule modul
srcTarget = Parsed `elem` optTargetTypes opts
useSubDir = optUseSubdir opts
targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
source = CS.showModule modul
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
-> IO ()
......@@ -239,10 +241,10 @@ writeFlatCurry opts fn env modSum il = do
when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
when fcyTarget $ EF.writeFlatCurry useSubDir (flatName fn) prog
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts