module CompilerOpts
( Options (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)
, CymakeMode (..), Verbosity (..), TargetType (..)
, WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel
, defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts
, getCompilerOpts, updateOpts, usage
) where
import Data.List (intercalate, nub)
import Data.Maybe (isJust)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import System.FilePath
(addTrailingPathSeparator, normalise, splitSearchPath)
import Curry.Files.Filenames (currySubdir)
import Curry.Syntax.Extension
data Options = Options
{ optMode :: CymakeMode
, optVerbosity :: Verbosity
, optForce :: Bool
, optLibraryPaths :: [FilePath]
, optImportPaths :: [FilePath]
, optHtmlDir :: Maybe FilePath
, optUseSubdir :: Bool
, optInterface :: Bool
, optPrepOpts :: PrepOpts
, optWarnOpts :: WarnOpts
, optTargetTypes :: [TargetType]
, optExtensions :: [KnownExtension]
, optDebugOpts :: DebugOpts
} deriving Show
data PrepOpts = PrepOpts
{ ppPreprocess :: Bool
, ppCmd :: String
, ppOpts :: [String]
} deriving Show
data WarnOpts = WarnOpts
{ wnWarn :: Bool
, wnWarnFlags :: [WarnFlag]
, wnWarnAsError :: Bool
} deriving Show
data DebugOpts = DebugOpts
{ dbDumpLevels :: [DumpLevel]
, dbDumpEnv :: Bool
, dbDumpRaw :: Bool
} deriving Show
defaultOptions :: Options
defaultOptions = Options
{ optMode = ModeMake
, optVerbosity = VerbStatus
, optForce = False
, optLibraryPaths = []
, optImportPaths = []
, optHtmlDir = Nothing
, optUseSubdir = True
, optInterface = True
, optPrepOpts = defaultPrepOpts
, optWarnOpts = defaultWarnOpts
, optTargetTypes = []
, optExtensions = []
, optDebugOpts = defaultDebugOpts
}
defaultPrepOpts :: PrepOpts
defaultPrepOpts = PrepOpts
{ ppPreprocess = False
, ppCmd = ""
, ppOpts = []
}
defaultWarnOpts :: WarnOpts
defaultWarnOpts = WarnOpts
{ wnWarn = True
, wnWarnFlags = stdWarnFlags
, wnWarnAsError = False
}
defaultDebugOpts :: DebugOpts
defaultDebugOpts = DebugOpts
{ dbDumpLevels = []
, dbDumpEnv = False
, dbDumpRaw = False
}
data CymakeMode
= ModeHelp
| ModeVersion
| ModeNumericVersion
| ModeMake
deriving (Eq, Show)
data Verbosity
= VerbQuiet
| VerbStatus
deriving (Eq, Ord, Show)
verbosities :: [(Verbosity, String, String)]
verbosities = [ ( VerbQuiet , "0", "quiet" )
, ( VerbStatus, "1", "status")
]
data TargetType
= Tokens
| Parsed
| FlatCurry
| ExtendedFlatCurry
| AbstractCurry
| UntypedAbstractCurry
| Html
deriving (Eq, Show)
data WarnFlag
= WarnMultipleImports
| WarnDisjoinedRules
| WarnUnusedGlobalBindings
| WarnUnusedBindings
| WarnNameShadowing
| WarnOverlapping
| WarnIncompletePatterns
| WarnMissingSignatures
deriving (Eq, Bounded, Enum, Show)
stdWarnFlags :: [WarnFlag]
stdWarnFlags =
[ WarnMultipleImports , WarnDisjoinedRules
, WarnUnusedBindings , WarnNameShadowing , WarnOverlapping
, WarnIncompletePatterns, WarnMissingSignatures
]
warnFlags :: [(WarnFlag, String, String)]
warnFlags =
[ ( WarnMultipleImports , "multiple-imports"
, "multiple imports" )
, ( WarnDisjoinedRules , "disjoined-rules"
, "disjoined function rules" )
, ( WarnUnusedGlobalBindings, "unused-global-bindings"
, "unused bindings" )
, ( WarnUnusedBindings , "unused-bindings"
, "unused bindings" )
, ( WarnNameShadowing , "name-shadowing"
, "name shadowing" )
, ( WarnOverlapping , "overlapping"
, "overlapping function rules" )
, ( WarnIncompletePatterns , "incomplete-patterns"
, "incomplete pattern matching")
, ( WarnMissingSignatures , "missing-signatures"
, "missing type signatures" )
]
data DumpLevel
= DumpParsed
| DumpKindChecked
| DumpSyntaxChecked
| DumpPrecChecked
| DumpTypeChecked
| DumpExportChecked
| DumpQualified
| DumpDesugared
| DumpSimplified
| DumpLifted
| DumpTranslated
| DumpCaseCompleted
| DumpFlatCurry
deriving (Eq, Bounded, Enum, Show)
dumpLevel :: [(DumpLevel, String, String)]
dumpLevel = [ (DumpParsed , "dump-parse", "parsing" )
, (DumpKindChecked , "dump-kc" , "kind checking" )
, (DumpSyntaxChecked, "dump-sc" , "syntax checking" )
, (DumpPrecChecked , "dump-pc" , "precedence checking" )
, (DumpTypeChecked , "dump-tc" , "type checking" )
, (DumpExportChecked, "dump-ec" , "export checking" )
, (DumpQualified , "dump-qual" , "qualification" )
, (DumpDesugared , "dump-ds" , "desugaring" )
, (DumpLifted , "dump-lift" , "lifting" )
, (DumpSimplified , "dump-simpl", "simplification" )
, (DumpTranslated , "dump-trans", "pattern matching compilation")
, (DumpCaseCompleted, "dump-cc" , "case completion" )
, (DumpFlatCurry , "dump-flat" , "translation into FlatCurry" )
]
extensions :: [(KnownExtension, String, String)]
extensions =
[ ( AnonFreeVars , "AnonFreeVars"
, "enable anonymous free variables" )
, ( FunctionalPatterns, "FunctionalPatterns"
, "enable functional patterns" )
, ( NegativeLiterals , "NegativeLiterals"
, "desugar negated literals as negative literal")
, ( NoImplicitPrelude , "NoImplicitPrelude"
, "do not implicitly import the Prelude")
]
type OptErr = (Options, [String])
type OptErrTable opt = [(String, String, opt -> opt)]
onOpts :: (Options -> Options) -> OptErr -> OptErr
onOpts f (opts, errs) = (f 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])
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 :: ((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
lookup3 k ((k', _, v2) : kvs)
| k == k' = Just v2
| otherwise = lookup3 k kvs
renderOptErrTable :: OptErrTable opt -> String
renderOptErrTable ds
= intercalate "\n" $ map (\(k, d, _) -> " " ++ rpad maxLen k ++ ": " ++ d) ds
where
maxLen = maximum $ map (\(k, _, _) -> length k) ds
rpad n x = x ++ replicate (n length x) ' '
options :: [OptDescr (OptErr -> OptErr)]
options =
[ Option "h?" ["help"]
(NoArg (onOpts $ \ opts -> opts { optMode = ModeHelp }))
"display this help and exit"
, Option "V" ["version"]
(NoArg (onOpts $ \ opts -> opts { optMode = ModeVersion }))
"show the version number and exit"
, Option "" ["numeric-version"]
(NoArg (onOpts $ \ opts -> opts { optMode = ModeNumericVersion }))
"show the numeric version number and exit"
, mkOptDescr onOpts "v" ["verbosity"] "n" "verbosity level" verbDescriptions
, Option "q" ["no-verb"]
(NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbQuiet } ))
"set verbosity level to quiet"
, Option "f" ["force"]
(NoArg (onOpts $ \ opts -> opts { optForce = True }))
"force compilation of target file"
, Option "P" ["lib-dir"]
(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 (withArg onOpts $ \ arg opts -> opts { optImportPaths =
nub $ optImportPaths opts ++
map (normalise . addTrailingPathSeparator) (splitSearchPath arg)
}) "dir[:dir]")
"search for imports in dir[:dir]"
, Option [] ["htmldir"]
(ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir =
Just arg }) "dir")
"write HTML documentation into directory `dir'"
, Option "" ["no-subdir"]
(NoArg (onOpts $ \ opts -> opts { optUseSubdir = False }))
("disable writing to `" ++ currySubdir ++ "' subdirectory")
, Option "" ["no-intf"]
(NoArg (onOpts $ \ opts -> opts { optInterface = False }))
"do not create an interface file"
, Option "" ["no-warn"]
(NoArg (onWarnOpts $ \ opts -> opts { wnWarn = False }))
"do not print warnings"
, Option "" ["no-overlap-warn"]
(NoArg (onWarnOpts $ \ opts -> opts {wnWarnFlags =
addFlag WarnOverlapping (wnWarnFlags opts) }))
"do not print warnings for overlapping rules"
, targetOption Tokens "tokens"
"generate token stream"
, targetOption Parsed "parse-only"
"generate source representation"
, targetOption FlatCurry "flat"
"generate FlatCurry code"
, targetOption ExtendedFlatCurry "extended-flat"
"generate FlatCurry code with source references"
, targetOption AbstractCurry "acy"
"generate typed AbstractCurry"
, targetOption UntypedAbstractCurry "uacy"
"generate untyped AbstractCurry"
, targetOption Html "html"
"generate html documentation"
, 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>"
, Option "e" ["extended"]
(NoArg (onOpts $ \ opts -> opts { optExtensions =
nub $ kielExtensions ++ optExtensions opts }))
"enable extended Curry functionalities"
, mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions
, mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions
, mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions
]
targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr)
targetOption ty flag desc
= Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ ty : optTargetTypes opts })) desc
verbDescriptions :: OptErrTable Options
verbDescriptions = map toDescr verbosities
where
toDescr (flag, name, desc)
= (name, desc, \ opts -> opts { optVerbosity = flag })
extDescriptions :: OptErrTable Options
extDescriptions = map toDescr extensions
where
toDescr (flag, name, desc)
= (name, desc,
\ opts -> opts { optExtensions = addFlag flag (optExtensions opts)})
warnDescriptions :: OptErrTable WarnOpts
warnDescriptions
= [ ( "all" , "turn on all warnings"
, \ opts -> opts { wnWarnFlags = [minBound .. maxBound] } )
, ("none" , "turn off all warnings"
, \ opts -> opts { wnWarnFlags = [] } )
, ("error", "treat warnings as errors"
, \ opts -> opts { wnWarnAsError = True } )
] ++ map turnOn warnFlags ++ map turnOff warnFlags
where
turnOn (flag, name, desc)
= (name, "warn for " ++ desc
, \ opts -> opts { wnWarnFlags = addFlag flag (wnWarnFlags opts)})
turnOff (flag, name, desc)
= ("no-" ++ name, "do not warn for " ++ desc
, \ opts -> opts { wnWarnFlags = removeFlag flag (wnWarnFlags opts)})
debugDescriptions :: OptErrTable DebugOpts
debugDescriptions =
[ ( "dump-all", "dump everything"
, \ opts -> opts { dbDumpLevels = [minBound .. maxBound] })
, ( "dump-none", "dump nothing"
, \ opts -> opts { dbDumpLevels = [] })
, ( "dump-env" , "additionally dump compiler environment"
, \ opts -> opts { dbDumpEnv = True })
, ( "dump-raw" , "dump as raw AST (instead of pretty printing)"
, \ opts -> opts { dbDumpRaw = True })
] ++ map toDescr dumpLevel
where
toDescr (flag, name, desc)
= (name , "dump code after " ++ desc
, \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
addFlag :: Eq a => a -> [a] -> [a]
addFlag o opts = nub $ o : opts
removeFlag :: Eq a => a -> [a] -> [a]
removeFlag o opts = filter (/= o) opts
updateOpts :: Options -> [String] -> (Options, [String], [String])
updateOpts opts args = (opts', files, errs ++ errs2 ++ checkOpts opts files)
where
(opts', errs2) = foldl (flip ($)) (opts, []) optErrs
(optErrs, files, errs) = getOpt Permute options args
parseOpts :: [String] -> (Options, [String], [String])
parseOpts = updateOpts defaultOptions
checkOpts :: Options -> [String] -> [String]
checkOpts opts _
= [ "The option '--htmldir' is only valid for HTML generation mode"
| isJust (optHtmlDir opts) && Html `notElem` optTargetTypes opts ]
usage :: String -> String
usage prog = usageInfo header options
where header = "usage: " ++ prog ++ " [OPTION] ... MODULES ..."
getCompilerOpts :: IO (String, Options, [String], [String])
getCompilerOpts = do
args <- getArgs
prog <- getProgName
let (opts, files, errs) = parseOpts args
return (prog, opts, files, errs)