symantic-cli 2.3.3.20190711 → 2.4.0.20190719

raw patch · 6 files changed

+445/−112 lines, 6 filesdep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• Symantic/CLI/API.hs +46/−19
• Symantic/CLI/Help.hs +2/−2
• Symantic/CLI/Layout.hs +247/−39
• Symantic/CLI/Parser.hs +86/−27
• Symantic/CLI/Schema.hs +62/−24
• symantic-cli.cabal +2/−1

@@ -10,8 +10,8 @@ import Data.Eq (Eq) import Data.Function (($), (.), id) import Data.Kind (Constraint)-import Data.Maybe (Maybe(..))-import Data.String (String)+import Data.Maybe (Maybe(..), fromJust)+import Data.String (String, IsString(..)) import Text.Show (Show)  -- * Class 'App'@@ -70,6 +70,7 @@ class AltApp repr where 	many0 :: repr (a->k) k -> repr ([a]->k) k 	many1 :: repr (a->k) k -> repr ([a]->k) k+	-- Trans defaults 	default many0 :: 	 Trans repr => 	 AltApp (UnTrans repr) =>@@ -83,7 +84,7 @@  -- * Class 'Permutable' class Permutable repr where-	-- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.+	-- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@. 	type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr 	type Permutation repr = Permutation (UnTrans repr) 	runPermutation :: Permutation repr k a -> repr (a->k) k@@ -101,6 +102,14 @@ opts <?> next = runPermutation opts <.> next infixr 4 <?> +-- * Class 'Sequenceable'+class Sequenceable repr where+	-- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.+	type Sequence (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr+	type Sequence repr = Sequence (UnTrans repr)+	runSequence :: Sequence repr k a -> repr (a->k) k+	toSequence :: repr (a->k) k -> Sequence repr k a+ -- * Type 'Name' type Name = String @@ -175,31 +184,49 @@  |   TagLong Name  |   TagShort Char  deriving (Eq, Show)+instance IsString Tag where+	fromString = \case+	 [c] -> TagShort c+	 c:'|':cs -> Tag c cs+	 cs -> TagLong cs  -- * Class 'CLI_Tag' class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where 	type TagConstraint repr a :: Constraint-	tagged :: Tag -> repr f k -> repr f k+	tag :: Tag -> repr f k -> repr f k+	-- tag n = (tag n <.>) 	endOpts :: repr k k 	-	-- tagged n = (tag n <.>)-	short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a-	short n = toPermutation . tagged (TagShort n)-	long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a-	long n = toPermutation . tagged (TagLong n)-	-	option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a-	option = toPermDefault 	flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool-	flag n = toPermDefault False $ tagged n $ just True-	shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a-	shortOpt n a = toPermDefault a . tagged (TagShort n)-	longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a-	longOpt n a = toPermDefault a . tagged (TagLong n)+	flag n = toPermDefault False $ tag n $ just True 	+	optionalTag ::+	 TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>+	 Tag -> repr (a->k) k -> Permutation repr k (Maybe a)+	optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust+	+	defaultTag ::+	 TagConstraint repr a =>+	 Tag -> a -> repr (a->k) k -> Permutation repr k a+	defaultTag n a = toPermDefault a . tag n+	+	requiredTag ::+	 TagConstraint repr a =>+	 Tag -> repr (a->k) k -> Permutation repr k a+	requiredTag n = toPermutation . tag n+	+	many0Tag ::+	 TagConstraint repr a => AltApp repr =>+	 Tag -> repr (a->k) k -> Permutation repr k [a]+	many0Tag n = toPermDefault [] . many1 . tag n+	many1Tag ::+	 TagConstraint repr a => AltApp repr =>+	 Tag -> repr (a->k) k -> Permutation repr k [a]+	many1Tag n = toPermutation . many1 . tag n+	 	-- Trans defaults 	type TagConstraint repr a = TagConstraint (UnTrans repr) a-	default tagged ::+	default tag :: 	 Trans repr => 	 CLI_Tag (UnTrans repr) => 	 Tag -> repr f k -> repr f k@@ -207,7 +234,7 @@ 	 Trans repr => 	 CLI_Tag (UnTrans repr) => 	 repr k k-	tagged n = noTrans . tagged n . unTrans+	tag n = noTrans . tag n . unTrans 	endOpts = noTrans endOpts  -- * Class 'CLI_Response'

@@ -221,7 +221,7 @@ 			Doc.from (Doc.Word n) instance SchemaDoc d => CLI_Tag (Help d) where 	type TagConstraint (Help d) a = ()-	tagged n (Help h s) =+	tag n (Help h s) = 		Help (\inh -> 			if (isJust (helpInh_message inh) 			|| helpInh_helpless_options inh)@@ -241,7 +241,7 @@ 				[ Tree.Node (HelpNode_Tag, d) ts ] 			else [] 		 ) schema-		where schema = tagged n s+		where schema = tag n s 	endOpts = Help mempty endOpts instance SchemaDoc d => CLI_Help (Help d) where 	type HelpConstraint (Help d) d' = d ~ d'

@@ -5,6 +5,12 @@ {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d module Symantic.CLI.Layout where +-- TODO: remove when debugging is done+import Prelude (Char, String, putStr)+import Symantic.Document (runPlain)+import Data.Maybe (fromJust)+import Data.Text (Text)+ import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), (>>)) import Control.Monad.Trans.State.Strict@@ -33,7 +39,7 @@    -- ^ Synthetized (bottom-up) 'help'.    -- Useful in 'LayoutPerm' to merge nested 'help'    -- and nesting 'help' of the permutation.- , unLayout     :: LayoutInh d -> State (LayoutState d) ()+ , layoutMonad  :: LayoutInh d -> State (LayoutState d) ()  }  runLayout :: LayoutDoc d => Bool -> Layout d f k -> d@@ -44,6 +50,14 @@ 	(`execState`id) $ 	l defLayoutInh +coerceLayout :: Layout d f k -> Layout d f' k'+coerceLayout (Layout s h l) = Layout (coerceSchema s) h l++instance Semigroup d => Semigroup (Layout d f k) where+	Layout xs xh xm <> Layout ys yh ym =+		Layout (xs<>ys) (xh<>yh) $ \inh ->+			xm inh >> ym inh+ -- ** Type 'LayoutInh' newtype LayoutInh d = LayoutInh  { layoutInh_message :: {-!-}[d]@@ -75,27 +89,38 @@ runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>) +runLayoutForest' :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d+runLayoutForest' full = Doc.catV . (runLayoutTree full <$>)+ runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d runLayoutTree full =-	Doc.setIndent mempty 0 .+	-- Doc.setIndent mempty 0 . 	Doc.catV . runLayoutNode full  runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d] runLayoutNode full (Tree.Node n ts0) = 	(case n of-	 LayoutNode_Tags ds -> (<$> ds) $ \(mh,sch) ->-		case mh of-		 [] -> Doc.whiter sch-		 _ | not full -> Doc.whiter sch-		 h -> Doc.fillOrBreak 15 (Doc.whiter sch) <>-			Doc.space <> Doc.align (Doc.justify (Doc.catV h))-	 LayoutNode_Help mh sch ->+	 LayoutNode_Single sch mh -> 		[ Doc.align $ 			case mh of 			 [] -> Doc.whiter sch 			 _ | not full -> Doc.whiter sch 			 h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h) 		]+	 LayoutNode_List ns ds ->+		((if full then ns else []) <>) $+		(<$> ds) $ \(sch, mh) ->+			case mh of+			 [] ->+				Doc.whiter sch+			 _ | not full -> Doc.whiter sch+			 h ->+				Doc.fillOrBreak 15 (Doc.whiter sch) <>+					Doc.space <> Doc.align (Doc.justify (Doc.catV h))+	 LayoutNode_Forest sch ds ts ->+		[Doc.whiter sch] <>+		(if List.null ds || not full then [] else [Doc.catV ds]) <>+		(if List.null ts then [] else [runLayoutForest' full ts]) 	) <> docSubTrees ts0 	where 	docSubTrees [] = []@@ -135,7 +160,7 @@ 			case (lk Nothing, rk Nothing) of 			 (Nothing, Nothing) -> \case 				 Nothing -> k Nothing-				 Just ts -> k $ Just [Tree.Node (LayoutNode_Help (lh<>rh) $ docSchema sch) ts]+				 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) (lh<>rh)) ts] 			 (Just lt, Just rt) -> \case 				 Nothing -> k $ Just (lt<>rt) 				 Just ts -> k $ Just (lt<>rt<>ts)@@ -153,9 +178,56 @@ 	opt (Layout xs xh xm) = Layout sch xh $ \inh -> do 		modify' $ \k -> \case 		 Nothing -> k Nothing-		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] mempty{-FIXME-}) ts]+		 Just _ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []{-FIXME-}) mempty] 		xm inh 		where sch = opt xs+instance LayoutDoc d => AltApp (Layout d) where+	many0 (Layout xs xh xm) = Layout sch xh $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node nod mempty]+			where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts+		xm inh{layoutInh_message=[]}+		where sch = many0 xs+	many1 (Layout xs xh xm) = Layout sch xh $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node nod mempty]+			where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts+		xm inh{layoutInh_message=[]}+		where sch = many1 xs+instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where+	type Permutation (Layout d) = LayoutPerm d+	runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node nod ts]+			where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})+		where sch = runPermutation $ SchemaPerm id []+	toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->+		[(docSchema xl, layoutInh_message inh <> xh)]+	toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->+		[(Doc.brackets (docSchema xl), layoutInh_message inh <> xh)]+instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where+	type Sequence (Layout d) = LayoutSeq d+	runSequence (LayoutSeq s h m) = Layout (runSequence s) h m+	toSequence (Layout s h m) = LayoutSeq (toSequence s) h m+	{-+	runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node nod mempty]+			-- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})+			where+			nod = LayoutNode_Forest mempty {-(docSchema sch)-}+			 (layoutInh_message inh) (gs <> ts)+			gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->+				Tree.Node (LayoutNode_Single d ds) mempty+			 +		where sch = runSequence s+	toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->+		[(docSchema s, layoutInh_message inh <> h)]+	-} instance Pro (Layout d) where 	dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where@@ -164,38 +236,41 @@ 		 Nothing -> k Nothing 		 Just ts -> k $ Just 			[ Tree.Node-				 ( LayoutNode_Help (layoutInh_message inh)-				 $ Doc.magentaer $ docSchema $ command n nothing+				 ( LayoutNode_Single+					 (Doc.magentaer $ docSchema $ command n nothing)+					 (layoutInh_message inh) 				 ) ts 			]-		xm inh+		xm inh{layoutInh_message=[]} 		where sch = command n xl instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where 	type TagConstraint (Layout d) a = TagConstraint (Schema d) a-	tagged n (Layout xs xh xm) = Layout (tagged n xs) xh $ \inh -> do+	tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do 		modify' $ \k -> \case 		 Nothing -> k Nothing 		 Just ts -> k $ Just 			[ Tree.Node-			 ( LayoutNode_Tags [-				 ( layoutInh_message inh-				 , docSchema (tagged n nothing)+			 ( LayoutNode_List [] [+				 ( docSchema (tag n nothing)+				 , layoutInh_message inh 				 ) 				] 			 ) ts 			]-		xm inh+		xm inh{layoutInh_message=[]} 	endOpts = Layout sch [] $ \_inh -> do 		modify' $ \k -> \case 		 Nothing -> k Nothing-		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]+		 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts] 		where sch = endOpts instance LayoutDoc d => CLI_Var (Layout d) where 	type VarConstraint (Layout d) a = VarConstraint (Schema d) a-	var' n = Layout sch [] $ \_inh -> do+	var' n = Layout sch [] $ \inh -> do 		modify' $ \k -> \case 		 Nothing -> k Nothing-		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]+		 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]+			where h | List.null (layoutInh_message inh) = []+			        | otherwise = [(docSchema sch, layoutInh_message inh)] 		where sch = var' n 	just a  = Layout (just a) [] $ \_inh -> pure () 	nothing = Layout nothing  [] $ \_inh -> pure ()@@ -212,7 +287,7 @@ 		 Nothing -> k Nothing 		 Just ts -> k $ Just 			 [ Tree.Node-				 (LayoutNode_Help [] $ Doc.magentaer $ docSchema $ program n nothing)+				 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) []) 				 ts 			 ] 		xm inh@@ -227,10 +302,29 @@ 		 Nothing -> k $ Just [] 		 Just ts -> k $ Just ts +-- ** Type 'LayoutSeq'+data LayoutSeq d k a = LayoutSeq+ {   layoutSeq_schema :: SchemaSeq d k a+ ,   layoutSeq_help  :: [d]+ ,   layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()+ }+instance Functor (LayoutSeq d k) where+	f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh+instance Applicative (LayoutSeq d k) where+	pure a = LayoutSeq (pure a) [] $ \_inh -> return ()+	LayoutSeq fs fh f <*> LayoutSeq xs xh x =+		LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh+instance LayoutDoc d => CLI_Help (LayoutSeq d) where+	type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'+	help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->+		m inh{layoutInh_message=[msg]}+	program n (LayoutSeq s h m) = LayoutSeq (program n s) h m+	rule    n (LayoutSeq s h m) = LayoutSeq (rule n s) h m+ -- ** Type 'LayoutPerm' data LayoutPerm d k a = LayoutPerm- { layoutPerm_help :: [d]- , layoutPerm_elem :: LayoutInh d -> [([d], d)]+ {   layoutPerm_help :: [d]+ ,   layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]  } instance Functor (LayoutPerm d k) where 	_f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh@@ -238,18 +332,6 @@ 	pure _a = LayoutPerm [] $ \_inh -> [] 	LayoutPerm _fh f <*> LayoutPerm _xh x = 		LayoutPerm [] $ \inh -> f inh <> x inh-instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where-	type Permutation (Layout d) = LayoutPerm d-	runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do-		modify' $ \k -> \case-		 Nothing -> k Nothing-		 Just ts -> k $ Just [Tree.Node (LayoutNode_Tags (ps inh)) ts]-		where-		sch = runPermutation $ SchemaPerm id []-	toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->-		[(layoutInh_message inh <> xh, docSchema xl)]-	toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->-		[(layoutInh_message inh <> xh, Doc.brackets (docSchema xl))] instance LayoutDoc d => CLI_Help (LayoutPerm d) where 	type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d' 	help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->@@ -259,6 +341,132 @@  -- ** Type 'LayoutNode' data LayoutNode d- =   LayoutNode_Help [d] d- |   LayoutNode_Tags [([d], d)]+ =   LayoutNode_Single d {-help-}[d]+ |   LayoutNode_List [d] [(d, {-help-}[d])]+ |   LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))  deriving (Show)++{-+h0 = putStr $ runPlain $ runLayout True $+	help "TOTO help" $ command "toto" $+		many0 $ runSequence $ ((,)+		 <$> toSequence (help "Question help" $ var @String "Question")+		 <*> toSequence (help "Answer help" $ tag (TagLong "ans") (var @Char "Answer"))+		 )++h1 = putStr $ runPlain $ runLayout True $+	"This command reads and checks."+	`help`+	command "election" $+		api_quests <.>+		response @()+	where+	api_quests =+		("Some questions."::Doc.Plain String)+		`help`+		many0 (runSequence $ (,)+		 <$> toSequence api_quest+		 <*> toSequence api_answers+		 )+	api_quest =+		("A question."::Doc.Plain String)+		`help`+		var @String "QUESTION"+	api_answers =+		("Some answers."::Doc.Plain String)+		`help`+		many0 $ help ("An answer"::Doc.Plain String) (var @String "ANSWER")++h2 = putStr $ runPlain $ runLayout True $+	"This command reads and checks."+	`help`+	command "election" $+		api_quests <.>+		response @()+	where+	api_quests =+		("Some questions."::Doc.Plain String)+		`help`+		many0 api_quest+	api_quest =+		("A question."::Doc.Plain String)+		`help`+		var @String "QUESTION"++h3 = putStr $ runPlain $ runLayout True $+	"This command reads and checks."+	`help`+	command "election" $+		api_quests <.>+		response @()+	where+	api_quests =+		("Some questions."::Doc.Plain String)+		`help`+		many0 (runSequence ((,) <$> toSequence api_quest <*> toSequence api_answers))+		-- many0 api_answers+	api_quest =+		("A question."::Doc.Plain String)+		`help`+		var @String "QUESTION"+	api_answers =+		("Some answers."::Doc.Plain String)+		`help`+		many0 $ help ("An answer"::Doc.Plain String) (var @String "ANSWER")++data AdminElection_Params = AdminElection_Params+ {   adminElection_name         :: Text+ ,   adminElection_description  :: Text+ ,   adminElection_uuid         :: Maybe Text+ ,   adminElection_grades       :: [Text]+ ,   adminElection_defaultGrade :: Maybe Text+ }++helpD d = help (d::Doc.Plain String)+infixr 0 `helpD`++h4 = putStr $ runPlain $ runLayout True $+	"This command reads and checks the trustees' public keys"+	`helpD`+	command "election" $+		rule "PARAMS"+		 (AdminElection_Params+			 <$> api_param_name+			 <*> api_param_description+			 <*> api_option_uuid+			 <*> api_param_grades+			 <*> api_param_defaultGrade+		 )+		<?> api_quests+		<.> response @(Maybe ())+	where+	api_param_name =+		"Name of the election."+		`helpD`+		requiredTag (TagLong "name") $ var "STRING"+	api_param_description =+		"Description of the election."+		`helpD`+		defaultTag (TagLong "description") "" $ var "STRING"+	api_option_uuid =+		"UUID of the election."+		`helpD`+		optionalTag (TagLong "uuid") $ var "UUID"+	api_quests =+		"Some questions."+		`helpD`+		many1 (var @Text "STRING")+	api_param_grades = toPermutation $+		many1 $+			"The grades to evaluate the choices, from the lowest to the highest."+			`helpD`+			tag (TagLong "grade") $+				var @Text "STRING"+	api_param_defaultGrade = toPermDefault Nothing $+		"The grade used when no grade is given by a voter.\n"<>+		"Defaults to the lowest grade."+		`helpD`+			tag (TagLong "default-grade") $+				dimap Just fromJust $+					var @Text "STRING"+-}

@@ -35,6 +35,8 @@ import Text.Read (Read, readEither) import Text.Show (Show(..), ShowS, showString, showParen) import Type.Reflection as Reflection+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Merge.Strict as Map@@ -101,7 +103,7 @@  showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String showErrorItem pxy = \case- P.Tokens ts -> P.showTokens pxy ts+ P.Tokens ts   -> P.showTokens pxy ts  P.Label label -> NonEmpty.toList label  P.EndOfInput  -> "end of input" @@ -113,6 +115,10 @@ instance Ord e => Alternative (Parser e d f) where 	empty = Parser empty 	Parser x <|> Parser y = Parser $ x <|> y+instance Ord e => Sequenceable (Parser e d) where+	type Sequence (Parser e d) = ParserSeq e d+	runSequence = unParserSeq+	toSequence  = ParserSeq 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@@ -123,7 +129,8 @@ 			 Nothing -> 				maybe 				 (Parser $ P.token (const Nothing) Set.empty)-				 -- NOTE: not 'empty' so that 'P.TrivialError' has the unexpected token.+				 -- NOTE: Not 'empty' here so that 'P.TrivialError'+				 -- has the unexpected token. 				 (Parser . return) ma 	toPermutation (Parser x) = 		ParserPerm Nothing@@ -152,7 +159,7 @@ 	command n x = commands Map.empty (Map.singleton n x) instance Ord e => CLI_Tag (Parser e d) where 	type TagConstraint (Parser e d) a = ()-	tagged name p = Parser $ P.try $ do+	tag name p = Parser $ P.try $ do 		void $ (`P.token` exp) $ \tok -> 			if lookupTag tok name 			then Just tok@@ -269,6 +276,10 @@ 	output = Text.putStr instance Outputable TL.Text where 	output = TL.putStr+instance Outputable BS.ByteString where+	output = BS.putStr+instance Outputable BSL.ByteString where+	output = BSL.putStr instance Outputable (Doc.Plain TLB.Builder) where 	output = 		TL.putStr .@@ -297,11 +308,31 @@ 	output (OnHandle h a) = Text.hPutStr h a instance Outputable (OnHandle TL.Text) where 	output (OnHandle h a) = TL.hPutStr h a+instance Outputable (OnHandle BS.ByteString) where+	output (OnHandle h a) = BS.hPutStr h a+instance Outputable (OnHandle BSL.ByteString) where+	output (OnHandle h a) = BSL.hPutStr h a instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where 	output (OnHandle h d) = 		TL.hPutStr h $ 		TLB.toLazyText $ 		Doc.runPlain d+instance+ ( Outputable a+ , Reflection.Typeable a+ ) => Outputable (Maybe a) where+	output = \case+	 Nothing -> return ()+	 Just a  -> output a+instance+ ( Reflection.Typeable e+ , Reflection.Typeable a+ , Outputable (OnHandle e)+ , Outputable a+ ) => Outputable (Either e a) where+	output = \case+	 Left e -> output $ OnHandle IO.stderr e+	 Right a -> output a  -- * Class 'IOType' -- | Like a MIME type but for input/output of a CLI.@@ -319,8 +350,11 @@ instance IOType String instance IOType Text.Text instance IOType TL.Text+instance IOType BS.ByteString+instance IOType BSL.ByteString instance IOType (Doc.Plain TLB.Builder)-instance IOType (IO.Handle, Doc.Plain TLB.Builder)+instance Reflection.Typeable a => IOType (Maybe a)+instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)  -- * Class 'FromSegment' class FromSegment a where@@ -338,6 +372,22 @@ instance FromSegment Integer instance FromSegment Natural +-- ** Type 'ParserSeq'+-- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.+-- Used to gather collected values into a single one,+-- which is for instance needed for using 'many0' on multiple 'var's.+newtype ParserSeq e d k a = ParserSeq+ { unParserSeq :: Parser e d (a->k) k }+instance Functor (ParserSeq e d k) where+	a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x+		where merge = \a2k2k b2k -> a2k2k $ b2k . a2b+instance Applicative (ParserSeq e d k) where+	pure a = ParserSeq $ Parser $ pure ($ a)+	ParserSeq (Parser f) <*> ParserSeq (Parser x) =+		ParserSeq $ Parser $ merge <$> f <*> x+		where merge a2b2k2k a2k2k b2k =+			a2b2k2k $ \a2b -> a2k2k (b2k . a2b)+ -- ** Type 'ParserPerm' data ParserPerm e d repr k a = ParserPerm  { permutation_result :: !(Maybe ((a->k)->k))@@ -345,21 +395,20 @@  }  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)+	a2b `fmap` ParserPerm a ma =+		ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)+		where merge = \a2k2k b2k -> a2k2k $ b2k . a2b 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+		a = merge <$> f <*> x 		lhsAlt = (<*> rhs) <$> ma2b 		rhsAlt = (lhs <*>) <$> ma+		merge a2b2k2k a2k2k b2k =+			a2b2k2k $ \a2b -> a2k2k (b2k . a2b) 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@@ -375,7 +424,8 @@  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)+unTransParserPerm (ParserPerm a ma) =+	ParserPerm a (unTransParserPerm <$> unTrans ma)  hoistParserPerm ::  Functor (repr ()) =>@@ -387,7 +437,7 @@ -- ** Class 'CLI_Routing' class CLI_Routing repr where 	commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k-	-- taggeds  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k+	-- tags  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k instance Ord e => CLI_Routing (Parser e d) where 	commands preCmds cmds = Parser $ 		P.token check exp >>= unParser@@ -409,8 +459,8 @@   Map Name (Router repr a k) ->   Map Name (Router repr a k) ->   Router repr a k- -- | Represent 'tagged'.- Router_Tagged :: Tag -> Router repr f k -> Router repr f k+ -- | Represent 'tag'.+ Router_Tag :: Tag -> Router repr f k -> Router repr f k  -- | Represent ('<.>').  Router_App :: Router repr a b -> Router repr b c -> Router repr a c  -- | Represent ('<!>').@@ -427,11 +477,6 @@ instance Ord e => Alternative (Router (Parser e d) f) where 	empty = noTrans empty 	f <|> x = noTrans (unTrans f <|> unTrans x)-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 e d) => Show (Router repr a b) where 	showsPrec p = \case 	 Router_Any{} -> showString "X"@@ -444,11 +489,10 @@ 			case xs of 			 [] -> id 			 _ -> showString ", " . go xs-	 Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x+	 Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x 	 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 Ord e => Trans (Router (Parser e d)) where 	type UnTrans (Router (Parser e d)) = Parser e d 	noTrans = Router_Any@@ -456,7 +500,7 @@ 	unTrans (Router_Alt x y) = unTrans x <!> unTrans y 	unTrans (Router_App x y) = unTrans x <.> unTrans y 	unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)-	unTrans (Router_Tagged n x) = tagged n (unTrans x)+	unTrans (Router_Tag n x) = tag n (unTrans x) 	unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)  instance Ord e => App (Router (Parser e d)) where@@ -464,6 +508,16 @@ instance Ord e => Alt (Router (Parser e d)) where 	(<!>) = Router_Alt 	alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y+instance Ord e => AltApp (Router (Parser e d))+instance Ord e => Sequenceable (Router (Parser e d)) where+	type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)+	runSequence = noTrans . runSequence . unRouterParserSeq+	toSequence  = RouterParserSeq . toSequence . unTrans+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 Ord e => Pro (Router (Parser e d)) instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where 	command "" x = x@@ -476,7 +530,7 @@ 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+	tag = Router_Tag 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'@@ -486,7 +540,7 @@ 	rule _n    = id instance Ord e => CLI_Response (Router (Parser e d)) instance Ord e => CLI_Routing (Router (Parser e d)) where-	-- taggeds  = Router_Taggeds+	-- tags  = Router_Tags 	commands = Router_Commands  router ::@@ -494,7 +548,7 @@  Router repr a b -> Router repr a b router = {-debug1 "router" $-} \case  x@Router_Any{} -> x- Router_Tagged n x -> Router_Tagged n (router x)+ Router_Tag n x -> Router_Tag n (router x)  Router_Alt x y -> router x`router_Alt`router y  Router_Commands preCmds cmds -> 	Router_Commands@@ -584,7 +638,12 @@ 		 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr 		 yr                 -> xr`router_Alt`yr --- ** Type 'Arg'+-- ** Type 'RouterParserSeq'+newtype RouterParserSeq repr k a = RouterParserSeq+ { unRouterParserSeq :: repr k a }+ deriving (Functor, Applicative)++-- * Type 'Arg' data Arg  =   ArgSegment Segment  |   ArgTagLong Name

@@ -161,15 +161,53 @@ 		Doc.brackets $ 		runSchema s inh{schemaInh_op=(op, SideL)} 		where op = infixN0+instance SchemaDoc d => Sequenceable (Schema d) where+	type Sequence (Schema d) = SchemaSeq d+	runSequence (SchemaSeq fin ps) =+		case ps of+		 [] -> fin $ Schema $ \_inh -> Nothing+		 _ -> fin $ Schema $ \inh -> Just $+			pairIfNeeded (schemaInh_op inh) op $+			Doc.intercalate Doc.breakspace $+			catMaybes $ (<$> ps) $ \(Schema s) ->+				s inh+				 { schemaInh_op=(op, SideL)+				 , schemaInh_or=docOrH }+		where op = infixN 10+	toSequence = SchemaSeq id . pure+instance SchemaDoc d => Permutable (Schema d) where+	type Permutation (Schema d) = SchemaPerm d+	runPermutation (SchemaPerm fin ps) =+		case ps of+		 [] -> fin $ Schema $ \_inh -> Nothing+		 _ -> fin $ Schema $ \inh -> Just $+			pairIfNeeded (schemaInh_op inh) op $+			Doc.intercalate Doc.breakspace $+			catMaybes $ (<$> ps) $ \(Schema s) ->+				s inh+				 { schemaInh_op=(op, SideL)+				 , schemaInh_or=docOrH }+		where op = infixN 10+	toPermutation = SchemaPerm id . pure+	toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $+		if needsParenInfix (schemaInh_op inh) op+		then+			Doc.brackets $+				runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}+		else+			runSchema s inh{schemaInh_op=(op, SideL)}+		where op = infixN0 instance Pro (Schema d) where 	dimap _a2b _b2a = coerceSchema instance SchemaDoc d => AltApp (Schema d) where 	many0 s = Schema $ \inh -> Just $+		pairIfNeeded (schemaInh_op inh) op $ 		runSchema s inh{schemaInh_op=(op, SideL)}<>"*"-		where op = infixN 10+		where op = infixN 11 	many1 s = Schema $ \inh -> Just $+		pairIfNeeded (schemaInh_op inh) op $ 		runSchema s inh{schemaInh_op=(op, SideL)}<>"+"-		where op = infixN 10+		where op = infixN 11 instance SchemaDoc d => CLI_Command (Schema d) where 	-- type CommandConstraint (Schema d) a = () 	command n s = Schema $ \inh -> Just $@@ -199,7 +237,7 @@ 	 -- only in the help. instance SchemaDoc d => CLI_Tag (Schema d) where 	type TagConstraint (Schema d) a = ()-	tagged n r = Schema $ \inh ->+	tag n r = Schema $ \inh -> 		unSchema (prefix n <.> r) inh 		where 		prefix = \case@@ -231,6 +269,27 @@ 	type Response (Schema d) = () 	response' = Schema $ \_inh -> Nothing +-- ** Type 'SchemaSeq'+data SchemaSeq d k a = SchemaSeq+ { schemaSeq_finalizer :: forall b c.+                           Schema d (b->c) c ->+                           Schema d (b->c) c+   -- ^ Used to implement 'rule'.+ , schemaSeq_alternatives :: [Schema d (a->k) k]+   -- ^ Collect alternatives for rendering them all at once in 'runSequence'.+ }+instance Functor (SchemaSeq d k) where+	_f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)+instance Applicative (SchemaSeq d k) where+	pure _a = SchemaSeq id mempty+	SchemaSeq fd f <*> SchemaSeq fx x =+		SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)+instance SchemaDoc d => CLI_Help (SchemaSeq d) where+	type HelpConstraint (SchemaSeq d) d' = d ~ d'+	help _msg = id+	program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps+	rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps+ -- ** Type 'SchemaPerm' data SchemaPerm d k a = SchemaPerm  { schemaPerm_finalizer :: forall b c.@@ -246,27 +305,6 @@ 	pure _a = SchemaPerm id mempty 	SchemaPerm fd f <*> SchemaPerm fx x = 		SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)-instance SchemaDoc d => Permutable (Schema d) where-	type Permutation (Schema d) = SchemaPerm d-	runPermutation (SchemaPerm fin ps) =-		case ps of-		 [] -> fin $ Schema $ \_inh -> Nothing-		 _ -> fin $ Schema $ \inh -> Just $-			Doc.intercalate Doc.breakspace $-			catMaybes $ (<$> ps) $ \(Schema s) ->-				s inh-				 { schemaInh_op=(op, SideL)-				 , schemaInh_or=docOrH }-		where op = infixN 10-	toPermutation = SchemaPerm id . pure-	toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $-		if needsParenInfix (schemaInh_op inh) op-		then-			Doc.brackets $-				runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}-		else-			runSchema s inh{schemaInh_op=(op, SideL)}-		where op = infixN0 instance SchemaDoc d => CLI_Help (SchemaPerm d) where 	type HelpConstraint (SchemaPerm d) d' = d ~ d' 	help _msg = id

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 2.3.3.20190711+version: 2.4.0.20190719 category: System, CLI, Options, Parsing synopsis: Symantics for parsing and documenting a CLI description:@@ -61,6 +61,7 @@     -- -fhide-source-paths   build-depends:       base              >= 4.10 && < 5+    , bytestring        >= 0.10     , containers        >= 0.5     , megaparsec        >= 7.0     , symantic-document >= 1.5