-- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
--
-- This file is a part of decafc.
--
-- decafc is free software: you can redistribute it and/or modify it under the
-- terms of the MIT (X11) License as described in the LICENSE file.
--
-- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE.  See the X11 license for more details.

module Util.CLI (generateUsage, getConfiguration) where

import Configuration
import Configuration.Types
import Control.Applicative ((<$>))
import Control.Monad (foldM)
import Data.List.Split (wordsBy)
import Data.Text (Text)
import Formatting
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)

--------------------------------- FlagAction ----------------------------------

-- I'll describe the behavior of each flag in terms of a 'FlagAction':
type FlagAction = Configuration -> Either String Configuration

{- Later, I'll 'foldM' over a list of FlagActions to apply them to a
configuration type.  If a FlagAction fails (e.g., because it was unable to
parse an argument), it'll return a 'Left', in which case the error will be
detectable at the end of the fold.  (Of course, I won't be able to recover from
command-line errors, but this seems reasonable behavior for a compiler. -}

------------------------------- Available flags -------------------------------

generateUsage :: IO String
generateUsage :: IO [Char]
generateUsage = do
  [Char]
firstLine <- IO [Char]
generateSummary
  [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$
    [[Char]] -> [Char]
unlines
      [ [Char]
firstLine,
        [Char] -> [OptDescr FlagAction] -> [Char]
forall a. [Char] -> [OptDescr a] -> [Char]
usageInfo [Char]
"Summary of options:" [OptDescr FlagAction]
options,
        [Char]
"Long description of options:",
        [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init [Char]
longDescription -- drop trailing newline
      ]

{- The rest of this section is organized in the order of the lines in the usage
message. -}

generateSummary :: IO String
generateSummary :: IO [Char]
generateSummary =
  Format [Char] ([Char] -> [Char]) -> [Char] -> [Char]
forall a. Format [Char] a -> a
formatToString (Format [Char] ([Char] -> [Char])
forall r. Format r ([Char] -> r)
string Format [Char] ([Char] -> [Char])
-> Format [Char] [Char] -> Format [Char] ([Char] -> [Char])
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format [Char] [Char]
" [options] <filename>")
    ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getProgName

options :: [OptDescr FlagAction]
options :: [OptDescr FlagAction]
options =
  [ [Char]
-> [[Char]] -> ArgDescr FlagAction -> [Char] -> OptDescr FlagAction
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char
't']
      [[Char]
"target"]
      ( ([Char] -> FlagAction) -> [Char] -> ArgDescr FlagAction
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg
          ( \[Char]
stage -> \Configuration
conf -> do
              CompilerStage
parsedStage <- [Char] -> Either [Char] CompilerStage
readStage [Char]
stage
              FlagAction
forall a. a -> Either [Char] a
forall (m :: * -> *) a. Monad m => a -> m a
return FlagAction -> FlagAction
forall a b. (a -> b) -> a -> b
$ Configuration
conf {$sel:explicitTarget:Configuration :: Maybe CompilerStage
explicitTarget = CompilerStage -> Maybe CompilerStage
forall a. a -> Maybe a
Just CompilerStage
parsedStage}
          )
          [Char]
"<stage>"
      )
      [Char]
"compile to the given stage",
    [Char]
-> [[Char]] -> ArgDescr FlagAction -> [Char] -> OptDescr FlagAction
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char
'o']
      [[Char]
"output"]
      ( ([Char] -> FlagAction) -> [Char] -> ArgDescr FlagAction
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg
          ( \[Char]
outfile -> \Configuration
conf ->
              FlagAction
forall a b. b -> Either a b
Right FlagAction -> FlagAction
forall a b. (a -> b) -> a -> b
$ Configuration
conf {$sel:outputFileName:Configuration :: Maybe [Char]
outputFileName = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
outfile}
          )
          [Char]
"<outfile>"
      )
      [Char]
"write output to <outfile>",
    [Char]
-> [[Char]] -> ArgDescr FlagAction -> [Char] -> OptDescr FlagAction
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char
'O']
      [[Char]
"opt"]
      ( ([Char] -> FlagAction) -> [Char] -> ArgDescr FlagAction
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg
          ( \[Char]
optSpec -> \Configuration
conf -> do
              OptimizationSpecification
parsedOptSpec <- [Char] -> Either [Char] OptimizationSpecification
readOptimizationSpec [Char]
optSpec
              FlagAction
forall a. a -> Either [Char] a
forall (m :: * -> *) a. Monad m => a -> m a
return FlagAction -> FlagAction
forall a b. (a -> b) -> a -> b
$ Configuration
conf {$sel:opt:Configuration :: OptimizationSpecification
opt = OptimizationSpecification
parsedOptSpec}
          )
          [Char]
"<(opt|-opt|all)...>"
      )
      [Char]
"perform the listed optimizations",
    [Char]
-> [[Char]] -> ArgDescr FlagAction -> [Char] -> OptDescr FlagAction
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char
'd']
      [[Char]
"debug"]
      (FlagAction -> ArgDescr FlagAction
forall a. a -> ArgDescr a
NoArg (\Configuration
conf -> FlagAction
forall a b. b -> Either a b
Right FlagAction -> FlagAction
forall a b. (a -> b) -> a -> b
$ Configuration
conf {$sel:debug:Configuration :: Bool
debug = Bool
True}))
      [Char]
"print debugging information"
  ]

longDescription :: String
longDescription :: [Char]
longDescription =
  [[Char]] -> [Char]
unlines
    [ [Char]
"  -t <stage>          <stage> is one of \"scan\", \"parse\", \"cfg\", \"inter\", or \"assembly\".",
      [Char]
"  --target=<stage>    Compilation will proceed to the given stage and halt there.",
      [Char]
"  ",
      [Char]
"  -d                  Print debugging information.  If this option is not given,",
      [Char]
"  --debug             then there will be no output to the screen on successful",
      [Char]
"  ",
      [Char]
"  -O <optspec>        Perform the listed optimizations.  <optspec> is a comma-",
      [Char]
"  --opt=<optspec>     separated list of optimization names, or the special symbol",
      [Char]
"                      \"all\", meaning all possible optimizations.  You may",
      [Char]
"                      explicitly disable an optimization by prefixing its name",
      [Char]
"                      '-'.  As an example, \"hoistLoop,-unrollLoops\" will enable",
      [Char]
"                      hoisting of loop invariant code but will disable loop",
      [Char]
"                      unrolling.",
      [Char]
"  ",
      [Char]
"  -o <outfile>        Write output to <outfile>.  If this option is not given,",
      [Char]
"  --output=<outfile>  output will be written to standard output."
    ]

---------------------------- Reading option specs -----------------------------

readStage :: String -> Either String CompilerStage
readStage :: [Char] -> Either [Char] CompilerStage
readStage [Char]
stageString =
  case ReadS CompilerStage
forall a. Read a => ReadS a
reads [Char]
stageString of
    [(CompilerStage
stage, [Char]
"")] -> CompilerStage -> Either [Char] CompilerStage
forall a b. b -> Either a b
Right CompilerStage
stage
    [(CompilerStage, [Char])]
_ -> [Char] -> Either [Char] CompilerStage
forall a b. a -> Either a b
Left ([Char] -> Either [Char] CompilerStage)
-> [Char] -> Either [Char] CompilerStage
forall a b. (a -> b) -> a -> b
$ Format [Char] ([Char] -> [Char]) -> [Char] -> [Char]
forall a. Format [Char] a -> a
formatToString (Format ([Char] -> [Char]) ([Char] -> [Char])
"unknown stage `" Format ([Char] -> [Char]) ([Char] -> [Char])
-> Format [Char] ([Char] -> [Char])
-> Format [Char] ([Char] -> [Char])
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format [Char] ([Char] -> [Char])
forall r. Format r ([Char] -> r)
string Format [Char] ([Char] -> [Char])
-> Format [Char] [Char] -> Format [Char] ([Char] -> [Char])
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format [Char] [Char]
"'\n") [Char]
stageString

readOptimizationSpec :: String -> Either String OptimizationSpecification
readOptimizationSpec :: [Char] -> Either [Char] OptimizationSpecification
readOptimizationSpec [Char]
optString =
  let opts :: [[Char]]
opts = (Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') [Char]
optString
   in if [Char]
"all" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opts
        then OptimizationSpecification
-> Either [Char] OptimizationSpecification
forall a b. b -> Either a b
Right OptimizationSpecification
All
        else OptimizationSpecification
-> Either [Char] OptimizationSpecification
forall a b. b -> Either a b
Right (OptimizationSpecification
 -> Either [Char] OptimizationSpecification)
-> OptimizationSpecification
-> Either [Char] OptimizationSpecification
forall a b. (a -> b) -> a -> b
$ [OptimizationName] -> OptimizationSpecification
Some ([OptimizationName] -> OptimizationSpecification)
-> [OptimizationName] -> OptimizationSpecification
forall a b. (a -> b) -> a -> b
$ [[Char]] -> ([Char] -> OptimizationName) -> [OptimizationName]
forall {a} {b}. [a] -> (a -> b) -> [b]
for [[Char]]
opts (([Char] -> OptimizationName) -> [OptimizationName])
-> ([Char] -> OptimizationName) -> [OptimizationName]
forall a b. (a -> b) -> a -> b
$ \[Char]
optSpec -> case [Char]
optSpec of
          (Char
'-' : [Char]
optName) -> [Char] -> OptimizationName
Disable [Char]
optName
          [Char]
optName -> [Char] -> OptimizationName
Enable [Char]
optName
  where
    for :: [a] -> (a -> b) -> [b]
for = ((a -> b) -> [a] -> [b]) -> [a] -> (a -> b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map

------------------------------ Main entry points ------------------------------

-- | Parses command-line options, returning a 'Configuration' describing the
-- behavior of the compiler.
getConfiguration :: IO (Either String Configuration)
getConfiguration :: IO (Either [Char] Configuration)
getConfiguration = do
  -- Fetch the arguments and process them.
  [[Char]]
args <- IO [[Char]]
getArgs
  -- return $ do
  let maybeSelectedOptions :: Either [Char] Configuration
maybeSelectedOptions = do
        let ([FlagAction]
flagActions, [[Char]]
nonOptions, [[Char]]
errors) = ArgOrder FlagAction
-> [OptDescr FlagAction]
-> [[Char]]
-> ([FlagAction], [[Char]], [[Char]])
forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt ArgOrder FlagAction
forall a. ArgOrder a
Permute [OptDescr FlagAction]
options [[Char]]
args
        -- If there were any errors, notify the monad.
        ([Char] -> Either [Char] Any) -> [[Char]] -> Either [Char] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> Either [Char] Any
forall a b. a -> Either a b
Left [[Char]]
errors
        {- Construct the options struct by applying the 'flagActions' to the
        default configuration. -}
        Configuration
selectedOptions <- (Configuration -> FlagAction -> Either [Char] Configuration)
-> Configuration -> [FlagAction] -> Either [Char] Configuration
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((FlagAction -> FlagAction)
-> Configuration -> FlagAction -> Either [Char] Configuration
forall a b c. (a -> b -> c) -> b -> a -> c
flip FlagAction -> FlagAction
forall a. a -> a
id) Configuration
defaultConfiguration [FlagAction]
flagActions
        -- What file are we reading?
        [Char]
inputFileName <-
          [Char] -> Maybe [Char] -> Either [Char] [Char]
forall {a} {b}. a -> Maybe b -> Either a b
maybeToEither [Char]
"no input file specified\n" (Maybe [Char] -> Either [Char] [Char])
-> Maybe [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe [Char]
forall {a}. [a] -> Maybe a
headMay [[Char]]
nonOptions
        FlagAction
forall a b. b -> Either a b
Right FlagAction -> FlagAction
forall a b. (a -> b) -> a -> b
$ Configuration
selectedOptions {$sel:input:Configuration :: [Char]
input = [Char]
inputFileName}
  case Either [Char] Configuration
maybeSelectedOptions of
    Left [Char]
errorMessage -> do
      [Char]
usage <- [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
generateUsage -- drop trailing newline
      Either [Char] Configuration -> IO (Either [Char] Configuration)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Configuration -> IO (Either [Char] Configuration))
-> Either [Char] Configuration -> IO (Either [Char] Configuration)
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Configuration
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Configuration)
-> [Char] -> Either [Char] Configuration
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]
errorMessage, [Char]
usage]
    Right Configuration
selectedOptions -> Either [Char] Configuration -> IO (Either [Char] Configuration)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Configuration -> IO (Either [Char] Configuration))
-> Either [Char] Configuration -> IO (Either [Char] Configuration)
forall a b. (a -> b) -> a -> b
$ FlagAction
forall a b. b -> Either a b
Right Configuration
selectedOptions
  where
    maybeToEither :: a -> Maybe b -> Either a b
maybeToEither a
_ (Just b
a) = b -> Either a b
forall a b. b -> Either a b
Right b
a
    maybeToEither a
msg Maybe b
Nothing = a -> Either a b
forall a b. a -> Either a b
Left a
msg
    headMay :: [a] -> Maybe a
headMay [] = Maybe a
forall a. Maybe a
Nothing
    headMay (a
x : [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x