module System.Console.CmdTheLine.Arg
(
optInfo, posInfo
, flag, flagAll, vFlag, vFlagAll
, opt, defaultOpt, optAll, defaultOptAll
, pos, revPos, posAny, posLeft, posRight, revPosLeft, revPosRight
, required, nonEmpty, lastOf
) where
import System.Console.CmdTheLine.Common
import System.Console.CmdTheLine.CmdLine ( optArg, posArg )
import System.Console.CmdTheLine.ArgVal ( ArgVal(..) )
import qualified System.Console.CmdTheLine.Err as E
import qualified System.Console.CmdTheLine.Trie as T
import Control.Applicative
import Text.PrettyPrint
import Data.List ( sort, sortBy )
import Data.Function ( on )
argFail :: Doc -> Err a
argFail = Left . MsgFail
optInfo :: [String] -> ArgInfo
optInfo names = ArgInfo
{ absence = Present ""
, argDoc = ""
, argName = ""
, argSection = defaultSection
, posKind = PosAny
, optKind = FlagKind
, optNames = map dash names
, repeatable = False
}
where
defaultSection
| names == [] = "ARGUMENTS"
| otherwise = "OPTIONS"
dash "" =
error "System.Console.CmdTheLine.Arg.optInfo recieved empty string as name"
dash str@[_] = "-" ++ str
dash str = "--" ++ str
posInfo :: ArgInfo
posInfo = optInfo []
flag :: ArgInfo -> Term Bool
flag ai =
if isPos ai
then error E.errNotPos
else Term [ai] yield
where
yield _ cl = case optArg cl ai of
[] -> Right False
[( _, _, Nothing )] -> Right True
[( _, f, Just v )] -> argFail $ E.flagValue f v
(( _, f, _ ) :
( _, g, _ ) :
_ ) -> argFail $ E.optRepeated f g
flagAll :: ArgInfo -> Term [Bool]
flagAll ai
| isPos ai = error E.errNotPos
| otherwise = Term [ai'] yield
where
ai' = ai { repeatable = True }
yield _ cl = case optArg cl ai' of
[] -> Right []
xs -> mapM truth xs
truth ( _, f, mv ) = case mv of
Nothing -> Right True
Just v -> argFail $ E.flagValue f v
vFlag :: a -> [( a, ArgInfo )] -> Term a
vFlag v assoc = Term (map flag assoc) yield
where
flag ( _, ai )
| isPos ai = error E.errNotPos
| otherwise = ai
yield _ cl = go Nothing assoc
where
go mv [] = case mv of
Nothing -> Right v
Just ( _, v ) -> Right v
go mv (( v, ai ) : rest) = case optArg cl ai of
[] -> go mv rest
[( _, f, Nothing )] -> case mv of
Nothing -> go (Just ( f, v )) rest
Just ( g, _ ) -> argFail $ E.optRepeated g f
[( _, f, Just v )] -> argFail $ E.flagValue f v
(( _, f, _ ) :
( _, g, _ ) :
_ ) -> argFail $ E.optRepeated g f
vFlagAll :: [a] -> [( a, ArgInfo)] -> Term [a]
vFlagAll vs assoc = Term (map flag assoc) yield
where
flag ( _, ai )
| isPos ai = error E.errNotOpt
| otherwise = ai { repeatable = True }
yield _ cl = do
result <- foldl addLookup (Right []) assoc
case result of
[] -> return vs
_ -> return . map snd $ sortBy (compare `on` fst) result
where
addLookup acc ( v, ai ) = case optArg cl ai of
[] -> acc
xs -> (++) <$> mapM flagVal xs <*> acc
where
flagVal ( pos, f, mv ) = case mv of
Nothing -> Right ( pos, v )
Just v -> argFail $ E.flagValue f v
parseOptValue :: ArgVal a => String -> String -> Err a
parseOptValue f v = case parser v of
Left e -> Left . UsageFail $ E.optParseValue f e
Right v -> Right v
mkOpt :: ArgVal a => Maybe a -> a -> ArgInfo -> Term a
mkOpt vopt v ai
| isPos ai = error E.errNotOpt
| otherwise = Term [ai'] yield
where
ai' = ai { absence = Present . show $ pp v
, optKind = case vopt of
Nothing -> OptKind
Just dv -> OptVal . show $ pp dv
}
yield _ cl = case optArg cl ai' of
[] -> Right v
[( _, f, Just v )] -> parseOptValue f v
[( _, f, Nothing )] -> case vopt of
Nothing -> argFail $ E.optValueMissing f
Just optv -> Right optv
(( _, f, _ ) :
( _, g, _ ) :
_ ) -> argFail $ E.optRepeated g f
opt :: ArgVal a => a -> ArgInfo -> Term a
opt = mkOpt Nothing
defaultOpt :: ArgVal a => a -> a -> ArgInfo -> Term a
defaultOpt x = mkOpt $ Just x
mkOptAll :: ( ArgVal a, Ord a ) => Maybe a -> [a] -> ArgInfo -> Term [a]
mkOptAll vopt vs ai
| isPos ai = error E.errNotOpt
| otherwise = Term [ai'] yield
where
ai' = ai { absence = Present ""
, repeatable = True
, optKind = case vopt of
Nothing -> OptKind
Just dv -> OptVal . show $ pp dv
}
yield _ cl = case optArg cl ai' of
[] -> Right vs
xs -> map snd . sortBy (compare `on` fst) <$> mapM parse xs
parse ( pos, f, mv' ) = case mv' of
Just v -> (,) pos <$> parseOptValue f v
Nothing -> case vopt of
Nothing -> argFail $ E.optValueMissing f
Just dv -> Right ( pos, dv )
optAll :: ( ArgVal a, Ord a ) => [a] -> ArgInfo -> Term [a]
optAll = mkOptAll Nothing
defaultOptAll :: ( ArgVal a, Ord a ) => a -> [a] -> ArgInfo -> Term [a]
defaultOptAll x = mkOptAll $ Just x
parsePosValue :: ArgVal a => ArgInfo -> String -> Err a
parsePosValue ai v = case parser v of
Left e -> Left . UsageFail $ E.posParseValue ai e
Right v -> Right v
mkPos :: ArgVal a => Bool -> Int -> a -> ArgInfo -> Term a
mkPos rev pos v ai = Term [ai'] yield
where
ai' = ai { absence = Present . show $ pp v
, posKind = PosN rev pos
}
yield _ cl = case posArg cl ai' of
[] -> Right v
[v] -> parsePosValue ai' v
_ -> error "saw list with more than one member in pos converter"
pos :: ArgVal a => Int -> a -> ArgInfo -> Term a
pos = mkPos False
revPos :: ArgVal a => Int -> a -> ArgInfo -> Term a
revPos = mkPos True
posList :: ArgVal a => PosKind -> [a] -> ArgInfo -> Term [a]
posList kind vs ai
| isOpt ai = error E.errNotPos
| otherwise = Term [ai'] yield
where
ai' = ai { posKind = kind }
yield _ cl = case posArg cl ai' of
[] -> Right vs
xs -> mapM (parsePosValue ai') xs
posAny :: ArgVal a => [a] -> ArgInfo -> Term [a]
posAny = posList PosAny
posLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]
posLeft = posList . PosL False
posRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]
posRight = posList . PosR False
revPosLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]
revPosLeft = posList . PosL True
revPosRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]
revPosRight = posList . PosR True
absent = map (\ ai -> ai { absence = Absent })
required :: Term (Maybe a) -> Term a
required (Term ais yield) = Term ais' yield'
where
ais' = absent ais
yield' ei cl = case yield ei cl of
Left e -> Left e
Right mv -> maybe (argFail . E.argMissing $ head ais') Right mv
nonEmpty :: Term [a] -> Term [a]
nonEmpty (Term ais yield) = Term ais' yield'
where
ais' = absent ais
yield' ei cl = case yield ei cl of
Left e -> Left e
Right [] -> argFail . E.argMissing $ head ais'
Right xs -> Right xs
lastOf :: Term [a] -> Term a
lastOf (Term ais yield) = Term ais yield'
where
yield' ei cl = case yield ei cl of
Left e -> Left e
Right [] -> argFail . E.argMissing $ head ais
Right xs -> Right $ last xs