packages feed

symantic-cli 2.2.2.20190628 → 2.2.4.20190701

raw patch · 5 files changed

+55/−50 lines, 5 files

Files

Symantic/CLI/API.hs view
@@ -28,19 +28,28 @@ -- * Class 'Alt' class Alt repr where 	(<!>) :: repr a k -> repr b k -> repr (a:!:b) k+	alt :: repr a k -> repr a k -> repr a 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)+	default alt ::+	 Trans repr =>+	 Alt (UnTrans repr) =>+	 repr a k -> repr a k -> repr a k 	default opt :: 	 Trans repr => 	 Alt (UnTrans repr) => 	 repr (a->k) k -> repr (Maybe a->k) k+	x <!> y = noTrans (unTrans x <!> unTrans y)+	x `alt` y = noTrans (unTrans x `alt` unTrans y) 	opt = noTrans . opt . unTrans+-- NOTE: yes infixr, not infixl like <|>,+-- in order to run left-most checks first. infixr 3 <!>+infixr 3 `alt`  -- ** Type (':!:') -- | Like @(,)@ but @infixr@.
Symantic/CLI/Help.hs view
@@ -89,7 +89,7 @@  Monoid d =>  Docable d =>  Tree (HelpNode, d) -> d-runHelpNode (Tree.Node (n,d) _ts) = d -- "[" <> Doc.stringH (show n) <> "]" <> d+runHelpNode (Tree.Node (_n,d) _ts) = d  -- | Introduce 'Doc.newline' according to the 'HelpNode's -- put next to each others.@@ -98,7 +98,7 @@  Docable d =>  HelpInh d ->  Tree.Forest (HelpNode, d) -> d-runHelpNodes inh [] = mempty+runHelpNodes _inh [] = mempty runHelpNodes inh ( t0@(Tree.Node _ t0s)                  : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) = 	runHelpNode t0 <>@@ -132,10 +132,6 @@ 	Doc.newline <> 	Doc.newline <> 	runHelpNodes inh (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 <>@@ -160,6 +156,7 @@ 	Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px) instance Docable 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) 	{- 	try (Help h s) = Help h (try s)
Symantic/CLI/Parser.hs view
@@ -8,7 +8,6 @@ {-# 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.Monad (Monad(..), join, sequence, forM_, void) import Control.Monad.Trans.Class (MonadTrans(..))@@ -29,7 +28,6 @@ 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)@@ -141,6 +139,7 @@ 	Parser x <!> Parser y = Parser $ 		(\a2k (a:!:_b) -> a2k a) <$> P.try x <|> 		(\b2k (_a:!:b) -> b2k b) <$> y+	Parser x `alt` Parser y = Parser $ P.try x <|> y 	opt (Parser x) = Parser $ 		mapCont Just <$> P.try x instance Ord e => AltApp (Parser e d) where@@ -151,7 +150,7 @@ 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 (Partial_Full, x)+	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@@ -316,12 +315,6 @@ 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))@@ -370,15 +363,17 @@  -- ** Class 'CLI_Routing' class CLI_Routing repr where-	commands :: Map Name (Partial, repr a k) -> repr a k+	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 instance Ord e => CLI_Routing (Parser e d) where-	commands cmds = Parser $+	commands preCmds cmds = Parser $ 		P.token check exp >>= unParser 		where 		exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds 		check = \case-		 ArgSegment cmd -> snd <$> Map.lookup cmd cmds+		 ArgSegment cmd ->+			Map.lookup cmd cmds <|>+			Map.lookup cmd preCmds 		 _ -> Nothing  -- * Type 'Router'@@ -387,7 +382,10 @@  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.  Router_Any :: repr a b -> Router repr a b  -- | Represent 'commands'.- Router_Commands :: Map Name (Partial, Router repr a k) -> Router repr a k+ Router_Commands ::+  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 ('<.>').@@ -414,7 +412,7 @@ 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 ((snd <$>) <$> Map.toList ms) . showString "]"+	 Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]" 		where 		go :: forall h k. [(Segment, Router repr h k)] -> ShowS 		go [] = id@@ -434,7 +432,7 @@ 	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_Commands ms) = commands ((unTrans <$>) <$> ms)+	unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds) 	unTrans (Router_Tagged n x) = tagged n (unTrans x) 	unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x) @@ -442,15 +440,16 @@ 	(<.>) = Router_App 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 => Pro (Router (Parser e d)) instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where 	command "" x = x-	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+	command n x =+		let is = List.tail $ List.inits n in+		let (preCmds, cmds) = List.splitAt (List.length is - 1) is in+		Router_Commands+		 (Map.fromAscList $ (,x) <$> preCmds)+		 (Map.fromAscList $ (,x) <$> 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@@ -474,7 +473,10 @@  x@Router_Any{} -> x  Router_Tagged n x -> Router_Tagged n (router x)  Router_Alt x y -> router x`router_Alt`router y- Router_Commands xs -> Router_Commands $ (router <$>) <$> xs+ Router_Commands preCmds cmds ->+	Router_Commands+	 (router <$> preCmds)+	 (router <$> cmds)  Router_App xy z -> 	case xy of 	 Router_App x y ->@@ -493,8 +495,10 @@ router_Alt = {-debug2 "router_Alt"-} go 	where 	-- Merge alternative commands together.-	go (Router_Commands xs) (Router_Commands ys) =-		xs`router_Commands`ys+	go (Router_Commands xp xs) (Router_Commands yp ys) =+		Router_Commands+		 (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.+		 (router_Commands True xs ys) 	 	-- Merge left first or right first, depending on which removes 'Router_Alt'. 	go x (y`Router_Alt`z) =@@ -529,25 +533,19 @@  router_Commands ::  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 =+ Bool ->+ Map Segment (Router repr a k) ->+ Map Segment (Router repr b k) ->+ Map Segment (Router repr (a:!:b) k)+router_Commands allowMerging = 	-- NOTE: a little bit more complex than required 	-- in order to merge 'Router_Union's instead of nesting them, 	-- such that 'unTrans' 'Router_Union' applies them all at once.-	Router_Commands $ 	Map.merge-	 (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+	 (Map.mapMissing $ const keepX)+	 (Map.mapMissing $ const keepY)+	 (Map.zipWithMaybeMatched $ const $ \x y ->+		if allowMerging then Just $ mergeFull x y else Nothing) 	where 	keepX = \case 	 Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
Symantic/CLI/Schema.hs view
@@ -149,6 +149,7 @@ 				schemaInh_or inh <> 				runSchema rp inh{schemaInh_op=(op, SideR)} 		where op = infixB SideL 2+	alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y 	opt s = Schema $ \inh -> Just $ 		Doc.brackets $ 		runSchema s inh{schemaInh_op=(op, SideL)}@@ -185,7 +186,7 @@ 	nothing = Schema $ \_inh -> Nothing instance Docable d => CLI_Env (Schema d) where 	type EnvConstraint (Schema d) a = ()-	env' n = Schema $ \_inh -> Nothing+	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@@ -251,7 +252,7 @@ 				 , schemaInh_or=docOrH } 			where op = infixN 10 	toPermutation = SchemaPerm id . pure-	toPermDefault a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $+	toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $ 		if needsParenInfix (schemaInh_op inh) op 		then 			Doc.breakalt
symantic-cli.cabal view
@@ -2,8 +2,8 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 2.2.2.20190628-category: +version: 2.2.4.20190701+category: System, CLI, Options, Parsing synopsis: Symantics for parsing and documenting a CLI description:   An extensible, typed and embedded Domain-Specific Language (DSL)