module Evoke.Options
  ( parse
  ) where

import qualified Control.Monad as Monad
import qualified Evoke.Hsc as Hsc
import qualified GhcPlugins as Ghc
import qualified System.Console.GetOpt as Console

-- | Parses command line options. Adds warnings and throws errors as
-- appropriate. Returns the list of parsed options.
parse :: [Console.OptDescr a] -> [String] -> Ghc.SrcSpan -> Ghc.Hsc [a]
parse :: [OptDescr a] -> [String] -> SrcSpan -> Hsc [a]
parse [OptDescr a]
optDescrs [String]
strings SrcSpan
srcSpan = do
  let
    ([a]
xs, [String]
args, [String]
opts, [String]
errs) = ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
Console.getOpt' ArgOrder a
forall a. ArgOrder a
Console.Permute [OptDescr a]
optDescrs [String]
strings
  [String] -> (String -> Hsc ()) -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Monad.forM_ [String]
opts
    ((String -> Hsc ()) -> Hsc ()) -> (String -> Hsc ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> MsgDoc -> Hsc ()
Hsc.addWarning SrcSpan
srcSpan
    (MsgDoc -> Hsc ()) -> (String -> MsgDoc) -> String -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MsgDoc
Ghc.text
    (String -> MsgDoc) -> (String -> String) -> String -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
"unknown option: "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
quote
  [String] -> (String -> Hsc ()) -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Monad.forM_ [String]
args
    ((String -> Hsc ()) -> Hsc ()) -> (String -> Hsc ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> MsgDoc -> Hsc ()
Hsc.addWarning SrcSpan
srcSpan
    (MsgDoc -> Hsc ()) -> (String -> MsgDoc) -> String -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MsgDoc
Ghc.text
    (String -> MsgDoc) -> (String -> String) -> String -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
"unexpected argument: "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
quote
  Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs)
    (Hsc () -> Hsc ()) -> (String -> Hsc ()) -> String -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> MsgDoc -> Hsc ()
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
    (MsgDoc -> Hsc ()) -> (String -> MsgDoc) -> String -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgDoc] -> MsgDoc
Ghc.vcat
    ([MsgDoc] -> MsgDoc) -> (String -> [MsgDoc]) -> String -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> MsgDoc) -> [String] -> [MsgDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> MsgDoc
Ghc.text
    ([String] -> [MsgDoc])
-> (String -> [String]) -> String -> [MsgDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    (String -> Hsc ()) -> String -> Hsc ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String]
errs
  [a] -> Hsc [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs

-- | Quotes a string using GHC's weird quoting format.
--
-- >>> quote "thing"
-- "`thing'"
quote :: String -> String
quote :: String -> String
quote String
string = String
"`" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
string String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"