module Multiarg.Mode.Internal where
import Data.Either (partitionEithers)
import Multiarg.Maddash
import Multiarg.Internal
import Multiarg.Util
import Multiarg.Types
import Prelude hiding (Word)
newtype ModeName = ModeName String
deriving (Eq, Ord, Show)
data ParsedMode a
= ModeGood a
| ModeError [OptionError] (Either OptionError OptName)
deriving (Eq, Ord, Show)
instance Functor ParsedMode where
fmap f (ModeGood a) = ModeGood (f a)
fmap _ (ModeError ls ei) = ModeError ls ei
data Mode r = Mode ModeName ([Word] -> ParsedMode r)
instance Functor Mode where
fmap f (Mode s p) = Mode s (fmap (fmap f) p)
parsedCommandLineToParsedMode
:: ([a] -> r)
-> ParsedCommandLine a
-> ParsedMode r
parsedCommandLineToParsedMode fMode (ParsedCommandLine ls mayOpt)
= case mayOpt of
Nothing -> case mayLast errs of
Nothing -> ModeGood (fMode goods)
Just (errs1st, errsLst) -> ModeError errs1st (Left errsLst)
Just opt -> ModeError errs (Right opt)
where
(errs, goods) = partitionEithers ls
mode
:: String
-> [OptSpec a]
-> (String -> a)
-> ([a] -> r)
-> Mode r
mode name opts fPos fMode
= Mode (ModeName name)
$ parsedCommandLineToParsedMode fMode
. parseCommandLinePure opts fPos
. map (\(Word s) -> s)
data GlobalLocalEnd a
= GlobalInsufficientOptArgs OptName
| ModeNotFound String [String]
| NoMode
| ModeFound (ParsedMode a)
deriving (Eq, Ord, Show)
data GlobalLocal g r
= GlobalLocal [Either OptionError g] (GlobalLocalEnd r)
deriving (Eq, Ord, Show)
data ModeResult g r
= ModeResult [g] (Either [String] r)
deriving (Eq, Ord, Show)
getModeResult
:: GlobalLocal g r
-> Either (String, [String]) (ModeResult g r)
getModeResult (GlobalLocal eis end)
= combine global (endToModeResult end)
where
(glblErrs, glblGoods) = partitionEithers eis
global = case glblErrs of
[] -> Right glblGoods
x:xs -> Left (x, xs)
combine
:: Either (OptionError, [OptionError]) [g]
-> Either (String, [String]) (Either [String] r)
-> Either (String, [String]) (ModeResult g r)
combine (Left (oe1, oes)) (Left (me1, mes)) =
Left ( globalOptErrorToString oe1
, map globalOptErrorToString oes ++ (me1 : mes) )
combine (Left (oe1, oes)) (Right _) =
Left (globalOptErrorToString oe1, map globalOptErrorToString oes)
combine (Right _) (Left (me1, mes)) = Left (me1, mes)
combine (Right glbls) (Right r) =
Right (ModeResult glbls r)
endToModeResult
:: GlobalLocalEnd a
-> Either (String, [String]) (Either [String] a)
endToModeResult end = case end of
GlobalInsufficientOptArgs on -> Left
(labeledInsufficientOptArgs "global" on, [])
ModeNotFound s ss -> Right (Left $ s:ss)
NoMode -> Right (Left [])
ModeFound pm -> extractParsedMode pm
extractParsedMode
:: ParsedMode a
-> Either (String, [String]) (Either b a)
extractParsedMode (ModeGood g) = Right . Right $ g
extractParsedMode (ModeError es lst) = Left $ case es of
[] -> (eiToError lst, [])
(x:xs) ->
( modeOptErrorToString x
, (map modeOptErrorToString xs) ++ [eiToError lst] )
globalOptErrorToString :: OptionError -> String
globalOptErrorToString = optErrorToString "global"
modeOptErrorToString :: OptionError -> String
modeOptErrorToString = optErrorToString "mode"
optErrorToString :: String -> OptionError -> String
optErrorToString lbl oe = case oe of
BadOption opt ->
"unrecognized " ++ lbl ++ " option: " ++ optNameToString opt
LongArgumentForZeroArgumentOption lng arg ->
"argument given for " ++ lbl ++ " option that takes no arguments. "
++ "option: --" ++ longNameToString lng
++ " argument: " ++ optArgToString arg
eiToError :: Either OptionError OptName -> String
eiToError ei = case ei of
Left oe -> modeOptErrorToString oe
Right on -> labeledInsufficientOptArgs "mode" on
labeledInsufficientOptArgs :: String -> OptName -> String
labeledInsufficientOptArgs lbl on = "insufficient option arguments "
++ "given for " ++ lbl ++ " option: " ++ optNameToString on
parseModeLine
:: [OptSpec g]
-> [Mode r]
-> [String]
-> Either (String, [String]) (ModeResult g r)
parseModeLine glbl mds =
getModeResult
. parseModeLineWithErrors glbl mds
parseModeLineWithErrors
:: [OptSpec g]
-> [Mode r]
-> [String]
-> GlobalLocal g r
parseModeLineWithErrors glbl mds tokStrings = GlobalLocal lsErrsGoods end
where
toks = map Word tokStrings
(shorts, longs) = splitOptSpecs glbl
(outs, eiOptTok) = processWords shorts longs toks
lsErrsGoods = map f . concat $ outs
where
f (Good a) = Right a
f (OptionError e) = Left e
end = case eiOptTok of
Left (opt, _) -> GlobalInsufficientOptArgs opt
Right [] -> NoMode
Right (x:xs) -> case findExactMode x mds of
Nothing -> ModeNotFound (unWord x) (map unWord xs)
where
unWord (Word t) = t
Just (Mode _ f) -> ModeFound (f xs)
findExactMode
:: Word
-> [Mode a]
-> Maybe (Mode a)
findExactMode _ [] = Nothing
findExactMode tok@(Word s) (m@(Mode (ModeName n) _) : ms)
| s == n = Just m
| otherwise = findExactMode tok ms