Group adjacent and non-adjacent options/commands

Author: tbidne

src/Options/Applicative/Help/Core.hs

@@ -21,10 +21,9 @@ module Options.Applicative.Help.Core (
 
 import Control.Applicative
 import Control.Monad (guard)
-import Data.Function (on)
-import Data.List (sort, intercalate, intersperse, groupBy)
+import Data.List (sort, intercalate, intersperse)
 import Data.Foldable (any, foldl')
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, catMaybes)
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (mempty)
 #endif
@@ -34,7 +33,7 @@ import Data.Semigroup (Semigroup (..))
 import Prelude hiding (any)
 
 import Options.Applicative.Common
-import Options.Applicative.Internal (groupFst)
+import Options.Applicative.Internal (groupFstAll)
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
@@ -202,7 +201,7 @@ optionsDesc global pprefs p = vsepChunks
   $ mapParser doc p
   where
     groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
-    groupByTitle = groupFst
+    groupByTitle = groupFstAll . catMaybes
 
     tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)
     tabulateGroup l@((title,_):_) = (title, tabulate (prefTabulateFill pprefs) (snd <$> l))
@@ -271,7 +270,7 @@ parserHelp pprefs p =
       : (group_title <$> cs)
   where
     def = "Available commands:"
-    cs = groupBy ((==) `on` fst) $ cmdDesc pprefs p
+    cs = groupFstAll $ cmdDesc pprefs p
 
     group_title a@((n, _) : _) =
       with_title (fromMaybe def n) $

src/Options/Applicative/Internal.hs

@@ -28,7 +28,7 @@ module Options.Applicative.Internal
   , disamb
 
   , mapParserOptions
-  , groupFst
+  , groupFstAll
   ) where
 
 import Control.Applicative
@@ -41,8 +41,9 @@ import Control.Monad.Trans.Reader
   (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
 import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
 import Data.Function (on)
-import Data.List (groupBy)
-import Data.Maybe (catMaybes)
+import qualified Data.List as L
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Data.List.NonEmpty as NE
 
 import Options.Applicative.Types
 
@@ -275,11 +276,53 @@ hoistList = foldr cons empty
   where
     cons x xs = pure x <|> xs
 
--- | Strips 'Nothing', then groups on the first element of the tuple.
+-- | Groups on the first element of the tuple. This differs from the simple
+-- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped
+-- together. For example:
+--
+-- @
+--   groupFst = groupBy ((==) `on` fst)
+--
+--   let xs = [(1, "a"), (1, "b"), (3, "c"), (2, "d"), (3, "e"), (2, "f")]
+--
+--   groupFst xs === [[(1,"a"),(1,"b")],[(3,"c")],[(2,"d")],[(3,"e")],[(2,"f")]]
+--   groupFstAll xs === [[(1,"a"),(1,"b")],[(3,"c"),(3,"e")],[(2,"d"),(2,"f")]]
+-- @
+--
+-- Notice that the original order is preserved i.e. we do not first sort on
+-- the first element.
 --
 -- @since 0.19.0.0
-groupFst :: (Eq a) => [Maybe (a, b)] -> [[(a, b)]]
-groupFst = groupBy ((==) `on` fst) . catMaybes
+groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]]
+groupFstAll =
+  -- In order to group all (adjacent + non-adjacent) Eq elements together, we
+  -- sort the list so that the Eq elements are in fact adjacent, _then_ group.
+  -- We don't want to destroy the original order, however, so we add a
+  -- temporary index that maintains this original order. The full logic is:
+  --
+  -- 1. Add index i that preserves original order.
+  -- 2. Sort on tuple's fst.
+  -- 3. Group by fst.
+  -- 4. Sort by i, restoring original order.
+  -- 5. Drop index i.
+  fmap (NE.toList . dropIdx)
+    . L.sortOn toIdx
+    . NE.groupBy ((==) `on` fst')
+    . L.sortOn fst'
+    . addIdx
+  where
+    dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
+    dropIdx = fmap (\(_, y) -> y)
+
+    toIdx :: NonEmpty (Int, (a, b)) -> Int
+    toIdx ((x, _) :| _) = x
+
+    -- Like fst, ignores our added index
+    fst' :: (Int, (a, b)) -> a
+    fst' (_, (x, _)) = x
+
+    addIdx :: [(a, b)] -> [(Int, (a, b))]
+    addIdx = zip [1 ..]
 
 -- | Maps an Option modifying function over the Parser.
 --

src/Options/Applicative/Types.hs

@@ -152,7 +152,7 @@ data OptVisibility
 --
 -- @since 0.19.0.0
 newtype OptGroup = OptGroup [String]
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 instance Semigroup OptGroup where
   OptGroup xs <> OptGroup ys = OptGroup (xs ++ ys)

tests/parser_group_basic.err.txt

@@ -8,18 +8,14 @@ Usage: parser_group_basic --hello TARGET [--file-log-path PATH]
 
 Available options:
   --hello TARGET           Target for the greeting
+  -q,--quiet               Whether to be quiet
+  -v,--verbosity ARG       Console verbosity
+  -h,--help                Show this help text
 
 Logging
   --file-log-path PATH     Log file path
   --file-log-verbosity INT File log verbosity
 
-Available options:
-  -q,--quiet               Whether to be quiet
-
 System Options
   --poll                   Whether to poll
   --timeout INT            Whether to time out
-
-Available options:
-  -v,--verbosity ARG       Console verbosity
-  -h,--help                Show this help text

tests/parser_group_command_groups.err.txt

@@ -9,31 +9,25 @@ Usage: parser_group_command_groups --hello TARGET [--file-log-path PATH]
 
 Available options:
   --hello TARGET           Target for the greeting
+  -q,--quiet               Whether to be quiet
+  -v,--verbosity ARG       Console verbosity
+  -h,--help                Show this help text
 
 Logging
   --file-log-path PATH     Log file path
   --file-log-verbosity INT File log verbosity
 
-Available options:
-  -q,--quiet               Whether to be quiet
-
 System Options
   --poll                   Whether to poll
   --timeout INT            Whether to time out
 
-Available options:
-  -v,--verbosity ARG       Console verbosity
-  -h,--help                Show this help text
-
 Available commands:
   list 2                   Lists elements
+  delete                   Deletes elements
 
 Info commands
   list                     Lists elements
   print                    Prints table
 
-Available commands:
-  delete                   Deletes elements
-
 Query commands
   query                    Runs a query

tests/parser_group_duplicate_command_groups.err.txt

@@ -12,15 +12,13 @@ Available options:
   -v,--verbosity ARG       Console verbosity
   -h,--help                Show this help text
 
+Available commands:
+  query                    Runs a query
+
 Info commands
   list                     Lists elements
+  print                    Prints table
 
 Update commands
   delete                   Deletes elements
   insert                   Inserts elements
-
-Available commands:
-  query                    Runs a query
-
-Info commands
-  print                    Prints table

tests/parser_group_duplicates.err.txt

@@ -9,22 +9,16 @@ Usage: parser_group_duplicates --hello TARGET [--file-log-path PATH]
 
 Available options:
   --hello TARGET           Target for the greeting
+  -q,--quiet               Whether to be quiet
+  -v,--verbosity ARG       Console verbosity
+  -h,--help                Show this help text
 
 Logging
   --file-log-path PATH     Log file path
   --file-log-verbosity INT File log verbosity
-
-Available options:
-  -q,--quiet               Whether to be quiet
+  --log-namespace STR      Log namespace
 
 System
   --poll                   Whether to poll
   --timeout INT            Whether to time out
   --sysFlag                Some flag
-
-Logging
-  --log-namespace STR      Log namespace
-
-Available options:
-  -v,--verbosity ARG       Console verbosity
-  -h,--help                Show this help text

tests/parser_group_nested.err.txt

@@ -8,18 +8,14 @@ Usage: parser_group_nested --hello TARGET [--file-log-path PATH] [--poll]
 
 Available options:
   --hello TARGET           Target for the greeting
+  -q,--quiet               Whether to be quiet
+  -v,--verbosity ARG       Console verbosity
+  -h,--help                Show this help text
 
 Logging
   --file-log-path PATH     Log file path
+  --file-log-verbosity INT File log verbosity
 
 Logging.System Options
   --poll                   Whether to poll
   --timeout INT            Whether to time out
-
-Logging
-  --file-log-verbosity INT File log verbosity
-
-Available options:
-  -q,--quiet               Whether to be quiet
-  -v,--verbosity ARG       Console verbosity
-  -h,--help                Show this help text