content: {-# LANGUAGE CPP #-}
  
  module Ivory.Compile.C.CmdlineFrontend.Options where
  
  import           Prelude               ()
  import           Prelude.Compat
  #if !MIN_VERSION_base(4,11,0)
  import           Data.Semigroup        (Semigroup(..))
  #endif
  
  import           System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute),
                                          OptDescr (..), getOpt, usageInfo)
  
  import           System.Environment    (getProgName)
  import           System.Exit           (exitFailure, exitSuccess)
  
  -- Option Parsing --------------------------------------------------------------
  
  data OptParser opt = OptParser [String] (opt -> opt)
  
  instance Semigroup (OptParser opt) where
    -- left-to-right composition makes the last option parsed take precedence
    OptParser as f <> OptParser bs g = OptParser (as ++ bs) (f . g)
  
  instance Monoid (OptParser opt) where
    mempty = OptParser [] id
    mappend = (<>)
  
  -- | Option parser succeeded, use this function to transform the default
  -- options.
  success :: (opt -> opt) -> OptParser opt
  success  = OptParser []
  
  -- | Option parser failed, emit this message.
  --
  -- XXX currently not used.
  --invalid :: String -> OptParser opt
  --invalid msg = Error [msg]
  
  
  -- | Yield either a list of errors, or a function to produce an options
  -- structure, given a set of default options.  Discard any non-options.
  parseOptions :: [OptDescr (OptParser opt)] -> [String]
               -> (Either [String] (opt -> opt))
  parseOptions opts args = case getOpt Permute opts args of
    (fs,[],[]) -> case mconcat fs of
      OptParser [] f -> Right f
      OptParser es _ -> Left es
    (_,_,es)  -> Left es
  
  
  
  -- Command Line Options --------------------------------------------------------
  
  data Opts = Opts
    { outDir        :: Maybe FilePath
    -- ^ output directory for all files (or standard out).
    , outHdrDir     :: Maybe FilePath
    -- ^ if set, output directory for headers. Otherwise, use @outDir@.
    , outArtDir     :: Maybe FilePath
    -- ^ if set, output directory for artifacts. Otherwise, use @outDir@.
    , otherHdr      :: Maybe String
    -- ^ In special circumstances, an implementation may not fully implement libc (e.g., if `math.h` does not include `isnan`). In these cases, another header can be added to every Ivory-generated source using the flag.
  
    -- optimization passes
    , constFold     :: Bool
    , overflow      :: Bool
    , divZero       :: Bool
    , ixCheck       :: Bool
    , fpCheck       :: Bool
    , outProcSyms   :: Bool
    , bitShiftCheck :: Bool
    -- CFG stuff
    , cfg           :: Bool
    , cfgDotDir     :: FilePath
    , cfgProc       :: [String]
    -- debugging
    , verbose       :: Bool
    , srcLocs       :: Bool
    -- Typechecking
    , tcWarnings    :: Bool
    , tcErrors      :: Bool
    , scErrors      :: Bool
  
    , help          :: Bool
    } deriving (Show)
  
  initialOpts :: Opts
  initialOpts  = Opts
    { outDir       = Nothing
    , outHdrDir    = Nothing
    , outArtDir    = Nothing
    , otherHdr     = Nothing
  
    -- optimization/safety passes
    , constFold    = False
    , overflow     = False
    , divZero      = False
    , ixCheck      = False
    , fpCheck      = False
    , outProcSyms  = False
    , bitShiftCheck = False
  
    -- CFG stuff
    , cfg          = False
    , cfgDotDir    = ""
    , cfgProc      = []
    -- debugging
    , verbose      = False
    , srcLocs      = False
    , tcWarnings   = True
    , tcErrors     = True
    , scErrors     = True
    , help         = False
    }
  
  setStdOut :: OptParser Opts
  setStdOut  = success (\opts -> opts { outDir = Nothing } )
  
  setOutDir :: String -> OptParser Opts
  setOutDir str = success (\opts -> opts { outDir = Just str })
  
  setHdrDir :: String -> OptParser Opts
  setHdrDir str = success (\opts -> opts { outHdrDir = Just str })
  
  setArtDir :: String -> OptParser Opts
  setArtDir str = success (\opts -> opts { outArtDir = Just str })
  
  setOtherHdr :: String -> OptParser Opts
  setOtherHdr h = success (\opts -> opts { otherHdr = Just h })
  
  setConstFold :: OptParser Opts
  setConstFold  = success (\opts -> opts { constFold = True })
  
  setOverflow :: OptParser Opts
  setOverflow  = success (\opts -> opts { overflow = True })
  
  setDivZero :: OptParser Opts
  setDivZero  = success (\opts -> opts { divZero = True })
  
  setIxCheck :: OptParser Opts
  setIxCheck  = success (\opts -> opts { ixCheck = True })
  
  setFpCheck :: OptParser Opts
  setFpCheck  = success (\opts -> opts { fpCheck = True })
  
  setProcSyms :: OptParser Opts
  setProcSyms  = success (\opts -> opts { outProcSyms = True })
  
  setBitShiftCheck :: OptParser Opts
  setBitShiftCheck  = success (\opts -> opts { bitShiftCheck = True })
  
  setCfg :: OptParser Opts
  setCfg  = success (\opts -> opts { cfg = True })
  
  setCfgDotDir :: String -> OptParser Opts
  setCfgDotDir str = success (\opts -> opts { cfgDotDir = str })
  
  addCfgProc :: String -> OptParser Opts
  addCfgProc str = success (\opts -> opts { cfgProc = cfgProc opts ++ [str] })
  
  setVerbose :: OptParser Opts
  setVerbose  = success (\opts -> opts { verbose = True })
  
  setSrcLocs :: OptParser Opts
  setSrcLocs  = success (\opts -> opts { srcLocs = True })
  
  setWarnings :: OptParser Opts
  setWarnings = success (\opts -> opts { tcWarnings = True })
  
  setErrors :: Bool -> OptParser Opts
  setErrors b = success (\opts -> opts { tcErrors = b })
  
  setSanityCheck :: Bool -> OptParser Opts
  setSanityCheck b = success (\opts -> opts { scErrors = b })
  
  setHelp :: OptParser Opts
  setHelp  = success (\opts -> opts { help = True })
  
  options :: [OptDescr (OptParser Opts)]
  options  =
    [ Option "" ["std-out"] (NoArg setStdOut)
      "print to stdout only"
    , Option "" ["src-dir"] (ReqArg setOutDir "PATH")
      "output directory for source files"
    , Option "" ["hdr-dir"] (ReqArg setHdrDir "PATH")
      "output directory for header files"
    , Option "" ["other-hdr"] (ReqArg setOtherHdr "HEADER")
      "Additional headers to include in generated files"
    , Option "" ["const-fold"] (NoArg setConstFold)
      "enable the constant folding pass"
    , Option "" ["overflow"] (NoArg setOverflow)
      "enable overflow checking annotations"
    , Option "" ["div-zero"] (NoArg setDivZero)
      "generate assertions checking for division by zero."
    , Option "" ["ix-check"] (NoArg setIxCheck)
      "generate assertions checking for back indexes (e.g., negative)"
    , Option "" ["fp-check"] (NoArg setFpCheck)
      "generate assertions checking for NaN and Infinitiy."
    , Option "" ["bitshift-check"] (NoArg setBitShiftCheck)
      "generate assertions checking for bit-shift overflow."
    , Option "" ["out-proc-syms"] (NoArg setProcSyms)
      "dump out the modules' function symbols"
    , Option "" ["cfg"] (NoArg setCfg)
      "Output control-flow graph and max stack usage."
    , Option "" ["cfg-dot-dir"] (ReqArg setCfgDotDir "PATH")
      "output directory for CFG Graphviz file"
    , Option "" ["cfg-proc"] (ReqArg addCfgProc "NAME")
      "entry function(s) for CFG computation."
    , Option "" ["verbose"] (NoArg setVerbose)
      "verbose debugging output"
    , Option "" ["srclocs"] (NoArg setSrcLocs)
      "output source locations from the Ivory code"
    , Option "" ["tc-warnings"] (NoArg setWarnings)
      "show type-check warnings"
    , Option "" ["tc-errors"] (NoArg $ setErrors True)
      "Abort on type-check errors (default)"
    , Option "" ["no-tc-errors"] (NoArg $ setErrors False)
      "Treat type-check errors as warnings"
    , Option "" ["sanity-check"] (NoArg $ setSanityCheck True)
      "Enable sanity-check"
    , Option "" ["no-sanity-check"] (NoArg $ setSanityCheck False)
      "Disable sanity-check"
    , Option "h" ["help"] (NoArg setHelp)
      "display this message"
    ]
  
  -- | Parse an @Opts@ structure from a list of strings.
  parseOpts :: [String] -> IO Opts
  parseOpts args = case parseOptions options args of
    Right f   ->
      let opts = f initialOpts
       in if help opts
             then printUsage [] >> exitSuccess
             else return opts
    Left errs -> printUsage errs >> exitFailure
  
  printUsage :: [String] -> IO ()
  printUsage errs = do
    prog <- getProgName
    let banner = unlines
          (errs ++ ["", "Usage: " ++ prog ++ " [OPTIONS]"])
    putStrLn (usageInfo banner options)
  
  
  