packages feed

symantic-cli 2.2.4.20190701 → 2.3.2.20190711

raw patch · 6 files changed

+391/−107 lines, 6 filesdep ~symantic-document

Dependency ranges changed: symantic-document

Files

Symantic/CLI.hs view
@@ -3,8 +3,10 @@  , module Symantic.CLI.Parser  , module Symantic.CLI.Schema  , module Symantic.CLI.Help+ , module Symantic.CLI.Layout  ) where import Symantic.CLI.API import Symantic.CLI.Parser import Symantic.CLI.Schema import Symantic.CLI.Help+import Symantic.CLI.Layout
Symantic/CLI/Help.hs view
@@ -27,10 +27,10 @@      -- ^ The 'Schema' of the current symantic.  } -runHelp :: Docable d => HelpInh d -> Help d f k -> d+runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline -docHelp :: Docable d => Doc.Indentable d => Docable d => Help d f k -> d+docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc d => Help d f k -> d docHelp = runHelp defHelpInh  coerceHelp :: Help d f k -> Help d f' k'@@ -59,7 +59,7 @@      -- ^ Whether to print full help.  } -defHelpInh :: Docable d => HelpInh d+defHelpInh :: SchemaDoc d => HelpInh d defHelpInh = HelpInh  { helpInh_message          = Nothing  , helpInh_command_indent   = 2@@ -85,19 +85,12 @@  |   HelpNode_Env  deriving Show -runHelpNode ::- Monoid d =>- Docable d =>- Tree (HelpNode, d) -> d+runHelpNode :: SchemaDoc d => Tree (HelpNode, d) -> d runHelpNode (Tree.Node (_n,d) _ts) = d  -- | Introduce 'Doc.newline' according to the 'HelpNode's -- put next to each others.-runHelpNodes ::- Monoid d =>- Docable d =>- HelpInh d ->- Tree.Forest (HelpNode, d) -> d+runHelpNodes :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d runHelpNodes _inh [] = mempty runHelpNodes inh ( t0@(Tree.Node _ t0s)                  : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =@@ -149,12 +142,12 @@ 	fromString s  = Help $ \_ro -> Just $ fromString s instance Show (Help Doc.Term e s a) where 	show = TL.unpack . Doc.textTerm . runHelp-instance Docable d => Functor (Help d f) where+instance SchemaDoc d => Functor (Help d f) where 	f <$$> Help h s = Help h (f<$$>s) -}-instance Docable d => App (Help d) where+instance SchemaDoc d => App (Help d) where 	Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)-instance Docable d => Alt (Help d) where+instance SchemaDoc d => Alt (Help d) where 	Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr) 	Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr) 	opt (Help h s) = Help h (opt s)@@ -163,22 +156,22 @@ 	choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs)) 	option a (Help h s) = Help h (option a s) 	-}-instance Docable d => Permutable (Help d) where+instance SchemaDoc d => Permutable (Help d) where 	type Permutation (Help d) = HelpPerm d 	runPermutation (HelpPerm h s) = Help h $ runPermutation s 	toPermutation   (Help h s) = HelpPerm h $ toPermutation s 	toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s instance Pro (Help d) where 	dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s-instance Docable d => AltApp (Help d) where+instance SchemaDoc d => AltApp (Help d) where 	many0 (Help h s) = Help h (many0 s) 	many1 (Help h s) = Help h (many1 s)-instance Docable d => CLI_Var (Help d) where+instance SchemaDoc d => CLI_Var (Help d) where 	type VarConstraint (Help d) a = () 	var' n  = Help mempty (var' n) 	just a  = Help mempty (just a) 	nothing = Help mempty nothing-instance Docable d => CLI_Env (Help d) where+instance SchemaDoc d => CLI_Env (Help d) where 	type EnvConstraint (Help d) a = () 	env' n = 		Help (\inh ->@@ -187,7 +180,7 @@ 				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) 				else [] in 			let d =-				Doc.breakfill (helpInh_tag_indent inh)+				Doc.fillOrBreak (helpInh_tag_indent inh) 				 (Doc.bold (Doc.green (Doc.from (Doc.Word n))) 					<> Doc.space) 				<> (if null ts then mempty else Doc.space)@@ -196,7 +189,7 @@ 			[ Tree.Node (HelpNode_Env, d) ts ] 		 ) schema 		where schema = env' n-instance Docable d => CLI_Command (Help d) where+instance SchemaDoc d => CLI_Command (Help d) where 	-- type CommandConstraint (Help d) a = () 	command n (Help h s) = 		Help (\inh ->@@ -209,11 +202,12 @@ 				 , helpInh_command_rule = True 				 } in 			let d =+				let ind = helpInh_command_indent inh in 				(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)+				<> Doc.incrIndent (Doc.spaces ind) ind 				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) 			in 			[ Tree.Node (HelpNode_Command, d) ts ]@@ -225,7 +219,7 @@ 			Doc.angles $ 			Doc.magentaer $ 			Doc.from (Doc.Word n)-instance Docable d => CLI_Tag (Help d) where+instance SchemaDoc d => CLI_Tag (Help d) where 	type TagConstraint (Help d) a = () 	tagged n (Help h s) = 		Help (\inh ->@@ -237,7 +231,7 @@ 					maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <> 					h inh{helpInh_message=Nothing} in 				let d =-					Doc.breakfill (helpInh_tag_indent inh)+					Doc.fillOrBreak (helpInh_tag_indent inh) 					 (Doc.bold $ 						Schema.runSchema schema (helpInh_schema inh) 						<> Doc.space) -- FIXME: space is not always needed@@ -249,7 +243,7 @@ 		 ) schema 		where schema = tagged n s 	endOpts = Help mempty endOpts-instance Docable d => CLI_Help (Help d) where+instance SchemaDoc d => CLI_Help (Help d) where 	type HelpConstraint (Help d) d' = d ~ d' 	help msg (Help h s) = Help 	 (\inh -> h inh{helpInh_message=Just msg})@@ -265,10 +259,10 @@ 				 , helpInh_command_rule = True 				 } in 			let d =+				let ind = helpInh_command_indent inh in 				Schema.runSchema schema (helpInh_schema inh) 				<> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)-				<> Doc.incrIndent-				 (helpInh_command_indent inh)+				<> Doc.incrIndent (Doc.spaces ind) ind 				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) 			in 			[ Tree.Node (HelpNode_Rule, d) ts ]@@ -286,11 +280,11 @@ 				 , helpInh_command_rule = True 				 } in 			let d =+				let ind = helpInh_command_indent inh in 				ref<>Doc.space<>"::= " 				<> Schema.runSchema schema (helpInh_schema inh) 				<> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)-				<> Doc.incrIndent-				 (helpInh_command_indent inh)+				<> Doc.incrIndent (Doc.spaces ind) ind 				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) 			in 			[ Tree.Node (HelpNode_Rule, d) ts ]@@ -303,7 +297,7 @@ 			Doc.magentaer $ 			Doc.from (Doc.Word n) type HelpResponseArgs = SchemaResponseArgs-instance Docable d => CLI_Response (Help d) where+instance SchemaDoc d => CLI_Response (Help d) where 	type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d) 	type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a 	type Response (Help d) = () -- Response (Schema d)@@ -316,7 +310,7 @@ 	response' = Help mempty $ response' @(Schema d) @a  {--instance Docable d => Sym_AltApp (Help d) where+instance SchemaDoc d => Sym_AltApp (Help d) where 	many (Help h s) = Help h (many s) 	some (Help h s) = Help h (many s) -}@@ -331,7 +325,7 @@ 	pure a = HelpPerm mempty (pure a) 	HelpPerm fh f <*> HelpPerm xh x = 		HelpPerm (fh<>xh) (f<*>x)-instance Docable d => CLI_Help (HelpPerm d) where+instance SchemaDoc d => CLI_Help (HelpPerm d) where 	type HelpConstraint (HelpPerm d) d' = d ~ d' 	help msg (HelpPerm h s) = HelpPerm 	 (\inh -> h inh{helpInh_message=Just msg})
+ Symantic/CLI/Layout.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d+module Symantic.CLI.Layout where++import Control.Applicative (Applicative(..))+import Control.Monad (Monad(..), (>>))+import Control.Monad.Trans.State.Strict+import Data.Bool+import Data.Function (($), (.), id)+import Data.Functor (Functor(..), (<$>))+import Data.Maybe (Maybe(..), fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))+import Data.Tree (Tree(..), Forest)+import Text.Show (Show(..))+import qualified Data.List as List+import qualified Data.Tree as Tree+import qualified Symantic.Document as Doc++import Symantic.CLI.API+import Symantic.CLI.Schema++-- * Type 'Layout'+data Layout d f k = Layout+ { layoutSchema :: Schema d f k+   -- ^ Synthetized (bottom-up) 'Schema'.+   -- Useful for complex grammar rules or 'alt'ernatives associated+   -- to the left of a 'response'.+ , layoutHelp   :: [d]+   -- ^ Synthetized (bottom-up) 'help'.+   -- Useful in 'LayoutPerm' to merge nested 'help'+   -- and nesting 'help' of the permutation.+ , unLayout     :: LayoutInh d -> State (LayoutState d) ()+ }++runLayout :: LayoutDoc d => Bool -> Layout d f k -> d+runLayout full (Layout _s _h l) =+	runLayoutForest full $+	fromMaybe [] $+	($ (Just [])) $+	(`execState`id) $+	l defLayoutInh++-- ** Type 'LayoutInh'+newtype LayoutInh d = LayoutInh+ { layoutInh_message :: {-!-}[d]+ }++defLayoutInh :: LayoutInh d+defLayoutInh = LayoutInh+ { layoutInh_message = []+ }++-- ** Type 'LayoutState'+type LayoutState d = Diff (Tree.Forest (LayoutNode d))++-- ** Type 'Diff'+-- | A continuation-passing-style constructor,+-- (each constructor prepending something),+-- augmented with 'Maybe' to change the prepending+-- according to what the following parts are.+-- Used in '<!>' and 'alt' to know if branches+-- lead to at least one route (ie. contain at least one 'response').+type Diff a = Maybe a -> Maybe a++-- ** Type 'LayoutDoc'+type LayoutDoc d =+ ( SchemaDoc d+ , Doc.Justifiable d+ )++runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d+runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)++runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d+runLayoutTree full =+	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 ->+		[ Doc.align $+			case mh of+			 [] -> Doc.whiter sch+			 _ | not full -> Doc.whiter sch+			 h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)+		]+	) <> docSubTrees ts0+	where+	docSubTrees [] = []+	docSubTrees [t] =+		-- "|" :+		shift (Doc.blacker "└──"<>Doc.space)+		      (Doc.spaces 4)+		      (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)+	docSubTrees (t:ts) =+		-- "|" :+		shift (Doc.blacker "├──"<>Doc.space)+		      (Doc.blacker "│"<>Doc.spaces 3)+		      (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)+		<> docSubTrees ts+	+	shift d ds =+		List.zipWith (<>)+		 (d : List.repeat ds)++instance LayoutDoc d => App (Layout d) where+	Layout xs xh xm <.> Layout ys yh ym =+		Layout (xs<.>ys) (xh<>yh) $ \inh ->+			xm inh >> ym inh+instance LayoutDoc d => Alt (Layout d) where+	Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do+		k <- get+		+		put id+		lm inh+		lk <- get+		+		put id+		rm inh+		rk <- get+		+		put $+			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 lt, Just rt) -> \case+				 Nothing -> k $ Just (lt<>rt)+				 Just ts -> k $ Just (lt<>rt<>ts)+			 (Just lt, Nothing) -> \case+				 Nothing -> k $ Just lt+				 Just ts -> k $ Just (lt<>ts)+			 (Nothing, Just rt) -> \case+				 Nothing -> k $ Just rt+				 Just ts -> k $ Just (rt<>ts)+		where sch = ls<!>rs+	Layout ls lh lm `alt` Layout rs rh rm =+		(Layout ls lh lm <!> Layout rs rh rm)+		 {layoutSchema=sch}+		where sch = ls`alt`rs+	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]+		xm inh+		where sch = opt xs+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+	command n (Layout xl xh xm) = Layout sch xh $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just+			[ Tree.Node+				 ( LayoutNode_Help (layoutInh_message inh)+				 $ Doc.magentaer $ docSchema $ command n nothing+				 ) ts+			]+		xm inh+		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+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just+			[ Tree.Node+			 ( LayoutNode_Tags [+				 ( layoutInh_message inh+				 , docSchema (tagged n nothing)+				 )+				]+			 ) ts+			]+		xm inh+	endOpts = Layout sch [] $ \_inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ 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+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]+		where sch = var' n+	just a  = Layout (just a) [] $ \_inh -> pure ()+	nothing = Layout nothing  [] $ \_inh -> pure ()+instance LayoutDoc d => CLI_Env (Layout d) where+	type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a+	env' n = Layout (env' n) [] $ \_inh -> pure ()+instance LayoutDoc d => CLI_Help (Layout d) where+	type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'+	help msg (Layout s _h m) = Layout+	 (help msg s) [msg]+	 (\inh -> m inh{layoutInh_message=[msg]})+	program n (Layout xl xh xm) = Layout sch xh $ \inh -> do+		modify' $ \k -> \case+		 Nothing -> k Nothing+		 Just ts -> k $ Just+			 [ Tree.Node+				 (LayoutNode_Help [] $ Doc.magentaer $ docSchema $ program n nothing)+				 ts+			 ]+		xm inh+		where sch = program n xl+	rule _n = id+instance LayoutDoc d => CLI_Response (Layout d) where+	type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a+	type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a+	type Response (Layout d) = Response (Schema d)+	response' = Layout response' [] $ \_inh -> do+		modify' $ \k -> \case+		 Nothing -> k $ Just []+		 Just ts -> k $ Just ts++-- ** Type 'LayoutPerm'+data LayoutPerm d k a = LayoutPerm+ { layoutPerm_help :: [d]+ , layoutPerm_elem :: LayoutInh d -> [([d], d)]+ }+instance Functor (LayoutPerm d k) where+	_f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh+instance Applicative (LayoutPerm d k) where+	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 ->+		m inh{layoutInh_message=[msg]}+	program _n = id+	rule    _n = id++-- ** Type 'LayoutNode'+data LayoutNode d+ =   LayoutNode_Help [d] d+ |   LayoutNode_Tags [([d], d)]+ deriving (Show)
Symantic/CLI/Parser.hs view
@@ -105,7 +105,6 @@  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 e d f) where@@ -262,24 +261,47 @@ instance Outputable Int instance Outputable Integer instance Outputable Natural+instance Outputable Char where+	output c = IO.putStr [c] 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+instance Outputable (Doc.Plain TLB.Builder) where 	output = 		TL.putStr . 		TLB.toLazyText .-		Doc.runPlain .-		Doc.runAnsiText-instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where-	output (h,d) =+		Doc.runPlain++-- ** Type 'OnHandle'+data OnHandle a = OnHandle IO.Handle a+instance IOType a => IOType (OnHandle a) where+	ioType = ioType @a+instance Outputable (OnHandle ()) where+	output _ = return ()+instance Outputable (OnHandle Bool) where+	output (OnHandle h a) = IO.hPrint h a+instance Outputable (OnHandle Int) where+	output (OnHandle h a) = IO.hPrint h a+instance Outputable (OnHandle Integer) where+	output (OnHandle h a) = IO.hPrint h a+instance Outputable (OnHandle Natural) where+	output (OnHandle h a) = IO.hPrint h a+instance Outputable (OnHandle Char) where+	output (OnHandle h c) = IO.hPutStr h [c]+instance Outputable (OnHandle String) where+	output (OnHandle h a) = IO.hPutStr h a+instance Outputable (OnHandle Text.Text) where+	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 (Doc.Plain TLB.Builder)) where+	output (OnHandle h d) = 		TL.hPutStr h $ 		TLB.toLazyText $-		Doc.runPlain $-		Doc.runAnsiText d+		Doc.runPlain d  -- * Class 'IOType' -- | Like a MIME type but for input/output of a CLI.@@ -290,14 +312,15 @@  instance IOType () instance IOType Bool+instance IOType Char 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 (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder))+instance IOType (Doc.Plain TLB.Builder)+instance IOType (IO.Handle, Doc.Plain TLB.Builder)  -- * Class 'FromSegment' class FromSegment a where
Symantic/CLI/Schema.hs view
@@ -31,17 +31,14 @@ runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d runSchema (Schema s) = fromMaybe mempty . s -docSchema :: Monoid d => Docable d => Schema d f k -> d+docSchema :: Monoid d => SchemaDoc d => Schema d f k -> d docSchema s = runSchema s defSchemaInh  coerceSchema :: Schema d f k -> Schema d f' k' coerceSchema Schema{..} = Schema{..} --- ** Type 'Doc'-type Doc = Doc.AnsiText (Doc.Plain TLB.Builder)---- ** Class 'Docable'-type Docable d =+-- ** Class 'SchemaDoc'+type SchemaDoc d =  ( Semigroup d  , Monoid d  , IsString d@@ -64,16 +61,16 @@  ,   schemaInh_or     :: d  } -defSchemaInh :: Docable d => SchemaInh d+defSchemaInh :: SchemaDoc d => SchemaInh d defSchemaInh = SchemaInh  { schemaInh_op     = (infixN0, SideL)  , schemaInh_define = True  , schemaInh_or     = docOrH  } -pairIfNeeded :: Docable d => SchemaInh d -> Infix -> d -> d-pairIfNeeded SchemaInh{..} op =-	if needsParenInfix schemaInh_op op+pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d+pairIfNeeded opInh op =+	if needsParenInfix opInh op 	then Doc.align . Doc.parens 	else id @@ -85,12 +82,11 @@ instance (Semigroup d, IsString d) => IsString (Schema d f k) where 	fromString "" = Schema $ \_inh -> Nothing 	fromString s  = Schema $ \_inh -> Just $ fromString s-instance Show (Schema Doc a k) where+instance Show (Schema (Doc.Plain TLB.Builder) a k) where 	show = 		TL.unpack . 		TLB.toLazyText . 		Doc.runPlain .-		Doc.runAnsiText . 		docSchema  docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d@@ -98,56 +94,67 @@ docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space  {--instance Docable d => Functor (Schema d f) where+instance SchemaDoc d => Functor (Schema d f) where 	_f `fmap` Schema x = Schema $ \inh ->-		pairIfNeeded inh op <$>+		pairIfNeeded (schemaInh_op inh) op <$> 		x inh{schemaInh_op=(op, SideR)} 		where 		op = infixB SideL 10 -}-instance Docable d => App (Schema d) where+instance SchemaDoc d => App (Schema d) where 	Schema f <.> Schema x = Schema $ \inh ->-		case (f inh{schemaInh_op=(op, SideL)}, x inh{schemaInh_op=(op, SideR)}) of-		 (Nothing, Nothing) -> Nothing-		 (Just f', Nothing) -> Just f'-		 (Nothing, Just x') -> Just x'-		 (Just f', Just x') -> Just $ pairIfNeeded inh op $ f' <> Doc.space <> x'+		case f inh{schemaInh_op=(op, SideL)} of+		 Nothing -> x inh{schemaInh_op=(op, SideR)}+		 Just fd ->+			case x inh{schemaInh_op=(op, SideR)} of+			 Nothing -> Just fd+			 Just xd -> Just $+				pairIfNeeded (schemaInh_op inh) op $+				fd <> Doc.space <> xd 		where 		op = infixB SideL 10-instance Docable d => Alt (Schema d) where-	lp <!> rp = Schema $ \inh ->-		case (unSchema lp inh, unSchema rp inh) of+instance SchemaDoc d => Alt (Schema d) where+	l <!> r = Schema $ \inh ->+		-- NOTE: first try to see if both sides are 'Just',+		-- otherwise does not change the inherited operator context.+		case (unSchema l inh, unSchema r inh) of 		 (Nothing, Nothing) -> Nothing-		 (Just lp', Nothing) -> Just lp'-		 (Nothing, Just rp') -> Just rp'+		 (Just ld, Nothing) -> Just ld+		 (Nothing, Just rd) -> Just rd 		 (Just{}, Just{}) -> Just $ 			if needsParenInfix (schemaInh_op inh) op 			then+				-- NOTE: when parenthesis are needed+				-- first try to fit the alternative on a single line,+				-- otherwise align them on multiple lines. 				Doc.breakalt 				 (Doc.parens $ 					-- Doc.withBreakable Nothing $-					runSchema lp inh+					runSchema l inh 					 { schemaInh_op=(op, SideL) 					 , schemaInh_or=docOrH } <> 					docOrH <>-					runSchema rp inh+					runSchema r inh 					 { schemaInh_op=(op, SideR) 					 , schemaInh_or=docOrH }) 				 (Doc.align $ 					Doc.parens $ 					Doc.space <>-					runSchema lp inh+					runSchema l inh 					 { schemaInh_op=(op, SideL) 					 , schemaInh_or=docOrV } <> 					docOrV <>-					runSchema rp inh+					runSchema r inh 					 { schemaInh_op=(op, SideR) 					 , schemaInh_or=docOrV } <> 					Doc.newline) 			else-				runSchema lp inh{schemaInh_op=(op, SideL)} <>+				-- NOTE: when parenthesis are NOT needed+				-- just concat alternatives using the inherited separator+				-- (either horizontal or vertical).+				runSchema l inh{schemaInh_op=(op, SideL)} <> 				schemaInh_or inh <>-				runSchema rp inh{schemaInh_op=(op, SideR)}+				runSchema r inh{schemaInh_op=(op, SideR)} 		where op = infixB SideL 2 	alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y 	opt s = Schema $ \inh -> Just $@@ -156,18 +163,19 @@ 		where op = infixN0 instance Pro (Schema d) where 	dimap _a2b _b2a = coerceSchema-instance Docable d => AltApp (Schema d) where+instance SchemaDoc d => AltApp (Schema d) where 	many0 s = Schema $ \inh -> Just $ 		runSchema s inh{schemaInh_op=(op, SideL)}<>"*" 		where op = infixN 10 	many1 s = Schema $ \inh -> Just $-		runSchema s inh{schemaInh_op=(op, SideL)}<>"..."+		runSchema s inh{schemaInh_op=(op, SideL)}<>"+" 		where op = infixN 10-instance Docable d => CLI_Command (Schema d) where+instance SchemaDoc d => CLI_Command (Schema d) where 	-- type CommandConstraint (Schema d) a = () 	command n s = Schema $ \inh -> Just $ 		if schemaInh_define inh || List.null n 		then+			Doc.align $ 			runSchema 			 (fromString n <.> coerceSchema s) 			 inh{schemaInh_define = False}@@ -178,18 +186,18 @@ 			Doc.angles $ 			Doc.magentaer $ 			Doc.from (Doc.Word n)-instance Docable d => CLI_Var (Schema d) where+instance SchemaDoc d => CLI_Var (Schema d) where 	type VarConstraint (Schema d) a = () 	var' n = Schema $ \_inh -> Just $ 		Doc.underline $ Doc.from $ Doc.Word n 	just _  = Schema $ \_inh -> Nothing 	nothing = Schema $ \_inh -> Nothing-instance Docable d => CLI_Env (Schema d) where+instance SchemaDoc d => CLI_Env (Schema d) where 	type EnvConstraint (Schema d) a = () 	env' _n = Schema $ \_inh -> Nothing 	 -- NOTE: environment variables are not shown in the schema, 	 -- only in the help.-instance Docable d => CLI_Tag (Schema d) where+instance SchemaDoc d => CLI_Tag (Schema d) where 	type TagConstraint (Schema d) a = () 	tagged n r = Schema $ \inh -> 		unSchema (prefix n <.> r) inh@@ -199,7 +207,7 @@ 		 TagShort s   -> fromString ['-', s] 		 TagLong  l   -> fromString ("--"<>l) 	endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"-instance Docable d => CLI_Help (Schema d) where+instance SchemaDoc d => CLI_Help (Schema d) where 	type HelpConstraint (Schema d) d' = d ~ d' 	help _msg = id 	program n s = Schema $ \inh -> Just $@@ -217,7 +225,7 @@ 			Doc.magentaer $ 			Doc.from (Doc.Word n) data SchemaResponseArgs a-instance Docable d => CLI_Response (Schema d) where+instance SchemaDoc d => CLI_Response (Schema d) where 	type ResponseConstraint (Schema d) a = () 	type ResponseArgs (Schema d) a = SchemaResponseArgs a 	type Response (Schema d) = ()@@ -225,50 +233,42 @@  -- ** Type 'SchemaPerm' data SchemaPerm d k a = SchemaPerm- { schemaPerm_finalizer    :: forall b c. Schema d (b->c) c -> Schema d (b->c) c+ { schemaPerm_finalizer :: forall b c.+                           Schema d (b->c) c ->+                           Schema d (b->c) c    -- ^ Used to implement 'rule'.  , schemaPerm_alternatives :: [Schema d (a->k) k]    -- ^ Collect alternatives for rendering them all at once in 'runPermutation'.  } instance Functor (SchemaPerm d k) where-	_f`fmap`SchemaPerm w ps = SchemaPerm w (coerceSchema <$> ps)+	_f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps) instance Applicative (SchemaPerm d k) where 	pure _a = SchemaPerm id mempty-	SchemaPerm fd w <*> SchemaPerm fx x =-		SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x)-instance Docable d => Permutable (Schema d) where+	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 w ps) =+	runPermutation (SchemaPerm fin ps) = 		case ps of-		 [] -> w $ Schema $ \_inh -> Nothing-		 [Schema s] -> w $ Schema s-		 _ -> w $ Schema $ \inh -> Just $-			-- pairIfNeeded inh op $-			Doc.align $+		 [] -> 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+		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.breakalt-			 (Doc.brackets $-				-- Doc.withBreakable Nothing $-				runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})-			 (Doc.align $-				Doc.brackets $-				Doc.space <>-				runSchema s inh{schemaInh_op=(op, SideL)} <>-				Doc.newline)+			Doc.brackets $+				runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH} 		else 			runSchema s inh{schemaInh_op=(op, SideL)} 		where op = infixN0-instance Docable d => CLI_Help (SchemaPerm d) where+instance SchemaDoc d => CLI_Help (SchemaPerm d) where 	type HelpConstraint (SchemaPerm d) d' = d ~ d' 	help _msg = id-	program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps-	rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps+	program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps+	rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps
symantic-cli.cabal view
@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 2.2.4.20190701+version: 2.3.2.20190711 category: System, CLI, Options, Parsing synopsis: Symantics for parsing and documenting a CLI description:@@ -38,6 +38,7 @@     Symantic.CLI.Help     Symantic.CLI.Parser     Symantic.CLI.Schema+    Symantic.CLI.Layout   default-language: Haskell2010   default-extensions:     FlexibleContexts@@ -62,6 +63,6 @@       base              >= 4.10 && < 5     , containers        >= 0.5     , megaparsec        >= 7.0-    , symantic-document >= 1.1.1+    , symantic-document >= 1.5     , text              >= 1.2     , transformers      >= 0.5