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

Frontend options structured towards preprocessor support

parent c7cc8e01
......@@ -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,45 @@ 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 explanatino 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)
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)
onOptsArg :: (String -> Options -> Options) -> String -> OptErr -> OptErr
onOptsArg f arg (opts, errs) = (f arg opts, errs)
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 +283,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 +307,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"
......@@ -265,11 +331,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"]
......@@ -301,56 +367,56 @@ options =
(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
......
......@@ -73,7 +73,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)
-- ---------------------------------------------------------------------------
......@@ -160,19 +160,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 +200,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 +212,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 +220,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 +285,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 +316,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 +331,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
when (optDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
where
header = lookupHeader dumpLevel
......
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