Commit 58c06a2e authored by Björn Peemöller 's avatar Björn Peemöller

Merge branch 'preprocessor'

parents c7cc8e01 fb6eb202
......@@ -36,7 +36,7 @@ Executable cymake
Build-Depends: base == 3.*
Build-Depends:
curry-base == 0.3.9
, containers, either, mtl, transformers
, containers, directory, either, mtl, process, transformers
ghc-options: -Wall
Other-Modules:
Base.CurryTypes
......
......@@ -17,7 +17,7 @@ import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
import Curry.Base.Message hiding (warn)
import CompilerOpts (Options (..), Verbosity (..))
import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..))
type CYT m a = EitherT [Message] m a
......@@ -36,10 +36,10 @@ info opts msg = unless (optVerbosity opts < VerbInfo) (putMsg msg)
status :: MonadIO m => Options -> String -> m ()
status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)
warn :: MonadIO m => Options -> [Message] -> m ()
warn opts msgs = when (optWarn opts && not (null msgs)) $ do
warn :: MonadIO m => WarnOpts -> [Message] -> m ()
warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
when (optWarnAsError opts) $ liftIO $ do
when (wnWarnAsError opts) $ liftIO $ do
putErrLn "Failed due to -Werror"
exitFailure
......
......@@ -91,4 +91,5 @@ exportCheck _ env (Module ps m es is ds)
-- |Check for warnings.
warnCheck :: Options -> CompilerEnv -> Module -> [Message]
warnCheck opts env mdl = WC.warnCheck opts (valueEnv env) (tyConsEnv env) mdl
warnCheck opts env mdl
= WC.warnCheck (optWarnOpts opts) (valueEnv env) (tyConsEnv env) mdl
......@@ -47,9 +47,9 @@ import CompilerOpts
-- - idle case alternatives
-- - overlapping case alternatives
-- - non-adjacent function rules
warnCheck :: Options -> ValueEnv -> TCEnv -> Module -> [Message]
warnCheck :: WarnOpts -> ValueEnv -> TCEnv -> Module -> [Message]
warnCheck opts valEnv tcEnv (Module _ mid es is ds)
= runOn (initWcState mid valEnv tcEnv (optWarnFlags opts)) $ do
= runOn (initWcState mid valEnv tcEnv (wnWarnFlags opts)) $ do
checkExports es
checkImports is
checkDeclGroup ds
......
......@@ -15,9 +15,11 @@
help information as well as parsing the command line arguments.
-}
module CompilerOpts
( Options (..), CymakeMode (..), Verbosity (..), TargetType (..)
, WarnFlag (..), KnownExtension (..), DumpLevel (..)
, dumpLevel, defaultOptions, getCompilerOpts, usage
( Options (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)
, CymakeMode (..), Verbosity (..), TargetType (..)
, WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel
, defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts
, getCompilerOpts, usage
) where
import Data.List (intercalate, nub)
......@@ -32,25 +34,45 @@ import Curry.Syntax.Extension
-- Option data structures
-- -----------------------------------------------------------------------------
-- |Data type for recording compiler options
-- |Compiler options
data Options = Options
-- general
{ 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
, 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?
, optPrepOpts :: PrepOpts -- ^ preprocessor options
, optWarnOpts :: WarnOpts -- ^ warning options
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [KnownExtension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dump levels
, optDumpEnv :: Bool -- ^ dump compilation environment
, optDumpRaw :: Bool -- ^ dump data structure
, optDebugOpts :: DebugOpts -- ^ debug options
} deriving Show
-- |Preprocessor options
data PrepOpts = PrepOpts
{ ppPreprocess :: Bool -- ^ apply custom preprocessor
, ppCmd :: String -- ^ preprocessor command
, ppOpts :: [String] -- ^ preprocessor options
} deriving Show
-- |Warning options
data WarnOpts = WarnOpts
{ wnWarn :: Bool -- ^ show warnings? (legacy option)
, wnWarnFlags :: [WarnFlag] -- ^ Warnings flags (see below)
, wnWarnAsError :: Bool -- ^ Should warnings be treated as errors?
} deriving Show
-- |Debug options
data DebugOpts = DebugOpts
{ dbDumpLevels :: [DumpLevel] -- ^ dump levels
, dbDumpEnv :: Bool -- ^ dump compilation environment
, dbDumpRaw :: Bool -- ^ dump data structure
} deriving Show
-- | Default compiler options
......@@ -63,14 +85,35 @@ defaultOptions = Options
, optImportPaths = []
, optUseSubdir = True
, optInterface = True
, optWarn = True
, optWarnFlags = stdWarnFlags
, optWarnAsError = False
, optPrepOpts = defaultPrepOpts
, optWarnOpts = defaultWarnOpts
, optTargetTypes = []
, optExtensions = []
, optDumps = []
, optDumpEnv = False
, optDumpRaw = False
, optDebugOpts = defaultDebugOpts
}
-- | Default preprocessor options
defaultPrepOpts :: PrepOpts
defaultPrepOpts = PrepOpts
{ ppPreprocess = False
, ppCmd = ""
, ppOpts = []
}
-- | Default warning options
defaultWarnOpts :: WarnOpts
defaultWarnOpts = WarnOpts
{ wnWarn = True
, wnWarnFlags = stdWarnFlags
, wnWarnAsError = False
}
-- | Default dump options
defaultDebugOpts :: DebugOpts
defaultDebugOpts = DebugOpts
{ dbDumpLevels = []
, dbDumpEnv = False
, dbDumpRaw = False
}
-- |Modus operandi of the program
......@@ -128,13 +171,20 @@ stdWarnFlags =
-- |Description and flag of warnings flags
warnFlags :: [(WarnFlag, String, String)]
warnFlags =
[ (WarnMultipleImports , "multiple-imports" , "multiple imports" )
, (WarnDisjoinedRules , "disjoined-rules" , "disjoined function rules" )
, (WarnUnusedBindings , "unused-bindings" , "unused bindings" )
, (WarnNameShadowing , "name-shadowing" , "name shadowing" )
, (WarnOverlapping , "overlapping" , "overlapping function rules" )
, (WarnIncompletePatterns, "incomplete-patterns", "incomplete pattern matching")
, (WarnIdleAlternatives , "idle-alternatives" , "idle case alternatives" )
[ ( WarnMultipleImports , "multiple-imports"
, "multiple imports" )
, ( WarnDisjoinedRules , "disjoined-rules"
, "disjoined function rules" )
, ( WarnUnusedBindings , "unused-bindings"
, "unused bindings" )
, ( WarnNameShadowing , "name-shadowing"
, "name shadowing" )
, ( WarnOverlapping , "overlapping"
, "overlapping function rules" )
, ( WarnIncompletePatterns, "incomplete-patterns"
, "incomplete pattern matching")
, ( WarnIdleAlternatives , "idle-alternatives"
, "idle case alternatives" )
]
-- |Dump level
......@@ -187,29 +237,49 @@ extensions =
-- more complicated to enable malformed arguments to be reported.
-- -----------------------------------------------------------------------------
-- |Instead of just returning the resulting 'Options' structure, we also
-- collect errors from arguments passed to specific options.
type OptErr = (Options, [String])
type OptErrTable = [(String, String, Options -> Options)]
-- |An 'OptErrTable' consists of a list of entries of the following form:
-- * a flag to be recognized on the command line
-- * an explanation text for the usage information
-- * a modification funtion adjusting the options structure
-- The type is parametric about the option's type to adjust.
type OptErrTable opt = [(String, String, opt -> opt)]
onOpts :: (Options -> Options) -> OptErr -> OptErr
onOpts f (opts, errs) = (f opts, errs)
onOptsArg :: (String -> Options -> Options) -> String -> OptErr -> OptErr
onOptsArg f arg (opts, errs) = (f arg opts, errs)
onPrepOpts :: (PrepOpts -> PrepOpts) -> OptErr -> OptErr
onPrepOpts f (opts, errs) = (opts { optPrepOpts = f (optPrepOpts opts) }, errs)
onWarnOpts :: (WarnOpts -> WarnOpts) -> OptErr -> OptErr
onWarnOpts f (opts, errs) = (opts { optWarnOpts = f (optWarnOpts opts) }, errs)
onDebugOpts :: (DebugOpts -> DebugOpts) -> OptErr -> OptErr
onDebugOpts f (opts, errs)
= (opts { optDebugOpts = f (optDebugOpts opts) }, errs)
withArg :: ((opt -> opt) -> OptErr -> OptErr)
-> (String -> opt -> opt) -> String -> OptErr -> OptErr
withArg lift f arg = lift (f arg)
addErr :: String -> OptErr -> OptErr
addErr err (opts, errs) = (opts, errs ++ [err])
mkOptErrOption :: String -> [String] -> String -> String -> OptErrTable
-> OptDescr (OptErr -> OptErr)
mkOptErrOption flags longFlags arg what tbl = Option flags longFlags
(ReqArg (parseOptErr what tbl) arg)
mkOptDescr :: ((opt -> opt) -> OptErr -> OptErr)
-> String -> [String] -> String -> String -> OptErrTable opt
-> OptDescr (OptErr -> OptErr)
mkOptDescr lift flags longFlags arg what tbl = Option flags longFlags
(ReqArg (parseOptErr lift what tbl) arg)
("set " ++ what ++ " `" ++ arg ++ "', where `" ++ arg ++ "' is one of\n"
++ renderOptErrTable tbl)
parseOptErr :: String -> OptErrTable -> String -> OptErr -> OptErr
parseOptErr what table opt = case lookup3 opt table of
Just f -> onOpts f
parseOptErr :: ((opt -> opt) -> OptErr -> OptErr)
-> String -> OptErrTable opt -> String -> OptErr -> OptErr
parseOptErr lift what table opt = case lookup3 opt table of
Just f -> lift f
Nothing -> addErr $ "unrecognized " ++ what ++ '`' : opt ++ "'\n"
where
lookup3 _ [] = Nothing
......@@ -217,7 +287,7 @@ parseOptErr what table opt = case lookup3 opt table of
| k == k' = Just v2
| otherwise = lookup3 k kvs
renderOptErrTable :: OptErrTable -> String
renderOptErrTable :: OptErrTable opt -> String
renderOptErrTable ds
= intercalate "\n" $ map (\(k, d, _) -> rpad maxLen k ++ ": " ++ d) ds
where
......@@ -241,7 +311,7 @@ options =
(NoArg (onOpts $ \ opts -> opts { optMode = ModeHtml }))
"generate html code and exit"
-- verbosity
, mkOptErrOption "v" ["verbosity"] "n" "verbosity level" verbDescriptions
, mkOptDescr onOpts "v" ["verbosity"] "n" "verbosity level" verbDescriptions
, Option "q" ["no-verb"]
(NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbQuiet } ))
"set verbosity level to quiet"
......@@ -250,11 +320,11 @@ options =
(NoArg (onOpts $ \ opts -> opts { optForce = True }))
"force compilation of target file"
, Option "P" ["lib-dir"]
(ReqArg (onOptsArg $ \ arg opts -> opts { optLibraryPaths =
(ReqArg (withArg onOpts $ \ arg opts -> opts { optLibraryPaths =
nub $ optLibraryPaths opts ++ splitSearchPath arg}) "dir[:dir]")
"search for libraries in dir[:dir]"
, Option "i" ["import-dir"]
(ReqArg (onOptsArg $ \ arg opts -> opts { optImportPaths =
(ReqArg (withArg onOpts $ \ arg opts -> opts { optImportPaths =
nub $ optImportPaths opts ++ splitSearchPath arg}) "dir[:dir]")
"search for imports in dir[:dir]"
, Option "" ["no-subdir"]
......@@ -265,11 +335,11 @@ options =
"do not create an interface file"
-- legacy warning flags
, Option "" ["no-warn"]
(NoArg (onOpts $ \ opts -> opts { optWarn = False }))
(NoArg (onWarnOpts $ \ opts -> opts { wnWarn = False }))
"do not print warnings"
, Option "" ["no-overlap-warn"]
(NoArg (onOpts $ \ opts -> opts { optWarnFlags =
addFlag WarnOverlapping (optWarnFlags opts) }))
(NoArg (onWarnOpts $ \ opts -> opts {wnWarnFlags =
addFlag WarnOverlapping (wnWarnFlags opts) }))
"do not print warnings for overlapping rules"
-- target types
, Option "" ["parse-only"]
......@@ -296,61 +366,72 @@ options =
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ UntypedAbstractCurry : optTargetTypes opts }))
"generate untyped AbstractCurry code"
, Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
"use custom preprocessor"
, Option "" ["pgmF"]
(ReqArg (withArg onPrepOpts $ \ arg opts -> opts { ppCmd = arg})
"cmd")
"execute preprocessor command <cmd>"
, Option "" ["optF"]
(ReqArg (withArg onPrepOpts $ \ arg opts ->
opts { ppOpts = ppOpts opts ++ [arg]}) "option")
"execute preprocessor with option <option>"
-- extensions
, Option "e" ["extended"]
(NoArg (onOpts $ \ opts -> opts { optExtensions =
nub $ kielExtensions ++ optExtensions opts }))
"enable extended Curry functionalities"
, mkOptErrOption "X" [] "ext" "language extension" extDescriptions
, mkOptErrOption "W" [] "opt" "warning option" warnDescriptions
, mkOptErrOption "d" [] "opt" "debug option" debugDescriptions
, mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions
, mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions
, mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions
]
verbDescriptions :: OptErrTable
verbDescriptions :: OptErrTable Options
verbDescriptions = map toDescr verbosities
where
toDescr (flag, name, desc)
= (name, desc, \ opts -> opts { optVerbosity = flag })
extDescriptions :: OptErrTable
extDescriptions :: OptErrTable Options
extDescriptions = map toDescr extensions
where
toDescr (flag, name, desc)
= (name, desc,
\ opts -> opts { optExtensions = addFlag flag (optExtensions opts)})
warnDescriptions :: OptErrTable
warnDescriptions :: OptErrTable WarnOpts
warnDescriptions
= [ ( "all" , "turn on all warnings"
, \ opts -> opts { optWarnFlags = [minBound .. maxBound] } )
, \ opts -> opts { wnWarnFlags = [minBound .. maxBound] } )
, ("none" , "turn off all warnings"
, \ opts -> opts { optWarnFlags = [] } )
, \ opts -> opts { wnWarnFlags = [] } )
, ("error", "treat warnings as errors"
, \ opts -> opts { optWarnAsError = True } )
, \ opts -> opts { wnWarnAsError = True } )
] ++ map turnOn warnFlags ++ map turnOff warnFlags
where
turnOn (flag, name, desc)
= (name, "warn for " ++ desc
, \ opts -> opts { optWarnFlags = addFlag flag (optWarnFlags opts)})
, \ opts -> opts { wnWarnFlags = addFlag flag (wnWarnFlags opts)})
turnOff (flag, name, desc)
= ("no-" ++ name, "do not warn for " ++ desc
, \ opts -> opts { optWarnFlags = removeFlag flag (optWarnFlags opts)})
, \ opts -> opts { wnWarnFlags = removeFlag flag (wnWarnFlags opts)})
debugDescriptions :: OptErrTable
debugDescriptions :: OptErrTable DebugOpts
debugDescriptions =
[ ( "dump-all", "dump everything"
, \ opts -> opts { optDumps = [minBound .. maxBound] })
, \ opts -> opts { dbDumpLevels = [minBound .. maxBound] })
, ( "dump-none", "dump nothing"
, \ opts -> opts { optDumps = [] })
, \ opts -> opts { dbDumpLevels = [] })
, ( "dump-env" , "additionally dump compiler environment"
, \ opts -> opts { optDumpEnv = True })
, \ opts -> opts { dbDumpEnv = True })
, ( "dump-raw" , "dump as raw AST (instead of pretty printed)"
, \ opts -> opts { optDumpRaw = True })
, \ opts -> opts { dbDumpRaw = True })
] ++ map toDescr dumpLevel
where
toDescr (flag, name, desc)
= (name , "dump " ++ desc
, \ opts -> opts { optDumps = addFlag flag (optDumps opts)})
, \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
addFlag :: Eq a => a -> [a] -> [a]
addFlag o opts = nub $ o : opts
......
......@@ -26,7 +26,8 @@ import Curry.Files.PathUtils
import Base.Messages
import CompilerOpts (Options (..), TargetType (..))
import CompilerOpts ( Options (..), DebugOpts (..), TargetType (..)
, defaultDebugOpts)
import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
......@@ -78,7 +79,8 @@ makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
process :: Source -> CYIO ()
process (Source fn deps) = do
let isFinalFile = dropExtension targetFile == dropExtension fn
isEnforced = optForce opts || (not $ null $ optDumps opts)
isDump = not $ null $ dbDumpLevels $ optDebugOpts opts
isEnforced = optForce opts || isDump
destFiles = if isFinalFile then destNames fn else [getFlatName fn]
depFiles = fn : mapMaybe curryInterface deps
......@@ -98,7 +100,8 @@ makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
compile f = do
status opts $ "compiling " ++ normalise f
compileModule (opts { optTargetTypes = [FlatCurry], optDumps = [] }) f
compileModule (opts { optTargetTypes = [FlatCurry]
, optDebugOpts = defaultDebugOpts }) f
skipFinal f = status opts $ "skipping " ++ normalise f
skip f = info opts $ "skipping " ++ normalise f
......
......@@ -40,7 +40,7 @@ import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- other
import CompilerOpts (Options (..), WarnFlag (..))
import CompilerOpts (Options (..), WarnOpts (..), WarnFlag (..))
import qualified IL as IL
import qualified ModuleSummary
import Transformations (transType)
......@@ -765,8 +765,8 @@ flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls)
--
checkOverlapping :: Expr -> Expr -> FlatState ()
checkOverlapping e1 e2 = do
opts <- compilerOpts
when (WarnOverlapping `elem` optWarnFlags opts) $ checkOverlap e1 e2
warnOpts <- optWarnOpts `liftM` compilerOpts
when (WarnOverlapping `elem` wnWarnFlags warnOpts) $ checkOverlap e1 e2
where
checkOverlap (Case _ _ _ _) _ = functionId >>= genWarning . overlappingRules
checkOverlap _ (Case _ _ _ _) = functionId >>= genWarning . overlappingRules
......
......@@ -18,11 +18,17 @@ module Modules
( compileModule, loadModule, checkModuleHeader, checkModule, writeOutput
) where
import qualified Control.Exception as C (catch, IOException)
import Control.Monad (unless, when)
import qualified Data.Map as Map (elems)
import Data.Maybe (fromMaybe)
import System.IO (hClose, hGetContents, openFile, IOMode (ReadMode))
import qualified Control.Exception as C (catch, IOException)
import Control.Monad (liftM, unless, when)
import qualified Data.Map as Map (elems)
import Data.Maybe (fromMaybe)
import System.Directory (getTemporaryDirectory, removeFile)
import System.Exit (ExitCode (..))
import System.FilePath (normalise)
import System.IO
(IOMode (ReadMode), Handle, hClose, hGetContents, hPutStr, openFile
, openTempFile)
import System.Process (system)
import Curry.Base.Ident
import Curry.Base.Message (runMsg)
......@@ -73,7 +79,7 @@ import Transformations
compileModule :: Options -> FilePath -> CYIO ()
compileModule opts fn = do
(env, mdl) <- loadModule opts fn >>= checkModule opts
warn opts $ warnCheck opts env mdl
warn (optWarnOpts opts) $ warnCheck opts env mdl
liftIO $ writeOutput opts fn (env, mdl)
-- ---------------------------------------------------------------------------
......@@ -82,7 +88,7 @@ compileModule opts fn = do
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
loadModule opts fn = do
parsed <- parseModule fn
parsed <- parseModule opts fn
-- check module header
mdl <- checkModuleHeader opts fn parsed
-- load the imported interfaces into an InterfaceEnv
......@@ -92,16 +98,46 @@ loadModule opts fn = do
cEnv <- importModules opts mdl iEnv
return (cEnv, mdl)
parseModule :: FilePath -> CYIO CS.Module
parseModule fn = do
parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule opts fn = do
mbSrc <- liftIO $ readModule fn
case mbSrc of
Nothing -> left [message $ text $ "Missing file: " ++ fn]
Just src -> do
-- parse module
case runMsg (CS.parseModule fn src) of
Left err -> left [err]
Right (parsed, _) -> right parsed
case runMsg (CS.unlit fn src) of
Left err -> left [err]
Right (ul, _) -> do
prepd <- preprocess (optPrepOpts opts) fn ul
-- parse module
case runMsg (CS.parseModule fn prepd) of
Left err -> left [err]
Right (parsed, _) -> right parsed
preprocess :: PrepOpts -> FilePath -> String -> CYIO String
preprocess opts fn src
| not (ppPreprocess opts) = return src
| otherwise = do
res <- liftIO $ withTempFile $ \ inFn inHdl -> do
hPutStr inHdl src
hClose inHdl
withTempFile $ \ outFn outHdl -> do
hClose outHdl
ec <- system $ unwords $
[ppCmd opts, normalise fn, inFn, outFn] ++ ppOpts opts
case ec of
ExitFailure x -> return $ Left [message $ text $
"Preprocessor exited with exit code " ++ show x]
ExitSuccess -> Right `liftM` readFile outFn
either left right res
withTempFile :: (FilePath -> Handle -> IO a) -> IO a
withTempFile act = do
tmp <- getTemporaryDirectory
(fn, hdl) <- openTempFile tmp "cymake.curry"
res <- act fn hdl
hClose hdl
removeFile fn
return res
checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
-> CYT m CS.Module
......@@ -160,19 +196,20 @@ checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)
checkModule :: Options -> (CompilerEnv, CS.Module)
-> CYIO (CompilerEnv, CS.Module)
checkModule opts (env, mdl) = do
doDump opts (DumpParsed , env , show $ CS.ppModule mdl)
doDump debugOpts (DumpParsed , env , show $ CS.ppModule mdl)
(env1, kc) <- kindCheck opts env mdl -- should be only syntax checking ?
doDump opts (DumpKindChecked , env1, show $ CS.ppModule kc)
doDump debugOpts (DumpKindChecked , env1, show $ CS.ppModule kc)
(env2, sc) <- syntaxCheck opts env1 kc
doDump opts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
doDump debugOpts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
(env3, pc) <- precCheck opts env2 sc
doDump opts (DumpPrecChecked , env3, show $ CS.ppModule pc)
doDump debugOpts (DumpPrecChecked , env3, show $ CS.ppModule pc)
(env4, tc) <- if withTypeCheck
then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
else return (env3, pc)
doDump opts (DumpTypeChecked , env4, show $ CS.ppModule tc)
doDump debugOpts (DumpTypeChecked , env4, show $ CS.ppModule tc)
return (env4, tc)
where
debugOpts = optDebugOpts opts
withTypeCheck = any (`elem` optTargetTypes opts)
[FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
......@@ -199,8 +236,9 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
, (DumpTranslated , env4, presentIL il )
, (DumpCaseCompleted, env5, presentIL ilCaseComp)
]
presentCS = if optDumpRaw opts then show else show . CS.ppModule
presentIL = if optDumpRaw opts then show else show . IL.ppModule
presentCS = if dumpRaw then show else show . CS.ppModule
presentIL = if dumpRaw then show else show . IL.ppModule
dumpRaw = dbDumpRaw (optDebugOpts opts)
-- ---------------------------------------------------------------------------
-- Writing output
......@@ -210,7 +248,7 @@ writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
writeParsed opts fn modul
let (env1, qlfd) = qual opts env modul
doDump opts (DumpQualified, env1, show $ CS.ppModule qlfd)
doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
writeAbstractCurry opts fn env1 qlfd
when withFlat $ do
-- checkModule checks types, and then transModule introduces new
......@@ -218,7 +256,7 @@ writeOutput opts fn (env, modul) = do
-- types of the newly introduced functions are not inferred (hsi)
let (env2, il, dumps) = transModule opts env1 qlfd
-- dump intermediate results
mapM_ (doDump opts) dumps
mapM_ (doDump (optDebugOpts opts)) dumps
-- generate interface file
let intf = exportInterface env2 qlfd
writeInterface opts fn intf
......@@ -283,7 +321,7 @@ writeFlat opts fn env modSum il = do
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
warn opts msgs
warn (optWarnOpts opts) msgs
when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
when fcyTarget $ EF.writeFlatCurry useSubDir (flatName fn) prog
where
......@@ -314,7 +352,7 @@ writeFlatIntf opts fn env modSum il
emptyIntf = EF.Prog "" [] [] [] []
(newInterface, intMsgs) = genFlatInterface opts modSum env il
outputInterface = do
warn opts intMsgs
warn (optWarnOpts opts) intMsgs
EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
......@@ -329,9 +367,9 @@ writeAbstractCurry opts fname env modul = do
useSubDir = optUseSubdir opts
-- |The 'dump' function writes the selected information to standard output.
doDump :: MonadIO m => Options -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $ do