module System.Console.CmdTheLine.Common where
import Data.Function ( on )
import Text.PrettyPrint ( Doc, text )
import Control.Applicative ( Applicative(..) )
import qualified Data.Map as M
import Control.Monad.Trans.Error
data Absence = Absent
| Present String
deriving ( Eq )
data OptKind = FlagKind
| OptKind
| OptVal String
deriving ( Eq )
data PosKind = PosAny
| PosN Bool Int
| PosL Bool Int
| PosR Bool Int
deriving ( Eq, Ord )
data ArgInfo = ArgInfo
{ absence :: Absence
, argDoc :: String
, argName :: String
, argSec :: String
, posKind :: PosKind
, optKind :: OptKind
, optNames :: [String]
, repeatable :: Bool
}
instance Eq ArgInfo where
ai == ai'
| isPos ai && isPos ai' = ((==) `on` posKind) ai ai'
| isOpt ai && isOpt ai' = ((==) `on` optNames) ai ai'
| otherwise = False
instance Ord ArgInfo where
compare ai ai'
| isPos ai && isPos ai' = (compare `on` posKind) ai ai'
| isOpt ai && isOpt ai' = (compare `on` optNames) ai ai'
| isOpt ai && isPos ai' = LT
| otherwise = GT
data Arg = Opt [( Int
, String
, Maybe String
)]
| Pos [String]
type CmdLine = M.Map ArgInfo Arg
isOpt, isPos :: ArgInfo -> Bool
isOpt ai = optNames ai /= []
isPos ai = optNames ai == []
data ManBlock = S String
| P String
| I String String
| NoBlank
deriving ( Eq )
type Title = ( String, Int, String, String, String )
type Page = ( Title, [ManBlock] )
data TermInfo = TermInfo
{
termName :: String
, termDoc :: String
, termSec :: String
, stdOptSec :: String
, version :: String
, man :: [ManBlock]
} deriving ( Eq )
defTI :: TermInfo
defTI = TermInfo
{ termName = ""
, version = ""
, termDoc = ""
, termSec = "COMMANDS"
, stdOptSec = "OPTIONS"
, man = []
}
type Command = ( TermInfo, [ArgInfo] )
data EvalInfo = EvalInfo
{ term :: Command
, main :: Command
, choices :: [Command]
}
data HelpFormat = Pager | Plain | Groff deriving ( Eq )
data Fail = MsgFail Doc
| UsageFail Doc
| HelpFail HelpFormat (Maybe String)
instance Error Fail where
strMsg = MsgFail . text
type Err = ErrorT Fail IO
type Yield a = EvalInfo -> CmdLine -> Err a
data Term a = Term [ArgInfo] (Yield a)
instance Functor Term where
fmap = yield . result . result . fmap
where
yield f (Term ais y) = Term ais (f y)
result = (.)
instance Applicative Term where
pure v = Term [] (\ _ _ -> return v)
(Term args f) <*> (Term args' v) = Term (args ++ args') wrapped
where
wrapped ei cl = f ei cl <*> v ei cl
data EvalKind = Simple
| Main
| Choice
evalKind :: EvalInfo -> EvalKind
evalKind ei
| choices ei == [] = Simple
| fst (term ei) == fst (main ei) = Main
| otherwise = Choice
descCompare :: Ord a => a -> a -> Ordering
descCompare = flip compare
splitOn :: Eq a => a -> [a] -> ( [a], [a] )
splitOn sep xs = ( left, rest' )
where
rest' = if rest == [] then rest else tail rest
( left, rest ) = span (/= sep) xs
select :: a -> [( Bool, a )] -> a
select baseCase = foldr (uncurry (?)) baseCase
where
(?) True = const
(?) False = flip const