module Multiarg.Maddash
(
OptName(..)
, optSpec
, ArgSpec(..)
, ShortName
, LongName
, shortName
, longName
, shortNameToChar
, longNameToString
, Output(..)
, Pallet(..)
, State(..)
, isReady
, isPending
, processWord
, processWords
, OptArg(..)
, OptionError(..)
) where
import Control.Applicative
import Multiarg.Types
data Output a
= Good a
| OptionError OptionError
deriving (Eq, Ord, Show)
instance Functor Output where
fmap f (Good a) = Good (f a)
fmap _ (OptionError e) = OptionError e
data Pallet a
= NotAnOption
| Full [Output a]
deriving (Eq, Ord, Show)
instance Functor Pallet where
fmap _ NotAnOption = NotAnOption
fmap f (Full os) = Full (map (fmap f) os)
data State a
= Ready
| Pending OptName (Word -> ([Output a], State a))
instance Functor State where
fmap _ Ready = Ready
fmap f (Pending o g)
= Pending o (\t -> let (os, st') = g t
in (map (fmap f) os, fmap f st'))
instance Show (State a) where
show Ready = "Ready"
show (Pending o _) = "Pending - " ++ show o
isReady :: State a -> Bool
isReady Ready = True
isReady _ = False
isPending :: State a -> Bool
isPending (Pending _ _) = True
isPending _ = False
processWord
:: [(ShortName, ArgSpec a)]
-> [(LongName, ArgSpec a)]
-> State a
-> Word
-> (Pallet a, State a)
processWord shorts longs st inp = case st of
Pending _ f -> (Full os, st')
where
(os, st') = f inp
Ready -> case procOpt of
Just (os, st') -> (Full os, st')
Nothing -> (NotAnOption, Ready)
where
procOpt = procShort shorts inp <|> procLong longs inp
processWords
:: [(ShortName, ArgSpec a)]
-> [(LongName, ArgSpec a)]
-> [Word]
-> ([[Output a]], Either (OptName, Word -> ([Output a], State a)) [Word])
processWords shorts longs = go Ready
where
go Ready [] = ([], Right [])
go (Pending opt f) [] = ([], Left (opt, f))
go st (t:ts) = (rs, eiToksPend)
where
(pallet, st') = processWord shorts longs st t
(rs, eiToksPend) = case pallet of
NotAnOption -> ([], Right (t:ts))
Full out -> (out : outRest, ei)
where
(outRest, ei) = go st' ts
data OptionError
= BadOption OptName
| LongArgumentForZeroArgumentOption LongName OptArg
deriving (Eq, Ord, Show)
procShort
:: [(ShortName, ArgSpec a)]
-> Word
-> Maybe ([Output a], State a)
procShort shorts inp = fmap (getShortOpt shorts) (isShort inp)
getShortOpt
:: [(ShortName, ArgSpec a)]
-> (ShortName, ShortTail)
-> ([Output a], State a)
getShortOpt shorts (short, rest) = case lookup short shorts of
Nothing -> ( [OptionError (BadOption (OptName (Left short))) ], Ready)
Just arg -> procShortOpt shorts short arg rest
procShortOpt
:: [(ShortName, ArgSpec a)]
-> ShortName
-> ArgSpec a
-> ShortTail
-> ([Output a], State a)
procShortOpt opts _ (ZeroArg a) inp = (this : rest, st)
where
this = Good a
(rest, st) = case splitShortTail inp of
Nothing -> ([], Ready)
Just (opt,arg) -> getShortOpt opts (opt, arg)
procShortOpt _ shrt (OneArg f) (ShortTail inp) = case inp of
[] -> ([], Pending opt g)
where
g tok = ([res], Ready)
where
res = Good . f . optArgToString $ arg
arg = wordToOptArg tok
xs -> ([res], Ready)
where
res = Good . f . optArgToString $ optArg
optArg = OptArg xs
where
opt = OptName (Left shrt)
procShortOpt _ shrt (TwoArg f) (ShortTail inp) = ([], Pending opt g)
where
g tok1 = case inp of
[] -> ([], Pending opt h)
where
h tok2 = ([res], Ready)
where
oa2 = wordToOptArg tok2
res = Good $ f (optArgToString oa1) (optArgToString oa2)
xs -> ([res], Ready)
where
res = Good $ f (optArgToString tokArg) (optArgToString oa1)
tokArg = OptArg xs
where
oa1 = wordToOptArg tok1
opt = OptName (Left shrt)
procShortOpt _ shrt (ThreeArg f) (ShortTail inp) = ([], Pending opt g)
where
opt = OptName (Left shrt)
g tok1 = ([], Pending opt h)
where
oa1 = wordToOptArg tok1
h tok2 = case inp of
[] -> ([], Pending opt i)
where
i tok3 = ([res], Ready)
where
oa3 = wordToOptArg tok3
res = Good $ f (optArgToString oa1) (optArgToString oa2)
(optArgToString oa3)
tokInp -> ([res], Ready)
where
tokArg = wordToOptArg (Word tokInp)
res = Good $ f (optArgToString tokArg) (optArgToString oa1)
(optArgToString oa2)
where
oa2 = wordToOptArg tok2
procLong
:: [(LongName, ArgSpec a)]
-> Word
-> Maybe ([Output a], State a)
procLong longs inp = fmap (procLongOpt longs) (isLong inp)
procLongOpt
:: [(LongName, ArgSpec a)]
-> (LongName, Maybe OptArg)
-> ([Output a], State a)
procLongOpt longs (inp, mayArg) = case lookup inp longs of
Nothing -> ( [OptionError (BadOption . OptName . Right $ inp)], Ready)
Just (ZeroArg r) -> ([result], Ready)
where
result = case mayArg of
Nothing -> Good r
Just arg -> OptionError (LongArgumentForZeroArgumentOption inp arg)
Just (OneArg f) -> case mayArg of
Nothing -> ([], Pending opt run)
where
run tok = ([out], Ready)
where
out = Good $ f (optArgToString arg1)
arg1 = wordToOptArg tok
Just arg -> ([out], Ready)
where
out = Good $ f (optArgToString arg)
Just (TwoArg f) -> ([], Pending opt g)
where
g gTok = case mayArg of
Just arg1 -> ([out], Ready)
where
out = Good $ f (optArgToString arg1) (optArgToString gArg)
Nothing -> ([], Pending opt h)
where
h hTok = ([out], Ready)
where
out = Good $ f (optArgToString gArg)
(optArgToString hArg)
hArg = wordToOptArg hTok
where
gArg = wordToOptArg gTok
Just (ThreeArg f) -> ([], Pending opt g)
where
g gTok = ([], Pending opt h)
where
gArg = wordToOptArg gTok
h hTok = case mayArg of
Just arg1 -> ([out], Ready)
where
out = Good $ f (optArgToString arg1) (optArgToString gArg)
(optArgToString hArg)
Nothing -> ([], Pending opt i)
where
i iTok = ([out], Ready)
where
iArg = wordToOptArg iTok
out = Good $ f (optArgToString gArg)
(optArgToString hArg)
(optArgToString iArg)
where
hArg = wordToOptArg hTok
where
opt = OptName (Right inp)