From: Julien Moutinho <julm@sourcephile.fr>
Date: Tue, 26 May 2020 03:33:32 +0000 (+0200)
Subject: remove tabs and move to src/
X-Git-Url: https://git.sourcephile.fr/haskell/symantic-cli.git/commitdiff_plain

remove tabs and move to src/
---

diff --git a/Symantic/CLI/API.hs b/Symantic/CLI/API.hs
deleted file mode 100644
index 3f6763b..0000000
--- a/Symantic/CLI/API.hs
+++ /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
index f186855..0000000
--- a/Symantic/CLI/Help.hs
+++ /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
index f2c8380..0000000
--- a/Symantic/CLI/Layout.hs
+++ /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
index a92bdaf..0000000
--- a/Symantic/CLI/Parser.hs
+++ /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
index 23f8f4b..0000000
--- a/Symantic/CLI/Schema.hs
+++ /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
index af28388..0000000
--- a/Symantic/CLI/Test.hs
+++ /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
diff --git a/Symantic/CLI.hs b/src/Symantic/CLI.hs
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
index 0000000..5e5722a
--- /dev/null
+++ b/src/Symantic/CLI/API.hs
@@ -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
diff --git a/Symantic/CLI/Fixity.hs b/src/Symantic/CLI/Fixity.hs
similarity index 80%
rename from Symantic/CLI/Fixity.hs
rename to src/Symantic/CLI/Fixity.hs
index 8cd67ee..df8c9a2 100644
--- a/Symantic/CLI/Fixity.hs
+++ b/src/Symantic/CLI/Fixity.hs
@@ -52,30 +52,30 @@ infixN5 = infixN 5
 -- 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
-	precedence :: a -> Precedence
+  precedence :: a -> Precedence
 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
-	precedence = unifix_prece
+  precedence = unifix_prece
 instance PrecedenceOf Infix where
-	precedence = infix_prece
+  precedence = infix_prece
 
 -- * Type 'Associativity'
 data Associativity
diff --git a/Symantic/CLI/HLint.hs b/src/Symantic/CLI/HLint.hs
similarity index 100%
rename from Symantic/CLI/HLint.hs
rename to src/Symantic/CLI/HLint.hs
diff --git a/src/Symantic/CLI/Help.hs b/src/Symantic/CLI/Help.hs
new file mode 100644
index 0000000..8394a90
--- /dev/null
+++ b/src/Symantic/CLI/Help.hs
@@ -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
index 0000000..bbd898d
--- /dev/null
+++ b/src/Symantic/CLI/Layout.hs
@@ -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
index 0000000..b9bb44e
--- /dev/null
+++ b/src/Symantic/CLI/Parser.hs
@@ -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
index 0000000..e6ab26b
--- /dev/null
+++ b/src/Symantic/CLI/Schema.hs
@@ -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
diff --git a/Symantic/HLint.hs b/src/Symantic/HLint.hs
similarity index 100%
rename from Symantic/HLint.hs
rename to src/Symantic/HLint.hs
diff --git a/symantic-cli.cabal b/symantic-cli.cabal
index 3331b04..7f55069 100644
--- a/symantic-cli.cabal
+++ b/symantic-cli.cabal
@@ -32,6 +32,7 @@ Source-Repository head
   type:     git
 
 Library
+  hs-source-dirs: src
   exposed-modules:
     Symantic.CLI
     Symantic.CLI.API
@@ -58,7 +59,6 @@ Library
     -Wall
     -Wincomplete-uni-patterns
     -Wincomplete-record-updates
-    -fno-warn-tabs
     -- -fhide-source-paths
   build-depends:
       base              >= 4.10 && < 5