module System.Console.CmdTheLine.Arg
( Arg
, OptInfo( optName, optDoc, optSec ), PosInfo( posName, posDoc, posSec )
, optInfo, posInfo
, flag, flagAll, vFlag, vFlagAll
, opt, defaultOpt, optAll, defaultOptAll
, pos, revPos, posAny, posLeft, posRight, revPosLeft, revPosRight
, value, required, nonEmpty, lastOf
) where
import System.Console.CmdTheLine.Common hiding ( Arg )
import System.Console.CmdTheLine.CmdLine ( optArg, posArg )
import System.Console.CmdTheLine.ArgVal ( ArgVal, pp, parser )
import qualified System.Console.CmdTheLine.Err as E
import Control.Applicative
import Control.Arrow ( second )
import Control.Monad.Trans.Error ( throwError )
import Text.PrettyPrint
import Data.List ( sortBy, foldl' )
import Data.Function ( on )
argFail :: Doc -> Err a
argFail = throwError . MsgFail
newtype Arg a = Arg (Term a)
data OptInfo = OInf
{ unOInf :: ArgInfo
, optName :: String
, optDoc :: String
, optSec :: String
}
fromOptInfo :: OptInfo -> ArgInfo
fromOptInfo oi = (unOInf oi)
{ argName = optName oi
, argDoc = optDoc oi
, argSec = optSec oi
}
data PosInfo = PInf
{ unPInf :: ArgInfo
, posName :: String
, posDoc :: String
, posSec :: String
}
fromPosInfo :: PosInfo -> ArgInfo
fromPosInfo pi = (unPInf pi)
{ argName = posName pi
, argDoc = posDoc pi
, argSec = posSec pi
}
mkInfo :: [String] -> ArgInfo
mkInfo names = ArgInfo
{ absence = Present ""
, argDoc = ""
, argName = ""
, argSec = ""
, posKind = PosAny
, optKind = FlagKind
, optNames = map dash names
, repeatable = False
}
where
dash "" =
error "System.Console.CmdTheLine.Arg.mkInfo recieved empty string as name"
dash str@[_] = "-" ++ str
dash str = "--" ++ str
optInfo :: [String] -> OptInfo
optInfo [] =
error "System.Console.CmdTheLine.Arg.optInfo recieved empty list of names."
optInfo names = OInf (mkInfo names) "" "" "OPTIONS"
posInfo :: PosInfo
posInfo = PInf (mkInfo []) "" "" "ARGUMENTS"
flag :: OptInfo -> Arg Bool
flag oi = Arg $ Term [ai] yield
where
ai = fromOptInfo oi
yield _ cl = case optArg cl ai of
[] -> return False
[( _, _, Nothing )] -> return True
[( _, f, Just v )] -> argFail $ E.flagValue f v
(( _, f, _ ) :
( _, g, _ ) :
_ ) -> argFail $ E.optRepeated f g
flagAll :: OptInfo -> Arg [Bool]
flagAll oi = Arg $ Term [ai'] yield
where
ai = fromOptInfo oi
ai' = ai { repeatable = True }
yield _ cl = case optArg cl ai' of
[] -> return []
xs -> mapM truth xs
truth ( _, f, mv ) = case mv of
Nothing -> return True
Just v -> argFail $ E.flagValue f v
vFlag :: a -> [( a, OptInfo )] -> Arg a
vFlag v assoc = Arg $ Term (map snd assoc') yield
where
assoc' = map (second fromOptInfo) assoc
yield _ cl = go Nothing assoc'
where
go mv [] = case mv of
Nothing -> return v
Just ( _, v ) -> return 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, OptInfo)] -> Arg [a]
vFlagAll vs assoc = Arg $ Term (map flag assoc') yield
where
assoc' = map (second fromOptInfo) assoc
flag ( _, ai )
| isPos ai = error E.errNotOpt
| otherwise = ai { repeatable = True }
yield _ cl = do
result <- foldl' addLookup (return []) 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 -> return ( 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 -> throwError . UsageFail $ E.optParseValue f e
Right v -> return v
mkOpt :: ArgVal a => Maybe a -> a -> OptInfo -> Arg a
mkOpt vopt v oi = Arg $ Term [ai'] yield
where
ai = fromOptInfo oi
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
[] -> return v
[( _, f, Just v )] -> parseOptValue f v
[( _, f, Nothing )] -> case vopt of
Nothing -> argFail $ E.optValueMissing f
Just optv -> return optv
(( _, f, _ ) :
( _, g, _ ) :
_ ) -> argFail $ E.optRepeated g f
opt :: ArgVal a => a -> OptInfo -> Arg a
opt = mkOpt Nothing
defaultOpt :: ArgVal a => a -> a -> OptInfo -> Arg a
defaultOpt x = mkOpt $ Just x
mkOptAll :: ( ArgVal a, Ord a ) => Maybe a -> [a] -> OptInfo -> Arg [a]
mkOptAll vopt vs oi = Arg $ Term [ai'] yield
where
ai = fromOptInfo oi
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
[] -> return 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 -> return ( pos, dv )
optAll :: ( ArgVal a, Ord a ) => [a] -> OptInfo -> Arg [a]
optAll = mkOptAll Nothing
defaultOptAll :: ( ArgVal a, Ord a ) => a -> [a] -> OptInfo -> Arg [a]
defaultOptAll x = mkOptAll $ Just x
parsePosValue :: ArgVal a => ArgInfo -> String -> Err a
parsePosValue ai v = case parser v of
Left e -> throwError . UsageFail $ E.posParseValue ai e
Right v -> return v
mkPos :: ArgVal a => Bool -> Int -> a -> PosInfo -> Arg a
mkPos rev pos v oi = Arg $ Term [ai'] yield
where
ai = fromPosInfo oi
ai' = ai { absence = Present . show $ pp v
, posKind = PosN rev pos
}
yield _ cl = case posArg cl ai' of
[] -> return v
[v] -> parsePosValue ai' v
_ -> error "saw list with more than one member in pos converter"
pos :: ArgVal a => Int -> a -> PosInfo -> Arg a
pos = mkPos False
revPos :: ArgVal a => Int -> a -> PosInfo -> Arg a
revPos = mkPos True
posList :: ArgVal a => PosKind -> [a] -> PosInfo -> Arg [a]
posList kind vs oi = Arg $ Term [ai'] yield
where
ai = fromPosInfo oi
ai' = ai { posKind = kind }
yield _ cl = case posArg cl ai' of
[] -> return vs
xs -> mapM (parsePosValue ai') xs
posAny :: ArgVal a => [a] -> PosInfo -> Arg [a]
posAny = posList PosAny
posLeft :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a]
posLeft = posList . PosL False
posRight :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a]
posRight = posList . PosR False
revPosLeft :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a]
revPosLeft = posList . PosL True
revPosRight :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a]
revPosRight = posList . PosR True
absent :: [ArgInfo] -> [ArgInfo]
absent = map (\ ai -> ai { absence = Absent })
value :: Arg a -> Term a
value (Arg term) = term
required :: Arg (Maybe a) -> Term a
required (Arg (Term ais yield)) = Term ais' yield'
where
ais' = absent ais
yield' ei cl = aux =<< yield ei cl
aux = maybe (argFail . E.argMissing $ head ais') return
nonEmpty :: Arg [a] -> Term [a]
nonEmpty (Arg (Term ais yield)) = Term ais' yield'
where
ais' = absent ais
yield' ei cl = aux =<< yield ei cl
aux [] = argFail . E.argMissing $ head ais'
aux xs = return xs
lastOf :: Arg [a] -> Term a
lastOf (Arg (Term ais yield)) = Term ais yield'
where
yield' ei cl = aux =<< yield ei cl
aux [] = argFail . E.argMissing $ head ais
aux xs = return $ last xs