{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module UI.Butcher.Monadic.Internal.Types
( CommandDesc (..)
, cmd_mParent
, cmd_help
, cmd_synopsis
, cmd_parts
, cmd_out
, cmd_children
, cmd_visibility
, emptyCommandDesc
, CmdParserF (..)
, CmdParser
, PartDesc (..)
, Input (..)
, ParsingError (..)
, addSuggestion
, ManyUpperBound (..)
, Visibility (..)
, CompletionItem (..)
)
where
#include "prelude.inc"
import Control.Monad.Free
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
import qualified Lens.Micro.TH as LensTH
import qualified Text.PrettyPrint as PP
data Input = InputString String | InputArgs [String]
deriving (Show, Eq)
data ParsingError = ParsingError
{ _pe_messages :: [String]
, _pe_remaining :: Input
}
deriving (Show, Eq)
data ManyUpperBound
= ManyUpperBound1
| ManyUpperBoundN
data Visibility = Visible | Hidden
deriving (Show, Eq)
data CmdParserF f out a
= CmdParserHelp PP.Doc a
| CmdParserSynopsis String a
| CmdParserPeekDesc (CommandDesc () -> a)
| CmdParserPeekInput (String -> a)
| forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a)
| forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a)
| forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a)
| forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)
| CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
| CmdParserGrouped String a
| CmdParserGroupEnd a
| forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a)
type CmdParser f out = Free (CmdParserF f out)
data CommandDesc out = CommandDesc
{ _cmd_mParent :: Maybe (Maybe String, CommandDesc out)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: Deque (Maybe String, CommandDesc out)
, _cmd_visibility :: Visibility
}
data PartDesc
= PartLiteral String
| PartVariable String
| PartOptional PartDesc
| PartAlts [PartDesc]
| PartSeq [PartDesc]
| PartDefault String
PartDesc
| PartSuggestion [CompletionItem] PartDesc
| PartRedirect String
PartDesc
| PartReorder [PartDesc]
| PartMany PartDesc
| PartWithHelp PP.Doc PartDesc
| PartHidden PartDesc
deriving Show
addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc
addSuggestion Nothing = id
addSuggestion (Just sugs) = PartSuggestion sugs
data CompletionItem
= CompletionString String
| CompletionDirectory
| CompletionFile
deriving Show
deriving instance Functor (CmdParserF f out)
deriving instance Functor CommandDesc
emptyCommandDesc :: CommandDesc out
emptyCommandDesc =
CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
instance Show (CommandDesc out) where
show c = "Command help=" ++ show (_cmd_help c)
++ " synopsis=" ++ show (_cmd_synopsis c)
++ " mParent=" ++ show (fst <$> _cmd_mParent c)
++ " out=" ++ maybe "(none)" (\_ -> "(smth)") (_cmd_out c)
++ " parts.length=" ++ show (length $ _cmd_parts c)
++ " parts=" ++ show (_cmd_parts c)
++ " children=" ++ show (fst <$> _cmd_children c)
LensTH.makeLenses ''CommandDesc
LensTH.makeLenses ''PartDesc
--
-- instance Show FlagDesc where
-- show (FlagDesc _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve
-- class Typeable a => IsParam a where
-- paramParse :: String -> Maybe (a, String, String) -- value, representation, rest
-- paramStaticDef :: a
-- emptyParamDesc :: ParamDesc a
-- emptyParamDesc = ParamDesc Nothing Nothing
-- deriving instance Show a => Show (ParamDesc a)
-- instance Show a => Show (CmdParserF out a) where
-- show (CmdParserHelp s x) = "(CmdParserHelp " ++ show s ++ " " ++ show x ++ ")"
-- show (CmdParserFlag shorts longs _ _) = "(CmdParserFlag -" ++ shorts ++ " " ++ show longs ++ ")"
-- show (CmdParserParam s _ _) = "(CmdParserParam " ++ s ++ ")"
-- show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")"
-- show (CmdParserRun _) = "CmdParserRun"
instance Alternative Deque where
empty = mempty
(<|>) = Deque.prepend
instance MonadPlus Deque