From 9bb290aef95110aa51d166516cdb69a42061dbd3 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm@autogeree.net>
Date: Thu, 27 Jun 2019 23:24:14 +0000
Subject: [PATCH] parser: add support for prefixes of commands

---
 Symantic/CLI/Parser.hs | 74 ++++++++++++++++++++++++++----------------
 symantic-cli.cabal     |  2 +-
 2 files changed, 47 insertions(+), 29 deletions(-)

diff --git a/Symantic/CLI/Parser.hs b/Symantic/CLI/Parser.hs
index 85346af..bd09140 100644
--- a/Symantic/CLI/Parser.hs
+++ b/Symantic/CLI/Parser.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
 module Symantic.CLI.Parser where
 
+import Control.Arrow (second)
 import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
 import Control.Monad (Monad(..), join, sequence, forM_, void)
 import Control.Monad.Trans.Class (MonadTrans(..))
@@ -28,6 +29,7 @@ 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)
@@ -149,7 +151,7 @@ instance Pro (Parser e d) where
 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
+	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
@@ -314,6 +316,12 @@ 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))
@@ -362,7 +370,7 @@ hoistParserPerm f (ParserPerm a 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 Ord e => CLI_Routing (Parser e d) where
 	commands cmds = Parser $
@@ -370,7 +378,7 @@ instance Ord e => CLI_Routing (Parser e d) where
 		where
 		exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
 		check = \case
-		 ArgSegment cmd -> Map.lookup cmd cmds
+		 ArgSegment cmd -> snd <$> Map.lookup cmd cmds
 		 _ -> Nothing
 
 -- * Type 'Router'
@@ -379,7 +387,7 @@ data Router repr a b where
  -- 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 ('<.>').
@@ -406,7 +414,7 @@ instance Ord e => Permutable (Router (Parser e d)) 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
@@ -426,7 +434,7 @@ instance Ord e => Trans (Router (Parser e d)) where
 	unTrans (Router_Any x) = x
 	unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 	unTrans (Router_App x y) = unTrans x <.> unTrans y
-	unTrans (Router_Commands ms) = commands (unTrans <$> ms)
+	unTrans (Router_Commands ms) = commands ((unTrans <$>) <$> ms)
 	unTrans (Router_Tagged n x) = tagged n (unTrans x)
 	unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 
@@ -437,7 +445,12 @@ instance Ord e => Alt (Router (Parser e d)) where
 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
+	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
@@ -461,7 +474,7 @@ router = {-debug1 "router" $-} \case
  x@Router_Any{} -> x
  Router_Tagged n x -> Router_Tagged n (router x)
  Router_Alt x y -> router x`router_Alt`router y
- Router_Commands xs -> Router_Commands $ router <$> xs
+ Router_Commands xs -> Router_Commands $ (router <$>) <$> xs
  Router_App xy z ->
 	case xy of
 	 Router_App x y ->
@@ -516,8 +529,8 @@ router_Alt = {-debug2 "router_Alt"-} go
 
 router_Commands ::
  repr ~ Parser e d =>
- Map Segment (Router repr a k) ->
- Map Segment (Router repr b k) ->
+ 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
@@ -525,25 +538,30 @@ router_Commands xs ys =
 	-- 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
 
 -- ** Type 'Arg'
 data Arg
diff --git a/symantic-cli.cabal b/symantic-cli.cabal
index 55c7f4d..b1160a6 100644
--- a/symantic-cli.cabal
+++ b/symantic-cli.cabal
@@ -2,7 +2,7 @@ name: symantic-cli
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 2.2.1.20190624
+version: 2.2.2.20190628
 category: 
 synopsis: Symantics for parsing and documenting a CLI
 description:
-- 
2.47.2