-- |
-- Module: Options.Tokenize
-- License: MIT
module Options.Tokenize
  ( Token (..),
    tokenFlagName,
    Tokens (..),
    tokensMap,
    tokenize,
  )
where

import Control.Monad.Except hiding (throwError)
import qualified Control.Monad.Except
import Control.Monad.State
import Data.Functor.Identity
import qualified Data.Map
import Options.Types
import Options.Util

data Token
  = TokenUnary String -- flag name
  | Token String String -- flag name, flag value
  deriving (Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)

tokenFlagName :: Token -> String
tokenFlagName :: Token -> String
tokenFlagName (TokenUnary String
s) = String
s
tokenFlagName (Token String
s String
_) = String
s

data Tokens = Tokens
  { Tokens -> [([OptionKey], Token)]
tokensList :: [([OptionKey], Token)],
    Tokens -> [String]
tokensArgv :: [String]
  }
  deriving (Int -> Tokens -> ShowS
[Tokens] -> ShowS
Tokens -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tokens] -> ShowS
$cshowList :: [Tokens] -> ShowS
show :: Tokens -> String
$cshow :: Tokens -> String
showsPrec :: Int -> Tokens -> ShowS
$cshowsPrec :: Int -> Tokens -> ShowS
Show)

tokensMap :: Tokens -> Data.Map.Map OptionKey [Token]
tokensMap :: Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Data.Map.fromListWith (\[Token]
xs [Token]
ys -> [Token]
ys forall a. [a] -> [a] -> [a]
++ [Token]
xs) do
  ([OptionKey]
keys, Token
token) <- Tokens -> [([OptionKey], Token)]
tokensList Tokens
tokens
  OptionKey
key <- [OptionKey]
keys
  forall (m :: * -> *) a. Monad m => a -> m a
return (OptionKey
key, [Token
token])

data TokState = TokState
  { TokState -> [String]
stArgv :: [String],
    TokState -> [String]
stArgs :: [String],
    TokState -> [([OptionKey], Token)]
stOpts :: [([OptionKey], Token)],
    TokState -> Map Char ([OptionKey], OptionInfo)
stShortKeys :: Data.Map.Map Char ([OptionKey], OptionInfo),
    TokState -> Map String ([OptionKey], OptionInfo)
stLongKeys :: Data.Map.Map String ([OptionKey], OptionInfo),
    TokState -> [(String, [OptionInfo])]
stSubcommands :: [(String, [OptionInfo])],
    TokState -> Maybe String
stSubCmd :: Maybe String
  }

newtype Tok a = Tok {forall a. Tok a -> ExceptT String (StateT TokState Identity) a
unTok :: ExceptT String (StateT TokState Identity) a}

instance Functor Tok where
  fmap :: forall a b. (a -> b) -> Tok a -> Tok b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Tok where
  pure :: forall a. a -> Tok a
pure = forall a. ExceptT String (StateT TokState Identity) a -> Tok a
Tok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a b. Tok (a -> b) -> Tok a -> Tok b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Tok where
  Tok a
m >>= :: forall a b. Tok a -> (a -> Tok b) -> Tok b
>>= a -> Tok b
f = forall a. ExceptT String (StateT TokState Identity) a -> Tok a
Tok (forall a. Tok a -> ExceptT String (StateT TokState Identity) a
unTok Tok a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Tok a -> ExceptT String (StateT TokState Identity) a
unTok forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Tok b
f)

instance MonadState Tok where
  type StateType Tok = TokState
  get :: Tok (StateType Tok)
get = forall a. ExceptT String (StateT TokState Identity) a -> Tok a
Tok forall (m :: * -> *). MonadState m => m (StateType m)
get
  put :: StateType Tok -> Tok ()
put = forall a. ExceptT String (StateT TokState Identity) a -> Tok a
Tok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadState m => StateType m -> m ()
put

tokenize :: OptionDefinitions -> [String] -> (Maybe String, Either String Tokens)
tokenize :: OptionDefinitions
-> [String] -> (Maybe String, Either String Tokens)
tokenize (OptionDefinitions [OptionInfo]
options [(String, [OptionInfo])]
subcommands) [String]
argv = forall a. Identity a -> a
runIdentity do
  let st :: TokState
st =
        TokState
          { stArgv :: [String]
stArgv = [String]
argv,
            stArgs :: [String]
stArgs = [],
            stOpts :: [([OptionKey], Token)]
stOpts = [],
            stShortKeys :: Map Char ([OptionKey], OptionInfo)
stShortKeys = [OptionInfo] -> Map Char ([OptionKey], OptionInfo)
toShortKeys [OptionInfo]
options,
            stLongKeys :: Map String ([OptionKey], OptionInfo)
stLongKeys = [OptionInfo] -> Map String ([OptionKey], OptionInfo)
toLongKeys [OptionInfo]
options,
            stSubcommands :: [(String, [OptionInfo])]
stSubcommands = [(String, [OptionInfo])]
subcommands,
            stSubCmd :: Maybe String
stSubCmd = forall a. Maybe a
Nothing
          }
  (Either String ()
err, TokState
st') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall a. Tok a -> ExceptT String (StateT TokState Identity) a
unTok Tok ()
loop)) TokState
st
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( TokState -> Maybe String
stSubCmd TokState
st',
      case Either String ()
err of
        Left String
err' -> forall a b. a -> Either a b
Left String
err'
        Right ()
_ -> forall a b. b -> Either a b
Right ([([OptionKey], Token)] -> [String] -> Tokens
Tokens (forall a. [a] -> [a]
reverse (TokState -> [([OptionKey], Token)]
stOpts TokState
st')) (TokState -> [String]
stArgs TokState
st'))
    )

loop :: Tok ()
loop :: Tok ()
loop = do
  Maybe String
ms <- Tok (Maybe String)
nextItem
  TokState
st <- forall (m :: * -> *). MonadState m => m (StateType m)
get
  case Maybe String
ms of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
s -> (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tok ()
loop) case ShowS
stringToGhc704 String
s of
      Char
'-' : Char
'-' : [] -> forall (m :: * -> *). MonadState m => StateType m -> m ()
put (TokState
st {stArgv :: [String]
stArgv = [], stArgs :: [String]
stArgs = TokState -> [String]
stArgs TokState
st forall a. [a] -> [a] -> [a]
++ TokState -> [String]
stArgv TokState
st})
      Char
'-' : Char
'-' : String
opt -> String -> Tok ()
parseLong String
opt
      Char
'-' : Char
optChar : String
optValue -> Char -> String -> Tok ()
parseShort Char
optChar String
optValue
      Char
'-' : [] -> String -> Tok ()
addArg String
s
      String
decoded -> case (TokState -> [(String, [OptionInfo])]
stSubcommands TokState
st, TokState -> Maybe String
stSubCmd TokState
st) of
        ([], Maybe String
_) -> String -> Tok ()
addArg String
s
        ([(String, [OptionInfo])]
_, Just String
_) -> String -> Tok ()
addArg String
s
        ([(String, [OptionInfo])]
_, Maybe String
Nothing) -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
decoded (TokState -> [(String, [OptionInfo])]
stSubcommands TokState
st) of
          Maybe [OptionInfo]
Nothing -> forall a. String -> Tok a
throwError (String
"Unknown subcommand " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
decoded forall a. [a] -> [a] -> [a]
++ String
".")
          Just [OptionInfo]
subOptions -> String -> [OptionInfo] -> Tok ()
mergeSubcommand String
decoded [OptionInfo]
subOptions

nextItem :: Tok (Maybe String)
nextItem :: Tok (Maybe String)
nextItem = do
  TokState
st <- forall (m :: * -> *). MonadState m => m (StateType m)
get
  case TokState -> [String]
stArgv TokState
st of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    (String
x : [String]
xs) -> do
      forall (m :: * -> *). MonadState m => StateType m -> m ()
put (TokState
st {stArgv :: [String]
stArgv = [String]
xs})
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
x)

addArg :: String -> Tok ()
addArg :: String -> Tok ()
addArg String
s = forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify (\StateType Tok
st -> StateType Tok
st {stArgs :: [String]
stArgs = TokState -> [String]
stArgs StateType Tok
st forall a. [a] -> [a] -> [a]
++ [String
s]})

addOpt :: [OptionKey] -> Token -> Tok ()
addOpt :: [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys Token
val =
  forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify
    ( \StateType Tok
st ->
        StateType Tok
st
          { stOpts :: [([OptionKey], Token)]
stOpts = ([OptionKey]
keys, Token
val) forall a. a -> [a] -> [a]
: TokState -> [([OptionKey], Token)]
stOpts StateType Tok
st
          }
    )

mergeSubcommand :: String -> [OptionInfo] -> Tok ()
mergeSubcommand :: String -> [OptionInfo] -> Tok ()
mergeSubcommand String
name [OptionInfo]
opts = forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify \StateType Tok
st ->
  StateType Tok
st
    { stSubCmd :: Maybe String
stSubCmd = forall a. a -> Maybe a
Just String
name,
      stShortKeys :: Map Char ([OptionKey], OptionInfo)
stShortKeys = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Data.Map.unionWith ([OptionKey], OptionInfo)
-> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo)
unionKeys (TokState -> Map Char ([OptionKey], OptionInfo)
stShortKeys StateType Tok
st) ([OptionInfo] -> Map Char ([OptionKey], OptionInfo)
toShortKeys [OptionInfo]
opts),
      stLongKeys :: Map String ([OptionKey], OptionInfo)
stLongKeys = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Data.Map.unionWith ([OptionKey], OptionInfo)
-> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo)
unionKeys (TokState -> Map String ([OptionKey], OptionInfo)
stLongKeys StateType Tok
st) ([OptionInfo] -> Map String ([OptionKey], OptionInfo)
toLongKeys [OptionInfo]
opts)
    }

-- note: unionKeys assumes that the OptionInfo is equivalent in both maps.
unionKeys :: ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo)
unionKeys :: ([OptionKey], OptionInfo)
-> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo)
unionKeys ([OptionKey]
keys1, OptionInfo
info) ([OptionKey]
keys2, OptionInfo
_) = ([OptionKey]
keys1 forall a. [a] -> [a] -> [a]
++ [OptionKey]
keys2, OptionInfo
info)

parseLong :: String -> Tok ()
parseLong :: String -> Tok ()
parseLong String
optName = do
  Map String ([OptionKey], OptionInfo)
longKeys <- forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets TokState -> Map String ([OptionKey], OptionInfo)
stLongKeys
  case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
optName of
    (String
before, String
after) -> case String
after of
      Char
'=' : String
value -> case forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup String
before Map String ([OptionKey], OptionInfo)
longKeys of
        Maybe ([OptionKey], OptionInfo)
Nothing -> forall a. String -> Tok a
throwError (String
"Unknown flag --" forall a. [a] -> [a] -> [a]
++ String
before)
        Just ([OptionKey]
keys, OptionInfo
info) ->
          if OptionInfo -> Bool
optionInfoUnaryOnly OptionInfo
info
            then forall a. String -> Tok a
throwError (String
"Flag --" forall a. [a] -> [a] -> [a]
++ String
before forall a. [a] -> [a] -> [a]
++ String
" takes no parameters.")
            else [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> String -> Token
Token (String
"--" forall a. [a] -> [a] -> [a]
++ String
before) String
value)
      String
_ -> case forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup String
optName Map String ([OptionKey], OptionInfo)
longKeys of
        Maybe ([OptionKey], OptionInfo)
Nothing -> forall a. String -> Tok a
throwError (String
"Unknown flag --" forall a. [a] -> [a] -> [a]
++ String
optName)
        Just ([OptionKey]
keys, OptionInfo
info) ->
          if OptionInfo -> Bool
optionInfoUnary OptionInfo
info
            then [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> Token
TokenUnary (String
"--" forall a. [a] -> [a] -> [a]
++ String
optName))
            else do
              Maybe String
next <- Tok (Maybe String)
nextItem
              case Maybe String
next of
                Maybe String
Nothing -> forall a. String -> Tok a
throwError (String
"The flag --" forall a. [a] -> [a] -> [a]
++ String
optName forall a. [a] -> [a] -> [a]
++ String
" requires a parameter.")
                Just String
value -> [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> String -> Token
Token (String
"--" forall a. [a] -> [a] -> [a]
++ String
optName) String
value)

parseShort :: Char -> String -> Tok ()
parseShort :: Char -> String -> Tok ()
parseShort Char
optChar String
optValue = do
  let optName :: String
optName = Char
'-' forall a. a -> [a] -> [a]
: [Char
optChar]
  Map Char ([OptionKey], OptionInfo)
shortKeys <- forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets TokState -> Map Char ([OptionKey], OptionInfo)
stShortKeys
  case forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup Char
optChar Map Char ([OptionKey], OptionInfo)
shortKeys of
    Maybe ([OptionKey], OptionInfo)
Nothing -> forall a. String -> Tok a
throwError (String
"Unknown flag " forall a. [a] -> [a] -> [a]
++ String
optName)
    Just ([OptionKey]
keys, OptionInfo
info) ->
      if OptionInfo -> Bool
optionInfoUnary OptionInfo
info
        then -- don't check optionInfoUnaryOnly, because that's only set by --help
        -- options and they define no short flags.
        do
          [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> Token
TokenUnary String
optName)
          case String
optValue of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Char
nextChar : String
nextValue -> Char -> String -> Tok ()
parseShort Char
nextChar String
nextValue
        else case String
optValue of
          String
"" -> do
            Maybe String
next <- Tok (Maybe String)
nextItem
            case Maybe String
next of
              Maybe String
Nothing -> forall a. String -> Tok a
throwError (String
"The flag " forall a. [a] -> [a] -> [a]
++ String
optName forall a. [a] -> [a] -> [a]
++ String
" requires a parameter.")
              Just String
value -> [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> String -> Token
Token String
optName String
value)
          String
_ -> [OptionKey] -> Token -> Tok ()
addOpt [OptionKey]
keys (String -> String -> Token
Token String
optName String
optValue)

toShortKeys :: [OptionInfo] -> Data.Map.Map Char ([OptionKey], OptionInfo)
toShortKeys :: [OptionInfo] -> Map Char ([OptionKey], OptionInfo)
toShortKeys [OptionInfo]
opts = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Data.Map.fromListWith (\([OptionKey]
keys1, OptionInfo
info) ([OptionKey]
keys2, OptionInfo
_) -> ([OptionKey]
keys2 forall a. [a] -> [a] -> [a]
++ [OptionKey]
keys1, OptionInfo
info)) do
  OptionInfo
opt <- [OptionInfo]
opts
  Char
flag <- OptionInfo -> String
optionInfoShortFlags OptionInfo
opt
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char
flag, ([OptionInfo -> OptionKey
optionInfoKey OptionInfo
opt], OptionInfo
opt))

toLongKeys :: [OptionInfo] -> Data.Map.Map String ([OptionKey], OptionInfo)
toLongKeys :: [OptionInfo] -> Map String ([OptionKey], OptionInfo)
toLongKeys [OptionInfo]
opts = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Data.Map.fromListWith (\([OptionKey]
keys1, OptionInfo
info) ([OptionKey]
keys2, OptionInfo
_) -> ([OptionKey]
keys2 forall a. [a] -> [a] -> [a]
++ [OptionKey]
keys1, OptionInfo
info)) do
  OptionInfo
opt <- [OptionInfo]
opts
  String
flag <- OptionInfo -> [String]
optionInfoLongFlags OptionInfo
opt
  forall (m :: * -> *) a. Monad m => a -> m a
return (String
flag, ([OptionInfo -> OptionKey
optionInfoKey OptionInfo
opt], OptionInfo
opt))

throwError :: String -> Tok a
throwError :: forall a. String -> Tok a
throwError = forall a. ExceptT String (StateT TokState Identity) a -> Tok a
Tok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
Control.Monad.Except.throwError