module Options(
processOptions,
Opt(..),
options,
Mode(..),
StopCondition(..),
putVerbose,
putVerboseLn,
putProgress,
putProgressLn,
getArguments,
findHoCache,
verbose,
verbose2,
progress,
dump,
wdump,
fopts,
flint,
fileOptions,
withOptions,
withOptionsT,
getArgString,
outputName,
OptM(),
OptT(),
OptionMonad(..),
flagOpt
) where
import Control.Monad.Error()
import Control.Monad.Identity
import Control.Monad.Reader
import Data.List(nub)
import Data.Maybe
import System.Console.GetOpt
import System.Directory
import System.IO.Unsafe
import System.Environment (getArgs, getProgName, getEnv)
import System.Exit
import qualified Data.ByteString.UTF8 as BS
import qualified Data.Map as M
import qualified Data.Set as S
import RawFiles(targets_ini)
import Support.IniParse
import Support.TempDir
import Support.Cabal
import Util.ExitCodes
import Util.Gen
import Util.YAML
import Version.Config
import Version.Version(versionString,versionContext)
import qualified FlagDump
import qualified FlagOpts
import qualified Version.Config as VC
data Mode = BuildHl FilePath
| Interactive
| Version
| VersionCtx
| ShowHelp
| ShowConfig
| CompileExe
| ShowHo String
| ListLibraries
| PrintHscOptions
| PurgeCache
| Preprocess
deriving(Eq)
data StopCondition
= StopError String
| StopParse
| StopTypeCheck
| StopC
| CompileHo
| StopNot
deriving(Eq)
data Opt = Opt {
optMode :: Mode,
optColumns :: !Int,
optDump :: [String],
optStmts :: [String],
optFOpts :: [String],
optIncdirs :: [String],
optCCargs :: [String],
optHls :: [String],
optAutoLoads :: [String],
optHlPath :: [String],
optIncs :: [String],
optDefs :: [String],
optExtensions :: [String],
optStop :: StopCondition,
optWorkDir :: Maybe FilePath,
optAnnotate :: Maybe FilePath,
optDeps :: Maybe FilePath,
optHoDir :: Maybe FilePath,
optHoCache :: Maybe FilePath,
optTargetsIni :: Maybe FilePath,
optArgs :: [String],
optStale :: [String],
optKeepGoing :: !Bool,
optMainFunc :: Maybe (Bool,String),
optArch :: [String],
optCross :: Bool,
optOutName :: Maybe String,
optIgnoreHo :: !Bool,
optNoWriteHo :: !Bool,
optNoAuto :: !Bool,
optVerbose :: !Int,
optStatLevel :: !Int,
optInis :: M.Map String String,
optDumpSet :: S.Set FlagDump.Flag,
optFOptsSet :: S.Set FlagOpts.Flag
}
optAnnotate_s v = optAnnotate_u (const v)
optAnnotate_u f r@Opt{optAnnotate = x} = r{optAnnotate = f x}
optArch_u f r@Opt{optArch = x} = r{optArch = f x}
optCCargs_u f r@Opt{optCCargs = x} = r{optCCargs = f x}
optColumns_s v = optColumns_u (const v)
optColumns_u f r@Opt{optColumns = x} = r{optColumns = f x}
optCross_s v = optCross_u (const v)
optCross_u f r@Opt{optCross = x} = r{optCross = f x}
optDefs_u f r@Opt{optDefs = x} = r{optDefs = f x}
optDeps_s v = optDeps_u (const v)
optDeps_u f r@Opt{optDeps = x} = r{optDeps = f x}
optDump_u f r@Opt{optDump = x} = r{optDump = f x}
optExtensions_u f r@Opt{optExtensions = x} = r{optExtensions = f x}
optFOptsSet_u f r@Opt{optFOptsSet = x} = r{optFOptsSet = f x}
optFOpts_u f r@Opt{optFOpts = x} = r{optFOpts = f x}
optHlPath_u f r@Opt{optHlPath = x} = r{optHlPath = f x}
optHls_u f r@Opt{optHls = x} = r{optHls = f x}
optHoCache_s v = optHoCache_u (const v)
optHoCache_u f r@Opt{optHoCache = x} = r{optHoCache = f x}
optIgnoreHo_s v = optIgnoreHo_u (const v)
optIgnoreHo_u f r@Opt{optIgnoreHo = x} = r{optIgnoreHo = f x}
optIncdirs_u f r@Opt{optIncdirs = x} = r{optIncdirs = f x}
optIncs_u f r@Opt{optIncs = x} = r{optIncs = f x}
optKeepGoing_s v = optKeepGoing_u (const v)
optKeepGoing_u f r@Opt{optKeepGoing = x} = r{optKeepGoing = f x}
optMainFunc_s v = optMainFunc_u (const v)
optMainFunc_u f r@Opt{optMainFunc = x} = r{optMainFunc = f x}
optMode_s v = optMode_u (const v)
optMode_u f r@Opt{optMode = x} = r{optMode = f x}
optNoAuto_s v = optNoAuto_u (const v)
optNoAuto_u f r@Opt{optNoAuto = x} = r{optNoAuto = f x}
optNoWriteHo_s v = optNoWriteHo_u (const v)
optNoWriteHo_u f r@Opt{optNoWriteHo = x} = r{optNoWriteHo = f x}
optOutName_s v = optOutName_u (const v)
optOutName_u f r@Opt{optOutName = x} = r{optOutName = f x}
optStale_u f r@Opt{optStale = x} = r{optStale = f x}
optStatLevel_u f r@Opt{optStatLevel = x} = r{optStatLevel = f x}
optStop_s v = optStop_u (const v)
optStop_u f r@Opt{optStop = x} = r{optStop = f x}
optVerbose_u f r@Opt{optVerbose = x} = r{optVerbose = f x}
optWorkDir_s v = optWorkDir_u (const v)
optWorkDir_u f r@Opt{optWorkDir = x} = r{optWorkDir = f x}
optTargetsIni_s v = optTargetsIni_u (const v)
optTargetsIni_u f r@Opt{optTargetsIni = x} = r{optTargetsIni = f x}
emptyOpt = Opt {
optMode = CompileExe,
optColumns = getColumns,
optCross = False,
optIncdirs = initialIncludes,
optAnnotate = Nothing,
optDeps = Nothing,
optHls = [],
optAutoLoads = [],
optHlPath = initialLibIncludes,
optIncs = [],
optDefs = [],
optExtensions = [],
optStop = StopNot,
optDump = [],
optStale = [],
optStmts = [],
optFOpts = ["default"],
optCCargs = [],
optWorkDir = Nothing,
optHoDir = Nothing,
optHoCache = Nothing,
optTargetsIni = Nothing,
optArgs = [],
optIgnoreHo = False,
optNoWriteHo = False,
optKeepGoing = False,
optMainFunc = Nothing,
optArch = ["default"],
optOutName = Nothing,
optVerbose = 0,
optStatLevel = 1,
optNoAuto = False,
optDumpSet = S.singleton FlagDump.Progress,
optFOptsSet = S.empty
}
idu "-" _ = []
idu d ds = ds ++ [d]
theoptions :: [OptDescr (Opt -> Opt)]
theoptions =
[ Option ['V'] ["version"] (NoArg (optMode_s Version)) "print version info and exit"
, Option [] ["version-context"] (NoArg (optMode_s VersionCtx)) "print version context info and exit"
, Option [] ["help"] (NoArg (optMode_s ShowHelp)) "print help information and exit"
, Option [] ["info"] (NoArg (optMode_s ShowConfig)) "show compiler configuration information and exit"
, Option [] ["purge-cache"] (NoArg (optMode_s PurgeCache)) "clean out Ajhc compilation cache"
, Option ['v'] ["verbose"] (NoArg (optVerbose_u (+1))) "chatty output on stderr"
, Option ['z'] [] (NoArg (optStatLevel_u (+1))) "Increase verbosity of statistics"
, Option ['d'] [] (ReqArg (optDump_u . (:)) "[no-]flag") "dump specified data during compilation"
, Option ['f'] [] (ReqArg (optFOpts_u . (:)) "[no-]flag") "set or clear compilation options"
, Option ['X'] [] (ReqArg (optExtensions_u . (:)) "ExtensionName") "enable the given language extension"
, Option ['o'] ["output"] (ReqArg (optOutName_s . Just) "FILE") "output to FILE"
, Option ['i'] ["include"] (ReqArg (optIncdirs_u . idu) "DIR") "where to look for source files"
, Option ['I'] [] (ReqArg (optIncs_u . idu) "DIR") "add to preprocessor include path"
, Option ['D'] [] (ReqArg (optDefs_u . (:)) "NAME=VALUE") "add new definitions to set in preprocessor"
, Option [] ["optc"] (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler"
, Option ['c'] [] (NoArg (optStop_s CompileHo)) "just compile the modules, caching the results."
, Option ['C'] [] (NoArg (optStop_s StopC)) "compile to C code"
, Option ['E'] [] (NoArg (optMode_s Preprocess)) "preprocess the input and print result to stdout"
, Option ['k'] ["keepgoing"] (NoArg (optKeepGoing_s True)) "keep going on errors"
, Option [] ["cross"] (NoArg (optCross_s True)) "enable cross-compilation, choose target with the -m flag"
, Option [] ["stop"] (ReqArg (optStop_s . stop) "parse/typecheck/c") "stop after the given pass, parse/typecheck/c"
, Option [] ["width"] (ReqArg (optColumns_s . read) "COLUMNS") "width of screen for debugging output"
, Option [] ["main"] (ReqArg (optMainFunc_s . Just . (,) False) "Main.main") "main entry point"
, Option ['m'] ["arch"] (ReqArg (optArch_u . idu ) "arch") "target architecture options"
, Option [] ["entry"] (ReqArg (optMainFunc_s . Just . (,) True) "<expr>") "main entry point, showable expression"
, Option [] ["show-ho"] (ReqArg (optMode_s . ShowHo) "file.ho") "Show ho file"
, Option [] ["noauto"] (NoArg (optNoAuto_s True)) "Don't automatically load base and haskell98 packages"
, Option ['p'] [] (ReqArg (optHls_u . (:)) "package") "Load given haskell library package"
, Option ['L'] [] (ReqArg (optHlPath_u . idu) "path") "Look for haskell libraries in the given directory"
, Option [] ["build-hl"] (ReqArg (optMode_s . BuildHl) "desc.yaml") "Build hakell library from given library description file"
, Option [] ["annotate-source"] (ReqArg (optAnnotate_s . Just) "<dir>") "Write preprocessed and annotated source code to the directory specified"
, Option [] ["deps"] (ReqArg (optDeps_s . Just) "<file.yaml>") "Write dependency information to file specified"
, Option [] ["interactive"] (NoArg (optMode_s Interactive)) "run interactivly ( for debugging only)"
, Option [] ["ignore-cache"] (NoArg (optIgnoreHo_s True)) "Ignore existing compilation cache entries."
, Option [] ["readonly-cache"] (NoArg (optNoWriteHo_s True)) "Do not write new information to the compilation cache."
, Option [] ["no-cache"] (NoArg (optNoWriteHo_s True . optIgnoreHo_s True)) "Do not use or update the cache."
, Option [] ["cache-dir"] (ReqArg (optHoCache_s . Just ) "AJHC_CACHE") "Use a global cache located in the directory passed as an argument."
, Option [] ["stale"] (ReqArg (optStale_u . idu) "Module") "Treat these modules as stale, even if they exist in the cache"
, Option [] ["list-libraries"] (NoArg (optMode_s ListLibraries)) "List of installed libraries"
, Option [] ["tdir"] (ReqArg (optWorkDir_s . Just) "dir/") "specify the directory where all intermediate files/dumps will be placed."
, Option [] ["targetsini"] (ReqArg (optTargetsIni_s . Just) "targets.ini") "specify the targets.ini file."
]
stop "parse" = StopParse
stop "deps" = StopParse
stop "typecheck" = StopTypeCheck
stop "c" = StopC
stop s = StopError s
getColumns :: Int
getColumns = read $ unsafePerformIO (getEnv "COLUMNS" `mplus` return "80")
postProcessFD :: Monad m => Opt -> m Opt
postProcessFD o = case FlagDump.process (optDumpSet o) (optDump o ++ vv) of
(s,[]) -> return $ o { optDumpSet = s, optDump = [] }
(_,xs) -> fail ("Unrecognized dump flag passed to '-d': "
++ unwords xs ++ "\nValid dump flags:\n\n" ++ FlagDump.helpMsg)
where
vv | optVerbose o >= 2 = ["veryverbose"]
| optVerbose o >= 1 = ["verbose"]
| otherwise = []
postProcessFO :: Monad m => Opt -> m Opt
postProcessFO o = case FlagOpts.process (optFOptsSet o) (optFOpts o) of
(s,[]) -> return $ o { optFOptsSet = s, optFOpts = [] }
(_,xs) -> fail ("Unrecognized flag passed to '-f': "
++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg)
getArguments = do
x <- lookupEnv "AJHC_OPTS"
let eas = maybe [] words x
as <- getArgs
return (eas ++ as)
pfill ::
Int
-> (a -> Int)
-> [a]
-> [[a]]
pfill maxn length xs = f maxn xs [] [] where
f n (x:xs) ws ls | lx < n = f (n lx) xs (x:ws) ls where
lx = length x
f _ (x:xs) [] ls = f (maxn length x) xs [x] ls
f _ (x:xs) ws ls = f (maxn length x) xs [x] (ws:ls)
f _ [] [] ls = reverse (map reverse ls)
f _ [] ws ls = reverse (map reverse (ws:ls))
helpUsage = usageInfo header theoptions ++ trailer where
header = "Usage: ajhc [OPTION...] Main.hs"
trailer = "\n" ++ mkoptlist "-d" FlagDump.helpFlags ++ "\n" ++ mkoptlist "-f" FlagOpts.helpFlags
mkoptlist d os = "valid " ++ d ++ " arguments: 'help' for more info\n " ++ intercalate "\n " (map (intercalate ", ") $ pfill 100 ((2 +) . length) os) ++ "\n"
processOptions :: IO Opt
processOptions = do
argv <- getArguments
let (o,ns,rc) = getOpt Permute theoptions argv
o <- return (foldl (flip ($)) emptyOpt o)
when (rc /= []) $ putErrLn (concat rc ++ helpUsage) >> exitWith exitCodeUsage
case optStop o of
StopError s -> putErrLn "bad option passed to --stop should be one of parse, deps, typecheck, or c" >> exitWith exitCodeUsage
_ -> return ()
case optMode o of
ShowHelp -> doShowHelp
ShowConfig -> doShowConfig
Version -> putStrLn versionString >> exitSuccess
VersionCtx -> putStrLn (versionString ++ BS.toString versionContext) >> exitSuccess
PrintHscOptions -> do
putStrLn $ "-I" ++ VC.datadir ++ "/" ++ VC.package ++ "-" ++ VC.shortVersion ++ "/include"
exitSuccess
_ -> return ()
cabalEtc <- getDataFileNameMaybe "etc"
Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME"
let fromMaybeToList Nothing = []
fromMaybeToList (Just s) = [s]
oTarget = fromMaybeToList $ optTargetsIni o
etcDir = fromMaybe confDir cabalEtc
iniFiles = [etcDir ++ "/targets.ini", etcDir ++ "/targets-local.ini", home ++ "/etc/ajhc/targets.ini", home ++ "/.ajhc/targets.ini"] ++ oTarget
inis <- parseIniFiles (optVerbose o > 0) (BS.toString targets_ini) iniFiles (optArch o)
o <- either putErrDie return $ postProcessFD o
when (FlagDump.Ini `S.member` optDumpSet o) $ flip mapM_ (M.toList inis) $ \(a,b) -> putStrLn (a ++ "=" ++ b)
let o1 = case M.lookup "gc" inis of
Just "jgc" -> optFOptsSet_u (S.insert FlagOpts.Jgc) o
Just "boehm" -> optFOptsSet_u (S.insert FlagOpts.Boehm) o
_ -> o
o2 <- either putErrDie return $ postProcessFO o1
when (FlagDump.Ini `S.member` optDumpSet o) $ do
putStrLn (show $ optDumpSet o)
putStrLn (show $ optFOptsSet o)
let autoloads = maybe [] (tokens (',' ==)) (M.lookup "autoload" inis)
return o2 { optArgs = ns, optInis = inis, optAutoLoads = autoloads }
doShowHelp = do
putStrLn helpUsage
exitSuccess
doShowConfig = do
putStrLn $ showYAML configs
exitSuccess
findHoCache :: IO (Maybe FilePath)
findHoCache = do
cd <- lookupEnv "AJHC_CACHE"
case optHoCache options `mplus` cd of
Just s -> do return (Just s)
Just "-" -> do return Nothing
Nothing | isNothing (optHoDir options) -> do
Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME"
let cd = home ++ "/.ajhc/cache"
createDirectoryIfMissing True cd
return (Just cd)
_ -> return Nothing
configs :: Node
configs = toNode [
"jhclibpath" ==> initialLibIncludes,
"version" ==> version,
"package" ==> package,
"libdir" ==> libdir,
"datadir" ==> datadir,
"libraryInstall" ==> libraryInstall,
"host" ==> host
] where
(==>) :: ToNode b => String -> b -> (String,Node)
a ==> b = (a,toNode b)
fileOptions :: Monad m => Opt -> [String] -> m Opt
fileOptions options xs = case getOpt Permute theoptions xs of
(os,[],[]) -> postProcessFD (foldl (flip ($)) options os) >>= postProcessFO
(_,_,errs) -> fail (concat errs)
options :: Opt
options = unsafePerformIO processOptions
putVerbose :: String -> IO ()
putVerbose s = when (optVerbose options > 0) $ putErr s
putVerboseLn :: String -> IO ()
putVerboseLn s = putVerbose (s ++ "\n")
putProgress :: String -> IO ()
putProgress s = when progress $ putErr s
putProgressLn :: String -> IO ()
putProgressLn s = putProgress (s ++ "\n")
progress :: Bool
progress = dump FlagDump.Progress
verbose :: Bool
verbose = optVerbose options > 0
verbose2 :: Bool
verbose2 = optVerbose options > 1
dump :: FlagDump.Flag -> Bool
dump s = s `S.member` optDumpSet options
fopts :: FlagOpts.Flag -> Bool
fopts s = s `S.member` optFOptsSet options
wdump :: (Monad m) => FlagDump.Flag -> m () -> m ()
wdump f = when (dump f)
flint :: Bool
flint = FlagOpts.Lint `S.member` optFOptsSet options
initialIncludes :: [String]
initialIncludes = unsafePerformIO $ do
p <- lookupEnv "AJHC_PATH"
let x = fromMaybe "" p
return (".":(tokens (== ':') x))
initialLibIncludes :: [String]
initialLibIncludes = unsafePerformIO $ do
ps <- lookupEnv "AJHC_LIBRARY_PATH"
h <- lookupEnv "HOME"
let paths = h ++ ["/usr/local","/usr"]
bases = ["/lib","/share"]
vers = ["/ajhc-" ++ shortVersion, "/ajhc"]
dat <- getDataFileNameMaybe "lib"
return $ nub $ maybe [] (tokens (':' ==)) ps ++ [ p ++ b ++ v | p <- paths, v <- vers, b <- bases ]
++ [d ++ v | d <- [libdir,datadir], v <- vers] ++ [libraryInstall] ++ maybeToList dat
class Monad m => OptionMonad m where
getOptions :: m Opt
getOptions = return options
instance OptionMonad Identity
newtype OptT m a = OptT (ReaderT Opt m a)
deriving(MonadIO,Monad,Functor,MonadTrans)
type OptM = OptT Identity
instance Monad m => OptionMonad (OptT m) where
getOptions = OptT ask
withOptions :: Opt -> OptM a -> a
withOptions opt (OptT x) = runIdentity (runReaderT x opt)
withOptionsT :: Opt -> OptT m a -> m a
withOptionsT opt (OptT x) = runReaderT x opt
outputName = fromMaybe "hs.out" (optOutName options)
flagOpt :: OptionMonad m => FlagOpts.Flag -> m Bool
flagOpt flag = do
opt <- getOptions
return (flag `S.member` optFOptsSet opt)
getArgString = do
name <- getProgName
args <- getArguments
return (simpleQuote (name:args),head $ lines versionString)