symantic-cli 2.0.0.20190615 → 2.2.1.20190629
raw patch · 6 files changed
+440/−464 lines, 6 filesdep +megaparsecdep ~symantic-document
Dependencies added: megaparsec
Dependency ranges changed: symantic-document
Files
- Symantic/CLI.hs +10/−0
- Symantic/CLI/API.hs +7/−8
- Symantic/CLI/Help.hs +19/−12
- Symantic/CLI/Parser.hs +389/−431
- Symantic/CLI/Schema.hs +10/−10
- symantic-cli.cabal +5/−3
+ Symantic/CLI.hs view
@@ -0,0 +1,10 @@+module Symantic.CLI+ ( module Symantic.CLI.API+ , module Symantic.CLI.Parser+ , module Symantic.CLI.Schema+ , module Symantic.CLI.Help+ ) where+import Symantic.CLI.API+import Symantic.CLI.Parser+import Symantic.CLI.Schema+import Symantic.CLI.Help
Symantic/CLI/API.hs view
@@ -5,20 +5,14 @@ {-# LANGUAGE UndecidableInstances #-} -- for type instance defaults module Symantic.CLI.API where -import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Eq (Eq) import Data.Function (($), (.), id)-import Data.Int (Int) import Data.Kind (Constraint)-import Data.Maybe (Maybe(..), maybe)-import Data.Monoid (Monoid)+import Data.Maybe (Maybe(..)) import Data.String (String)-import Data.Text (Text) import Text.Show (Show)-import Data.Functor (Functor(..), (<$>)) -- * Class 'App' class App repr where@@ -34,13 +28,18 @@ -- * Class 'Alt' class Alt repr where (<!>) :: repr a k -> repr b k -> repr (a:!:b) k+ opt :: repr (a->k) k -> repr (Maybe a->k) k -- Trans defaults default (<!>) :: Trans repr => Alt (UnTrans repr) => repr a k -> repr b k -> repr (a:!:b) k x <!> y = noTrans (unTrans x <!> unTrans y)- opt :: repr (a->k) k -> repr (Maybe a->k) k+ default opt ::+ Trans repr =>+ Alt (UnTrans repr) =>+ repr (a->k) k -> repr (Maybe a->k) k+ opt = noTrans . opt . unTrans infixr 3 <!> -- ** Type (':!:')
Symantic/CLI/Help.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (Word *) d+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d module Symantic.CLI.Help where import Control.Applicative (Applicative(..))@@ -99,7 +99,7 @@ HelpInh d -> Tree.Forest (HelpNode, d) -> d runHelpNodes inh [] = mempty-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Command, _) t0s)+runHelpNodes inh ( t0@(Tree.Node _ t0s) : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) = runHelpNode t0 <> Doc.newline <>@@ -111,15 +111,16 @@ Doc.newline <> runHelpNodes inh (t1:ts) runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)- : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =+ : t1@(Tree.Node (_, _) _) : ts ) = runHelpNode t0 <> Doc.newline <> (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <> runHelpNodes inh (t1:ts)-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Env, _) _)- : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)+ : t1 : ts ) = runHelpNode t0 <> Doc.newline <>+ Doc.newline <> runHelpNodes inh (t1:ts) runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) = runHelpNode t0 <>@@ -131,10 +132,12 @@ Doc.newline <> Doc.newline <> runHelpNodes inh (t1:ts)-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)- : t1 : ts ) =+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) = runHelpNode t0 <> Doc.newline <>+ runHelpNodes inh (t1:ts)+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =+ runHelpNode t0 <> Doc.newline <> runHelpNodes inh (t1:ts) runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts@@ -182,10 +185,13 @@ type EnvConstraint (Help d) a = () env' n = Help (\inh ->- let ts = maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) in+ let ts =+ if helpInh_full inh+ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)+ else [] in let d = Doc.breakfill (helpInh_tag_indent inh)- (Doc.bold (Doc.green (Doc.docFrom (Doc.Word n)))+ (Doc.bold (Doc.green (Doc.from (Doc.Word n))) <> Doc.space) <> (if null ts then mempty else Doc.space) <> Doc.align (runHelpNodes inh ts)@@ -206,7 +212,8 @@ , helpInh_command_rule = True } in let d =- (if not (null n) && helpInh_command_rule inh then ref<>Doc.space<>"::= " else mempty)+ (if not (null n) && helpInh_command_rule inh+ then ref<>Doc.space<>"::= " else mempty) <> Schema.runSchema schema (helpInh_schema inh) <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline) <> Doc.incrIndent (helpInh_command_indent inh)@@ -220,7 +227,7 @@ Doc.bold $ Doc.angles $ Doc.magentaer $- Doc.docFrom (Doc.Word n)+ Doc.from (Doc.Word n) instance Docable d => CLI_Tag (Help d) where type TagConstraint (Help d) a = () tagged n (Help h s) =@@ -297,7 +304,7 @@ Doc.bold $ Doc.angles $ Doc.magentaer $- Doc.docFrom (Doc.Word n)+ Doc.from (Doc.Word n) type HelpResponseArgs = SchemaResponseArgs instance Docable d => CLI_Response (Help d) where type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
Symantic/CLI/Parser.hs view
@@ -1,300 +1,240 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-} -- for Router {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used) module Symantic.CLI.Parser where +import Control.Arrow (second) import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)-import Control.Arrow (first)-import Control.Monad (Monad(..), join, sequence, unless)+import Control.Monad (Monad(..), join, sequence, forM_, void) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Except (ExceptT(..),throwE,runExceptT) import Control.Monad.Trans.State (StateT(..),evalState,get,put) import Data.Bool import Data.Char (Char) import Data.Either (Either(..)) import Data.Eq (Eq(..))+import Data.Foldable (null, toList) import Data.Function (($), (.), id, const)-import Data.Functor (Functor(..), (<$>))+import Data.Functor (Functor(..), (<$>), ($>)) import Data.Functor.Identity (Identity(..)) import Data.Int (Int)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map)-import Data.Maybe (Maybe(..), maybe)-import Data.Monoid (Monoid(..))+import Data.Maybe (Maybe(..), maybe, isNothing) import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String)+import Data.Tuple (snd)+import Numeric.Natural (Natural)+import Prelude (Integer, Num(..), error) import System.Environment (lookupEnv) import System.IO (IO)-import Text.Read (readEither)+import Text.Read (Read, readEither) import Text.Show (Show(..), ShowS, showString, showParen) import Type.Reflection as Reflection import qualified Data.List as List-import qualified Data.Text.Lazy.IO as TL-import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.IO as TL import qualified Symantic.Document as Doc import qualified System.IO as IO--- import qualified Debug.Trace as Debug+import qualified Text.Megaparsec as P import Symantic.CLI.API -- * Type 'Parser'-newtype Parser d f k = Parser- { unParser :: StateT ParserState- (ParserCheckT [ParserError] IO)- (f -> k) -- Reader f k+newtype Parser e d f k = Parser+ { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k }-instance Functor (Parser d f) where++parser ::+ P.ShowErrorComponent e =>+ Router (Parser e d) handlers (Response (Router (Parser e d))) ->+ handlers ->+ [Arg] -> IO ()+parser api handlers args = do+ P.runParserT+ (unParser $ unTrans $ router api)+ "" args >>= \case+ Left err ->+ forM_ (P.bundleErrors err) $ \e -> do+ IO.putStr $+ "Error parsing the command at argument #" <>+ show (P.errorOffset e + 1) <> ":\n" <>+ parseErrorTextPretty e+ Right app -> unResponseParser $ app handlers++-- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.+parseErrorTextPretty ::+ forall s e.+ (P.Stream s, P.ShowErrorComponent e) =>+ P.ParseError s e -> String+parseErrorTextPretty (P.TrivialError _ us ps) =+ if isNothing us && Set.null ps+ then "unknown parse error\n"+ else+ messageItemsPretty "unexpected "+ (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>+ messageItemsPretty "expecting "+ (showErrorItem pxy <$> Set.toAscList ps)+ where pxy = Proxy :: Proxy s+parseErrorTextPretty err = P.parseErrorTextPretty err++messageItemsPretty :: String -> [String] -> String+messageItemsPretty prefix ts+ | null ts = ""+ | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"++orList :: NonEmpty String -> String+orList (x:|[]) = x+orList (x:|[y]) = x <> " or " <> y+orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs++showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String+showErrorItem pxy = \case+ P.Tokens ts -> P.showTokens pxy ts+ P.Label label -> NonEmpty.toList label+ P.EndOfInput -> "end of input"+++instance Functor (Parser e d f) where a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x-instance Applicative (Parser d f) where+instance Applicative (Parser e d f) where pure = Parser . pure . const Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x-instance Alternative (Parser d f) where- empty = Parser $ do- StateT $ \st ->- throwE $ Fail st [ParserError_Alt]- Parser x <|> Parser y = Parser $- StateT $ \st -> do- lift (runExceptT (runStateT x st)) >>= \case- Left xe | FailFatal{} <- xe -> throwE xe- | otherwise ->- lift (runExceptT (runStateT y st)) >>= \case- Left ye -> throwE (xe<>ye)- Right yr -> ExceptT $ return $ Right yr- Right xr ->- return xr-instance Permutable (Parser d) where- type Permutation (Parser d) = ParserPerm d (Parser d)+instance Ord e => Alternative (Parser e d f) where+ empty = Parser empty+ Parser x <|> Parser y = Parser $ x <|> y+instance Ord e => Permutable (Parser e d) where+ type Permutation (Parser e d) = ParserPerm e d (Parser e d) runPermutation (ParserPerm ma p) = Parser $ do u2p <- unParser $ optional p unParser $ case u2p () of- Nothing -> maybe empty (Parser . return) ma Just perm -> runPermutation perm+ Nothing ->+ maybe+ (Parser $ P.token (const Nothing) Set.empty)+ -- NOTE: not 'empty' so that 'P.TrivialError' has the unexpected token.+ (Parser . return) ma toPermutation (Parser x) = ParserPerm Nothing (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x) toPermDefault a (Parser x) = ParserPerm (Just ($ a)) (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)--parser ::- -- d ~ String => -- dummy d- Router (Parser d) handlers (Response (Router (Parser d))) ->- handlers ->- [Arg] -> IO ()-parser api handlers args = do- lrApp <-- runExceptT $ runStateT- (unParser $ unTrans $ router api)- ParserState- { parserState_args = args- }- case lrApp of- Left err -> IO.print err- Right (app, _st) -> unResponseParser $ app handlers---- | Helper to parse the current argument.-popArg ::- ParserError ->- (Arg ->- StateT ParserState (ParserCheckT [ParserError] IO) a) ->- StateT ParserState (ParserCheckT [ParserError] IO) a-popArg errEnd f = do- st <- get- case parserState_args st of- [] -> lift $ throwE $ Fail st [errEnd]- curr:next -> do- lift (lift (runExceptT (runStateT (f curr) (ParserState next)))) >>= \case- Left err -> lift $ throwE err- Right (a,st') -> do- put st'- return a---- ** Type 'Arg'-data Arg- = ArgTagShort Char- | ArgTagLong Name- | ArgSegment Segment- deriving (Eq,Show)--parseArgs :: [String] -> [Arg]-parseArgs ss =- join $- (`evalState` False) $- sequence (f <$> ss)- where- f :: String -> StateT Bool Identity [Arg]- f s = do- skip <- get- if skip then return [ArgSegment s]- else case s of- '-':'-':[] -> do- put True- return [ArgTagLong ""]- '-':'-':cs -> return [ArgTagLong cs]- '-':cs@(_:_) -> return $ ArgTagShort <$> cs- seg -> return [ArgSegment seg]---- ** Type 'ParserState'-newtype ParserState = ParserState- { parserState_args :: [Arg]- } deriving (Show)---- ** Type 'Router'-type ParserCheckT e = ExceptT (Fail e)---- ** Type 'ParserError'-data ParserError- = ParserError_Alt -- ^ When there is no alternative.- | ParserError_Arg { expectedArg :: Name, gotArg :: Maybe Arg }- | ParserError_Env { expectedEnv :: Name, gotEnv :: Maybe String }- | ParserError_Tag { expectedTag :: Tag, gotArg :: Maybe Arg }- | ParserError_Cmd { expectedCmd :: [Name], gotCmd :: Maybe Arg }- | ParserError_Var { expectedVar :: Name, gotVar :: Maybe Arg }- | ParserError_End { gotEnd :: Arg }- deriving (Eq,Show)---- *** Type 'RouteResult'-type RouteResult e = Either (Fail e)---- *** Type 'Fail'-data Fail e- = Fail ParserState e -- ^ Keep trying other paths.- | FailFatal !ParserState !e -- ^ Don't try other paths.- deriving (Show)-failState :: Fail e -> ParserState-failState (Fail st _) = st-failState (FailFatal st _) = st-failError :: Fail e -> e-failError (Fail _st e) = e-failError (FailFatal _st e) = e-instance Semigroup e => Semigroup (Fail e) where- Fail _ x <> Fail st y = Fail st (x<>y)- FailFatal _ x <> Fail st _y = FailFatal st (x{-<>y-})- Fail _ _x <> FailFatal st y = FailFatal st ({-x<>-}y)- FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)-instance Monoid e => Monoid (Fail e) where- mempty = Fail (ParserState []) mempty- mappend = (<>)---- * Class 'FromSegment'-class FromSegment a where- fromSegment :: Segment -> Either String a-instance FromSegment String where- fromSegment = Right-instance FromSegment Int where- fromSegment = readEither-instance FromSegment Bool where- fromSegment = readEither---- ** Type 'ParserPerm'-data ParserPerm d repr k a = ParserPerm- { permutation_result :: !(Maybe ((a->k)->k))- , permutation_parser :: repr () (ParserPerm d repr k a)- }--instance (App repr, Functor (repr ())) => Functor (ParserPerm d repr k) where- a2b `fmap` ParserPerm a ma = ParserPerm- ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)- ((a2b `fmap`) `fmap` ma)-instance (App repr, Functor (repr ()), Alternative (repr ())) => Applicative (ParserPerm d repr k) where- pure a = ParserPerm (Just ($ a)) empty- lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =- ParserPerm a (lhsAlt <|> rhsAlt)- where- a =- (\a2b2k2k a2k2k -> \b2k ->- a2b2k2k $ \a2b -> a2k2k (b2k . a2b)- ) <$> f <*> x- lhsAlt = (<*> rhs) <$> ma2b- rhsAlt = (lhs <*>) <$> ma-instance CLI_Help repr => CLI_Help (ParserPerm d repr) where- type HelpConstraint (ParserPerm d repr) d' = HelpConstraint (Parser d) d'- program _n = id- rule _n = id--noTransParserPerm ::- Trans repr =>- Functor (UnTrans repr ()) =>- ParserPerm d (UnTrans repr) k a -> ParserPerm d repr k a-noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)--unTransParserPerm ::- Trans repr =>- Functor (UnTrans repr ()) =>- ParserPerm d repr k a -> ParserPerm d (UnTrans repr) k a-unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)--hoistParserPerm ::- Functor (repr ()) =>- (forall a b. repr a b -> repr a b) ->- ParserPerm d repr k c -> ParserPerm d repr k c-hoistParserPerm f (ParserPerm a ma) =- ParserPerm a (hoistParserPerm f <$> f ma)--instance App (Parser d) where+instance App (Parser e d) where Parser x <.> Parser y = Parser $ x >>= \a2b -> (. a2b) <$> y-instance Alt (Parser d) where+instance Ord e => Alt (Parser e d) where Parser x <!> Parser y = Parser $- StateT $ \st -> do- lift (runExceptT (runStateT x st)) >>= \case- Left xe | FailFatal{} <- xe -> throwE xe- | otherwise ->- lift (runExceptT (runStateT y st)) >>= \case- Left ye -> throwE (xe<>ye)- Right yr -> ExceptT $ return $ Right $- first (\b2k (_a:!:b) -> b2k b) yr- Right xr ->- return $ first (\a2k (a:!:_b) -> a2k a) xr- opt (Parser x) = Parser $ do- st <- get- lift (lift (runExceptT $ runStateT x st)) >>= \case- Left err -> return ($ Nothing)- Right (a,st') -> do- put st'- return (mapCont Just a)-instance AltApp (Parser d) where+ (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>+ (\b2k (_a:!:b) -> b2k b) <$> y+ opt (Parser x) = Parser $+ mapCont Just <$> P.try x+instance Ord e => AltApp (Parser e d) where many0 (Parser x) = Parser $ concatCont <$> many x many1 (Parser x) = Parser $ concatCont <$> some x-instance Pro (Parser d) where+instance Pro (Parser e d) where dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r-instance CLI_Command (Parser d) where- -- type CommandConstraint (Parser d) a = ()+instance Ord e => CLI_Command (Parser e d) where+ -- type CommandConstraint (Parser e d) a = () command "" x = x- command n x = commands $ Map.singleton n x-instance CLI_Var (Parser d) where- type VarConstraint (Parser d) a = FromSegment a- var' :: forall a k. VarConstraint (Parser d) a => Name -> Parser d (a->k) k+ command n x = commands $ Map.singleton n (Partial_Full, x)+instance Ord e => CLI_Tag (Parser e d) where+ type TagConstraint (Parser e d) a = ()+ tagged name p = Parser $ P.try $ do+ void $ (`P.token` exp) $ \tok ->+ if lookupTag tok name+ then Just tok+ else Nothing+ unParser p+ where+ exp =+ case name of+ TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t+ TagLong t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong t+ Tag s l -> Set.fromList+ [ P.Tokens $ pure $ ArgTagShort s+ , P.Tokens $ pure $ ArgTagLong l+ ]+ lookupTag (ArgTagShort x) (TagShort y) = x == y+ lookupTag (ArgTagShort x) (Tag y _) = x == y+ lookupTag (ArgTagLong x) (TagLong y) = x == y+ lookupTag (ArgTagLong x) (Tag _ y) = x == y+ lookupTag _ _ = False+ endOpts = Parser $ do+ (`P.token` exp) $ \case+ ArgTagLong "" -> Just id+ _ -> Nothing+ where+ exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""+instance Ord e => CLI_Var (Parser e d) where+ type VarConstraint (Parser e d) a = (IOType a, FromSegment a)+ var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k var' name = Parser $ do- popArg (ParserError_Var name Nothing) $ \curr -> do- st@ParserState{..} <- get- case curr of- ArgSegment seg ->- case fromSegment seg of- Left err -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]- Right a -> return ($ a)- _ -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]+ seg <- (`P.token` expName) $ \case+ ArgSegment seg -> Just seg+ _ -> Nothing+ lift (fromSegment seg) >>= \case+ Left err -> P.failure got expType+ where+ got = Just $ P.Tokens $ pure $ ArgSegment seg+ expType = Set.singleton $ P.Label $ NonEmpty.fromList $+ "<"<>name<>"> to be of type "<>ioType @a+ <> case err of+ "Prelude.read: no parse" -> ""+ "" -> ""+ _ -> ": "<>err+ Right a -> return ($ a)+ where+ expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">" just a = Parser $ return ($ a) nothing = Parser $ return id-instance CLI_Env (Parser d) where- type EnvConstraint (Parser d) a = FromSegment a- env' :: forall a k. EnvConstraint (Parser d) a => Name -> Parser d (a->k) k- env' name = Parser $ do- st <- get- lift (lift (lookupEnv name)) >>= \case- Nothing -> lift $ throwE $ Fail st [ParserError_Env name Nothing]- Just raw ->- case fromSegment raw of- Left err -> lift $ throwE $ Fail st [ParserError_Env name (Just raw)]- Right a -> return ($ a)+instance Ord e => CLI_Env (Parser e d) where+ type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)+ env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k+ env' name = Parser $+ lift (lookupEnv name) >>= \case+ Nothing -> P.failure got exp+ where+ got = Nothing+ exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"+ Just val ->+ lift (fromSegment val) >>= \case+ Right a -> return ($ a)+ Left err -> P.failure got exp+ where+ got = Just $ P.Tokens $ pure $ ArgEnv name val+ exp = Set.singleton $ P.Label $ NonEmpty.fromList $+ "${"<>name<>"} to be of type "<>ioType @a+ <> case err of+ "Prelude.read: no parse" -> ""+ "" -> ""+ _ -> ": "<>err+instance Ord e => CLI_Response (Parser e d) where+ type ResponseConstraint (Parser e d) a = Outputable a+ type ResponseArgs (Parser e d) a = ParserResponseArgs a+ type Response (Parser e d) = ParserResponse+ response' = Parser $+ P.eof $> \({-ParserResponseArgs-} io) ->+ ParserResponse $ io >>= output+instance Ord e => CLI_Help (Parser e d) where+ type HelpConstraint (Parser e d) d' = d ~ d'+ help _msg = id+ program n = Parser . P.label n . unParser+ rule n = Parser . P.label n . unParser concatCont :: [(a->k)->k] -> ([a]->k)->k concatCont = List.foldr (consCont (:)) ($ [])@@ -305,50 +245,10 @@ mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k) mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b) -instance CLI_Tag (Parser d) where- type TagConstraint (Parser d) a = ()- tagged name p = Parser $ do- popArg (ParserError_Tag name Nothing) $ \curr -> do- st <- get- case lookupTag curr name of- False -> lift $ throwE $ Fail st [ParserError_Tag name (Just curr)]- True ->- lift (lift (runExceptT (runStateT (unParser p) st))) >>= \case- Left (Fail st' e) -> lift $ throwE $ FailFatal st' e- Left e -> lift $ throwE e- Right (a,st') -> do- put st'- return a- where- lookupTag (ArgTagShort x) (TagShort y) = x == y- lookupTag (ArgTagShort x) (Tag y _) = x == y- lookupTag (ArgTagLong x) (TagLong y) = x == y- lookupTag (ArgTagLong x) (Tag _ y) = x == y- lookupTag _ _ = False- endOpts = Parser $ do- popArg (ParserError_Tag (TagLong "") Nothing) $ \curr -> do- st@ParserState{..} <- get- case curr of- ArgTagLong "" -> return id- _ -> return id -- TODO: raise an error and use option?- -- ** Type 'ParserResponse' newtype ParserResponse = ParserResponse { unResponseParser :: IO () } -- ** Type 'ParserResponseArgs'-newtype ParserResponseArgs a = ParserResponseArgs (IO a)- deriving (Functor,Applicative,Monad)--instance CLI_Response (Parser d) where- type ResponseConstraint (Parser d) a = Outputable a- type ResponseArgs (Parser d) a = ParserResponseArgs a- type Response (Parser d) = ParserResponse- response' = Parser $ do- st <- get- unless (List.null $ parserState_args st) $ do- lift $ throwE $ Fail st [ParserError_End $- List.head $ parserState_args st]- return $ \(ParserResponseArgs io) ->- ParserResponse $ io >>= output+type ParserResponseArgs = IO -- * Class 'Outputable' -- | Output of a CLI.@@ -356,24 +256,31 @@ output :: a -> IO () default output :: Show a => a -> IO () output = IO.print-instance Outputable String where- output = IO.putStrLn +instance Outputable () where+ output = return+instance Outputable Bool+instance Outputable Int+instance Outputable Integer+instance Outputable Natural+instance Outputable String where+ output = IO.putStr+instance Outputable Text.Text where+ output = Text.putStr+instance Outputable TL.Text where+ output = TL.putStr instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where output = TL.putStr . TLB.toLazyText . Doc.runPlain . Doc.runAnsiText--{--instance Outputable (Doc.Reorg Doc.Term) where- output = TL.hPutStrLn IO.stdout . Doc.textTerm-instance Outputable (Doc.Reorg DocIO.TermIO) where- output = DocIO.runTermIO IO.stdout-instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where- output = uncurry DocIO.runTermIO--}+instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where+ output (h,d) =+ TL.hPutStr h $+ TLB.toLazyText $+ Doc.runPlain $+ Doc.runAnsiText d -- * Class 'IOType' -- | Like a MIME type but for input/output of a CLI.@@ -382,67 +289,107 @@ default ioType :: Reflection.Typeable a => String ioType = show (Reflection.typeRep @a) +instance IOType ()+instance IOType Bool+instance IOType Int+instance IOType Integer+instance IOType Natural instance IOType String+instance IOType Text.Text+instance IOType TL.Text instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))-{--instance IOType (Doc.Reorg Doc.Term) where-instance IOType (Doc.Reorg DocIO.TermIO) where-instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)--}+instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) -instance CLI_Help (Parser d) where- type HelpConstraint (Parser d) d' = d ~ d'- help _msg = id+-- * Class 'FromSegment'+class FromSegment a where+ fromSegment :: Segment -> IO (Either String a)+ default fromSegment :: Read a => Segment -> IO (Either String a)+ fromSegment = return . readEither+instance FromSegment String where+ fromSegment = return . Right+instance FromSegment Text.Text where+ fromSegment = return . Right . Text.pack+instance FromSegment TL.Text where+ fromSegment = return . Right . TL.pack+instance FromSegment Bool+instance FromSegment Int+instance FromSegment Integer+instance FromSegment Natural++-- ** Type 'Partial'+data Partial+ = Partial_Prefix+ | Partial_Full+ deriving (Show)++-- ** Type 'ParserPerm'+data ParserPerm e d repr k a = ParserPerm+ { permutation_result :: !(Maybe ((a->k)->k))+ , permutation_parser :: repr () (ParserPerm e d repr k a)+ }++instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where+ a2b `fmap` ParserPerm a ma = ParserPerm+ ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)+ ((a2b `fmap`) `fmap` ma)+instance (App repr, Functor (repr ()), Alternative (repr ())) =>+ Applicative (ParserPerm e d repr k) where+ pure a = ParserPerm (Just ($ a)) empty+ lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =+ ParserPerm a (lhsAlt <|> rhsAlt)+ where+ a =+ (\a2b2k2k a2k2k -> \b2k ->+ a2b2k2k $ \a2b -> a2k2k (b2k . a2b)+ ) <$> f <*> x+ lhsAlt = (<*> rhs) <$> ma2b+ rhsAlt = (lhs <*>) <$> ma+instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where+ type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d' program _n = id- rule _n = id+ rule _n = id +noTransParserPerm ::+ Trans repr =>+ Functor (UnTrans repr ()) =>+ ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a+noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma) +unTransParserPerm ::+ Trans repr =>+ Functor (UnTrans repr ()) =>+ ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a+unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)++hoistParserPerm ::+ Functor (repr ()) =>+ (forall a b. repr a b -> repr a b) ->+ ParserPerm e d repr k c -> ParserPerm e d repr k c+hoistParserPerm f (ParserPerm a ma) =+ ParserPerm a (hoistParserPerm f <$> f ma)+ -- ** Class 'CLI_Routing' class CLI_Routing repr where- commands :: Map Name (repr a k) -> repr a k+ commands :: Map Name (Partial, repr a k) -> repr a k -- taggeds :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k-instance CLI_Routing (Parser d) where- commands cmds = Parser $ do- st@ParserState{..} <- get- let exp = Map.keys cmds- popArg (ParserError_Cmd exp Nothing) $ \curr ->- case curr of- ArgSegment cmd ->- case Map.lookup cmd cmds of- Nothing -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]- Just x -> unParser x- _ -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]- {-- taggeds ms = Parser $ do- st@ParserState{..} <- get- case parserState_args of- [] -> lift $ throwE $ Fail st [ParserError "empty path segment"]- curr:next ->- case lookupTag curr of- Nothing -> lift $ throwE $ Fail st [ParserError $ "expected: "<>fromString (show (Map.keys ms))<>" but got: "<>fromString (show curr)]- Just x -> do- put st{parserState_args=next}- unParser x+instance Ord e => CLI_Routing (Parser e d) where+ commands cmds = Parser $+ P.token check exp >>= unParser where- lookupTag (ArgTagShort x) = Map.lookup (Left x) ms- lookupTag (ArgTagLong x) = Map.lookup (Right x) ms- lookupTag _ = Nothing- -}+ exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds+ check = \case+ ArgSegment cmd -> snd <$> Map.lookup cmd cmds+ _ -> Nothing +-- * Type 'Router' data Router repr a b where -- | Lift any @(repr)@ into 'Router', those not useful to segregate -- wrt. the 'Trans'formation performed, aka. 'noTrans'. Router_Any :: repr a b -> Router repr a b -- | Represent 'commands'.- Router_Commands :: Map Name (Router repr a k) -> Router repr a k+ Router_Commands :: Map Name (Partial, Router repr a k) -> Router repr a k -- | Represent 'tagged'. Router_Tagged :: Tag -> Router repr f k -> Router repr f k- -- | Represent 'taggeds'.- {-- Router_Taggeds :: TagConstraint repr a =>- Map (Either Char Name) (Router repr (a -> k) k) ->- Router repr (a -> k) k- -} -- | Represent ('<.>'). Router_App :: Router repr a b -> Router repr b c -> Router repr a c -- | Represent ('<!>').@@ -451,23 +398,23 @@ -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'. Router_Union :: (b->a) -> Router repr a k -> Router repr b k -instance Functor (Router (Parser d) f) where+instance Ord e => Functor (Router (Parser e d) f) where a2b`fmap`x = noTrans (a2b <$> unTrans x)-instance Applicative (Router (Parser d) f) where+instance Ord e => Applicative (Router (Parser e d) f) where pure = noTrans . pure f <*> x = noTrans (unTrans f <*> unTrans x)-instance Alternative (Router (Parser d) f) where+instance Ord e => Alternative (Router (Parser e d) f) where empty = noTrans empty f <|> x = noTrans (unTrans f <|> unTrans x)-instance Permutable (Router (Parser d)) where- type Permutation (Router (Parser d)) = ParserPerm d (Router (Parser d))+instance Ord e => Permutable (Router (Parser e d)) where+ type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d)) runPermutation = noTrans . runPermutation . unTransParserPerm toPermutation = noTransParserPerm . toPermutation . unTrans toPermDefault a = noTransParserPerm . toPermDefault a . unTrans-instance (repr ~ Parser d) => Show (Router repr a b) where+instance (repr ~ Parser e d) => Show (Router repr a b) where showsPrec p = \case Router_Any{} -> showString "X"- Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . showString "]"+ Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go ((snd <$>) <$> Map.toList ms) . showString "]" where go :: forall h k. [(Segment, Router repr h k)] -> ShowS go [] = id@@ -476,83 +423,58 @@ case xs of [] -> id _ -> showString ", " . go xs- -- Router_Command n os x -> showString n . showString " " . showsPrec 10 (permutation_parser os) . showString " " . showsPrec p x Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x- {-- Router_Taggeds ms -> showParen (p>=10) $- showString "taggeds [" . go (Map.toList ms) . showString "]"- where- go :: forall h k. [(Either Char Name, Router repr h k)] -> ShowS- go [] = id- go ((n, r):xs) =- (showParen True $ showString (show n<>", ") . showsPrec 0 r) .- case xs of- [] -> id- _ -> showString ", " . go xs- -} Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]" -instance Trans (Router (Parser d)) where- type UnTrans (Router (Parser d)) = Parser d+instance Ord e => Trans (Router (Parser e d)) where+ type UnTrans (Router (Parser e d)) = Parser e d noTrans = Router_Any unTrans (Router_Any x) = x unTrans (Router_Alt x y) = unTrans x <!> unTrans y unTrans (Router_App x y) = unTrans x <.> unTrans y- -- unTrans (Router_Command n os x) = command n (unTransParserPerm os) (unTrans x)- unTrans (Router_Commands ms) = commands (unTrans <$> ms)+ unTrans (Router_Commands ms) = commands ((unTrans <$>) <$> ms) unTrans (Router_Tagged n x) = tagged n (unTrans x)- -- unTrans (Router_Taggeds ms) = taggeds (unTrans <$> ms) unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x) -instance App (Router (Parser d)) where+instance Ord e => App (Router (Parser e d)) where (<.>) = Router_App-instance Alt (Router (Parser d)) where+instance Ord e => Alt (Router (Parser e d)) where (<!>) = Router_Alt-instance Pro (Router (Parser d))-instance repr ~ (Parser d) => CLI_Command (Router repr) where- -- command = Router_Command+instance Ord e => Pro (Router (Parser e d))+instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where command "" x = x- command n x = Router_Commands $ Map.singleton n x-instance CLI_Var (Router (Parser d))-instance CLI_Env (Router (Parser d))-instance CLI_Tag (Router (Parser d)) where+ command n x = Router_Commands $ Map.fromAscList $+ go $ List.tail $ List.inits n+ where+ go [] = []+ go [cmd] = [(cmd, (Partial_Full, x))]+ go (cmd:cmds) = (cmd, (Partial_Prefix, x)) : go cmds+instance Ord e => CLI_Var (Router (Parser e d))+instance Ord e => CLI_Env (Router (Parser e d))+instance Ord e => CLI_Tag (Router (Parser e d)) where tagged = Router_Tagged-instance CLI_Help (Router (Parser d)) where+instance CLI_Help (Router (Parser e d)) where -- NOTE: set manually (instead of the 'Trans' default 'Router_Any') -- to remove them all, since they are useless for 'Parser' -- and may prevent patterns to be matched in 'router'. help _msg = id program _n = id rule _n = id-instance CLI_Response (Router (Parser d))-instance CLI_Routing (Router (Parser d)) where+instance Ord e => CLI_Response (Router (Parser e d))+instance Ord e => CLI_Routing (Router (Parser e d)) where -- taggeds = Router_Taggeds commands = Router_Commands router ::- repr ~ Parser d =>+ repr ~ Parser e d => Router repr a b -> Router repr a b router = {-debug1 "router" $-} \case x@Router_Any{} -> x- -- Router_Command n os x -> Router_Command n (hoistParserPerm router os) (router x) Router_Tagged n x -> Router_Tagged n (router x)- {-- Router_Tagged n x -> Router_Taggeds $- case n of- Tag c s -> Map.fromList [(Left c, r), (Right s, r)]- TagShort c -> Map.singleton (Left c) r- TagLong s -> Map.singleton (Right s) r- where r = router x- -}- {-- Router_Taggeds xs `Router_App` Router_Taggeds ys ->- Router_Taggeds $ router <$> (xs <> ys)- -} Router_Alt x y -> router x`router_Alt`router y- Router_Commands xs -> Router_Commands $ router <$> xs- -- Router_Taggeds xs -> Router_Taggeds $ router <$> xs+ Router_Commands xs -> Router_Commands $ (router <$>) <$> xs Router_App xy z -> case xy of Router_App x y ->@@ -561,29 +483,16 @@ Router_App (router y) (router z) _ -> router xy `Router_App` router z Router_Union u x -> Router_Union u (router x)- -- Router_Merge x -> Router_Merge (router x) -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'. router_Alt ::- repr ~ Parser d =>+ repr ~ Parser e d => Router repr a k -> Router repr b k -> Router repr (a:!:b) k router_Alt = {-debug2 "router_Alt"-} go where -- Merge alternative commands together.- {- NOTE: useless because 'command' is already a 'Router_Commands'.- go (Router_Command x xo xt) (Router_Command y yo yt) =- Map.singleton x (router (runPermutation xo <.> xt))- `router_Commands`- Map.singleton y (router (runPermutation yo <.> yt))- go (Router_Command x xo xt) (Router_Commands ys) =- Map.singleton x (router (runPermutation xo <.> xt))- `router_Commands` ys- go (Router_Commands xs) (Router_Command y yo yt) =- xs `router_Commands`- Map.singleton y (router (runPermutation yo <.> yt))- -} go (Router_Commands xs) (Router_Commands ys) = xs`router_Commands`ys @@ -619,9 +528,9 @@ go x y = x`Router_Alt`y router_Commands ::- repr ~ Parser d =>- Map Segment (Router repr a k) ->- Map Segment (Router repr b k) ->+ repr ~ Parser e d =>+ Map Segment (Partial, Router repr a k) ->+ Map Segment (Partial, Router repr b k) -> Router repr (a:!:b) k router_Commands xs ys = -- NOTE: a little bit more complex than required@@ -629,35 +538,84 @@ -- such that 'unTrans' 'Router_Union' applies them all at once. Router_Commands $ Map.merge- (Map.traverseMissing $ const $ \case- Router_Union u r ->- return $ Router_Union (\(x:!:_y) -> u x) r- r -> return $ Router_Union (\(x:!:_y) -> x) r)- (Map.traverseMissing $ const $ \case- Router_Union u r ->- return $ Router_Union (\(_x:!:y) -> u y) r- r -> return $ Router_Union (\(_x:!:y) -> y) r)- (Map.zipWithAMatched $ const $ \case- Router_Union xu xr -> \case- Router_Union yu yr ->- return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr- yr ->- return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr- xr -> \case- Router_Union yu yr ->- return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr- yr -> return $ xr`router_Alt`yr)+ (Map.mapMissing $ const $ second keepX)+ (Map.mapMissing $ const $ second keepY)+ (Map.zipWithMaybeMatched $ const $ \(xp,xr) (yp,yr) ->+ case (xp,yp) of+ (Partial_Prefix, Partial_Prefix) -> Nothing+ (Partial_Full , Partial_Prefix) -> Just $ (Partial_Full, keepX xr)+ (Partial_Prefix, Partial_Full ) -> Just $ (Partial_Full, keepY yr)+ (Partial_Full , Partial_Full ) -> Just $ (Partial_Full, mergeFull xr yr)+ ) xs ys+ where+ keepX = \case+ Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r+ r -> Router_Union (\(x:!:_y) -> x) r+ keepY = \case+ Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r+ r -> Router_Union (\(_x:!:y) -> y) r+ mergeFull = \case+ Router_Union xu xr -> \case+ Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr+ yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr+ xr -> \case+ Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr+ yr -> xr`router_Alt`yr -{--debug0 :: Show a => String -> a -> a-debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a-debug1 :: Show a => Show b => String -> (a->b) -> (a->b)-debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b- where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a-debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)-debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c+-- ** Type 'Arg'+data Arg+ = ArgSegment Segment+ | ArgTagLong Name+ | ArgTagShort Char+ | ArgEnv Name String -- ^ Here only for error reporting.+ deriving (Eq,Ord,Show)++lexer :: [String] -> [Arg]+lexer ss =+ join $+ (`evalState` False) $+ sequence (f <$> ss) where- b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a- c = b2c $ Debug.trace (n<>": b: "<>show b) b--}+ f :: String -> StateT Bool Identity [Arg]+ f s = do+ skip <- get+ if skip then return [ArgSegment s]+ else case s of+ '-':'-':[] -> do+ put True+ return [ArgTagLong ""]+ '-':'-':cs -> return [ArgTagLong cs]+ '-':cs@(_:_) -> return $ ArgTagShort <$> cs+ seg -> return [ArgSegment seg]++showArg :: Arg -> String+showArg = \case+ ArgTagShort t -> '-':[t]+ ArgTagLong t -> '-':'-':t+ ArgSegment seg -> seg+ ArgEnv name val -> name<>"="<>val++showArgs :: [Arg] -> String+showArgs args = List.intercalate " " $ showArg <$> args++instance P.Stream [Arg] where+ type Token [Arg] = Arg+ type Tokens [Arg] = [Arg]+ tokenToChunk Proxy = pure+ tokensToChunk Proxy = id+ chunkToTokens Proxy = id+ chunkLength Proxy = List.length+ chunkEmpty Proxy = List.null+ take1_ [] = Nothing+ take1_ (t:ts) = Just (t, ts)+ takeN_ n s+ | n <= 0 = Just ([], s)+ | List.null s = Nothing+ | otherwise = Just (List.splitAt n s)+ takeWhile_ = List.span+ showTokens Proxy = showArgs . toList+ -- NOTE: those make no sense when parsing a command line,+ -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.+ reachOffset = error "BUG: reachOffset must not be used on [Arg]"+ reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"
Symantic/CLI/Schema.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (Word *) d+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d module Symantic.CLI.Schema where import Control.Applicative (Applicative(..))@@ -50,9 +50,9 @@ , Doc.Spaceable d , Doc.Indentable d , Doc.Wrappable d- , Doc.DocFrom (Doc.Word Char) d- , Doc.DocFrom (Doc.Word Text) d- , Doc.DocFrom (Doc.Word String) d+ , Doc.From (Doc.Word Char) d+ , Doc.From (Doc.Word Text) d+ , Doc.From (Doc.Word String) d ) -- ** Type 'SchemaInh'@@ -93,9 +93,9 @@ Doc.runAnsiText . docSchema -docOrH, docOrV :: Doc.Spaceable d => Doc.DocFrom (Doc.Word Char) d => d-docOrH = Doc.space <> Doc.docFrom (Doc.Word '|') <> Doc.space-docOrV = Doc.newline <> Doc.docFrom (Doc.Word '|') <> Doc.space+docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d+docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space+docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space {- instance Docable d => Functor (Schema d f) where@@ -176,11 +176,11 @@ Doc.bold $ Doc.angles $ Doc.magentaer $- Doc.docFrom (Doc.Word n)+ Doc.from (Doc.Word n) instance Docable d => CLI_Var (Schema d) where type VarConstraint (Schema d) a = () var' n = Schema $ \_inh -> Just $- Doc.underline $ Doc.docFrom $ Doc.Word n+ Doc.underline $ Doc.from $ Doc.Word n just _ = Schema $ \_inh -> Nothing nothing = Schema $ \_inh -> Nothing instance Docable d => CLI_Env (Schema d) where@@ -214,7 +214,7 @@ Doc.bold $ Doc.angles $ Doc.magentaer $- Doc.docFrom (Doc.Word n)+ Doc.from (Doc.Word n) data SchemaResponseArgs a instance Docable d => CLI_Response (Schema d) where type ResponseConstraint (Schema d) a = ()
symantic-cli.cabal view
@@ -2,8 +2,8 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 2.0.0.20190615-category: +version: 2.2.1.20190629+category: System, CLI, Options, Parsing synopsis: Symantics for parsing and documenting a CLI description: An extensible, typed and embedded Domain-Specific Language (DSL)@@ -32,6 +32,7 @@ Library exposed-modules:+ Symantic.CLI Symantic.CLI.API Symantic.CLI.Fixity Symantic.CLI.Help@@ -60,6 +61,7 @@ build-depends: base >= 4.10 && < 5 , containers >= 0.5- , symantic-document >= 0.2+ , megaparsec >= 7.0+ , symantic-document >= 1.1.1 , text >= 1.2 , transformers >= 0.5