]> Git — Sourcephile - haskell/symantic-cli.git/commitdiff
remove tabs and move to src/ master
authorJulien Moutinho <julm@sourcephile.fr>
Tue, 26 May 2020 03:33:32 +0000 (05:33 +0200)
committerJulien Moutinho <julm@sourcephile.fr>
Tue, 26 May 2020 03:33:32 +0000 (05:33 +0200)
16 files changed:
Symantic/CLI/API.hs [deleted file]
Symantic/CLI/Help.hs [deleted file]
Symantic/CLI/Layout.hs [deleted file]
Symantic/CLI/Parser.hs [deleted file]
Symantic/CLI/Schema.hs [deleted file]
Symantic/CLI/Test.hs [deleted file]
src/Symantic/CLI.hs [moved from Symantic/CLI.hs with 100% similarity]
src/Symantic/CLI/API.hs [new file with mode: 0644]
src/Symantic/CLI/Fixity.hs [moved from Symantic/CLI/Fixity.hs with 80% similarity]
src/Symantic/CLI/HLint.hs [moved from Symantic/CLI/HLint.hs with 100% similarity]
src/Symantic/CLI/Help.hs [new file with mode: 0644]
src/Symantic/CLI/Layout.hs [new file with mode: 0644]
src/Symantic/CLI/Parser.hs [new file with mode: 0644]
src/Symantic/CLI/Schema.hs [new file with mode: 0644]
src/Symantic/HLint.hs [moved from Symantic/HLint.hs with 100% similarity]
symantic-cli.cabal

diff --git a/Symantic/CLI/API.hs b/Symantic/CLI/API.hs
deleted file mode 100644 (file)
index 3f6763b..0000000
+++ /dev/null
@@ -1,314 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
-module Symantic.CLI.API where
-
-import Data.Bool
-import Data.Char (Char)
-import Data.Eq (Eq)
-import Data.Function (($), (.), id)
-import Data.Kind (Constraint)
-import Data.Maybe (Maybe(..), fromJust)
-import Data.String (String, IsString(..))
-import Text.Show (Show)
-
--- * Class 'App'
-class App repr where
-       (<.>) :: repr a b -> repr b c -> repr a c
-       -- Trans defaults
-       default (<.>) ::
-        Trans repr =>
-        App (UnTrans repr) =>
-        repr a b -> repr b c -> repr a c
-       x <.> y = noTrans (unTrans x <.> unTrans y)
-infixr 4 <.>
-
--- * 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
-       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@.
-data (:!:) a b = a:!:b
-infixr 3 :!:
-
--- * Class 'Pro'
-class Pro repr where
-       dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
-       -- Trans defaults
-       default dimap ::
-        Trans repr =>
-        Pro (UnTrans repr) =>
-        (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
-       dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
-
--- * Class 'AltApp'
-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) =>
-        repr (a->k) k -> repr ([a]->k) k
-       default many1 ::
-        Trans repr =>
-        AltApp (UnTrans repr) =>
-        repr (a->k) k -> repr ([a]->k) k
-       many0   = noTrans . many0 . unTrans
-       many1   = noTrans . many1 . unTrans
-
--- * Class 'Permutable'
-class Permutable repr where
-       -- 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
-       toPermutation :: repr (a->k) k -> Permutation repr k a
-       toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
-
--- | Convenient wrapper to omit a 'runPermutation'.
---
--- @
--- opts '<?>' next = 'runPermutation' opts '<.>' next
--- @
-(<?>) ::
- App repr => Permutable repr =>
- Permutation repr b a -> repr b c -> repr (a->b) c
-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
-
--- * Type 'Segment'
-type Segment = String
-
--- * Class 'CLI_Command'
-class CLI_Command repr where
-       command :: Name -> repr a k -> repr a k
-
--- * Class 'CLI_Var'
-class CLI_Var repr where
-       type VarConstraint repr a :: Constraint
-       var' :: VarConstraint repr a => Name -> repr (a->k) k
-       -- Trans defaults
-       type VarConstraint repr a = VarConstraint (UnTrans repr) a
-       default var' ::
-        Trans repr =>
-        CLI_Var (UnTrans repr) =>
-        VarConstraint (UnTrans repr) a =>
-        Name -> repr (a->k) k
-       var' = noTrans . var'
-
--- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
--- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
-var ::
- forall a k repr.
- CLI_Var repr =>
- VarConstraint repr a =>
- Name -> repr (a->k) k
-var = var'
-{-# INLINE var #-}
-
--- * Class 'CLI_Var'
-class CLI_Constant repr where
-       constant :: Segment -> a -> repr (a->k) k
-       just     :: a -> repr (a->k) k
-       nothing  :: repr k k
-       default constant ::
-        Trans repr =>
-        CLI_Constant (UnTrans repr) =>
-        Segment -> a -> repr (a->k) k
-       default just ::
-        Trans repr =>
-        CLI_Constant (UnTrans repr) =>
-        a -> repr (a->k) k
-       default nothing ::
-        Trans repr =>
-        CLI_Constant (UnTrans repr) =>
-        repr k k
-       constant s = noTrans . constant s
-       just       = noTrans . just
-       nothing    = noTrans nothing
-
--- * Class 'CLI_Env'
-class CLI_Env repr where
-       type EnvConstraint repr a :: Constraint
-       env' :: EnvConstraint repr a => Name -> repr (a->k) k
-       -- Trans defaults
-       type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
-       default env' ::
-        Trans repr =>
-        CLI_Env (UnTrans repr) =>
-        EnvConstraint (UnTrans repr) a =>
-        Name -> repr (a->k) k
-       env' = noTrans . env'
-
--- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
--- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
-env ::
- forall a k repr.
- CLI_Env repr =>
- EnvConstraint repr a =>
- Name -> repr (a->k) k
-env = env'
-{-# INLINE env #-}
-
--- ** Type 'Tag'
-data Tag
- =   Tag Char Name
- |   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_Constant repr) => CLI_Tag repr where
-       type TagConstraint repr a :: Constraint
-       tag :: Tag -> repr f k -> repr f k
-       -- tag n = (tag n <.>)
-       endOpts :: repr k k
-       
-       flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
-       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 tag ::
-        Trans repr =>
-        CLI_Tag (UnTrans repr) =>
-        Tag -> repr f k -> repr f k
-       default endOpts ::
-        Trans repr =>
-        CLI_Tag (UnTrans repr) =>
-        repr k k
-       tag n = noTrans . tag n . unTrans
-       endOpts = noTrans endOpts
-
--- * Class 'CLI_Response'
-class CLI_Response repr where
-       type ResponseConstraint repr a :: Constraint
-       type ResponseArgs repr a :: * -- = (r:: *) | r -> a
-       type Response repr :: *
-       response' ::
-        ResponseConstraint repr a =>
-        repr (ResponseArgs repr a)
-             (Response repr)
-       -- Trans defaults
-       type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
-       type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
-       type Response repr = Response (UnTrans repr)
-       default response' ::
-        forall a.
-        Trans repr =>
-        CLI_Response (UnTrans repr) =>
-        ResponseConstraint (UnTrans repr) a =>
-        ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
-        Response repr ~ Response (UnTrans repr) =>
-        repr (ResponseArgs repr a)
-             (Response repr)
-       response' = noTrans (response' @_ @a)
-
-response ::
- forall a repr.
- CLI_Response repr =>
- ResponseConstraint repr a =>
- repr (ResponseArgs repr a)
-      (Response repr)
-response = response' @repr @a
-{-# INLINE response #-}
-
--- * Class 'CLI_Help'
-class CLI_Help repr where
-       type HelpConstraint repr d :: Constraint
-       help :: HelpConstraint repr d => d -> repr f k -> repr f k
-       help _msg = id
-       program :: Name -> repr f k -> repr f k
-       rule :: Name -> repr f k -> repr f k
-       -- Trans defaults
-       type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
-       default program ::
-        Trans repr =>
-        CLI_Help (UnTrans repr) =>
-        Name -> repr f k -> repr f k
-       default rule ::
-        Trans repr =>
-        CLI_Help (UnTrans repr) =>
-        Name -> repr f k -> repr f k
-       program n = noTrans . program n . unTrans
-       rule n = noTrans . rule n . unTrans
-infixr 0 `help`
-
--- * Type 'Trans'
-class Trans repr where
-       -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
-       type UnTrans repr :: * -> * -> *
-       -- | Lift the underlying @(repr)@esentation to @(repr)@.
-       -- Useful to define a combinator that does nothing in a 'Trans'formation.
-       noTrans :: UnTrans repr a b -> repr a b
-       -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
-       -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
-       -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
-       -- from the inferred @(repr)@ value (eg. in 'server').
-       unTrans :: repr a b -> UnTrans repr a b
diff --git a/Symantic/CLI/Help.hs b/Symantic/CLI/Help.hs
deleted file mode 100644 (file)
index f186855..0000000
+++ /dev/null
@@ -1,340 +0,0 @@
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
-module Symantic.CLI.Help where
-
-import Control.Applicative (Applicative(..))
-import Data.Bool
-import Data.Foldable (null)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import Data.Maybe (Maybe(..), maybe, isJust)
-import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Text.Show (Show(..))
-import Data.Tree as Tree
-import qualified Symantic.Document as Doc
-
-import Symantic.CLI.API
-import Symantic.CLI.Schema as Schema
-
--- * Type 'Help'
-data Help d f k
- =   Help
- {   help_result :: HelpInh d -> HelpResult d
-     -- ^ The 'HelpResult' of the current symantic.
- ,   help_schema :: Schema d f k
-     -- ^ The 'Schema' of the current symantic.
- }
-
-runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
-runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
-
-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'
-coerceHelp Help{help_schema, ..} = Help
- { help_schema = Schema.coerceSchema help_schema
- , ..
- }
-
--- ** Type 'HelpInh'
--- | Configuration inherited top-down.
-data HelpInh d
- =   HelpInh
- {   helpInh_message :: !(Maybe d)
-     -- ^ The message inherited from 'help's.
- ,   helpInh_command_indent :: !Doc.Indent
-     -- ^ 'Doc.Indent'ation for 'command's.
- ,   helpInh_tag_indent :: !Doc.Indent
-     -- ^ 'Doc.Indent'ation for 'Tag's.
- ,   helpInh_schema :: !(SchemaInh d)
-     -- ^ The inherited 'SchemaInh' for 'runSchema'.
- ,   helpInh_helpless_options :: !Bool
-     -- ^ Whether to include options without help in the listing.
- ,   helpInh_command_rule :: !Bool
-     -- ^ Whether to print the name of the rule.
- ,   helpInh_full :: !Bool
-     -- ^ Whether to print full help.
- }
-
-defHelpInh :: SchemaDoc d => HelpInh d
-defHelpInh = HelpInh
- { helpInh_message          = Nothing
- , helpInh_command_indent   = 2
- , helpInh_tag_indent       = 16
- , helpInh_schema           = defSchemaInh
- , helpInh_helpless_options = False
- , helpInh_command_rule     = False
- , helpInh_full             = True
- }
-
--- ** Type 'HelpResult'
-type HelpResult d = Tree.Forest (HelpNode, d)
-
-defHelpResult :: Monoid d => HelpResult d
-defHelpResult = mempty
-
--- *** Type 'HelpNode'
-data HelpNode
- =   HelpNode_Message
- |   HelpNode_Rule
- |   HelpNode_Command
- |   HelpNode_Tag
- |   HelpNode_Env
- deriving Show
-
-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 :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
-runHelpNodes _inh [] = mempty
-runHelpNodes inh ( t0@(Tree.Node _ t0s)
-                 : t1@(Tree.Node (HelpNode_Command, _) _) : 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_Tag, _) _)
-                 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
-       runHelpNode t0 <>
-       Doc.newline <>
-       runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
-                 : 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_Message, _) _)
-                 : t1 : ts ) =
-       runHelpNode t0 <>
-       Doc.newline <>
-       Doc.newline <>
-       runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
-       runHelpNode t0 <>
-       Doc.newline <>
-       Doc.newline <>
-       runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
-       runHelpNode t0 <>
-       Doc.newline <>
-       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
-
-instance Semigroup d => Semigroup (Help d f k) where
-       Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
-instance Monoid d => Monoid (Help d f k) where
-       mempty  = Help mempty mempty
-       mappend = (<>)
-{-
-instance (Semigroup d, IsString d) => IsString (Help d e s a) where
-       fromString "" = Help $ \_ro -> Nothing
-       fromString s  = Help $ \_ro -> Just $ fromString s
-instance Show (Help Doc.Term e s a) where
-       show = TL.unpack . Doc.textTerm . runHelp
-instance SchemaDoc d => Functor (Help d f) where
-       f <$$> Help h s = Help h (f<$$>s)
--}
-instance SchemaDoc d => App (Help d) where
-       Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
-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)
-       {-
-       try (Help h s) = Help h (try s)
-       choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
-       option a (Help h s) = Help h (option a s)
-       -}
-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 SchemaDoc d => AltApp (Help d) where
-       many0 (Help h s) = Help h (many0 s)
-       many1 (Help h s) = Help h (many1 s)
-instance SchemaDoc d => CLI_Var (Help d) where
-       type VarConstraint (Help d) a = ()
-       var' n  = Help mempty (var' n)
-instance SchemaDoc d => CLI_Constant (Help d) where
-       constant n a = Help mempty (constant n a)
-       just a       = Help mempty (just a)
-       nothing      = Help mempty nothing
-instance SchemaDoc d => CLI_Env (Help d) where
-       type EnvConstraint (Help d) a = ()
-       env' n =
-               Help (\inh ->
-                       let ts =
-                               if helpInh_full inh
-                               then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
-                               else [] in
-                       let d =
-                               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)
-                               <> Doc.align (runHelpNodes inh ts)
-                               in
-                       [ Tree.Node (HelpNode_Env, d) ts ]
-                ) schema
-               where schema = env' n
-instance SchemaDoc d => CLI_Command (Help d) where
-       -- type CommandConstraint (Help d) a = ()
-       command n (Help h s) =
-               Help (\inh ->
-                       let ts =
-                               (if helpInh_full inh
-                               then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
-                               else []) <>
-                               h inh
-                                { helpInh_message      = Nothing
-                                , 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 (Doc.spaces ind) ind
-                                ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
-                       in
-                       [ Tree.Node (HelpNode_Command, d) ts ]
-                ) schema
-               where
-               schema = command n s
-               ref =
-                       Doc.bold $
-                       Doc.angles $
-                       Doc.magentaer $
-                       Doc.from (Doc.Word n)
-instance SchemaDoc d => CLI_Tag (Help d) where
-       type TagConstraint (Help d) a = ()
-       tag n (Help h s) =
-               Help (\inh ->
-                       if (isJust (helpInh_message inh)
-                       || helpInh_helpless_options inh)
-                       && helpInh_full inh
-                       then
-                               let ts =
-                                       maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
-                                       h inh{helpInh_message=Nothing} in
-                               let d =
-                                       Doc.fillOrBreak (helpInh_tag_indent inh)
-                                        (Doc.bold $
-                                               Schema.runSchema schema (helpInh_schema inh)
-                                               <> Doc.space) -- FIXME: space is not always needed
-                                       <> (if null ts then mempty else Doc.space)
-                                       <> Doc.align (runHelpNodes inh ts)
-                                       in
-                               [ Tree.Node (HelpNode_Tag, d) ts ]
-                       else []
-                ) schema
-               where schema = tag n s
-       endOpts = Help mempty endOpts
-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})
-        (help msg s)
-       program n (Help h s) =
-               Help (\inh ->
-                       let ts =
-                               (if helpInh_full inh
-                               then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
-                               else []) <>
-                               h inh
-                                { helpInh_message      = Nothing
-                                , 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 (Doc.spaces ind) ind
-                                ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
-                       in
-                       [ Tree.Node (HelpNode_Rule, d) ts ]
-                ) schema
-               where
-               schema = program n s
-       rule n (Help h s) =
-               Help (\inh ->
-                       let ts =
-                               (if helpInh_full inh
-                               then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
-                               else []) <>
-                               h inh
-                                { helpInh_message      = Nothing
-                                , 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 (Doc.spaces ind) ind
-                                ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
-                       in
-                       [ Tree.Node (HelpNode_Rule, d) ts ]
-                ) schema
-               where
-               schema = rule n s
-               ref =
-                       Doc.bold $
-                       Doc.angles $
-                       Doc.magentaer $
-                       Doc.from (Doc.Word n)
-type HelpResponseArgs = SchemaResponseArgs
-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)
-       response' ::
-        forall a repr.
-        repr ~ Help d =>
-        ResponseConstraint repr a =>
-        repr (ResponseArgs repr a)
-             (Response repr)
-       response' = Help mempty $ response' @(Schema d) @a
-
-{-
-instance SchemaDoc d => Sym_AltApp (Help d) where
-       many (Help h s) = Help h (many s)
-       some (Help h s) = Help h (many s)
--}
-
--- * Type 'HelpPerm'
-data HelpPerm d k a
- =   HelpPerm (HelpInh d -> HelpResult d)
-              (SchemaPerm d k a)
-instance Functor (HelpPerm d k) where
-       f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
-instance Applicative (HelpPerm d k) where
-       pure a = HelpPerm mempty (pure a)
-       HelpPerm fh f <*> HelpPerm xh x =
-               HelpPerm (fh<>xh) (f<*>x)
-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})
-        (help msg s)
-       program n (HelpPerm h s) = HelpPerm
-        (help_result $ program n (Help h (runPermutation s)))
-        (rule n s)
-       rule n (HelpPerm h s) = HelpPerm
-        (help_result $ rule n (Help h (runPermutation s)))
-        (rule n s)
diff --git a/Symantic/CLI/Layout.hs b/Symantic/CLI/Layout.hs
deleted file mode 100644 (file)
index f2c8380..0000000
+++ /dev/null
@@ -1,348 +0,0 @@
-{-# 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(..), 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.
- , layoutMonad  :: 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
-
-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]
- }
-
-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 <$>)
-
-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.catV . runLayoutNode full
-
-runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
-runLayoutNode full (Tree.Node n ts0) =
-       (case n of
-        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 [] = []
-       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_Single (docSchema sch) (lh<>rh)) 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_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 ->
-               maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
-               unSchema xl defSchemaInh
-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
-       command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
-               modify' $ \k -> \case
-                Nothing -> k Nothing
-                Just ts -> k $ Just
-                       [ Tree.Node
-                                ( LayoutNode_Single
-                                        (Doc.magentaer $ docSchema $ command n nothing)
-                                        (layoutInh_message inh)
-                                ) ts
-                       ]
-               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
-       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 (tag n nothing)
-                                , layoutInh_message inh
-                                )
-                               ]
-                        ) ts
-                       ]
-               xm inh{layoutInh_message=[]}
-       endOpts = Layout sch [] $ \_inh -> do
-               modify' $ \k -> \case
-                Nothing -> k Nothing
-                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
-               modify' $ \k -> \case
-                Nothing -> k Nothing
-                Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
-                       where h = [(docSchema sch, layoutInh_message inh)]
-               where sch = var' n
-instance LayoutDoc d => CLI_Constant (Layout d) where
-       constant c a = Layout sch [] $ \inh -> do
-               modify' $ \k -> \case
-                Nothing -> k Nothing
-                Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
-                       where h = [(docSchema sch, layoutInh_message inh)]
-               where sch = constant c a
-       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_Single (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 '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_alts :: LayoutInh d -> [(d, {-help-}[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 => 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_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
deleted file mode 100644 (file)
index a92bdaf..0000000
+++ /dev/null
@@ -1,711 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-} -- for Router
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
-module Symantic.CLI.Parser where
-
-import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
-import Control.Monad (Monad(..), join, sequence, forM_, void)
-import Control.Monad.Trans.Class (MonadTrans(..))
-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.Identity (Identity(..))
-import Data.Int (Int)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, isNothing)
-import Data.Ord (Ord(..))
-import Data.Proxy (Proxy(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Numeric.Natural (Natural)
-import Prelude (Integer, Num(..), error)
-import System.Environment (lookupEnv)
-import System.IO (IO)
-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
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified System.Exit as System
-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 Text.Megaparsec as P
-
-import Symantic.CLI.API
-
--- * Type 'Parser'
-newtype Parser e d f k = Parser
- { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
- }
-
-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
-                       System.exitWith (System.ExitFailure 2)
-        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 e d f) where
-       pure = Parser . pure . const
-       Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
-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
-               u2p <- unParser $ optional p
-               unParser $
-                       case u2p () of
-                        Just perm -> runPermutation perm
-                        Nothing ->
-                               maybe
-                                (Parser $ P.token (const Nothing) Set.empty)
-                                -- NOTE: Not 'empty' here 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)
-instance App (Parser e d) where
-       Parser x <.> Parser y = Parser $
-               x >>= \a2b -> (. a2b) <$> y
-instance Ord e => Alt (Parser e d) where
-       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
-       many0 (Parser x) = Parser $ concatCont <$> many x
-       many1 (Parser x) = Parser $ concatCont <$> some x
-instance Pro (Parser e d) where
-       dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
-instance Ord e => CLI_Command (Parser e d) where
-       -- type CommandConstraint (Parser e d) a = ()
-       command "" x = 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 = ()
-       tag 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
-               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<>">"
-instance Ord e => CLI_Constant (Parser e d) where
-       constant "" a = just a
-       constant c  a = commands Map.empty (Map.singleton c (just a))
-       just a  = Parser $ return ($ a)
-       nothing = Parser $ return id
-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 (:)) ($ [])
-
-consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
-consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
-
-mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
-mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
-
--- ** Type 'ParserResponse'
-newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
--- ** Type 'ParserResponseArgs'
-type ParserResponseArgs = IO
-
--- * Class 'Outputable'
--- | Output of a CLI.
-class IOType a => Outputable a where
-       output :: a -> IO ()
-       default output :: Show a => a -> IO ()
-       output = IO.print
-
-instance Outputable () where
-       output = return
-instance Outputable Bool
-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 BS.ByteString where
-       output = BS.putStr
-instance Outputable BSL.ByteString where
-       output = BSL.putStr
-instance Outputable (Doc.Plain TLB.Builder) where
-       output =
-               TL.putStr .
-               TLB.toLazyText .
-               Doc.runPlain
-
--- ** Type 'OnHandle'
-data OnHandle a = OnHandle IO.Handle a
-instance Functor OnHandle where
-       fmap f (OnHandle h a) = OnHandle h (f 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 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 -> System.exitWith (System.ExitFailure 1)
-        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 -> do
-               output (OnHandle IO.stderr e)
-               System.exitWith (System.ExitFailure 1)
-        Right a -> output a
-
--- * Class 'IOType'
--- | Like a MIME type but for input/output of a CLI.
-class IOType a where
-       ioType :: String
-       default ioType :: Reflection.Typeable a => String
-       ioType = show (Reflection.typeRep @a)
-
-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 BS.ByteString
-instance IOType BSL.ByteString
-instance IOType (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
-       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 '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))
- , 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 (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 = 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
-       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) -> Map Name (repr a k) -> repr a 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
-               where
-               exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
-               check = \case
-                ArgSegment cmd ->
-                       Map.lookup cmd cmds <|>
-                       Map.lookup cmd preCmds
-                _ -> 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) ->
-  Map Name (Router repr a k) ->
-  Router repr a 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 ('<!>').
- Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
- -- | Unify 'Router's which have different 'handlers'.
- -- 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 Ord e => Functor (Router (Parser e d) f) where
-       a2b`fmap`x = noTrans (a2b <$> unTrans x)
-instance Ord e => Applicative (Router (Parser e d) f) where
-       pure = noTrans . pure
-       f <*> x = noTrans (unTrans f <*> unTrans x)
-instance Ord e => Alternative (Router (Parser e d) f) where
-       empty = noTrans empty
-       f <|> x = noTrans (unTrans f <|> unTrans x)
-instance (repr ~ Parser e d) => Show (Router repr a b) where
-       showsPrec p = \case
-        Router_Any{} -> showString "X"
-        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
-               go ((n, r):xs) =
-                       (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
-                       case xs of
-                        [] -> id
-                        _ -> showString ", " . go xs
-        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
-       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 preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
-       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
-       (<.>) = 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 => 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
-       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_Constant (Router (Parser e d))
-instance Ord e => CLI_Env (Router (Parser e d))
-instance Ord e => CLI_Tag (Router (Parser e d)) where
-       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'
-       -- and may prevent patterns to be matched in 'router'.
-       help _msg  = id
-       program _n = id
-       rule _n    = id
-instance Ord e => CLI_Response (Router (Parser e d))
-instance Ord e => CLI_Routing (Router (Parser e d)) where
-       -- tags  = Router_Tags
-       commands = Router_Commands
-
-router ::
- repr ~ Parser e d =>
- Router repr a b -> Router repr a b
-router = {-debug1 "router" $-} \case
- x@Router_Any{} -> 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
-        (router <$> preCmds)
-        (router <$> cmds)
- Router_App xy z ->
-       case xy of
-        Router_App x y ->
-               -- Associate to the right
-               Router_App (router x) $
-               Router_App (router y) (router z)
-        _ -> router xy `Router_App` router z
- Router_Union u x -> Router_Union u (router x)
-
--- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
-router_Alt ::
- 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.
-       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) =
-               case x`router_Alt`y of
-                Router_Alt x' y' ->
-                       case y'`router_Alt`z of
-                        yz@(Router_Alt _y z') ->
-                               case x'`router_Alt`z' of
-                                Router_Alt{} -> router x'`Router_Alt`yz
-                                xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
-                                       -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
-                        yz -> x'`router_Alt`yz
-                xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
-       go (x`Router_Alt`y) z =
-               case y`router_Alt`z of
-                Router_Alt y' z' ->
-                       case x`router_Alt`y' of
-                        xy@(Router_Alt x' _y) ->
-                               case x'`router_Alt`z' of
-                                Router_Alt{} -> xy`Router_Alt`router z'
-                                xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
-                                       -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
-                        xy -> xy`router_Alt`z'
-                yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
-       
-       -- Merge through 'Router_Union'.
-       go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
-       go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
-       
-       -- No merging
-       go x y = x`Router_Alt`y
-
-router_Commands ::
- repr ~ Parser e d =>
- 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.
-       Map.merge
-        (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
-        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
-
--- ** Type 'RouterParserSeq'
-newtype RouterParserSeq repr k a = RouterParserSeq
- { unRouterParserSeq :: repr k a }
- deriving (Functor, Applicative)
-
--- * 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
-       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]"
diff --git a/Symantic/CLI/Schema.hs b/Symantic/CLI/Schema.hs
deleted file mode 100644 (file)
index 23f8f4b..0000000
+++ /dev/null
@@ -1,315 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
-module Symantic.CLI.Schema where
-
-import Control.Applicative (Applicative(..))
-import Data.Bool
-import Data.Char (Char)
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
-import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
-import Data.Text (Text)
-import Text.Show (Show(..))
-import qualified Data.List as List
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
-import qualified Symantic.Document as Doc
-
-import Symantic.CLI.API
-import Symantic.CLI.Fixity
-
--- * Type 'Schema'
-newtype Schema d f k
- =      Schema { unSchema :: SchemaInh d -> Maybe d }
-
-runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
-runSchema (Schema s) = fromMaybe mempty . s
-
-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{..}
-
--- ** Class 'SchemaDoc'
-type SchemaDoc d =
- ( Semigroup d
- , Monoid d
- , IsString d
- , Doc.Colorable16 d
- , Doc.Decorable d
- , Doc.Spaceable d
- , Doc.Indentable d
- , Doc.Wrappable d
- , Doc.From (Doc.Word Char) d
- , Doc.From (Doc.Word Text) d
- , Doc.From (Doc.Word String) d
- )
-
--- ** Type 'SchemaInh'
--- | Inherited top-down.
-data SchemaInh d
- =   SchemaInh
- {   schemaInh_op     :: (Infix, Side) -- ^ Parent operator.
- ,   schemaInh_define :: Bool          -- ^ Whether to print a definition, or not.
- ,   schemaInh_or     :: d             -- ^ The separator to use between alternatives.
- }
-
-defSchemaInh :: SchemaDoc d => SchemaInh d
-defSchemaInh = SchemaInh
- { schemaInh_op     = (infixN0, SideL)
- , schemaInh_define = True
- , schemaInh_or     = docOrH
- }
-
-pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
-pairIfNeeded opInh op =
-       if needsParenInfix opInh op
-       then Doc.align . Doc.parens
-       else id
-
-instance Semigroup d => Semigroup (Schema d f k) where
-       Schema x <> Schema y = Schema $ x <> y
-instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
-       mempty  = Schema mempty
-       mappend = (<>)
-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.Plain TLB.Builder) a k) where
-       show =
-               TL.unpack .
-               TLB.toLazyText .
-               Doc.runPlain .
-               docSchema
-
-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 SchemaDoc d => Functor (Schema d f) where
-       _f `fmap` Schema x = Schema $ \inh ->
-               pairIfNeeded (schemaInh_op inh) op <$>
-               x inh{schemaInh_op=(op, SideR)}
-               where
-               op = infixB SideL 10
--}
-instance SchemaDoc d => App (Schema d) where
-       Schema f <.> Schema x = Schema $ \inh ->
-               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 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 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 l inh
-                                        { schemaInh_op=(op, SideL)
-                                        , schemaInh_or=docOrH } <>
-                                       docOrH <>
-                                       runSchema r inh
-                                        { schemaInh_op=(op, SideR)
-                                        , schemaInh_or=docOrH })
-                                (Doc.align $
-                                       Doc.parens $
-                                       Doc.space <>
-                                       runSchema l inh
-                                        { schemaInh_op=(op, SideL)
-                                        , schemaInh_or=docOrV } <>
-                                       docOrV <>
-                                       runSchema r inh
-                                        { schemaInh_op=(op, SideR)
-                                        , schemaInh_or=docOrV } <>
-                                       Doc.newline)
-                       else
-                               -- 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 r 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)}
-               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 11
-       many1 s = Schema $ \inh -> Just $
-               pairIfNeeded (schemaInh_op inh) op $
-               runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
-               where op = infixN 11
-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}
-               else ref
-               where
-               ref =
-                       Doc.bold $
-                       Doc.angles $
-                       Doc.magentaer $
-                       Doc.from (Doc.Word n)
-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
-instance SchemaDoc d => CLI_Constant (Schema d) where
-       constant c _a = Schema $ \_inh -> Just $
-               Doc.from (Doc.Word c)
-       just _  = Schema $ \_inh -> Nothing
-       nothing = Schema $ \_inh -> Nothing
-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 SchemaDoc d => CLI_Tag (Schema d) where
-       type TagConstraint (Schema d) a = ()
-       tag n r = Schema $ \inh ->
-               unSchema (prefix n <.> r) inh
-               where
-               prefix = \case
-                Tag      s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
-                TagShort s   -> fromString ['-', s]
-                TagLong  l   -> fromString ("--"<>l)
-       endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
-instance SchemaDoc d => CLI_Help (Schema d) where
-       type HelpConstraint (Schema d) d' = d ~ d'
-       help _msg = id
-       program n s = Schema $ \inh -> Just $
-               runSchema
-                (fromString n <.> coerceSchema s)
-                inh{schemaInh_define = False}
-       rule n s = Schema $ \inh -> Just $
-               if schemaInh_define inh
-               then runSchema s inh{schemaInh_define=False}
-               else ref
-               where
-               ref =
-                       Doc.bold $
-                       Doc.angles $
-                       Doc.magentaer $
-                       Doc.from (Doc.Word n)
-data SchemaResponseArgs a
-instance SchemaDoc d => CLI_Response (Schema d) where
-       type ResponseConstraint (Schema d) a = ()
-       type ResponseArgs (Schema d) a = SchemaResponseArgs a
-       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.
-                           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 fin ps = SchemaPerm fin (coerceSchema <$> ps)
-instance Applicative (SchemaPerm d k) where
-       pure _a = SchemaPerm id mempty
-       SchemaPerm fd f <*> SchemaPerm fx x =
-               SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
-instance SchemaDoc d => CLI_Help (SchemaPerm d) where
-       type HelpConstraint (SchemaPerm d) d' = d ~ d'
-       help _msg = id
-       program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
-       rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps
diff --git a/Symantic/CLI/Test.hs b/Symantic/CLI/Test.hs
deleted file mode 100644 (file)
index af28388..0000000
+++ /dev/null
@@ -1,122 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Symantic.CLI.Test where
-
--- import Data.Monoid (Monoid(..))
--- import Data.Ord (Ord(..))
--- import Text.Show (Show(..))
-import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.Ord (Ord(..))
-import Data.Either (Either(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Data.Void (Void)
-import Text.Show (Show(..))
-import Type.Reflection (Typeable)
-import System.IO (IO, print, stderr, putStrLn)
-import System.Environment (getArgs)
-import Data.Int (Int)
-import qualified Data.Set as Set
-import qualified Data.Text.Lazy.IO as TL
-import qualified Symantic.Document.Term as Doc
-import qualified Symantic.Document.Term.IO as DocIO
-import qualified System.IO as IO
-
-import Symantic.CLI
-
-data Opts = Opts
- { opts_git_dir   :: String
- , opts_work_tree :: String
- , opts_int       :: Int
- } deriving (Show)
-
-api =
-       -- rule "main" $
-       (rule "OPTIONS" $
-               Opts <$> longOpt "git-dir" "GIT_DIR" (var "path")
-                    <*> longOpt "work-tree" "X" (var "path")
-                    <*> longOpt "int" 0 (var "name"))
-       <?>
-       rule "INFOS" (
-               api_clone
-               <!> api_push
-               <!> api_fetch
-               <!> api_help
-               <!> api_version
-       )
-
-help_ d = help (d::DocIO.TermIO)
-
-api_help =
-       help_ "print some help" $
-       tagged (Tag 'h' "help") nothing
-       <.> response @DocIO.TermIO
-
-api_version =
-       help_ "print the version" $
-       tagged (TagLong "version") nothing
-       <.> response @String
-
-api_clone =
-       help_ "cloned" $
-       command "clone" $
-               (Clone <$> longOpt "branch" "master" (var "name"))
-               <?> response @(Opts,Clone)
-
-api_push =
-       command "push" $
-               (Push <$> longOpt "set-upstream" False (just True)
-                     <*> longOpt "all" False (just True))
-               <?> endOpts
-               <.> many1 (var @String "refspec")
-               <.> response @(Opts,Push,[String])
-
-api_fetch =
-       command "fetch" $
-               response @Opts
-
-data Clone = Clone String
- deriving (Show)
-data Push = Push Bool Bool
- deriving (Show)
-
-doc0 = DocIO.runTermIO IO.stderr $ plainDoc api
-help0 = DocIO.runTermIO IO.stderr $ helpDoc api
-route_git gitOpts =
-       route_clone :!:
-       route_push  :!:
-       route_fetch :!:
-       route_help  :!:
-       route_version
-       where
-       route_help    = return $ helpDoc api
-       route_version = return "1.0"
-       route_clone (cloneOpts::Clone) =
-               return (gitOpts,cloneOpts)
-       route_push pushOpts refs =
-               return (gitOpts,pushOpts,refs)
-       route_fetch =
-               return (gitOpts)
-
-instance Typeable (a,b) => IOType (a,b)
-instance Typeable (a,b,c) => IOType (a,b,c)
-instance IOType Opts
-instance (Show (a,b), Typeable (a,b)) => Outputable (a,b)
-instance (Show (a,b,c), Typeable (a,b,c)) => Outputable (a,b,c)
-instance Outputable Opts
-
-parser0 = parser api route_git
-main :: IO ()
-main = do
-       args <- getArgs
-       putStrLn $ "args: " <> show args
-       parser0 $ parseArgs args
similarity index 100%
rename from Symantic/CLI.hs
rename to src/Symantic/CLI.hs
diff --git a/src/Symantic/CLI/API.hs b/src/Symantic/CLI/API.hs
new file mode 100644 (file)
index 0000000..5e5722a
--- /dev/null
@@ -0,0 +1,314 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
+module Symantic.CLI.API where
+
+import Data.Bool
+import Data.Char (Char)
+import Data.Eq (Eq)
+import Data.Function (($), (.), id)
+import Data.Kind (Constraint)
+import Data.Maybe (Maybe(..), fromJust)
+import Data.String (String, IsString(..))
+import Text.Show (Show)
+
+-- * Class 'App'
+class App repr where
+  (<.>) :: repr a b -> repr b c -> repr a c
+  -- Trans defaults
+  default (<.>) ::
+   Trans repr =>
+   App (UnTrans repr) =>
+   repr a b -> repr b c -> repr a c
+  x <.> y = noTrans (unTrans x <.> unTrans y)
+infixr 4 <.>
+
+-- * 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
+  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@.
+data (:!:) a b = a:!:b
+infixr 3 :!:
+
+-- * Class 'Pro'
+class Pro repr where
+  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
+  -- Trans defaults
+  default dimap ::
+   Trans repr =>
+   Pro (UnTrans repr) =>
+   (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
+  dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
+
+-- * Class 'AltApp'
+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) =>
+   repr (a->k) k -> repr ([a]->k) k
+  default many1 ::
+   Trans repr =>
+   AltApp (UnTrans repr) =>
+   repr (a->k) k -> repr ([a]->k) k
+  many0   = noTrans . many0 . unTrans
+  many1   = noTrans . many1 . unTrans
+
+-- * Class 'Permutable'
+class Permutable repr where
+  -- 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
+  toPermutation :: repr (a->k) k -> Permutation repr k a
+  toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
+
+-- | Convenient wrapper to omit a 'runPermutation'.
+--
+-- @
+-- opts '<?>' next = 'runPermutation' opts '<.>' next
+-- @
+(<?>) ::
+ App repr => Permutable repr =>
+ Permutation repr b a -> repr b c -> repr (a->b) c
+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
+
+-- * Type 'Segment'
+type Segment = String
+
+-- * Class 'CLI_Command'
+class CLI_Command repr where
+  command :: Name -> repr a k -> repr a k
+
+-- * Class 'CLI_Var'
+class CLI_Var repr where
+  type VarConstraint repr a :: Constraint
+  var' :: VarConstraint repr a => Name -> repr (a->k) k
+  -- Trans defaults
+  type VarConstraint repr a = VarConstraint (UnTrans repr) a
+  default var' ::
+   Trans repr =>
+   CLI_Var (UnTrans repr) =>
+   VarConstraint (UnTrans repr) a =>
+   Name -> repr (a->k) k
+  var' = noTrans . var'
+
+-- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
+-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
+var ::
+ forall a k repr.
+ CLI_Var repr =>
+ VarConstraint repr a =>
+ Name -> repr (a->k) k
+var = var'
+{-# INLINE var #-}
+
+-- * Class 'CLI_Var'
+class CLI_Constant repr where
+  constant :: Segment -> a -> repr (a->k) k
+  just     :: a -> repr (a->k) k
+  nothing  :: repr k k
+  default constant ::
+   Trans repr =>
+   CLI_Constant (UnTrans repr) =>
+   Segment -> a -> repr (a->k) k
+  default just ::
+   Trans repr =>
+   CLI_Constant (UnTrans repr) =>
+   a -> repr (a->k) k
+  default nothing ::
+   Trans repr =>
+   CLI_Constant (UnTrans repr) =>
+   repr k k
+  constant s = noTrans . constant s
+  just       = noTrans . just
+  nothing    = noTrans nothing
+
+-- * Class 'CLI_Env'
+class CLI_Env repr where
+  type EnvConstraint repr a :: Constraint
+  env' :: EnvConstraint repr a => Name -> repr (a->k) k
+  -- Trans defaults
+  type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
+  default env' ::
+   Trans repr =>
+   CLI_Env (UnTrans repr) =>
+   EnvConstraint (UnTrans repr) a =>
+   Name -> repr (a->k) k
+  env' = noTrans . env'
+
+-- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
+-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
+env ::
+ forall a k repr.
+ CLI_Env repr =>
+ EnvConstraint repr a =>
+ Name -> repr (a->k) k
+env = env'
+{-# INLINE env #-}
+
+-- ** Type 'Tag'
+data Tag
+ =   Tag Char Name
+ |   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_Constant repr) => CLI_Tag repr where
+  type TagConstraint repr a :: Constraint
+  tag :: Tag -> repr f k -> repr f k
+  -- tag n = (tag n <.>)
+  endOpts :: repr k k
+  
+  flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
+  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 tag ::
+   Trans repr =>
+   CLI_Tag (UnTrans repr) =>
+   Tag -> repr f k -> repr f k
+  default endOpts ::
+   Trans repr =>
+   CLI_Tag (UnTrans repr) =>
+   repr k k
+  tag n = noTrans . tag n . unTrans
+  endOpts = noTrans endOpts
+
+-- * Class 'CLI_Response'
+class CLI_Response repr where
+  type ResponseConstraint repr a :: Constraint
+  type ResponseArgs repr a :: * -- = (r:: *) | r -> a
+  type Response repr :: *
+  response' ::
+   ResponseConstraint repr a =>
+   repr (ResponseArgs repr a)
+        (Response repr)
+  -- Trans defaults
+  type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
+  type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
+  type Response repr = Response (UnTrans repr)
+  default response' ::
+   forall a.
+   Trans repr =>
+   CLI_Response (UnTrans repr) =>
+   ResponseConstraint (UnTrans repr) a =>
+   ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
+   Response repr ~ Response (UnTrans repr) =>
+   repr (ResponseArgs repr a)
+        (Response repr)
+  response' = noTrans (response' @_ @a)
+
+response ::
+ forall a repr.
+ CLI_Response repr =>
+ ResponseConstraint repr a =>
+ repr (ResponseArgs repr a)
+      (Response repr)
+response = response' @repr @a
+{-# INLINE response #-}
+
+-- * Class 'CLI_Help'
+class CLI_Help repr where
+  type HelpConstraint repr d :: Constraint
+  help :: HelpConstraint repr d => d -> repr f k -> repr f k
+  help _msg = id
+  program :: Name -> repr f k -> repr f k
+  rule :: Name -> repr f k -> repr f k
+  -- Trans defaults
+  type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
+  default program ::
+   Trans repr =>
+   CLI_Help (UnTrans repr) =>
+   Name -> repr f k -> repr f k
+  default rule ::
+   Trans repr =>
+   CLI_Help (UnTrans repr) =>
+   Name -> repr f k -> repr f k
+  program n = noTrans . program n . unTrans
+  rule n = noTrans . rule n . unTrans
+infixr 0 `help`
+
+-- * Type 'Trans'
+class Trans repr where
+  -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
+  type UnTrans repr :: * -> * -> *
+  -- | Lift the underlying @(repr)@esentation to @(repr)@.
+  -- Useful to define a combinator that does nothing in a 'Trans'formation.
+  noTrans :: UnTrans repr a b -> repr a b
+  -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
+  -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
+  -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
+  -- from the inferred @(repr)@ value (eg. in 'server').
+  unTrans :: repr a b -> UnTrans repr a b
similarity index 80%
rename from Symantic/CLI/Fixity.hs
rename to src/Symantic/CLI/Fixity.hs
index 8cd67ee8ed6351328ed5da3aac33bd78dd325404..df8c9a2c4a2b452694f9e76baf8f1e6a01d5e418 100644 (file)
@@ -52,30 +52,30 @@ infixN5 = infixN 5
 -- needs to be enclosed by parenthesis.
 needsParenInfix :: (Infix, Side) -> Infix -> Bool
 needsParenInfix (po, lr) op =
 -- needs to be enclosed by parenthesis.
 needsParenInfix :: (Infix, Side) -> Infix -> Bool
 needsParenInfix (po, lr) op =
-       infix_prece op < infix_prece po
-       || infix_prece op == infix_prece po
-       && Bool.not associate
-       where
-       associate =
-               case (lr, infix_assoc po) of
-                (_, Just AssocB{})   -> True
-                (SideL, Just AssocL) -> True
-                (SideR, Just AssocR) -> True
-                _ -> False
+  infix_prece op < infix_prece po
+  || infix_prece op == infix_prece po
+  && Bool.not associate
+  where
+  associate =
+    case (lr, infix_assoc po) of
+     (_, Just AssocB{})   -> True
+     (SideL, Just AssocL) -> True
+     (SideR, Just AssocR) -> True
+     _ -> False
 
 -- * Type 'Precedence'
 type Precedence = Int
 
 -- ** Class 'PrecedenceOf'
 class PrecedenceOf a where
 
 -- * Type 'Precedence'
 type Precedence = Int
 
 -- ** Class 'PrecedenceOf'
 class PrecedenceOf a where
-       precedence :: a -> Precedence
+  precedence :: a -> Precedence
 instance PrecedenceOf Fixity where
 instance PrecedenceOf Fixity where
-       precedence (Fixity1 uni) = precedence uni
-       precedence (Fixity2 inf) = precedence inf
+  precedence (Fixity1 uni) = precedence uni
+  precedence (Fixity2 inf) = precedence inf
 instance PrecedenceOf Unifix where
 instance PrecedenceOf Unifix where
-       precedence = unifix_prece
+  precedence = unifix_prece
 instance PrecedenceOf Infix where
 instance PrecedenceOf Infix where
-       precedence = infix_prece
+  precedence = infix_prece
 
 -- * Type 'Associativity'
 data Associativity
 
 -- * Type 'Associativity'
 data Associativity
diff --git a/src/Symantic/CLI/Help.hs b/src/Symantic/CLI/Help.hs
new file mode 100644 (file)
index 0000000..8394a90
--- /dev/null
@@ -0,0 +1,340 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
+module Symantic.CLI.Help where
+
+import Control.Applicative (Applicative(..))
+import Data.Bool
+import Data.Foldable (null)
+import Data.Function (($), (.))
+import Data.Functor (Functor(..), (<$>))
+import Data.Maybe (Maybe(..), maybe, isJust)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Text.Show (Show(..))
+import Data.Tree as Tree
+import qualified Symantic.Document as Doc
+
+import Symantic.CLI.API
+import Symantic.CLI.Schema as Schema
+
+-- * Type 'Help'
+data Help d f k
+ =   Help
+ {   help_result :: HelpInh d -> HelpResult d
+     -- ^ The 'HelpResult' of the current symantic.
+ ,   help_schema :: Schema d f k
+     -- ^ The 'Schema' of the current symantic.
+ }
+
+runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
+runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
+
+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'
+coerceHelp Help{help_schema, ..} = Help
+ { help_schema = Schema.coerceSchema help_schema
+ , ..
+ }
+
+-- ** Type 'HelpInh'
+-- | Configuration inherited top-down.
+data HelpInh d
+ =   HelpInh
+ {   helpInh_message :: !(Maybe d)
+     -- ^ The message inherited from 'help's.
+ ,   helpInh_command_indent :: !Doc.Indent
+     -- ^ 'Doc.Indent'ation for 'command's.
+ ,   helpInh_tag_indent :: !Doc.Indent
+     -- ^ 'Doc.Indent'ation for 'Tag's.
+ ,   helpInh_schema :: !(SchemaInh d)
+     -- ^ The inherited 'SchemaInh' for 'runSchema'.
+ ,   helpInh_helpless_options :: !Bool
+     -- ^ Whether to include options without help in the listing.
+ ,   helpInh_command_rule :: !Bool
+     -- ^ Whether to print the name of the rule.
+ ,   helpInh_full :: !Bool
+     -- ^ Whether to print full help.
+ }
+
+defHelpInh :: SchemaDoc d => HelpInh d
+defHelpInh = HelpInh
+ { helpInh_message          = Nothing
+ , helpInh_command_indent   = 2
+ , helpInh_tag_indent       = 16
+ , helpInh_schema           = defSchemaInh
+ , helpInh_helpless_options = False
+ , helpInh_command_rule     = False
+ , helpInh_full             = True
+ }
+
+-- ** Type 'HelpResult'
+type HelpResult d = Tree.Forest (HelpNode, d)
+
+defHelpResult :: Monoid d => HelpResult d
+defHelpResult = mempty
+
+-- *** Type 'HelpNode'
+data HelpNode
+ =   HelpNode_Message
+ |   HelpNode_Rule
+ |   HelpNode_Command
+ |   HelpNode_Tag
+ |   HelpNode_Env
+ deriving Show
+
+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 :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
+runHelpNodes _inh [] = mempty
+runHelpNodes inh ( t0@(Tree.Node _ t0s)
+                 : t1@(Tree.Node (HelpNode_Command, _) _) : 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_Tag, _) _)
+                 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
+  runHelpNode t0 <>
+  Doc.newline <>
+  runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
+                 : 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_Message, _) _)
+                 : t1 : ts ) =
+  runHelpNode t0 <>
+  Doc.newline <>
+  Doc.newline <>
+  runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
+  runHelpNode t0 <>
+  Doc.newline <>
+  Doc.newline <>
+  runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
+  runHelpNode t0 <>
+  Doc.newline <>
+  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
+
+instance Semigroup d => Semigroup (Help d f k) where
+  Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
+instance Monoid d => Monoid (Help d f k) where
+  mempty  = Help mempty mempty
+  mappend = (<>)
+{-
+instance (Semigroup d, IsString d) => IsString (Help d e s a) where
+  fromString "" = Help $ \_ro -> Nothing
+  fromString s  = Help $ \_ro -> Just $ fromString s
+instance Show (Help Doc.Term e s a) where
+  show = TL.unpack . Doc.textTerm . runHelp
+instance SchemaDoc d => Functor (Help d f) where
+  f <$$> Help h s = Help h (f<$$>s)
+-}
+instance SchemaDoc d => App (Help d) where
+  Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
+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)
+  {-
+  try (Help h s) = Help h (try s)
+  choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
+  option a (Help h s) = Help h (option a s)
+  -}
+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 SchemaDoc d => AltApp (Help d) where
+  many0 (Help h s) = Help h (many0 s)
+  many1 (Help h s) = Help h (many1 s)
+instance SchemaDoc d => CLI_Var (Help d) where
+  type VarConstraint (Help d) a = ()
+  var' n  = Help mempty (var' n)
+instance SchemaDoc d => CLI_Constant (Help d) where
+  constant n a = Help mempty (constant n a)
+  just a       = Help mempty (just a)
+  nothing      = Help mempty nothing
+instance SchemaDoc d => CLI_Env (Help d) where
+  type EnvConstraint (Help d) a = ()
+  env' n =
+    Help (\inh ->
+      let
+       ts =
+        if helpInh_full inh
+        then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+        else []
+       d =
+        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)
+        <> Doc.align (runHelpNodes inh ts)
+      in [ Tree.Node (HelpNode_Env, d) ts ]
+     ) schema
+    where schema = env' n
+instance SchemaDoc d => CLI_Command (Help d) where
+  -- type CommandConstraint (Help d) a = ()
+  command n (Help h s) =
+    Help (\inh ->
+      let
+       ts =
+        (if helpInh_full inh
+        then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+        else []) <>
+        h inh
+         { helpInh_message      = Nothing
+         , helpInh_command_rule = True
+         }
+       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 (Doc.spaces ind) ind
+         ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+      in [ Tree.Node (HelpNode_Command, d) ts ]
+     ) schema
+    where
+    schema = command n s
+    ref =
+      Doc.bold $
+      Doc.angles $
+      Doc.magentaer $
+      Doc.from (Doc.Word n)
+instance SchemaDoc d => CLI_Tag (Help d) where
+  type TagConstraint (Help d) a = ()
+  tag n (Help h s) =
+    Help (\inh ->
+      if (isJust (helpInh_message inh)
+      || helpInh_helpless_options inh)
+      && helpInh_full inh
+      then
+        let
+         ts =
+          maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
+          h inh{helpInh_message=Nothing}
+         d =
+          Doc.fillOrBreak (helpInh_tag_indent inh)
+           (Doc.bold $
+            Schema.runSchema schema (helpInh_schema inh)
+            <> Doc.space) -- FIXME: space is not always needed
+          <> (if null ts then mempty else Doc.space)
+          <> Doc.align (runHelpNodes inh ts)
+        in [ Tree.Node (HelpNode_Tag, d) ts ]
+      else []
+     ) schema
+    where schema = tag n s
+  endOpts = Help mempty endOpts
+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})
+   (help msg s)
+  program n (Help h s) =
+    Help (\inh ->
+      let
+       ts =
+        (if helpInh_full inh
+        then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+        else []) <>
+        h inh
+         { helpInh_message      = Nothing
+         , helpInh_command_rule = True
+         }
+       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 (Doc.spaces ind) ind
+         ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+      in [ Tree.Node (HelpNode_Rule, d) ts ]
+     ) schema
+    where
+    schema = program n s
+  rule n (Help h s) =
+    Help (\inh ->
+      let
+       ts =
+        (if helpInh_full inh
+        then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+        else []) <>
+        h inh
+         { helpInh_message      = Nothing
+         , helpInh_command_rule = True
+         }
+       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 (Doc.spaces ind) ind
+         ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+      in [ Tree.Node (HelpNode_Rule, d) ts ]
+     ) schema
+    where
+    schema = rule n s
+    ref =
+      Doc.bold $
+      Doc.angles $
+      Doc.magentaer $
+      Doc.from (Doc.Word n)
+type HelpResponseArgs = SchemaResponseArgs
+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)
+  response' ::
+   forall a repr.
+   repr ~ Help d =>
+   ResponseConstraint repr a =>
+   repr (ResponseArgs repr a)
+        (Response repr)
+  response' = Help mempty $ response' @(Schema d) @a
+
+{-
+instance SchemaDoc d => Sym_AltApp (Help d) where
+  many (Help h s) = Help h (many s)
+  some (Help h s) = Help h (many s)
+-}
+
+-- * Type 'HelpPerm'
+data HelpPerm d k a
+ =   HelpPerm (HelpInh d -> HelpResult d)
+              (SchemaPerm d k a)
+instance Functor (HelpPerm d k) where
+  f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
+instance Applicative (HelpPerm d k) where
+  pure a = HelpPerm mempty (pure a)
+  HelpPerm fh f <*> HelpPerm xh x =
+    HelpPerm (fh<>xh) (f<*>x)
+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})
+   (help msg s)
+  program n (HelpPerm h s) = HelpPerm
+   (help_result $ program n (Help h (runPermutation s)))
+   (rule n s)
+  rule n (HelpPerm h s) = HelpPerm
+   (help_result $ rule n (Help h (runPermutation s)))
+   (rule n s)
diff --git a/src/Symantic/CLI/Layout.hs b/src/Symantic/CLI/Layout.hs
new file mode 100644 (file)
index 0000000..bbd898d
--- /dev/null
@@ -0,0 +1,348 @@
+{-# 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(..), 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.
+ , layoutMonad  :: 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
+
+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]
+ }
+
+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 <$>)
+
+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.catV . runLayoutNode full
+
+runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
+runLayoutNode full (Tree.Node n ts0) =
+  (case n of
+   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 [] = []
+  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_Single (docSchema sch) (lh<>rh)) 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_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 ->
+    maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
+    unSchema xl defSchemaInh
+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
+  command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
+    modify' $ \k -> \case
+     Nothing -> k Nothing
+     Just ts -> k $ Just
+      [ Tree.Node
+         ( LayoutNode_Single
+           (Doc.magentaer $ docSchema $ command n nothing)
+           (layoutInh_message inh)
+         ) ts
+      ]
+    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
+  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 (tag n nothing)
+         , layoutInh_message inh
+         )
+        ]
+       ) ts
+      ]
+    xm inh{layoutInh_message=[]}
+  endOpts = Layout sch [] $ \_inh -> do
+    modify' $ \k -> \case
+     Nothing -> k Nothing
+     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
+    modify' $ \k -> \case
+     Nothing -> k Nothing
+     Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
+      where h = [(docSchema sch, layoutInh_message inh)]
+    where sch = var' n
+instance LayoutDoc d => CLI_Constant (Layout d) where
+  constant c a = Layout sch [] $ \inh -> do
+    modify' $ \k -> \case
+     Nothing -> k Nothing
+     Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
+      where h = [(docSchema sch, layoutInh_message inh)]
+    where sch = constant c a
+  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_Single (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 '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_alts :: LayoutInh d -> [(d, {-help-}[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 => 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_Single d {-help-}[d]
+ |   LayoutNode_List [d] [(d, {-help-}[d])]
+ |   LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
+ deriving (Show)
diff --git a/src/Symantic/CLI/Parser.hs b/src/Symantic/CLI/Parser.hs
new file mode 100644 (file)
index 0000000..b9bb44e
--- /dev/null
@@ -0,0 +1,712 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE GADTs #-} -- for Router
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
+module Symantic.CLI.Parser where
+
+import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
+import Control.Monad (Monad(..), join, sequence, forM_, void)
+import Control.Monad.Trans.Class (MonadTrans(..))
+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.Identity (Identity(..))
+import Data.Int (Int)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), maybe, isNothing)
+import Data.Ord (Ord(..))
+import Data.Proxy (Proxy(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String)
+import Numeric.Natural (Natural)
+import Prelude (Integer, Num(..), error)
+import System.Environment (lookupEnv)
+import System.IO (IO)
+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
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified System.Exit as System
+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 Text.Megaparsec as P
+
+import Symantic.CLI.API
+
+-- * Type 'Parser'
+newtype Parser e d f k = Parser
+ { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
+ }
+
+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
+      System.exitWith (System.ExitFailure 2)
+   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 e d f) where
+  pure = Parser . pure . const
+  Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
+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
+    u2p <- unParser $ optional p
+    unParser $
+      case u2p () of
+       Just perm -> runPermutation perm
+       Nothing ->
+        maybe
+         (Parser $ P.token (const Nothing) Set.empty)
+         -- NOTE: Not 'empty' here 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)
+instance App (Parser e d) where
+  Parser x <.> Parser y = Parser $
+    x >>= \a2b -> (. a2b) <$> y
+instance Ord e => Alt (Parser e d) where
+  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
+  many0 (Parser x) = Parser $ concatCont <$> many x
+  many1 (Parser x) = Parser $ concatCont <$> some x
+instance Pro (Parser e d) where
+  dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
+instance Ord e => CLI_Command (Parser e d) where
+  -- type CommandConstraint (Parser e d) a = ()
+  command "" x = 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 = ()
+  tag 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
+    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<>">"
+instance Ord e => CLI_Constant (Parser e d) where
+  constant "" a = just a
+  constant c  a = commands Map.empty (Map.singleton c (just a))
+  just a  = Parser $ return ($ a)
+  nothing = Parser $ return id
+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 (:)) ($ [])
+
+consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
+consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
+
+mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
+mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
+
+-- ** Type 'ParserResponse'
+newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
+-- ** Type 'ParserResponseArgs'
+type ParserResponseArgs = IO
+
+-- * Class 'Outputable'
+-- | Output of a CLI.
+class IOType a => Outputable a where
+  output :: a -> IO ()
+  default output :: Show a => a -> IO ()
+  output = IO.print
+
+instance Outputable () where
+  output = return
+instance Outputable Bool
+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 BS.ByteString where
+  output = BS.putStr
+instance Outputable BSL.ByteString where
+  output = BSL.putStr
+instance Outputable (Doc.Plain TLB.Builder) where
+  output =
+    TL.putStr .
+    TLB.toLazyText .
+    Doc.runPlain
+
+-- ** Type 'OnHandle'
+data OnHandle a = OnHandle IO.Handle a
+instance Functor OnHandle where
+  fmap f (OnHandle h a) = OnHandle h (f 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 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 -> System.exitWith (System.ExitFailure 1)
+   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 -> do
+    output (OnHandle IO.stderr e)
+    System.exitWith (System.ExitFailure 1)
+   Right a -> output a
+
+-- * Class 'IOType'
+-- | Like a MIME type but for input/output of a CLI.
+class IOType a where
+  ioType :: String
+  default ioType :: Reflection.Typeable a => String
+  ioType = show (Reflection.typeRep @a)
+
+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 BS.ByteString
+instance IOType BSL.ByteString
+instance IOType (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
+  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 '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))
+ , 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 (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 = 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
+  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) -> Map Name (repr a k) -> repr a 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
+    where
+    exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
+    check = \case
+     ArgSegment cmd ->
+      Map.lookup cmd cmds <|>
+      Map.lookup cmd preCmds
+     _ -> 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) ->
+  Map Name (Router repr a k) ->
+  Router repr a 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 ('<!>').
+ Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
+ -- | Unify 'Router's which have different 'handlers'.
+ -- 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 Ord e => Functor (Router (Parser e d) f) where
+  a2b`fmap`x = noTrans (a2b <$> unTrans x)
+instance Ord e => Applicative (Router (Parser e d) f) where
+  pure = noTrans . pure
+  f <*> x = noTrans (unTrans f <*> unTrans x)
+instance Ord e => Alternative (Router (Parser e d) f) where
+  empty = noTrans empty
+  f <|> x = noTrans (unTrans f <|> unTrans x)
+instance (repr ~ Parser e d) => Show (Router repr a b) where
+  showsPrec p = \case
+   Router_Any{} -> showString "X"
+   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
+    go ((n, r):xs) =
+      (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
+      case xs of
+       [] -> id
+       _ -> showString ", " . go xs
+   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
+  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 preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
+  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
+  (<.>) = 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 => 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
+  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_Constant (Router (Parser e d))
+instance Ord e => CLI_Env (Router (Parser e d))
+instance Ord e => CLI_Tag (Router (Parser e d)) where
+  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'
+  -- and may prevent patterns to be matched in 'router'.
+  help _msg  = id
+  program _n = id
+  rule _n    = id
+instance Ord e => CLI_Response (Router (Parser e d))
+instance Ord e => CLI_Routing (Router (Parser e d)) where
+  -- tags  = Router_Tags
+  commands = Router_Commands
+
+router ::
+ repr ~ Parser e d =>
+ Router repr a b -> Router repr a b
+router = {-debug1 "router" $-} \case
+ x@Router_Any{} -> 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
+   (router <$> preCmds)
+   (router <$> cmds)
+ Router_App xy z ->
+  case xy of
+   Router_App x y ->
+    -- Associate to the right
+    Router_App (router x) $
+    Router_App (router y) (router z)
+   _ -> router xy `Router_App` router z
+ Router_Union u x -> Router_Union u (router x)
+
+-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
+router_Alt ::
+ 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.
+  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) =
+    case x`router_Alt`y of
+     Router_Alt x' y' ->
+      case y'`router_Alt`z of
+       yz@(Router_Alt _y z') ->
+        case x'`router_Alt`z' of
+         Router_Alt{} -> router x'`Router_Alt`yz
+         xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
+          -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
+       yz -> x'`router_Alt`yz
+     xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
+  go (x`Router_Alt`y) z =
+    case y`router_Alt`z of
+     Router_Alt y' z' ->
+      case x`router_Alt`y' of
+       xy@(Router_Alt x' _y) ->
+        case x'`router_Alt`z' of
+         Router_Alt{} -> xy`Router_Alt`router z'
+         xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
+          -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
+       xy -> xy`router_Alt`z'
+     yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
+  
+  -- Merge through 'Router_Union'.
+  go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
+  go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
+  
+  -- No merging
+  go x y = x`Router_Alt`y
+
+router_Commands ::
+ repr ~ Parser e d =>
+ 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.
+  Map.merge
+   (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
+   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
+
+-- ** Type 'RouterParserSeq'
+newtype RouterParserSeq repr k a = RouterParserSeq
+ { unRouterParserSeq :: repr k a }
+ deriving (Functor, Applicative)
+
+-- * 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
+  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]"
diff --git a/src/Symantic/CLI/Schema.hs b/src/Symantic/CLI/Schema.hs
new file mode 100644 (file)
index 0000000..e6ab26b
--- /dev/null
@@ -0,0 +1,315 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
+module Symantic.CLI.Schema where
+
+import Control.Applicative (Applicative(..))
+import Data.Bool
+import Data.Char (Char)
+import Data.Function (($), (.), id)
+import Data.Functor (Functor(..), (<$>))
+import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String, IsString(..))
+import Data.Text (Text)
+import Text.Show (Show(..))
+import qualified Data.List as List
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Symantic.Document as Doc
+
+import Symantic.CLI.API
+import Symantic.CLI.Fixity
+
+-- * Type 'Schema'
+newtype Schema d f k
+ =      Schema { unSchema :: SchemaInh d -> Maybe d }
+
+runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
+runSchema (Schema s) = fromMaybe mempty . s
+
+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{..}
+
+-- ** Class 'SchemaDoc'
+type SchemaDoc d =
+ ( Semigroup d
+ , Monoid d
+ , IsString d
+ , Doc.Colorable16 d
+ , Doc.Decorable d
+ , Doc.Spaceable d
+ , Doc.Indentable d
+ , Doc.Wrappable d
+ , Doc.From (Doc.Word Char) d
+ , Doc.From (Doc.Word Text) d
+ , Doc.From (Doc.Word String) d
+ )
+
+-- ** Type 'SchemaInh'
+-- | Inherited top-down.
+data SchemaInh d
+ =   SchemaInh
+ {   schemaInh_op     :: (Infix, Side) -- ^ Parent operator.
+ ,   schemaInh_define :: Bool          -- ^ Whether to print a definition, or not.
+ ,   schemaInh_or     :: d             -- ^ The separator to use between alternatives.
+ }
+
+defSchemaInh :: SchemaDoc d => SchemaInh d
+defSchemaInh = SchemaInh
+ { schemaInh_op     = (infixN0, SideL)
+ , schemaInh_define = True
+ , schemaInh_or     = docOrH
+ }
+
+pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
+pairIfNeeded opInh op =
+  if needsParenInfix opInh op
+  then Doc.align . Doc.parens
+  else id
+
+instance Semigroup d => Semigroup (Schema d f k) where
+  Schema x <> Schema y = Schema $ x <> y
+instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
+  mempty  = Schema mempty
+  mappend = (<>)
+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.Plain TLB.Builder) a k) where
+  show =
+    TL.unpack .
+    TLB.toLazyText .
+    Doc.runPlain .
+    docSchema
+
+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 SchemaDoc d => Functor (Schema d f) where
+  _f `fmap` Schema x = Schema $ \inh ->
+    pairIfNeeded (schemaInh_op inh) op <$>
+    x inh{schemaInh_op=(op, SideR)}
+    where
+    op = infixB SideL 10
+-}
+instance SchemaDoc d => App (Schema d) where
+  Schema f <.> Schema x = Schema $ \inh ->
+    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 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 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 l inh
+           { schemaInh_op=(op, SideL)
+           , schemaInh_or=docOrH } <>
+          docOrH <>
+          runSchema r inh
+           { schemaInh_op=(op, SideR)
+           , schemaInh_or=docOrH })
+         (Doc.align $
+          Doc.parens $
+          Doc.space <>
+          runSchema l inh
+           { schemaInh_op=(op, SideL)
+           , schemaInh_or=docOrV } <>
+          docOrV <>
+          runSchema r inh
+           { schemaInh_op=(op, SideR)
+           , schemaInh_or=docOrV } <>
+          Doc.newline)
+      else
+        -- 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 r 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)}
+    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 11
+  many1 s = Schema $ \inh -> Just $
+    pairIfNeeded (schemaInh_op inh) op $
+    runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
+    where op = infixN 11
+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}
+    else ref
+    where
+    ref =
+      Doc.bold $
+      Doc.angles $
+      Doc.magentaer $
+      Doc.from (Doc.Word n)
+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
+instance SchemaDoc d => CLI_Constant (Schema d) where
+  constant c _a = Schema $ \_inh -> Just $
+    Doc.from (Doc.Word c)
+  just _  = Schema $ \_inh -> Nothing
+  nothing = Schema $ \_inh -> Nothing
+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 SchemaDoc d => CLI_Tag (Schema d) where
+  type TagConstraint (Schema d) a = ()
+  tag n r = Schema $ \inh ->
+    unSchema (prefix n <.> r) inh
+    where
+    prefix = \case
+     Tag      s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
+     TagShort s   -> fromString ['-', s]
+     TagLong  l   -> fromString ("--"<>l)
+  endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
+instance SchemaDoc d => CLI_Help (Schema d) where
+  type HelpConstraint (Schema d) d' = d ~ d'
+  help _msg = id
+  program n s = Schema $ \inh -> Just $
+    runSchema
+     (fromString n <.> coerceSchema s)
+     inh{schemaInh_define = False}
+  rule n s = Schema $ \inh -> Just $
+    if schemaInh_define inh
+    then runSchema s inh{schemaInh_define=False}
+    else ref
+    where
+    ref =
+      Doc.bold $
+      Doc.angles $
+      Doc.magentaer $
+      Doc.from (Doc.Word n)
+data SchemaResponseArgs a
+instance SchemaDoc d => CLI_Response (Schema d) where
+  type ResponseConstraint (Schema d) a = ()
+  type ResponseArgs (Schema d) a = SchemaResponseArgs a
+  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.
+                           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 fin ps = SchemaPerm fin (coerceSchema <$> ps)
+instance Applicative (SchemaPerm d k) where
+  pure _a = SchemaPerm id mempty
+  SchemaPerm fd f <*> SchemaPerm fx x =
+    SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
+instance SchemaDoc d => CLI_Help (SchemaPerm d) where
+  type HelpConstraint (SchemaPerm d) d' = d ~ d'
+  help _msg = id
+  program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
+  rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps
similarity index 100%
rename from Symantic/HLint.hs
rename to src/Symantic/HLint.hs
index 3331b04957ebb238dd8b19edebe76f4e3fe93f34..7f550698b619e26f90ad91942636a967ee231d6d 100644 (file)
@@ -32,6 +32,7 @@ Source-Repository head
   type:     git
 
 Library
   type:     git
 
 Library
+  hs-source-dirs: src
   exposed-modules:
     Symantic.CLI
     Symantic.CLI.API
   exposed-modules:
     Symantic.CLI
     Symantic.CLI.API
@@ -58,7 +59,6 @@ Library
     -Wall
     -Wincomplete-uni-patterns
     -Wincomplete-record-updates
     -Wall
     -Wincomplete-uni-patterns
     -Wincomplete-record-updates
-    -fno-warn-tabs
     -- -fhide-source-paths
   build-depends:
       base              >= 4.10 && < 5
     -- -fhide-source-paths
   build-depends:
       base              >= 4.10 && < 5