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

Compilation errors removed

parent 7e5d0d97
...@@ -149,11 +149,11 @@ visitExpr _ aEnv _ = aEnv ...@@ -149,11 +149,11 @@ visitExpr _ aEnv _ = aEnv
visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv
visitStatement mid aEnv (StmtExpr _ expr) visitStatement mid aEnv (StmtExpr _ expr)
= visitExpression mid aEnv expr = visitExpr mid aEnv expr
visitStatement mid aEnv (StmtDecl decls) visitStatement mid aEnv (StmtDecl decls)
= foldl (visitDecl mid) aEnv decls = foldl (visitDecl mid) aEnv decls
visitStatement mid aEnv (StmtBind _ _ expr) visitStatement mid aEnv (StmtBind _ _ expr)
= visitExpression mid aEnv expr = visitExpr mid aEnv expr
visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv
visitAlt mid aEnv (Alt _ _ rhs) = visitRhs mid aEnv rhs visitAlt mid aEnv (Alt _ _ rhs) = visitRhs mid aEnv rhs
......
...@@ -8,7 +8,6 @@ ...@@ -8,7 +8,6 @@
module CompilerOpts module CompilerOpts
( Options (..), Verbosity (..), TargetType (..), Extension (..) ( Options (..), Verbosity (..), TargetType (..), Extension (..)
, DumpLevel (..), defaultOptions, compilerOpts, usage , DumpLevel (..), defaultOptions, compilerOpts, usage
, implicitPrelude
) where ) where
import Data.List (nub) import Data.List (nub)
...@@ -29,7 +28,7 @@ data Options = Options ...@@ -29,7 +28,7 @@ data Options = Options
, optForce :: Bool -- ^ force compilation , optForce :: Bool -- ^ force compilation
, optImportPaths :: [FilePath] -- ^ directories for imports , optImportPaths :: [FilePath] -- ^ directories for imports
, optOutput :: Maybe FilePath -- ^ name of output file , optOutput :: Maybe FilePath -- ^ name of output file
, optUseSubdir :: Bool -- use subdir for output? , optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ do not create an interface file , optInterface :: Bool -- ^ do not create an interface file
, optWarn :: Bool -- ^ warnings on/off , optWarn :: Bool -- ^ warnings on/off
, optOverlapWarn :: Bool -- ^ "overlap" warnings on/off , optOverlapWarn :: Bool -- ^ "overlap" warnings on/off
......
...@@ -23,9 +23,7 @@ In this section a lexer for Curry is implemented. ...@@ -23,9 +23,7 @@ In this section a lexer for Curry is implemented.
> import Data.Char (chr, ord, isAlpha, isAlphaNum, isSpace, isUpper > import Data.Char (chr, ord, isAlpha, isAlphaNum, isSpace, isUpper
> , isDigit, isOctDigit, isHexDigit) > , isDigit, isOctDigit, isHexDigit)
> import Data.List (intercalate) > import Data.List (intercalate)
> import qualified Data.Map as Map (Map, union, lookup, fromList > import qualified Data.Map as Map (Map, union, lookup, fromList)
> , findWithDefault)
> import Data.Maybe (fromMaybe)
> import Curry.Base.LexComb > import Curry.Base.LexComb
> import Curry.Base.LLParseComb (Symbol (..)) > import Curry.Base.LLParseComb (Symbol (..))
...@@ -236,9 +234,6 @@ all tokens in their source representation. ...@@ -236,9 +234,6 @@ all tokens in their source representation.
-- Helper for showing -- Helper for showing
> showsQualified :: [String] -> String -> ShowS
> showsQualified modul ident = showsEscaped $ intercalate "." $ modul ++ [ident]
> showsEscaped :: String -> ShowS > showsEscaped :: String -> ShowS
> showsEscaped s = showChar '`' . showString s . showChar '\'' > showsEscaped s = showChar '`' . showString s . showChar '\''
...@@ -540,7 +535,7 @@ Lexing functions ...@@ -540,7 +535,7 @@ Lexing functions
> lexSymbol :: (Token -> P a) -> P a > lexSymbol :: (Token -> P a) -> P a
> lexSymbol cont p s = > lexSymbol cont p s =
> cont (idTok (maybe Sym id (Map.lookup sym keywordsSpecialIds)) [] sym) > cont (idTok (maybe Sym id (Map.lookup sym reservedSpecialOps)) [] sym)
> (incr p (length sym)) rest > (incr p (length sym)) rest
> where (sym,rest) = span isSymbol s > where (sym,rest) = span isSymbol s
......
...@@ -726,7 +726,7 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected") ...@@ -726,7 +726,7 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
> sym :: Parser Token Ident a > sym :: Parser Token Ident a
> sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*> > sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
> tokens [Sym,Sym_Dot,Sym_Minus,Sym_MinusDot] > tokens [Sym, SymColon, SymDot, SymMinus, SymMinusDot]
> qSym :: Parser Token QualIdent a > qSym :: Parser Token QualIdent a
> qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym > qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
...@@ -735,15 +735,15 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected") ...@@ -735,15 +735,15 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
> colon :: Parser Token QualIdent a > colon :: Parser Token QualIdent a
> colon = (\ p _ -> qualify $ addPositionIdent p consId) <$> > colon = (\ p _ -> qualify $ addPositionIdent p consId) <$>
> position <*> token Colon > position <*> token SymColon
> minus :: Parser Token Ident a > minus :: Parser Token Ident a
> minus = (\ p _ -> addPositionIdent p minusId) <$> > minus = (\ p _ -> addPositionIdent p minusId) <$>
> position <*> token Sym_Minus > position <*> token SymMinus
> fminus :: Parser Token Ident a > fminus :: Parser Token Ident a
> fminus = (\ p _ -> addPositionIdent p fminusId) <$> > fminus = (\ p _ -> addPositionIdent p fminusId) <$>
> position <*> token Sym_MinusDot > position <*> token SymMinusDot
> tupleCommas :: Parser Token QualIdent a > tupleCommas :: Parser Token QualIdent a
> tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length ) > tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length )
......
...@@ -16,7 +16,7 @@ import Curry.Files.Filenames ...@@ -16,7 +16,7 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils ( dropExtension, doesModuleExist, lookupCurryFile import Curry.Files.PathUtils ( dropExtension, doesModuleExist, lookupCurryFile
, getModuleModTime, tryGetModuleModTime) , getModuleModTime, tryGetModuleModTime)
import CompilerOpts (Options (..), Extension (..), TargetType (..)) import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps) import CurryDeps (Source (..), flatDeps)
import Messages (status, abortWith) import Messages (status, abortWith)
import Modules (compileModule) import Modules (compileModule)
...@@ -27,7 +27,7 @@ import Modules (compileModule) ...@@ -27,7 +27,7 @@ import Modules (compileModule)
-} -}
buildCurry :: Options -> FilePath -> IO () buildCurry :: Options -> FilePath -> IO ()
buildCurry opts file = do buildCurry opts file = do
mbFile <- lookupCurryFile importPaths file mbFile <- lookupCurryFile (optImportPaths opts) file
case mbFile of case mbFile of
Nothing -> abortWith [missingModule file] Nothing -> abortWith [missingModule file]
Just f -> do Just f -> do
...@@ -85,13 +85,13 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where ...@@ -85,13 +85,13 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
compileFile f = do compileFile f = do
status opts $ "compiling " ++ f status opts $ "compiling " ++ f
compileModule (compOpts True) f >> return () compileModule (compOpts True) f
skipFile f = status opts $ "skipping " ++ f skipFile f = status opts $ "skipping " ++ f
generateFile f = do generateFile f = do
status opts $ "generating " ++ head (targetNames f) status opts $ "generating " ++ head (targetNames f)
compileModule (compOpts False) f >> return () compileModule (compOpts False) f
compOpts isImport compOpts isImport
| isImport = opts { optTargetTypes = [FlatCurry], optDumps = [] } | isImport = opts { optTargetTypes = [FlatCurry], optDumps = [] }
......
...@@ -42,7 +42,7 @@ dependencies and to update programs composed of multiple modules. ...@@ -42,7 +42,7 @@ dependencies and to update programs composed of multiple modules.
> mEnv <- deps implicitPrelude [] libPaths Map.empty fn > mEnv <- deps implicitPrelude [] libPaths Map.empty fn
> return $ flattenDeps mEnv > return $ flattenDeps mEnv
> where > where
> implicitPrelude = NoImplicitPrelude `notElem` optExtensions otps > implicitPrelude = NoImplicitPrelude `notElem` optExtensions opts
> libPaths = optImportPaths opts > libPaths = optImportPaths opts
> deps :: Bool -> [FilePath] -> [FilePath] -> SourceEnv -> FilePath > deps :: Bool -> [FilePath] -> [FilePath] -> SourceEnv -> FilePath
......
...@@ -87,12 +87,11 @@ makeInterfaces paths (CS.Module mid _ decls) = do ...@@ -87,12 +87,11 @@ makeInterfaces paths (CS.Module mid _ decls) = do
when (null errs) (mapM_ (compile deps1 . snd) deps1) when (null errs) (mapM_ (compile deps1 . snd) deps1)
return errs return errs
where where
compile deps' (Source file' mods) = do compile deps' (Source file' mods) = smake
_ <- smake [flatName file', flatIntName file'] [flatName file', flatIntName file']
(file':mapMaybe (flatInterface deps') mods) (file':mapMaybe (flatInterface deps') mods)
(compileModule (opts paths) file') (compileModule (opts paths) file')
(return Nothing) (return ())
return ()
compile _ _ = return () compile _ _ = return ()
flatInterface deps' mod1 = case (lookup mod1 deps') of flatInterface deps' mod1 = case (lookup mod1 deps') of
......
...@@ -109,7 +109,7 @@ partitionDecl parts (FlatExternalDecl pos ids) ...@@ -109,7 +109,7 @@ partitionDecl parts (FlatExternalDecl pos ids)
= partitionFuncDecls (\ident -> FlatExternalDecl pos [ident]) parts ids = partitionFuncDecls (\ident -> FlatExternalDecl pos [ident]) parts ids
-- op decls -- op decls
partitionDecl parts (InfixDecl pos fix prec idents) partitionDecl parts (InfixDecl pos fix prec idents)
= partitions {opDecls = map (\ident -> (InfixDecl pos fix prec [ident])) idents ++ opDecls parts } = parts {opDecls = map (\ident -> (InfixDecl pos fix prec [ident])) idents ++ opDecls parts }
-- default -- default
partitionDecl parts _ = parts partitionDecl parts _ = parts
......
...@@ -58,8 +58,8 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul ...@@ -58,8 +58,8 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces -- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-> ArityEnv -> IL.Module -> (Prog, [WarnMsg]) -> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul =
= (patchPreludeFCY intf, messages) (patchPreludeFCY intf, messages)
where (intf, messages) where (intf, messages)
= run opts cEnv mEnv tyEnv tcEnv aEnv True (visitModule modul) = run opts cEnv mEnv tyEnv tcEnv aEnv True (visitModule modul)
......
...@@ -427,7 +427,7 @@ token2code tok@(Token cat _) ...@@ -427,7 +427,7 @@ token2code tok@(Token cat _)
= Keyword (token2string tok) = Keyword (token2string tok)
| elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket, | elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,
RightBracket,Comma,Underscore,Backquote, RightBracket,Comma,Underscore,Backquote,
At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow, At,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
Tilde] Tilde]
= Symbol (token2string tok) = Symbol (token2string tok)
| elem cat [LineComment, NestedComment] | elem cat [LineComment, NestedComment]
...@@ -443,7 +443,7 @@ token2code tok@(Token cat _) ...@@ -443,7 +443,7 @@ token2code tok@(Token cat _)
isTokenIdentifier :: Token -> Bool isTokenIdentifier :: Token -> Bool
isTokenIdentifier (Token cat _) = isTokenIdentifier (Token cat _) =
elem cat [Id,QId,Sym,QSym,Sym_Dot,Sym_Minus,Sym_MinusDot] elem cat [Id, QId, Sym, QSym, SymColon, SymDot, SymMinus, SymMinusDot]
-- DECL Position -- DECL Position
...@@ -714,7 +714,6 @@ token2string (Token Backquote _) = "`" ...@@ -714,7 +714,6 @@ token2string (Token Backquote _) = "`"
token2string (Token VSemicolon _) = "" token2string (Token VSemicolon _) = ""
token2string (Token VRightBrace _) = "" token2string (Token VRightBrace _) = ""
token2string (Token At _) = "@" token2string (Token At _) = "@"
token2string (Token Colon _) = ":"
token2string (Token DotDot _) = ".." token2string (Token DotDot _) = ".."
token2string (Token DoubleColon _) = "::" token2string (Token DoubleColon _) = "::"
token2string (Token Equals _) = "=" token2string (Token Equals _) = "="
...@@ -723,9 +722,10 @@ token2string (Token Bar _) = "|" ...@@ -723,9 +722,10 @@ token2string (Token Bar _) = "|"
token2string (Token LeftArrow _) = "<-" token2string (Token LeftArrow _) = "<-"
token2string (Token RightArrow _) = "->" token2string (Token RightArrow _) = "->"
token2string (Token Tilde _) = "~" token2string (Token Tilde _) = "~"
token2string (Token Sym_Dot _) = "." token2string (Token SymColon _) = ":"
token2string (Token Sym_Minus _) = "-" token2string (Token SymDot _) = "."
token2string (Token Sym_MinusDot _) = "-." token2string (Token SymMinus _) = "-"
token2string (Token SymMinusDot _) = "-."
token2string (Token KW_case _) = "case" token2string (Token KW_case _) = "case"
token2string (Token KW_choice _) = "choice" token2string (Token KW_choice _) = "choice"
token2string (Token KW_data _) = "data" token2string (Token KW_data _) = "data"
......
...@@ -20,7 +20,6 @@ This module controls the compilation of modules. ...@@ -20,7 +20,6 @@ This module controls the compilation of modules.
> import Data.List (find, isPrefixOf, partition) > import Data.List (find, isPrefixOf, partition)
> import qualified Data.Map as Map (Map, empty, insert, insertWith, lookup, toList) > import qualified Data.Map as Map (Map, empty, insert, insertWith, lookup, toList)
> import Data.Maybe (fromMaybe) > import Data.Maybe (fromMaybe)
> import System.IO (stderr, hPutStrLn)
> import Text.PrettyPrint.HughesPJ (Doc, ($$), text, vcat) > import Text.PrettyPrint.HughesPJ (Doc, ($$), text, vcat)
> import qualified Curry.AbstractCurry as AC > import qualified Curry.AbstractCurry as AC
...@@ -34,14 +33,14 @@ This module controls the compilation of modules. ...@@ -34,14 +33,14 @@ This module controls the compilation of modules.
> import qualified Curry.IL as IL > import qualified Curry.IL as IL
> import Curry.Syntax > import Curry.Syntax
> import Base.Arity (ArityEnv, initAEnv, bindArities)
> import Base.Eval (evalEnv) > import Base.Eval (evalEnv)
> import Base.Import (bindAlias, initIEnv, fromDeclList)
> import Base.Module (ModuleEnv) > import Base.Module (ModuleEnv)
> import Base.OpPrec (PEnv, initPEnv) > import Base.OpPrec (PEnv, initPEnv)
> import Base.TypeConstructors (TCEnv, TypeInfo (..), initTCEnv, qualLookupTC) > import Base.TypeConstructors (TCEnv, TypeInfo (..), initTCEnv, qualLookupTC)
> import Base.Types (toType, fromQualType) > import Base.Types (toType, fromQualType)
> import Base.Value (ValueEnv, ValueInfo (..), initDCEnv) > import Base.Value (ValueEnv, ValueInfo (..), initDCEnv)
> import Base.Arity (ArityEnv, initAEnv, bindArities)
> import Base.Import (bindAlias, initIEnv)
> import Check.InterfaceCheck (interfaceCheck) > import Check.InterfaceCheck (interfaceCheck)
> import Check.KindCheck (kindCheck) > import Check.KindCheck (kindCheck)
> import Check.SyntaxCheck (syntaxCheck) > import Check.SyntaxCheck (syntaxCheck)
...@@ -66,7 +65,7 @@ This module controls the compilation of modules. ...@@ -66,7 +65,7 @@ This module controls the compilation of modules.
> import CurryToIL (ilTrans) > import CurryToIL (ilTrans)
> import Exports (expandInterface, exportInterface) > import Exports (expandInterface, exportInterface)
> import Imports (importInterface, importInterfaceIntf, importUnifyData) > import Imports (importInterface, importInterfaceIntf, importUnifyData)
> import Messages (errorAt, internalError) > import Messages (errorAt, internalError, putErrsLn)
> import Types > import Types
> import TypeSubst > import TypeSubst
...@@ -94,7 +93,7 @@ as a frontend for PAKCS, all functions for evaluating goals and generating C ...@@ -94,7 +93,7 @@ as a frontend for PAKCS, all functions for evaluating goals and generating C
code are obsolete and commented out. code are obsolete and commented out.
\begin{verbatim} \begin{verbatim}
> compileModule :: Options -> FilePath -> IO (Maybe FilePath) > compileModule :: Options -> FilePath -> IO ()
> compileModule opts fn = do > compileModule opts fn = do
> -- read and parse module > -- read and parse module
> parsed <- (ok . parseModule likeFlat fn) `liftM` readModule fn > parsed <- (ok . parseModule likeFlat fn) `liftM` readModule fn
...@@ -110,7 +109,7 @@ code are obsolete and commented out. ...@@ -110,7 +109,7 @@ code are obsolete and commented out.
> then do > then do
> (tyEnv, tcEnv, _, m', _, _) <- simpleCheckModule opts mEnv m > (tyEnv, tcEnv, _, m', _, _) <- simpleCheckModule opts mEnv m
> -- generate untyped AbstractCurry > -- generate untyped AbstractCurry
> when uacy $ genAbstract opts fn tyEnv tcEnv m' >> return () > when uacy $ genAbstract opts fn tyEnv tcEnv m'
> -- output the parsed source > -- output the parsed source
> when src $ genParsed opts fn m' > when src $ genParsed opts fn m'
> else do > else do
...@@ -123,8 +122,8 @@ code are obsolete and commented out. ...@@ -123,8 +122,8 @@ code are obsolete and commented out.
> -- dump intermediate results > -- dump intermediate results
> mapM_ (doDump opts) dumps > mapM_ (doDump opts) dumps
> -- generate target code > -- generate target code
> when (acy || uacy) $ genAbstract opts fn tyEnv tcEnv m' >> return () > when (acy || uacy) $ genAbstract opts fn tyEnv tcEnv m'
> when (fcy || xml) $ genFlat opts fn mEnv tyEnv tcEnv aEnv' intf m' il >> return () > when (fcy || xml) $ genFlat opts fn mEnv tyEnv tcEnv aEnv' intf m' il
> when src $ genParsed opts fn m' > when src $ genParsed opts fn m'
> where > where
> acy = AbstractCurry `elem` optTargetTypes opts > acy = AbstractCurry `elem` optTargetTypes opts
...@@ -168,7 +167,7 @@ only a qualified import is added. ...@@ -168,7 +167,7 @@ only a qualified import is added.
\begin{verbatim} \begin{verbatim}
> importPrelude :: Options -> FilePath -> Module -> Module > importPrelude :: Options -> FilePath -> Module -> Module
> importPrelude opts fn m(Module mid es ds) > importPrelude opts fn m@(Module mid es ds)
> -- the Prelude itself > -- the Prelude itself
> | mid == preludeMIdent = m > | mid == preludeMIdent = m
> -- disabled by option > -- disabled by option
...@@ -183,15 +182,15 @@ only a qualified import is added. ...@@ -183,15 +182,15 @@ only a qualified import is added.
> False -- qualified > False -- qualified
> Nothing -- no alias > Nothing -- no alias
> Nothing -- no selection of types, functions, etc. > Nothing -- no selection of types, functions, etc.
> imported = [imp | decl@(ImportDecl _ imp _ _ _) <- ds] > imported = [imp | (ImportDecl _ imp _ _ _) <- ds]
> -- | > -- |
> simpleCheckModule :: Options -> ModuleEnv -> Module > simpleCheckModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg]) > -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> simpleCheckModule opts mEnv (Module m es ds) = do > simpleCheckModule opts mEnv (Module m es ds) = do
> showWarnings warnMsgs > showWarnings opts warnMsgs
> return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs) > return (tyEnv'', tcEnv, aEnv'', modul, intf, warnMsgs)
> where > where
> -- split import declarations > -- split import declarations
> (impDs, topDs) = partition isImportDecl ds > (impDs, topDs) = partition isImportDecl ds
...@@ -215,9 +214,9 @@ only a qualified import is added. ...@@ -215,9 +214,9 @@ only a qualified import is added.
> checkModule :: Options -> ModuleEnv -> Module > checkModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg]) > -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> checkModule opts mEnv (Module m es ds) = do > checkModule opts mEnv (Module m es ds) = do
> showWarnings warnMsgs > showWarnings opts warnMsgs
> when (m == mkMIdent ["field114..."]) (error (show es)) > when (m == mkMIdent ["field114..."]) (error (show es))
> return (tyEnv''', tcEnv', aEnv'', modul, intf, msgs) > return (tyEnv''', tcEnv', aEnv'', modul, intf, warnMsgs)
> where > where
> (impDs, topDs) = partition isImportDecl ds > (impDs, topDs) = partition isImportDecl ds
> iEnv = foldr bindAlias initIEnv impDs > iEnv = foldr bindAlias initIEnv impDs
...@@ -484,7 +483,7 @@ Interface files are updated by the Curry builder when necessary. ...@@ -484,7 +483,7 @@ Interface files are updated by the Curry builder when necessary.
> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog > writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile opts (res, msgs) fname = do > writeFlatFile opts (res, msgs) fname = do
> showWarnings msgs > showWarnings opts msgs
> when extended $ writeExtendedFlat sub fname res > when extended $ writeExtendedFlat sub fname res
> when flat $ writeFlatCurry sub fname res > when flat $ writeFlatCurry sub fname res
> return res > return res
...@@ -535,51 +534,43 @@ be dependent on it any longer. ...@@ -535,51 +534,43 @@ be dependent on it any longer.
\begin{verbatim} \begin{verbatim}
> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv > genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
> -> Interface -> Module -> IL.Module -> IO (Maybe FilePath) > -> Interface -> Module -> IL.Module -> IO ()
> genFlat opts fname mEnv tyEnv tcEnv aEnv intf modul il > genFlat opts fname mEnv tyEnv tcEnv aEnv intf modul il = do
> | FlatCurry `elem` optTargetTypes opts > when fcy $ do
> = do _ <- writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il > _ <- writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
> let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il > let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il
> if optForce opts > if optForce opts
> then > then writeInterface flatInterface intMsgs
> do writeInterface flatInterface intMsgs > else do
> return Nothing > mfint <- readFlatInterface fintName
> else
> do mfint <- readFlatInterface fintName
> let flatIntf = fromMaybe emptyIntf mfint > let flatIntf = fromMaybe emptyIntf mfint
> if mfint == mfint -- necessary to close the file 'fintName' > when (mfint == mfint -- necessary to close the file 'fintName'
> && not (interfaceCheck flatIntf flatInterface) > && not (interfaceCheck flatIntf flatInterface)) $
> then > writeInterface flatInterface intMsgs
> do writeInterface flatInterface intMsgs > when xml $ writeXML (optUseSubdir opts) (optOutput opts) fname cEnv il
> return Nothing
> else return Nothing
> | FlatXml `elem` optTargetTypes opts
> = writeXML (optUseSubdir opts) (optOutput opts) fname cEnv il >>
> return Nothing
> | otherwise
> = internalError "@Modules.genFlat: illegal option"
> where > where
> fcy = FlatCurry `elem` optTargetTypes opts
> xml = FlatXml `elem` optTargetTypes opts
> fintName = flatIntName fname > fintName = flatIntName fname
> cEnv = curryEnv mEnv tcEnv intf modul > cEnv = curryEnv mEnv tcEnv intf modul
> emptyIntf = Prog "" [] [] [] [] > emptyIntf = Prog "" [] [] [] []
> writeInterface intf' msgs = do > writeInterface intf' msgs = do
> when (optWarn opts) (printMessages msgs) > showWarnings opts msgs
> writeFlatCurry (optUseSubdir opts) fintName intf' > writeFlatCurry (optUseSubdir opts) fintName intf'
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module -> IO (Maybe FilePath) > genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> genAbstract opts@Options{optUseSubdir=sub} fname tyEnv tcEnv modul > genAbstract opts fname tyEnv tcEnv modul = do
> | AbstractCurry `elem` optTargetTypes opts > when acy $ writeTypedAbs subdir Nothing fname tyEnv tcEnv modul
> = do writeTypedAbs sub Nothing fname tyEnv tcEnv modul > when uacy $ writeUntypedAbs subdir Nothing fname tyEnv tcEnv modul
> return Nothing > where
> | UntypedAbstractCurry `elem` optTargetTypes opts > subdir = optUseSubdir opts
> = do writeUntypedAbs sub Nothing fname tyEnv tcEnv modul > acy = AbstractCurry `elem` optTargetTypes opts
> return Nothing > uacy = UntypedAbstractCurry `elem` optTargetTypes opts
> | otherwise
> = internalError "@Modules.genAbstract: illegal option"
> genParsed :: Options -> FilePath -> Module -> IO () > genParsed :: Options -> FilePath -> Module -> IO ()
> getParsed opts fn modul = writeModule intoSubdir outputFile modString > genParsed opts fn modul = writeModule intoSubdir outputFile modString
> where > where
> intoSubdir = optUseSubdir opts > intoSubdir = optUseSubdir opts
> outputFile = fromMaybe (sourceRepName fn) (optOutput opts) > outputFile = fromMaybe (sourceRepName fn) (optOutput opts)
......
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