api: improve CLI_Tag

diff --git a/Symantic/CLI/API.hs b/Symantic/CLI/API.hs
index a6e4626b0c559405a7570a3c670d92d70ac0f8ee..83a885f9fc81e02f1c7e2a7799b5b2e787720ead 100644 (file)
--- a/Symantic/CLI/API.hs
+++ b/Symantic/CLI/API.hs
@@ -10,8 +10,8 @@ import Data.Char (Char)
 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'
@@ -184,31 +184,49 @@ data Tag
  |   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
@@ -216,7 +234,7 @@ class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where
         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'

diff --git a/Symantic/CLI/Help.hs b/Symantic/CLI/Help.hs
index 5234d623192b561ddb86912af1afd98afa16c84d..aa613b43955de95e25847aedbef16b21f97c45ce 100644 (file)
--- a/Symantic/CLI/Help.hs
+++ b/Symantic/CLI/Help.hs
@@ -221,7 +221,7 @@ instance SchemaDoc d => CLI_Command (Help d) where
                        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 @@ instance SchemaDoc d => CLI_Tag (Help d) where
                                [ 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'

diff --git a/Symantic/CLI/Layout.hs b/Symantic/CLI/Layout.hs
index 4a5a82cc6d9752f7ecf5ab0dee7146e4b7ab37f9..22611f7642c1d9fca10a73507ab205f05b1c609a 100644 (file)
--- a/Symantic/CLI/Layout.hs
+++ b/Symantic/CLI/Layout.hs
@@ -44,6 +44,14 @@ runLayout full (Layout _s _h l) =
        (`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]
@@ -105,7 +113,7 @@ runLayoutNode full (Tree.Node n ts0) =
                                        Doc.space <> Doc.align (Doc.justify (Doc.catV h))
         LayoutNode_Forest sch ds ts ->
                [Doc.whiter sch] <>
-               (if List.null ds then [] else [Doc.catV ds]) <>
+               (if List.null ds || not full then [] else [Doc.catV ds]) <>
                (if List.null ts then [] else [runLayoutForest' full ts])
        ) <> docSubTrees ts0
        where
@@ -231,13 +239,13 @@ instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
                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_List [] [
-                                ( docSchema (tagged n nothing)
+                                ( docSchema (tag n nothing)
                                 , layoutInh_message inh
                                 )
                                ]
@@ -327,6 +335,7 @@ instance LayoutDoc d => CLI_Help (LayoutPerm d) where
 
 -- ** 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)

diff --git a/Symantic/CLI/Parser.hs b/Symantic/CLI/Parser.hs
index f41f4354bce93535fd4a86b5d87383cde245aaff..c77bc35981c5f260203d73c942f6e8e375f1da6f 100644 (file)
--- a/Symantic/CLI/Parser.hs
+++ b/Symantic/CLI/Parser.hs
@@ -159,7 +159,7 @@ instance Ord e => CLI_Command (Parser e d) where
        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
@@ -437,7 +437,7 @@ hoistParserPerm f (ParserPerm a ma) =
 -- ** 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
@@ -459,8 +459,8 @@ data Router repr a b where
   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 ('<!>').
@@ -489,7 +489,7 @@ instance (repr ~ Parser e d) => Show (Router repr a b) where
                        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 "]"
@@ -500,7 +500,7 @@ instance Ord e => Trans (Router (Parser e d)) where
        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
@@ -530,7 +530,7 @@ instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 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'
@@ -540,7 +540,7 @@ instance CLI_Help (Router (Parser e d)) where
        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 ::
@@ -548,7 +548,7 @@ router ::
  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

diff --git a/Symantic/CLI/Schema.hs b/Symantic/CLI/Schema.hs
index 40ff429fd3fb59c0edb1e9fcaf87a2941a43bf91..f0b9659fab08c3b24193fa710c6c501b2bc7f8a5 100644 (file)
--- a/Symantic/CLI/Schema.hs
+++ b/Symantic/CLI/Schema.hs
@@ -237,7 +237,7 @@ instance SchemaDoc d => CLI_Env (Schema d) where
         -- 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

diff --git a/symantic-cli.cabal b/symantic-cli.cabal
index 55b0e6b63059f5a8a9a715df174a527624b8ff77..66f5a81d801f52cbd04ebcdb206306a66a0246d0 100644 (file)
--- a/symantic-cli.cabal
+++ b/symantic-cli.cabal
@@ -2,7 +2,7 @@ name: symantic-cli
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 2.3.5.20190714
+version: 2.4.0.20190719
 category: System, CLI, Options, Parsing
 synopsis: Symantics for parsing and documenting a CLI
 description: