module Options.Applicative.Types (
ParserInfo(..),
ParserDesc(..),
Context(..),
P,
infoParser,
infoDesc,
infoFullDesc,
infoProgDesc,
infoHeader,
infoFooter,
infoFailureCode,
descFull,
descProg,
descHeader,
descFooter,
descFailureCode,
Option(..),
OptName(..),
OptReader(..),
Parser(..),
ParserFailure(..),
optMain,
optDefault,
optShow,
optHelp,
optMetaVar,
optCont
) where
import Control.Applicative
import Control.Category
import Control.Monad
import Control.Monad.Trans.Error
import Control.Monad.Trans.Writer
import Data.Lens.Common
import Data.Monoid
import Prelude hiding ((.), id)
import System.Exit
data ParserInfo a = ParserInfo
{ _infoParser :: Parser a
, _infoDesc :: ParserDesc
} deriving Functor
data ParserDesc = ParserDesc
{ _descFull:: Bool
, _descProg:: String
, _descHeader :: String
, _descFooter :: String
, _descFailureCode :: Int
}
data Context where
Context :: Maybe String -> ParserInfo a -> Context
NullContext :: Context
instance Monoid Context where
mempty = NullContext
mappend _ c@(Context _ _) = c
mappend c _ = c
type P = ErrorT String (Writer Context)
data OptName = OptShort !Char
| OptLong !String
deriving (Eq, Ord)
data Option r a = Option
{ _optMain :: OptReader r
, _optDefault :: Maybe a
, _optShow :: Bool
, _optHelp :: String
, _optMetaVar :: String
, _optCont :: r -> P (Parser a) }
deriving Functor
data OptReader a
= OptReader [OptName] (String -> Maybe a)
| FlagReader [OptName] !a
| ArgReader (String -> Maybe a)
| CmdReader [String] (String -> Maybe (ParserInfo a))
deriving Functor
data Parser a where
NilP :: a -> Parser a
ConsP :: Option r (a -> b)
-> Parser a
-> Parser b
instance Functor Parser where
fmap f (NilP x) = NilP (f x)
fmap f (ConsP opt p) = ConsP (fmap (f.) opt) p
instance Applicative Parser where
pure = NilP
NilP f <*> p = fmap f p
ConsP opt p1 <*> p2 =
ConsP (fmap uncurry opt) $ (,) <$> p1 <*> p2
data ParserFailure = ParserFailure
{ errMessage :: String -> String
, errExitCode :: ExitCode
}
instance Error ParserFailure where
strMsg msg = ParserFailure
{ errMessage = \_ -> msg
, errExitCode = ExitFailure 1 }
optMain :: Lens (Option r a) (OptReader r)
optMain = lens _optMain $ \x o -> o { _optMain = x }
optDefault :: Lens (Option r a) (Maybe a)
optDefault = lens _optDefault $ \x o -> o { _optDefault = x }
optShow :: Lens (Option r a) Bool
optShow = lens _optShow $ \x o -> o { _optShow = x }
optHelp :: Lens (Option r a) String
optHelp = lens _optHelp $ \x o -> o { _optHelp = x }
optMetaVar :: Lens (Option r a) String
optMetaVar = lens _optMetaVar $ \x o -> o { _optMetaVar = x }
optCont :: Lens (Option r a) (r -> P (Parser a))
optCont = lens _optCont $ \x o -> o { _optCont = x }
descFull :: Lens ParserDesc Bool
descFull = lens _descFull $ \x p -> p { _descFull = x }
descProg :: Lens ParserDesc String
descProg = lens _descProg $ \x p -> p { _descProg = x }
descHeader :: Lens ParserDesc String
descHeader = lens _descHeader $ \x p -> p { _descHeader = x }
descFooter :: Lens ParserDesc String
descFooter = lens _descFooter $ \x p -> p { _descFooter = x }
descFailureCode :: Lens ParserDesc Int
descFailureCode = lens _descFailureCode $ \x p -> p { _descFailureCode = x }
infoParser :: Lens (ParserInfo a) (Parser a)
infoParser = lens _infoParser $ \x p -> p { _infoParser = x }
infoDesc :: Lens (ParserInfo a) ParserDesc
infoDesc = lens _infoDesc $ \x p -> p { _infoDesc = x }
infoFullDesc :: Lens (ParserInfo a) Bool
infoFullDesc = descFull . infoDesc
infoProgDesc :: Lens (ParserInfo a) String
infoProgDesc = descProg . infoDesc
infoHeader :: Lens (ParserInfo a) String
infoHeader = descHeader . infoDesc
infoFooter :: Lens (ParserInfo a) String
infoFooter = descFooter . infoDesc
infoFailureCode :: Lens (ParserInfo a) Int
infoFailureCode = descFailureCode . infoDesc