diff --git a/Symantic/CLI.hs b/Symantic/CLI.hs
new file mode 100644
--- /dev/null
+++ b/Symantic/CLI.hs
@@ -0,0 +1,10 @@
+module Symantic.CLI
+ ( module Symantic.CLI.API
+ , module Symantic.CLI.Parser
+ , module Symantic.CLI.Schema
+ , module Symantic.CLI.Help
+ ) where
+import Symantic.CLI.API
+import Symantic.CLI.Parser
+import Symantic.CLI.Schema
+import Symantic.CLI.Help
diff --git a/Symantic/CLI/API.hs b/Symantic/CLI/API.hs
--- a/Symantic/CLI/API.hs
+++ b/Symantic/CLI/API.hs
@@ -5,20 +5,14 @@
 {-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
 module Symantic.CLI.API where
 
-import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..))
 import Data.Bool
 import Data.Char (Char)
 import Data.Eq (Eq)
 import Data.Function (($), (.), id)
-import Data.Int (Int)
 import Data.Kind (Constraint)
-import Data.Maybe (Maybe(..), maybe)
-import Data.Monoid (Monoid)
+import Data.Maybe (Maybe(..))
 import Data.String (String)
-import Data.Text (Text)
 import Text.Show (Show)
-import Data.Functor (Functor(..), (<$>))
 
 -- * Class 'App'
 class App repr where
@@ -34,13 +28,18 @@
 -- * Class 'Alt'
 class Alt repr where
 	(<!>) :: repr a k -> repr b k -> repr (a:!:b) k
+	opt :: repr (a->k) k -> repr (Maybe a->k) k
 	-- Trans defaults
 	default (<!>) ::
 	 Trans repr =>
 	 Alt (UnTrans repr) =>
 	 repr a k -> repr b k -> repr (a:!:b) k
 	x <!> y = noTrans (unTrans x <!> unTrans y)
-	opt :: repr (a->k) k -> repr (Maybe a->k) k
+	default opt ::
+	 Trans repr =>
+	 Alt (UnTrans repr) =>
+	 repr (a->k) k -> repr (Maybe a->k) k
+	opt = noTrans . opt . unTrans
 infixr 3 <!>
 
 -- ** Type (':!:')
diff --git a/Symantic/CLI/Help.hs b/Symantic/CLI/Help.hs
--- a/Symantic/CLI/Help.hs
+++ b/Symantic/CLI/Help.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (Word *) d
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
 module Symantic.CLI.Help where
 
 import Control.Applicative (Applicative(..))
@@ -99,7 +99,7 @@
  HelpInh d ->
  Tree.Forest (HelpNode, d) -> d
 runHelpNodes inh [] = mempty
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Command, _) t0s)
+runHelpNodes inh ( t0@(Tree.Node _ t0s)
                  : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
 	runHelpNode t0 <>
 	Doc.newline <>
@@ -111,15 +111,16 @@
 	Doc.newline <>
 	runHelpNodes inh (t1:ts)
 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
-                 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
+                 : 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_Env, _) _)
-                 : t1@(Tree.Node (HelpNode_Env, _) _) : 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 <>
@@ -131,10 +132,12 @@
 	Doc.newline <>
 	Doc.newline <>
 	runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
-                 : t1 : ts ) =
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 	runHelpNode t0 <>
 	Doc.newline <>
+	runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
+	runHelpNode t0 <>
 	Doc.newline <>
 	runHelpNodes inh (t1:ts)
 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
@@ -182,10 +185,13 @@
 	type EnvConstraint (Help d) a = ()
 	env' n =
 		Help (\inh ->
-			let ts = maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) in
+			let ts =
+				if helpInh_full inh
+				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+				else [] in
 			let d =
 				Doc.breakfill (helpInh_tag_indent inh)
-				 (Doc.bold (Doc.green (Doc.docFrom (Doc.Word n)))
+				 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
 					<> Doc.space)
 				<> (if null ts then mempty else Doc.space)
 				<> Doc.align (runHelpNodes inh ts)
@@ -206,7 +212,8 @@
 				 , helpInh_command_rule = True
 				 } in
 			let d =
-				(if not (null n) && helpInh_command_rule inh then ref<>Doc.space<>"::= " else mempty)
+				(if not (null n) && helpInh_command_rule inh
+				then ref<>Doc.space<>"::= " else mempty)
 				<> Schema.runSchema schema (helpInh_schema inh)
 				<> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 				<> Doc.incrIndent (helpInh_command_indent inh)
@@ -220,7 +227,7 @@
 			Doc.bold $
 			Doc.angles $
 			Doc.magentaer $
-			Doc.docFrom (Doc.Word n)
+			Doc.from (Doc.Word n)
 instance Docable d => CLI_Tag (Help d) where
 	type TagConstraint (Help d) a = ()
 	tagged n (Help h s) =
@@ -297,7 +304,7 @@
 			Doc.bold $
 			Doc.angles $
 			Doc.magentaer $
-			Doc.docFrom (Doc.Word n)
+			Doc.from (Doc.Word n)
 type HelpResponseArgs = SchemaResponseArgs
 instance Docable d => CLI_Response (Help d) where
 	type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
diff --git a/Symantic/CLI/Parser.hs b/Symantic/CLI/Parser.hs
--- a/Symantic/CLI/Parser.hs
+++ b/Symantic/CLI/Parser.hs
@@ -1,300 +1,240 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs #-} -- for Router
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
 module Symantic.CLI.Parser where
 
+import Control.Arrow (second)
 import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
-import Control.Arrow (first)
-import Control.Monad (Monad(..), join, sequence, unless)
+import Control.Monad (Monad(..), join, sequence, forM_, void)
 import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Except (ExceptT(..),throwE,runExceptT)
 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 (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)
-import Data.Monoid (Monoid(..))
+import Data.Maybe (Maybe(..), maybe, isNothing)
 import Data.Ord (Ord(..))
+import Data.Proxy (Proxy(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String)
+import Data.Tuple (snd)
+import Numeric.Natural (Natural)
+import Prelude (Integer, Num(..), error)
 import System.Environment (lookupEnv)
 import System.IO (IO)
-import Text.Read (readEither)
+import Text.Read (Read, readEither)
 import Text.Show (Show(..), ShowS, showString, showParen)
 import Type.Reflection as Reflection
 import qualified Data.List as List
-import qualified Data.Text.Lazy.IO as TL
-import qualified Data.Text.Lazy.Builder as TLB
+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 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 Debug.Trace as Debug
+import qualified Text.Megaparsec as P
 
 import Symantic.CLI.API
 
 -- * Type 'Parser'
-newtype Parser d f k = Parser
- { unParser :: StateT ParserState
-               (ParserCheckT [ParserError] IO)
-               (f -> k) -- Reader f k
+newtype Parser e d f k = Parser
+ { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
  }
-instance Functor (Parser d f) where
+
+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
+	 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 d f) where
+instance Applicative (Parser e d f) where
 	pure = Parser . pure . const
 	Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
-instance Alternative (Parser d f) where
-	empty = Parser $ do
-		StateT $ \st ->
-			throwE $ Fail st [ParserError_Alt]
-	Parser x <|> Parser y = Parser $
-		StateT $ \st -> do
-			lift (runExceptT (runStateT x st)) >>= \case
-			 Left xe | FailFatal{} <- xe -> throwE xe
-			         | otherwise ->
-				lift (runExceptT (runStateT y st)) >>= \case
-				 Left ye -> throwE (xe<>ye)
-				 Right yr -> ExceptT $ return $ Right yr
-			 Right xr ->
-				return xr
-instance Permutable (Parser d) where
-	type Permutation (Parser d) = ParserPerm d (Parser d)
+instance Ord e => Alternative (Parser e d f) where
+	empty = Parser empty
+	Parser x <|> Parser y = Parser $ x <|> y
+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
-			 Nothing -> maybe empty (Parser . return) ma
 			 Just perm -> runPermutation perm
+			 Nothing ->
+				maybe
+				 (Parser $ P.token (const Nothing) Set.empty)
+				 -- NOTE: not 'empty' 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)
-
-parser ::
- -- d ~ String => -- dummy d
- Router (Parser d) handlers (Response (Router (Parser d))) ->
- handlers ->
- [Arg] -> IO ()
-parser api handlers args = do
-	lrApp <-
-		runExceptT $ runStateT
-		 (unParser $ unTrans $ router api)
-		 ParserState
-		 { parserState_args = args
-		 }
-	case lrApp of
-	 Left err -> IO.print err
-	 Right (app, _st) -> unResponseParser $ app handlers
-
--- | Helper to parse the current argument.
-popArg ::
- ParserError ->
- (Arg ->
-  StateT ParserState (ParserCheckT [ParserError] IO) a) ->
-  StateT ParserState (ParserCheckT [ParserError] IO) a
-popArg errEnd f = do
-	st <- get
-	case parserState_args st of
-	 [] -> lift $ throwE $ Fail st [errEnd]
-	 curr:next -> do
-		lift (lift (runExceptT (runStateT (f curr) (ParserState next)))) >>= \case
-		 Left err -> lift $ throwE err
-		 Right (a,st') -> do
-			put st'
-			return a
-
--- ** Type 'Arg'
-data Arg
- =   ArgTagShort Char
- |   ArgTagLong Name
- |   ArgSegment Segment
- deriving (Eq,Show)
-
-parseArgs :: [String] -> [Arg]
-parseArgs 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]
-
--- ** Type 'ParserState'
-newtype ParserState = ParserState
- { parserState_args :: [Arg]
- } deriving (Show)
-
--- ** Type 'Router'
-type ParserCheckT e = ExceptT (Fail e)
-
--- ** Type 'ParserError'
-data ParserError
- =   ParserError_Alt -- ^ When there is no alternative.
- |   ParserError_Arg { expectedArg :: Name,   gotArg :: Maybe Arg }
- |   ParserError_Env { expectedEnv :: Name,   gotEnv :: Maybe String }
- |   ParserError_Tag { expectedTag :: Tag,    gotArg :: Maybe Arg }
- |   ParserError_Cmd { expectedCmd :: [Name], gotCmd :: Maybe Arg }
- |   ParserError_Var { expectedVar :: Name,   gotVar :: Maybe Arg }
- |   ParserError_End {                        gotEnd :: Arg }
- deriving (Eq,Show)
-
--- *** Type 'RouteResult'
-type RouteResult e = Either (Fail e)
-
--- *** Type 'Fail'
-data Fail e
- =   Fail ParserState e -- ^ Keep trying other paths.
- |   FailFatal !ParserState !e -- ^ Don't try other paths.
- deriving (Show)
-failState :: Fail e -> ParserState
-failState (Fail st _)      = st
-failState (FailFatal st _) = st
-failError :: Fail e -> e
-failError (Fail _st e)      = e
-failError (FailFatal _st e) = e
-instance Semigroup e => Semigroup (Fail e) where
-	Fail _ x      <> Fail st y      = Fail      st (x<>y)
-	FailFatal _ x <> Fail st _y     = FailFatal st (x{-<>y-})
-	Fail _ _x     <> FailFatal st y = FailFatal st ({-x<>-}y)
-	FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
-instance Monoid e => Monoid (Fail e) where
-	mempty = Fail (ParserState []) mempty
-	mappend = (<>)
-
--- * Class 'FromSegment'
-class FromSegment a where
-	fromSegment :: Segment -> Either String a
-instance FromSegment String where
-	fromSegment = Right
-instance FromSegment Int where
-	fromSegment = readEither
-instance FromSegment Bool where
-	fromSegment = readEither
-
--- ** Type 'ParserPerm'
-data ParserPerm d repr k a = ParserPerm
- { permutation_result :: !(Maybe ((a->k)->k))
- , permutation_parser :: repr () (ParserPerm d repr k a)
- }
-
-instance (App repr, Functor (repr ())) => Functor (ParserPerm d repr k) where
-	a2b `fmap` ParserPerm a ma = ParserPerm
-	 ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
-	 ((a2b `fmap`) `fmap` ma)
-instance (App repr, Functor (repr ()), Alternative (repr ())) => Applicative (ParserPerm d repr k) where
-	pure a = ParserPerm (Just ($ a)) empty
-	lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
-		ParserPerm a (lhsAlt <|> rhsAlt)
-		where
-		a =
-		 (\a2b2k2k a2k2k -> \b2k ->
-			a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
-		 ) <$> f <*> x
-		lhsAlt = (<*> rhs) <$> ma2b
-		rhsAlt = (lhs <*>) <$> ma
-instance CLI_Help repr => CLI_Help (ParserPerm d repr) where
-	type HelpConstraint (ParserPerm d repr) d' = HelpConstraint (Parser d) d'
-	program _n = id
-	rule _n = id
-
-noTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm d (UnTrans repr) k a -> ParserPerm d repr k a
-noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
-
-unTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm d repr k a -> ParserPerm 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 d repr k c -> ParserPerm d repr k c
-hoistParserPerm f (ParserPerm a ma) =
-	ParserPerm a (hoistParserPerm f <$> f ma)
-
-instance App (Parser d) where
+instance App (Parser e d) where
 	Parser x <.> Parser y = Parser $
 		x >>= \a2b -> (. a2b) <$> y
-instance Alt (Parser d) where
+instance Ord e => Alt (Parser e d) where
 	Parser x <!> Parser y = Parser $
-		StateT $ \st -> do
-			lift (runExceptT (runStateT x st)) >>= \case
-			 Left xe | FailFatal{} <- xe -> throwE xe
-			         | otherwise ->
-				lift (runExceptT (runStateT y st)) >>= \case
-				 Left ye -> throwE (xe<>ye)
-				 Right yr -> ExceptT $ return $ Right $
-					first (\b2k (_a:!:b) -> b2k b) yr
-			 Right xr ->
-				return $ first (\a2k (a:!:_b) -> a2k a) xr
-	opt (Parser x) = Parser $ do
-		st <- get
-		lift (lift (runExceptT $ runStateT x st)) >>= \case
-		 Left err -> return ($ Nothing)
-		 Right (a,st') -> do
-			put st'
-			return (mapCont Just a)
-instance AltApp (Parser d) where
+		(\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
+		(\b2k (_a:!:b) -> b2k b) <$> 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 d) where
+instance Pro (Parser e d) where
 	dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
-instance CLI_Command (Parser d) where
-	-- type CommandConstraint (Parser d) a = ()
+instance Ord e => CLI_Command (Parser e d) where
+	-- type CommandConstraint (Parser e d) a = ()
 	command "" x = x
-	command n x = commands $ Map.singleton n x
-instance CLI_Var (Parser d) where
-	type VarConstraint (Parser d) a = FromSegment a
-	var' :: forall a k. VarConstraint (Parser d) a => Name -> Parser d (a->k) k
+	command n x = commands $ Map.singleton n (Partial_Full, x)
+instance Ord e => CLI_Tag (Parser e d) where
+	type TagConstraint (Parser e d) a = ()
+	tagged 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
-		popArg (ParserError_Var name Nothing) $ \curr -> do
-			st@ParserState{..} <- get
-			case curr of
-			 ArgSegment seg ->
-				case fromSegment seg of
-				 Left err -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
-				 Right a -> return ($ a)
-			 _ -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
+		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<>">"
 	just a  = Parser $ return ($ a)
 	nothing = Parser $ return id
-instance CLI_Env (Parser d) where
-	type EnvConstraint (Parser d) a = FromSegment a
-	env' :: forall a k. EnvConstraint (Parser d) a => Name -> Parser d (a->k) k
-	env' name = Parser $ do
-		st <- get
-		lift (lift (lookupEnv name)) >>= \case
-		 Nothing -> lift $ throwE $ Fail st [ParserError_Env name Nothing]
-		 Just raw ->
-				case fromSegment raw of
-				 Left err -> lift $ throwE $ Fail st [ParserError_Env name (Just raw)]
-				 Right a -> return ($ a)
+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 (:)) ($ [])
@@ -305,50 +245,10 @@
 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 
-instance CLI_Tag (Parser d) where
-	type TagConstraint (Parser d) a = ()
-	tagged name p = Parser $ do
-		popArg (ParserError_Tag name Nothing) $ \curr -> do
-			st <- get
-			case lookupTag curr name of
-			 False -> lift $ throwE $ Fail st [ParserError_Tag name (Just curr)]
-			 True ->
-				lift (lift (runExceptT (runStateT (unParser p) st))) >>= \case
-				 Left (Fail st' e) -> lift $ throwE $ FailFatal st' e
-				 Left e -> lift $ throwE e
-				 Right (a,st') -> do
-					put st'
-					return a
-		where
-		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
-		popArg (ParserError_Tag (TagLong "") Nothing) $ \curr -> do
-			st@ParserState{..} <- get
-			case curr of
-			 ArgTagLong "" -> return id
-			 _ -> return id -- TODO: raise an error and use option?
-
 -- ** Type 'ParserResponse'
 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
 -- ** Type 'ParserResponseArgs'
-newtype ParserResponseArgs a = ParserResponseArgs (IO a)
- deriving (Functor,Applicative,Monad)
-
-instance CLI_Response (Parser d) where
-	type ResponseConstraint (Parser d) a = Outputable a
-	type ResponseArgs (Parser d) a = ParserResponseArgs a
-	type Response (Parser d) = ParserResponse
-	response' = Parser $ do
-		st <- get
-		unless (List.null $ parserState_args st) $ do
-			lift $ throwE $ Fail st [ParserError_End $
-			 List.head $ parserState_args st]
-		return $ \(ParserResponseArgs io) ->
-			ParserResponse $ io >>= output
+type ParserResponseArgs = IO
 
 -- * Class 'Outputable'
 -- | Output of a CLI.
@@ -356,24 +256,31 @@
 	output :: a -> IO ()
 	default output :: Show a => a -> IO ()
 	output = IO.print
-instance Outputable String where
-	output = IO.putStrLn
 
+instance Outputable () where
+	output = return
+instance Outputable Bool
+instance Outputable Int
+instance Outputable Integer
+instance Outputable Natural
+instance Outputable String where
+	output = IO.putStr
+instance Outputable Text.Text where
+	output = Text.putStr
+instance Outputable TL.Text where
+	output = TL.putStr
 instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
 	output =
 		TL.putStr .
 		TLB.toLazyText .
 		Doc.runPlain .
 		Doc.runAnsiText
-
-{-
-instance Outputable (Doc.Reorg Doc.Term) where
-	output = TL.hPutStrLn IO.stdout . Doc.textTerm
-instance Outputable (Doc.Reorg DocIO.TermIO) where
-	output = DocIO.runTermIO IO.stdout
-instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where
-	output = uncurry DocIO.runTermIO
--}
+instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where
+	output (h,d) =
+		TL.hPutStr h $
+		TLB.toLazyText $
+		Doc.runPlain $
+		Doc.runAnsiText d
 
 -- * Class 'IOType'
 -- | Like a MIME type but for input/output of a CLI.
@@ -382,67 +289,107 @@
 	default ioType :: Reflection.Typeable a => String
 	ioType = show (Reflection.typeRep @a)
 
+instance IOType ()
+instance IOType Bool
+instance IOType Int
+instance IOType Integer
+instance IOType Natural
 instance IOType String
+instance IOType Text.Text
+instance IOType TL.Text
 instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
-{-
-instance IOType (Doc.Reorg Doc.Term) where
-instance IOType (Doc.Reorg DocIO.TermIO) where
-instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)
--}
+instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder))
 
-instance CLI_Help (Parser d) where
-	type HelpConstraint (Parser d) d' = d ~ d'
-	help _msg  = id
+-- * 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 'Partial'
+data Partial
+ =   Partial_Prefix
+ |   Partial_Full
+ deriving (Show)
+
+-- ** Type 'ParserPerm'
+data ParserPerm e d repr k a = ParserPerm
+ { permutation_result :: !(Maybe ((a->k)->k))
+ , 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
+	 ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
+	 ((a2b `fmap`) `fmap` ma)
+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 =
+		 (\a2b2k2k a2k2k -> \b2k ->
+			a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
+		 ) <$> f <*> x
+		lhsAlt = (<*> rhs) <$> ma2b
+		rhsAlt = (lhs <*>) <$> ma
+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
+	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) -> repr a k
+	commands :: Map Name (Partial, repr a k) -> repr a k
 	-- taggeds  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
-instance CLI_Routing (Parser d) where
-	commands cmds = Parser $ do
-		st@ParserState{..} <- get
-		let exp = Map.keys cmds
-		popArg (ParserError_Cmd exp Nothing) $ \curr ->
-			case curr of
-			 ArgSegment cmd ->
-				case Map.lookup cmd cmds of
-				 Nothing -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
-				 Just x -> unParser x
-			 _ -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
-	{-
-	taggeds ms = Parser $ do
-		st@ParserState{..} <- get
-		case parserState_args of
-		 [] -> lift $ throwE $ Fail st [ParserError "empty path segment"]
-		 curr:next ->
-			case lookupTag curr of
-			 Nothing -> lift $ throwE $ Fail st [ParserError $ "expected: "<>fromString (show (Map.keys ms))<>" but got: "<>fromString (show curr)]
-			 Just x -> do
-				put st{parserState_args=next}
-				unParser x
+instance Ord e => CLI_Routing (Parser e d) where
+	commands cmds = Parser $
+		P.token check exp >>= unParser
 		where
-		lookupTag (ArgTagShort x) = Map.lookup (Left x) ms
-		lookupTag (ArgTagLong x) = Map.lookup (Right x) ms
-		lookupTag _ = Nothing
-	-}
+		exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
+		check = \case
+		 ArgSegment cmd -> snd <$> Map.lookup cmd cmds
+		 _ -> 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) -> Router repr a k
+ Router_Commands :: Map Name (Partial, Router repr a k) -> Router repr a k
  -- | Represent 'tagged'.
  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
- -- | Represent 'taggeds'.
- {-
- Router_Taggeds :: TagConstraint repr a =>
-                  Map (Either Char Name) (Router repr (a -> k) k) ->
-                  Router repr (a -> k) k
- -}
  -- | Represent ('<.>').
  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
  -- | Represent ('<!>').
@@ -451,23 +398,23 @@
  -- 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 Functor (Router (Parser d) f) where
+instance Ord e => Functor (Router (Parser e d) f) where
 	a2b`fmap`x = noTrans (a2b <$> unTrans x)
-instance Applicative (Router (Parser d) f) where
+instance Ord e => Applicative (Router (Parser e d) f) where
 	pure = noTrans . pure
 	f <*> x = noTrans (unTrans f <*> unTrans x)
-instance Alternative (Router (Parser d) f) where
+instance Ord e => Alternative (Router (Parser e d) f) where
 	empty = noTrans empty
 	f <|> x = noTrans (unTrans f <|> unTrans x)
-instance Permutable (Router (Parser d)) where
-	type Permutation (Router (Parser d)) = ParserPerm d (Router (Parser d))
+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 (repr ~ Parser d) => Show (Router repr a b) where
+instance (repr ~ Parser e d) => Show (Router repr a b) where
 	showsPrec p = \case
 	 Router_Any{} -> showString "X"
-	 Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . showString "]"
+	 Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go ((snd <$>) <$> Map.toList ms) . showString "]"
 		where
 		go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 		go [] = id
@@ -476,83 +423,58 @@
 			case xs of
 			 [] -> id
 			 _ -> showString ", " . go xs
-	 -- Router_Command n os x -> showString n . showString " " . showsPrec 10 (permutation_parser os) . showString " " . showsPrec p x
 	 Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
-	 {-
-	 Router_Taggeds ms -> showParen (p>=10) $
-		showString "taggeds [" . go (Map.toList ms) . showString "]"
-		where
-		go :: forall h k. [(Either Char Name, 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_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 Trans (Router (Parser d)) where
-	type UnTrans (Router (Parser d)) = Parser d
+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_Command n os x) = command n (unTransParserPerm os) (unTrans x)
-	unTrans (Router_Commands ms) = commands (unTrans <$> ms)
+	unTrans (Router_Commands ms) = commands ((unTrans <$>) <$> ms)
 	unTrans (Router_Tagged n x) = tagged n (unTrans x)
-	-- unTrans (Router_Taggeds ms) = taggeds (unTrans <$> ms)
 	unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 
-instance App (Router (Parser d)) where
+instance Ord e => App (Router (Parser e d)) where
 	(<.>) = Router_App
-instance Alt (Router (Parser d)) where
+instance Ord e => Alt (Router (Parser e d)) where
 	(<!>) = Router_Alt
-instance Pro (Router (Parser d))
-instance repr ~ (Parser d) => CLI_Command (Router repr) where
-	-- command = Router_Command
+instance Ord e => Pro (Router (Parser e d))
+instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 	command "" x = x
-	command n x = Router_Commands $ Map.singleton n x
-instance CLI_Var (Router (Parser d))
-instance CLI_Env (Router (Parser d))
-instance CLI_Tag (Router (Parser d)) where
+	command n x = Router_Commands $ Map.fromAscList $
+		go $ List.tail $ List.inits n
+		where
+		go [] = []
+		go [cmd] = [(cmd, (Partial_Full, x))]
+		go (cmd:cmds) = (cmd, (Partial_Prefix, x)) : go cmds
+instance Ord e => CLI_Var (Router (Parser e d))
+instance Ord e => CLI_Env (Router (Parser e d))
+instance Ord e => CLI_Tag (Router (Parser e d)) where
 	tagged = Router_Tagged
-instance CLI_Help (Router (Parser d)) where
+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 CLI_Response (Router (Parser d))
-instance CLI_Routing (Router (Parser d)) where
+instance Ord e => CLI_Response (Router (Parser e d))
+instance Ord e => CLI_Routing (Router (Parser e d)) where
 	-- taggeds  = Router_Taggeds
 	commands = Router_Commands
 
 router ::
- repr ~ Parser d =>
+ repr ~ Parser e d =>
  Router repr a b -> Router repr a b
 router = {-debug1 "router" $-} \case
  x@Router_Any{} -> x
- -- Router_Command n os x -> Router_Command n (hoistParserPerm router os) (router x)
  Router_Tagged n x -> Router_Tagged n (router x)
- {-
- Router_Tagged n x -> Router_Taggeds $
-	case n of
-	 Tag c s -> Map.fromList [(Left c, r), (Right s, r)]
-	 TagShort c -> Map.singleton (Left c) r
-	 TagLong s -> Map.singleton (Right s) r
-	 where r = router x
- -}
- {-
- Router_Taggeds xs `Router_App` Router_Taggeds ys ->
-	Router_Taggeds $ router <$> (xs <> ys)
- -}
  Router_Alt x y -> router x`router_Alt`router y
- Router_Commands xs -> Router_Commands $ router <$> xs
- -- Router_Taggeds xs -> Router_Taggeds $ router <$> xs
+ Router_Commands xs -> Router_Commands $ (router <$>) <$> xs
  Router_App xy z ->
 	case xy of
 	 Router_App x y ->
@@ -561,29 +483,16 @@
 		Router_App (router y) (router z)
 	 _ -> router xy `Router_App` router z
  Router_Union u x -> Router_Union u (router x)
- -- Router_Merge x -> Router_Merge (router x)
 
 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 router_Alt ::
- repr ~ Parser d =>
+ 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.
-	{- NOTE: useless because 'command' is already a 'Router_Commands'.
-	go (Router_Command x xo xt) (Router_Command y yo yt) =
-		Map.singleton x (router (runPermutation xo <.> xt))
-		`router_Commands`
-		Map.singleton y (router (runPermutation yo <.> yt))
-	go (Router_Command x xo xt) (Router_Commands ys) =
-		Map.singleton x (router (runPermutation xo <.> xt))
-		`router_Commands` ys
-	go (Router_Commands xs) (Router_Command y yo yt) =
-		xs `router_Commands`
-		Map.singleton y (router (runPermutation yo <.> yt))
-	-}
 	go (Router_Commands xs) (Router_Commands ys) =
 		xs`router_Commands`ys
 	
@@ -619,9 +528,9 @@
 	go x y = x`Router_Alt`y
 
 router_Commands ::
- repr ~ Parser d =>
- Map Segment (Router repr a k) ->
- Map Segment (Router repr b k) ->
+ repr ~ Parser e d =>
+ Map Segment (Partial, Router repr a k) ->
+ Map Segment (Partial, Router repr b k) ->
  Router repr (a:!:b) k
 router_Commands xs ys =
 	-- NOTE: a little bit more complex than required
@@ -629,35 +538,84 @@
 	-- such that 'unTrans' 'Router_Union' applies them all at once.
 	Router_Commands $
 	Map.merge
-	 (Map.traverseMissing $ const $ \case
-		 Router_Union u r ->
-			return $ Router_Union (\(x:!:_y) -> u x) r
-		 r -> return $ Router_Union (\(x:!:_y) -> x) r)
-	 (Map.traverseMissing $ const $ \case
-		 Router_Union u r ->
-			return $ Router_Union (\(_x:!:y) -> u y) r
-		 r -> return $ Router_Union (\(_x:!:y) -> y) r)
-	 (Map.zipWithAMatched $ const $ \case
-		 Router_Union xu xr -> \case
-			 Router_Union yu yr ->
-				return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
-			 yr ->
-				return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
-		 xr -> \case
-			 Router_Union yu yr ->
-				return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
-			 yr -> return $ xr`router_Alt`yr)
+	 (Map.mapMissing $ const $ second keepX)
+	 (Map.mapMissing $ const $ second keepY)
+	 (Map.zipWithMaybeMatched $ const $ \(xp,xr) (yp,yr) ->
+		case (xp,yp) of
+		 (Partial_Prefix, Partial_Prefix) -> Nothing
+		 (Partial_Full  , Partial_Prefix) -> Just $ (Partial_Full, keepX xr)
+		 (Partial_Prefix, Partial_Full  ) -> Just $ (Partial_Full, keepY yr)
+		 (Partial_Full  , Partial_Full  ) -> Just $ (Partial_Full, mergeFull xr yr)
+	 )
 	 xs ys
+	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
 
-{-
-debug0 :: Show a => String -> a -> a
-debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a
-debug1 :: Show a => Show b => String -> (a->b) -> (a->b)
-debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b
-	where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a
-debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)
-debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c
+-- ** 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
-	b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a
-	c   = b2c   $ Debug.trace (n<>": b: "<>show b) b
--}
+	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
--- a/Symantic/CLI/Schema.hs
+++ b/Symantic/CLI/Schema.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (Word *) d
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
 module Symantic.CLI.Schema where
 
 import Control.Applicative (Applicative(..))
@@ -50,9 +50,9 @@
  , Doc.Spaceable d
  , Doc.Indentable d
  , Doc.Wrappable d
- , Doc.DocFrom (Doc.Word Char) d
- , Doc.DocFrom (Doc.Word Text) d
- , Doc.DocFrom (Doc.Word String) d
+ , Doc.From (Doc.Word Char) d
+ , Doc.From (Doc.Word Text) d
+ , Doc.From (Doc.Word String) d
  )
 
 -- ** Type 'SchemaInh'
@@ -93,9 +93,9 @@
 		Doc.runAnsiText .
 		docSchema
 
-docOrH, docOrV :: Doc.Spaceable d => Doc.DocFrom (Doc.Word Char) d => d
-docOrH = Doc.space <> Doc.docFrom (Doc.Word '|') <> Doc.space
-docOrV = Doc.newline <> Doc.docFrom (Doc.Word '|') <> Doc.space
+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 Docable d => Functor (Schema d f) where
@@ -176,11 +176,11 @@
 			Doc.bold $
 			Doc.angles $
 			Doc.magentaer $
-			Doc.docFrom (Doc.Word n)
+			Doc.from (Doc.Word n)
 instance Docable d => CLI_Var (Schema d) where
 	type VarConstraint (Schema d) a = ()
 	var' n = Schema $ \_inh -> Just $
-		Doc.underline $ Doc.docFrom $ Doc.Word n
+		Doc.underline $ Doc.from $ Doc.Word n
 	just _  = Schema $ \_inh -> Nothing
 	nothing = Schema $ \_inh -> Nothing
 instance Docable d => CLI_Env (Schema d) where
@@ -214,7 +214,7 @@
 			Doc.bold $
 			Doc.angles $
 			Doc.magentaer $
-			Doc.docFrom (Doc.Word n)
+			Doc.from (Doc.Word n)
 data SchemaResponseArgs a
 instance Docable d => CLI_Response (Schema d) where
 	type ResponseConstraint (Schema d) a = ()
diff --git a/symantic-cli.cabal b/symantic-cli.cabal
--- a/symantic-cli.cabal
+++ b/symantic-cli.cabal
@@ -2,8 +2,8 @@
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 2.0.0.20190615
-category: 
+version: 2.2.1.20190629
+category: System, CLI, Options, Parsing
 synopsis: Symantics for parsing and documenting a CLI
 description:
   An extensible, typed and embedded Domain-Specific Language (DSL)
@@ -32,6 +32,7 @@
 
 Library
   exposed-modules:
+    Symantic.CLI
     Symantic.CLI.API
     Symantic.CLI.Fixity
     Symantic.CLI.Help
@@ -60,6 +61,7 @@
   build-depends:
       base              >= 4.10 && < 5
     , containers        >= 0.5
-    , symantic-document >= 0.2
+    , megaparsec        >= 7.0
+    , symantic-document >= 1.1.1
     , text              >= 1.2
     , transformers      >= 0.5