cmdtheline 0.2.1.1 → 0.2.2

raw patch · 15 files changed

+214/−155 lines, 15 filesdep ~test-frameworkdep ~test-framework-hunitdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: test-framework, test-framework-hunit, transformers

API changes (from Hackage documentation)

Files

• README.md +6/−1
• cmdtheline.cabal +12/−6
• src/System/Console/CmdTheLine.hs +0/−5
• src/System/Console/CmdTheLine/Arg.hs +5/−4
• src/System/Console/CmdTheLine/ArgVal.hs +16/−3
• src/System/Console/CmdTheLine/CmdLine.hs +5/−7
• src/System/Console/CmdTheLine/Common.hs +16/−0
• src/System/Console/CmdTheLine/Err.hs +25/−3
• src/System/Console/CmdTheLine/GetOpt.hs +34/−0
• src/System/Console/CmdTheLine/Help.hs +36/−30
• src/System/Console/CmdTheLine/Manpage.hs +5/−11
• src/System/Console/CmdTheLine/Term.hs +2/−32
• src/System/Console/CmdTheLine/Trie.hs +35/−33
• src/System/Console/CmdTheLine/Util.hs +0/−1
• test/Main.hs +17/−19

@@ -1,4 +1,4 @@-CmdTheLine v0.2.1.1+CmdTheLine v0.2.1 ===============  [![Build Status](https://secure.travis-ci.org/eli-frey/cmdtheline.png)](http://travis-ci.org/eli-frey/cmdtheline)@@ -39,6 +39,11 @@  ###0.3 The next release candidate.++Contributors+------------++Bas Van Dijk -- GetOpt adapter  LICENSE -------

@@ -1,5 +1,5 @@ Name: cmdtheline-Version: 0.2.1.1+Version: 0.2.2 Synopsis: Declarative command-line option parsing and documentation library. Description:   CmdTheLine aims to remove tedium from the definition of command-line@@ -41,6 +41,11 @@     now two new functions exported with System.Console.CmdTheLine.Term, 'unwrap'     and 'unwrapChoice'.  As well a datatype representing cause of early exit,     'EvalExit' is exported.+  .+  Changes since 0.2.1+  .+  * Added adapter for interfacing with Getopt in module+    'System.Console.CmdTheLine'.  Homepage:      http://github.com/eli-frey/cmdtheline License:       MIT@@ -64,13 +69,14 @@   build-depends:  base >= 4.5 && < 5, containers >= 0.4 && < 0.6,                   parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,                   process >= 1.1, directory >= 1.1,-                  transformers >= 0.3 && < 0.4, filepath >= 1.3 && < 1.4+                  transformers >= 0.2 && < 0.4, filepath >= 1.3 && < 1.4    exposed-modules: System.Console.CmdTheLine,                    System.Console.CmdTheLine.Arg,                    System.Console.CmdTheLine.ArgVal,                    System.Console.CmdTheLine.Term,                    System.Console.CmdTheLine.Util+                   System.Console.CmdTheLine.GetOpt    other-modules:   System.Console.CmdTheLine.Common,                    System.Console.CmdTheLine.Err,@@ -82,12 +88,12 @@ test-suite Main   type:          exitcode-stdio-1.0   build-depends: base >= 4 && < 5, HUnit  >= 1.2.4 && < 2,-                 test-framework >= 0.6 && < 0.7,-                 test-framework-hunit >= 0.2 && < 0.3,+                 test-framework >= 0.6 && < 0.9,+                 test-framework-hunit >= 0.2 && < 0.4,                  containers >= 0.4 && < 0.6,                  parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,                  process >= 1.1, directory >= 1.1,-                 transformers >= 0.3 && < 0.4, filepath >= 1.3 && < 1.4-  ghc-options:   -Wall -rtsopts+                 transformers >= 0.2 && < 0.4, filepath >= 1.3 && < 1.4+  ghc-options:   -Wall -Werror -fno-warn-name-shadowing -rtsopts   hs-source-dirs: src, test   main-is:        Main.hs

@@ -32,11 +32,6 @@ import System.Console.CmdTheLine.Err import System.Console.CmdTheLine.Util -import Text.PrettyPrint ( Doc )--import Control.Monad    ( join )-import Control.Monad.Trans.Error ( throwError )- {-$term    CmdTheLine is centered around the 'Term' Applicative Functor.  It allows us

@@ -29,7 +29,6 @@ import System.Console.CmdTheLine.CmdLine ( optArg, posArg ) import System.Console.CmdTheLine.ArgVal  ( ArgVal, pp, parser ) import qualified System.Console.CmdTheLine.Err  as E-import qualified System.Console.CmdTheLine.Trie as T  import Control.Applicative import Control.Arrow       ( second )@@ -38,7 +37,7 @@  import Text.PrettyPrint -import Data.List     ( sort, sortBy )+import Data.List     ( sortBy, foldl' ) import Data.Function ( on )  argFail :: Doc -> Err a@@ -53,7 +52,7 @@ -- -- [@optDoc@]  :: String: defaults to @\"\"@. ----- [@otpSec@]  :: String: defautts to @\"OPTIONS\"@.+-- [@optSec@]  :: String: defaults to @\"OPTIONS\"@. data OptInfo = OInf   { unOInf  :: ArgInfo   , optName :: String@@ -122,6 +121,7 @@ -- -- It is considered a programming error to provide an empty list of names to -- optInfo.+optInfo :: [String] -> OptInfo optInfo [] =   error "System.Console.CmdTheLine.Arg.optInfo recieved empty list of names." optInfo names = OInf (mkInfo names) "" "" "OPTIONS"@@ -248,7 +248,7 @@     | otherwise = ai { repeatable = True }    yield _ cl = do-    result <- foldl addLookup (return []) assoc'+    result <- foldl' addLookup (return []) assoc'     case result of       [] -> return vs       _  -> return . map snd $ sortBy (compare `on` fst) result@@ -422,6 +422,7 @@ -- Arguments as terms. -- +absent :: [ArgInfo] -> [ArgInfo] absent = map (\ ai -> ai { absence = Absent })  -- | 'value' @arg@ makes @arg@ into a 'Term'.

@@ -19,13 +19,13 @@   , pair, triple, quadruple, quintuple   ) where -import System.Console.CmdTheLine.Common ( splitOn, select )+import System.Console.CmdTheLine.Common ( splitOn, select, HelpFormat(..) ) import qualified System.Console.CmdTheLine.Err as E import qualified System.Console.CmdTheLine.Trie as T  import Control.Arrow ( first, (***) ) import Data.Function ( on )-import Data.List     ( sort, unfoldr )+import Data.List     ( sort, unfoldr, foldl' ) import Data.Ratio    ( Ratio ) import Data.Tuple    ( swap ) @@ -55,11 +55,14 @@ pp     :: ArgVal a => ArgPrinter a pp = snd converter +decPoint, digits, sign :: Parsec String () String decPoint      = string "." digits        = many1 digit-concatParsers = foldl (liftA2 (++)) $ return [] sign          = option "" $ string "-" +concatParsers :: [Parsec String () String] -> Parsec String () String+concatParsers = foldl' (liftA2 (++)) $ return []+ pInteger  :: ( Read a, Integral a ) => Parsec String () a pFloating :: ( Read a, Floating a ) => Parsec String () a pInteger      = read <$> concatParsers [ sign, digits ]@@ -224,6 +227,7 @@     split []  = Nothing     split str = Just $ splitOn sep str +invalidVal :: String -> String -> Doc invalidVal = E.invalidVal `on` text  instance ArgVal Bool where@@ -292,4 +296,13 @@         invalidVal str "expected a ratio in the form '<numerator> % <denominator>'"  instance ArgVal (Maybe (Ratio Integer)) where+  converter = just++instance ArgVal HelpFormat where+  converter = enum [ ( "pager", Pager )+                   , ( "plain", Plain )+                   , ( "groff", Groff )+                   ]++instance ArgVal (Maybe HelpFormat) where   converter = just

@@ -19,9 +19,7 @@ import qualified System.Console.CmdTheLine.Trie as T import qualified Data.Map as M -import Data.List     ( sort )-import Data.Function ( on )-+import Data.List ( sort, foldl' )  optArg :: CmdLine -> ArgInfo -> [( Int, String, Maybe String )] optArg cl ai = case M.lookup ai cl of@@ -42,19 +40,19 @@  - ArgInfo to an empty list of Arg.  -} argInfoIndexes :: [ArgInfo] -> ( T.Trie ArgInfo, [ArgInfo], CmdLine )-argInfoIndexes = foldl go ( T.empty, [], M.empty )+argInfoIndexes = foldl' go ( T.empty, [], M.empty )   where   go ( optTrie, posAis, cl ) ai     | isPos ai  = ( optTrie                   , ai : posAis                   , M.insert ai (Pos []) cl                   )-    | otherwise = ( foldl add optTrie $ optNames ai+    | otherwise = ( foldl' add optTrie $ optNames ai                   , posAis                   , M.insert ai (Opt []) cl                   )     where-    add t name = T.add t name ai+    add t name = T.add name ai t  parseOptArg :: String -> ( String, Maybe String ) parseOptArg str@@ -133,7 +131,7 @@   last   = length args - 1   excess = E.posExcess . map text $ takeEnd (last - maxSpec) args -  ( cl', maxSpec ) = foldl go ( cl, -1 ) posInfo+  ( cl', maxSpec ) = foldl' go ( cl, -1 ) posInfo    takeEnd n = reverse . take n . reverse 

@@ -6,6 +6,7 @@  import Data.Function    ( on ) import Text.PrettyPrint ( Doc, text )+import Control.Applicative ( Applicative(..) )  import qualified Data.Map as M @@ -129,6 +130,7 @@   } deriving ( Eq )  -- | A default 'TermInfo'.+defTI :: TermInfo defTI = TermInfo   { termName  = ""   , version   = ""@@ -167,7 +169,20 @@ -- in the context of being computed from the command line arguments. data Term a = Term [ArgInfo] (Yield a) +instance Functor Term where+  fmap = yield . result . result . fmap+    where+    yield f (Term ais y) = Term ais (f y)+    result = (.) +instance Applicative Term where+  pure v = Term [] (\ _ _ -> return v)++  (Term args f) <*> (Term args' v) = Term (args ++ args') wrapped+    where+    wrapped ei cl = f ei cl <*> v ei cl++ data EvalKind = Simple   -- The program has no commands.               | Main     -- The default program is running.               | Choice   -- A command has been chosen.@@ -181,6 +196,7 @@ descCompare :: Ord a => a -> a -> Ordering descCompare = flip compare +splitOn :: Eq a => a -> [a] -> ( [a], [a] ) splitOn sep xs = ( left, rest' )   where   rest' = if rest == [] then rest else tail rest -- Skip the 'sep'.

@@ -8,7 +8,6 @@ import qualified System.Console.CmdTheLine.Help as H  import Text.PrettyPrint-import Data.List ( intersperse )  import Control.Monad ( join ) import Control.Monad.Trans.Error@@ -40,52 +39,74 @@ hsepMap :: (a -> Doc) -> [a] -> Doc hsepMap f = hsep . map f -errArgv     = text "argv array must have at least one element"+errArgv :: Doc+errArgv = text "argv array must have at least one element"++errNotOpt, errNotPos :: String errNotOpt   = "Option argument without name" errNotPos   = "Positional argument with a name"++errHelp :: Doc -> Doc errHelp doc = text "term error, help requested for unknown command" <+> doc  +alts :: [String] -> Doc alts []    = error "alts called on empty list"-alts [x]   = error "alts called on singleton list"+alts [_]   = error "alts called on singleton list" alts [x,y] = hsepMap text [ "either", x, "or", y ] alts xs    = text "one of:" <+> fsep (punctuate (char ',') (map text xs)) +invalid :: String -> Doc -> Doc -> Doc invalid kind s exp = hsep   [ text "invalid", text kind, quotes s<>char ',', exp ] +invalidVal :: Doc -> Doc -> Doc invalidVal = invalid "value" +no :: String -> String -> Doc no kind s = sep [ text "no such", text kind, quotes $ text s ] +notDir :: Doc -> Doc notDir  s = quotes (s) <+> text "is not a directory" +isDir :: Doc -> Doc isDir   s = quotes (s) <+> text "is a directory" +element :: String -> String -> Doc -> Doc element kind str exp = fsep   [ text "invalid element in", text kind, parens . quotes $ text str, exp ] +sepMiss :: Char -> String -> Doc sepMiss sep str = invalidVal (text str) $   hsep [ text "missing a", quotes $ char sep, text "separator" ] +unknown :: String -> String -> Doc unknown kind v = sep [ text "unknown", text kind, quotes $ text v ] +ambiguous :: String -> String -> [String] -> Doc ambiguous kind s ambs = hsep   [ text kind, quotes $ text s, text "ambiguous, could be", alts ambs ] +posExcess :: [Doc] -> Doc posExcess excess = text "too many arguments, don't know what to do with"                <+> hsepMap prep excess   where   prep = (<> text ",") . quotes +flagValue :: String -> String -> Doc flagValue f v = hsep   [ text "option", quotes $ text f   , text "is a flag, it cannot take the argument", quotes $ text v   ] +optValueMissing :: String -> Doc optValueMissing f = hsep   [ text "option", quotes $ text f, text "needs an argument" ]++optParseValue :: String -> Doc -> Doc optParseValue f e = sep [ text "option" <+> (quotes (text f)<>char ':'), e ]++optRepeated :: String -> String -> Doc optRepeated f f'   | f == f' = hsep     [ text "option", quotes $ text f, text "cannot be repeated" ]@@ -117,6 +138,7 @@     longName (x : xs)       | length x > 2 || xs == [] = x       | otherwise                = longName xs+    longName [] = undefined  print :: Handle -> EvalInfo -> Doc -> IO () print h ei e = hPrint h $ (text . termName . fst $ main ei) <> char ':' <+> e

@@ -0,0 +1,34 @@+-- | Adapter for "System.Console.GetOpt".+module System.Console.CmdTheLine.GetOpt where++import Data.Maybe+import Data.Traversable+import System.Console.GetOpt+import System.Console.CmdTheLine++-- | Sequence a list of @'OptDescr's@ into a term. Absent flags+-- (specified with 'NoArg') are filtered out.+optDescrsTerm :: [OptDescr a] -> Term [a]+optDescrsTerm = fmap catMaybes . sequenceA . map optDescrToTerm++-- | Convert an 'OptDescr' into a 'Term' which returns 'Nothing' if+-- 'NoArg' is specified and the flag is absent or 'Just' the argument+-- otherwise.+optDescrToTerm :: OptDescr a -> Term (Maybe a)+optDescrToTerm (Option shorts longs argDescr descr) =+    case argDescr of+      NoArg x        -> fmap (optional x) $ value $ flag                       $ optInf ""+      ReqArg to name -> fmap (fmap   to)  $ value $ opt                Nothing $ optInf name+      OptArg to name -> fmap (Just . to)  $ value $ defaultOpt Nothing Nothing $ optInf name+    where+      optional :: a -> Bool -> Maybe a+      optional x present | present   = Just x+                         | otherwise = Nothing++      optInf :: String -> OptInfo+      optInf name = (optInfo options) { optDoc  = descr+                                      , optName = name+                                      }++      options :: [String]+      options = map (:[]) shorts ++ longs

@@ -2,20 +2,22 @@  - This is open source software distributed under a MIT license.  - See the file 'LICENSE' for further information.  -}-module System.Console.CmdTheLine.Help where+module System.Console.CmdTheLine.Help+  ( printVersion, invocation, prepSynopsis, print ) where +import Prelude hiding ( print )+ import System.Console.CmdTheLine.Common import qualified System.Console.CmdTheLine.Manpage as Man  import Control.Applicative-import Control.Arrow       ( first, second )+import Control.Arrow       ( first )  import Data.Char     ( toUpper, toLower )-import Data.List     ( intersperse, sort, sortBy, partition )+import Data.List     ( intersperse, sort, sortBy, partition, foldl' ) import Data.Function ( on )-import Data.Maybe    ( catMaybes ) -import System.IO+import System.IO hiding ( print )   invocation :: Char -> EvalInfo -> String@@ -60,7 +62,7 @@   where   args = concat . intersperse " " $ map snd args'     where-    args' = sortBy revCmp . foldl formatPos [] . snd $ term ei+    args' = sortBy compare' . foldl' formatPos [] . snd $ term ei    formatPos acc ai     | isOpt ai  = acc@@ -78,38 +80,40 @@       PosN _ _ -> ""       _        -> "..." -  revCmp ( p, _ ) ( p', _ ) = case ( p', p ) of-    ( _,             PosAny    ) -> LT-    ( PosAny,        _         ) -> GT-    ( PosL  _     _, PosR  _ _ ) -> LT-    ( PosR  _     _, PosL  _ _ ) -> GT-    ( p, p' ) -> bifurcate+  compare' ( p, _ ) ( p', _ ) = case ( p', p ) of+    ( _,          PosAny    ) -> LT+    ( PosAny,     _         ) -> GT+    ( PosL  _  _, PosR  _ _ ) -> LT+    ( PosR  _  _, PosL  _ _ ) -> GT+    _ -> comparePos k k'     where-    bifurcate-      | not (getBool p) && not (getBool p') = case ( p, p' ) of-        ( PosL _ _,  PosN _ _ ) -> if k <= k' then LT else GT-        ( PosN _ _,  PosL _ _ ) -> if k >= k' then GT else LT-        ( PosN _ _,  _        ) -> if k <= k' then LT else GT-        _                       -> if k >= k' then GT else LT-+    comparePos       | getBool p && getBool p' = case ( p, p' ) of-        ( PosL _ _,  PosN _ _ ) -> if k >= k' then LT else GT-        ( PosN _ _,  PosL _ _ ) -> if k <= k' then GT else LT-        ( PosN _ _,  _        ) -> if k >= k' then LT else GT-        _                       -> if k <= k' then GT else LT-      where-      k  = getPos p-      k' = getPos p'+        ( PosL _ _, PosN _ _ ) -> flip compare -- if k >= k' then LT else GT+        ( PosN _ _, PosL _ _ ) -> compare -- if k <= k' then GT else LT+        ( PosN _ _, _        ) -> flip compare -- if k >= k' then LT else GT+        _                      -> compare -- if k <= k' then GT else LT +      | otherwise = case ( p, p' ) of+        ( PosL _ _, PosN _ _ ) -> compare -- if k <= k' then LT else GT+        ( PosN _ _, PosL _ _ ) -> flip compare -- if k >= k' then GT else LT+        ( PosN _ _, _        ) -> compare -- if k <= k' then LT else GT+        _                      -> flip compare -- if k >= k' then GT else LT++    k  = getPos p+    k' = getPos p'+     getPos x = case x of       PosL  _ pos -> pos       PosR  _ pos -> pos       PosN  _ pos -> pos+      _ -> undefined      getBool x = case x of       PosL  b _ -> b       PosR  b _ -> b       PosN  b _ -> b+      _ -> undefined  synopsisSection :: EvalInfo -> [ManBlock] synopsisSection ei = [ S "SYNOPSIS", P (synopsis ei) ]@@ -190,21 +194,21 @@ makeCmdItems ei = case evalKind ei of   Simple -> []   Choice -> []-  Main   -> sortBy (descCompare `on` fst) . foldl addCmd [] $ choices ei+  Main   -> sortBy (descCompare `on` fst) . foldl' addCmd [] $ choices ei   where   addCmd acc ( ti, _ ) = ( termSec ti, I (label ti) (termDoc ti) )                        : acc   label ti = "$(b," ++ termName ti ++ ")"  mergeOrphans :: ( [( String, ManBlock )], [Maybe ManBlock] ) -> [ManBlock]-mergeOrphans ( orphans, marked ) = fst $ foldl go ( [], orphans ) marked+mergeOrphans ( orphans, marked ) = fst $ foldl' go ( [], orphans ) marked   where   go ( acc, orphans ) (Just block) = ( block : acc, orphans )   go ( acc, orphans ) Nothing      = ( acc',        []      )         where     acc' = case orphans of       []           -> acc-      ( s, _ ) : _ -> let ( result, s' ) = foldl merge ( acc, s ) orphans+      ( s, _ ) : _ -> let ( result, s' ) = foldl' merge ( acc, s ) orphans                       in  S s' : result    merge ( acc, secName ) ( secName', item )@@ -215,7 +219,7 @@            -> ( [( String, ManBlock )], [Maybe ManBlock] ) mergeItems items blocks = ( orphans, marked )   where-  ( marked, _, _, orphans ) = foldl go ( [Nothing], [], False, items ) blocks+  ( marked, _, _, orphans ) = foldl' go ( [Nothing], [], False, items ) blocks      -- 'toInsert' is a list of manblocks that belong in the current section.   go ( acc, toInsert, mark, items ) block = case block of@@ -227,6 +231,7 @@       ( toInsert', is' ) = first (map snd) $ partition ((== str) . fst) items       acc'               = Just sec : marked       mark'              = str == "DESCRIPTION"+    transition _ = undefined      marked = if mark then Nothing : acc' else acc'       where@@ -240,6 +245,7 @@   cmp   = descCompare `on` fst   items = sortBy cmp $ cmds ++ args +eiSubst :: EvalInfo -> [( String, String )] eiSubst ei =   [ ( "tname", termName . fst $ term ei )   , ( "mname", termName . fst $ main ei )

@@ -19,7 +19,6 @@  import Data.Maybe ( catMaybes ) import Data.Char  ( isSpace )-import Data.List  ( subsequences, words )  import Text.Parsec import Text.PrettyPrint hiding ( char )@@ -27,6 +26,7 @@ type Subst = [( String, String )] -- An association list of                                   -- ( replacing, replacement ) pairs. +paragraphIndent, labelIndent :: Int paragraphIndent = 7 labelIndent     = 4 @@ -52,17 +52,11 @@    scan = many $ try (string "\\$") <|> try replace <|> pure <$> anyChar -  replace = do-    string "$("-    replacement <- try escape <|> choice replacers <|> safeChars-    char ')'-    return replacement+  replace = string "$(" >> content <* char ')'+    where+    content = try escape <|> choice replacers <|> safeChars -  escape = do-    c <- anyChar-    char ','-    str <- try replace <|> safeChars-    return $ esc c str+  escape = esc <$> (anyChar <* char ',') <*> try replace <|> safeChars    safeChars = many1 $ satisfy (/= ')') 

@@ -19,12 +19,10 @@ import System.Console.CmdTheLine.Common import System.Console.CmdTheLine.CmdLine ( create ) import System.Console.CmdTheLine.Arg-import System.Console.CmdTheLine.ArgVal import qualified System.Console.CmdTheLine.Err     as E import qualified System.Console.CmdTheLine.Help    as H import qualified System.Console.CmdTheLine.Trie    as T -import Control.Applicative hiding ( (<|>), empty ) import Control.Arrow       ( second ) import Control.Monad       ( join, (<=<) ) @@ -38,7 +36,6 @@ import System.IO  import Text.PrettyPrint-import Text.Parsec   --@@ -90,36 +87,9 @@   ----- Terms as Applicative Functors-----instance Functor Term where-  fmap = yield . result . result . fmap-    where-    yield f (Term ais y) = Term ais (f y)-    result = (.)--instance Applicative Term where-  pure v = Term [] (\ _ _ -> return v)--  (Term args f) <*> (Term args' v) = Term (args ++ args') wrapped-    where-    wrapped ei cl = f ei cl <*> v ei cl----- -- Standard Options -- -instance ArgVal HelpFormat where-  converter = enum [ ( "pager", Pager )-                   , ( "plain", Plain )-                   , ( "groff", Groff )-                   ]--instance ArgVal (Maybe HelpFormat) where-  converter = just- addStdOpts :: EvalInfo -> ( Yield (Maybe HelpFormat)                           , Maybe (Yield Bool)                           , EvalInfo@@ -208,7 +178,7 @@     Left  T.Ambiguous -> throwError . UsageFail $ E.ambiguous com arg ambs     where     index = foldl add T.empty choices-    add acc ( choice, _ ) = T.add acc (termName choice) choice+    add acc ( choice, _ ) = T.add (termName choice) choice acc      com  = "command"     ambs = sort $ T.ambiguities index arg@@ -268,7 +238,7 @@ -- Share code between 'evalChoice' and 'unwrapChoice' with this HOF. evalChoiceBy :: ProcessTo a b              -> [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO b-evalChoiceBy method args mainTerm@( term, termInfo ) choices = do+evalChoiceBy method args mainTerm@( _, termInfo ) choices = do   ( chosen, args' ) <- either handleErr return =<<     (runErrorT . fromErr $ chooseTerm termInfo eiChoices args) 

@@ -2,9 +2,14 @@  - This is open source software distributed under a MIT license.  - See the file 'LICENSE' for further information.  -}-module System.Console.CmdTheLine.Trie where+module System.Console.CmdTheLine.Trie+  ( add, lookup, empty, isEmpty, fromList, ambiguities+  , Trie, LookupFail(..)+  ) where +import Prelude hiding ( lookup ) import qualified Data.Map as M+import Data.List (foldl')  {-  - This implementation maps any non-ambiguous prefix of a key to its value.@@ -16,12 +21,12 @@              | Key a -- Value bound by an entire key.              | Amb   -- No Value bound due to ambiguity in the key.              | Nil   -- Attempt to retrieve a Value from an empty Trie.-               deriving (Eq)+               deriving ( Eq )  data Trie a = Trie   { val   :: Value a-  , succs :: CMap (Trie a)-  } deriving (Eq)+  , nexts :: CMap (Trie a)+  } deriving ( Eq )  data LookupFail = Ambiguous | NotFound deriving (Show) @@ -31,37 +36,31 @@ isEmpty :: Eq a => Trie a -> Bool isEmpty = (== empty) -add :: Trie a -> String -> a -> Trie a-add t k v = go t k (length k) 0 v (Pre v {- Allocate less. -})+add :: String -> a -> Trie a -> Trie a+add k v t = go t k   where-  go t k len i v preV =-    if i == len-       then Trie (Key v) (succs t)-       else Trie newVal  newSuccs+  go t s = case s of+    []     -> Trie (Key v) next+    c:rest ->+      let t'       = maybe empty id $ M.lookup c next+          newNexts = M.insert c (go t' rest) next +      in Trie newVal newNexts     where-    newVal = case val t of-      Amb       -> Amb-      Pre _     -> Amb-      v@(Key _) -> v-      Nil       -> preV+    next = nexts t -    newSuccs = M.insert (k !! i) (go t' k len (i + 1) v preV) (succs t)-      where-      t' = maybe empty id $ M.lookup (k !! i) (succs t)+    newVal = case val t of+      Amb        -> Amb+      Pre _      -> Amb+      v'@(Key _) -> v'+      Nil        -> Pre v -findNode :: String -> Trie a -> Maybe (Trie a)-findNode k t = go t k (length k) 0+findNode :: Trie a -> String -> Maybe (Trie a)+findNode t = foldl' go (Just t)   where-  go t k len i =-    if i == len-       then Just t-       else goNext =<< M.lookup (k !! i) (succs t)-    where-    goNext t' = go t' k len (i + 1)-+  go acc c = M.lookup c . nexts =<< acc  lookup :: String -> Trie a -> Either LookupFail a-lookup k t = case findNode k t of+lookup k t = case findNode t k of   Nothing -> Left NotFound   Just t' -> case val t' of     Key v -> Right v@@ -70,10 +69,10 @@     Nil   -> Left  NotFound  ambiguities :: Trie a -> String -> [String]-ambiguities t pre = case findNode pre t of+ambiguities t pre = case findNode t pre of   Nothing -> []   Just t' -> case val t' of-    Amb -> go [] pre $ M.toList (succs t') : []+    Amb -> go [] pre $ M.toList (nexts t') : []     _   -> []    where@@ -87,7 +86,7 @@       where       ( c, t'' ) = top -      assocs'    = M.toList (succs t'') : bottom : rest+      assocs'    = M.toList (nexts t'') : bottom : rest        pre'       = pre ++ return c       acc'       = case val t'' of@@ -95,7 +94,10 @@         Nil   -> error "saw Nil on descent"         _     -> acc +    -- FIXME: Handle this better.  At least produce a meaningful error message.+    descend _ = undefined+ fromList :: [( String, a )] -> Trie a-fromList assoc = foldl consume empty assoc+fromList assoc = foldl' consume empty assoc   where-  consume t ( k, v ) = add t k v+  consume t ( k, v ) = add k v t

@@ -18,7 +18,6 @@  import System.Console.CmdTheLine.Common import System.Console.CmdTheLine.Err-import System.Console.CmdTheLine.Term  import Control.Monad.IO.Class ( liftIO ) 

@@ -59,52 +59,50 @@     return v)  unwrapFB, unwrapAr, unwrapCP, unwrapCi :: [String] -> IO (Either EvalExit (IO ()))--unwrapFB args = mute $ unwrap args ( FB.term, FB.termInfo )-unwrapAr args = mute $ unwrap args ( Ar.arithTerm, Ar.termInfo )-unwrapCP args = mute $ unwrap args ( CP.term, CP.termInfo )-unwrapCi args = mute $-  unwrapChoice args Ci.defaultTerm [ Ci.rotTerm, Ci.morseTerm ]+unwrapFB args = unwrap args ( FB.term, FB.termInfo )+unwrapAr args = unwrap args ( Ar.arithTerm, Ar.termInfo )+unwrapCP args = unwrap args ( CP.term, CP.termInfo )+unwrapCi args = unwrapChoice args Ci.defaultTerm [ Ci.rotTerm, Ci.morseTerm ]  tests :: [Test] tests =   -- With FizzBuzz we'll test the different forms of option assignment and   -- flags.   [ testGroup "FizzBuzz"-    [ testCase "w/o args" . assert $ isRight <$> unwrapFB []-    , testCase "w/ good args" . assert $+    [ testCase " w/o args" . assert $ isRight <$> unwrapFB []+    , testCase " w/ good args" . assert $       isRight <$> unwrapFB [ "-q", "-s", "-v"                            , "-f", "bob", "--buzz", "ann", "-t20"                            ]-    , testCase "w/ bad args" . assert $ isLeft <$> unwrapFB [ "-zork" ]+    , testCase " w/ bad args" . assert $ isLeft <$> unwrapFB [ "-zork" ]     ]    -- With arith we'll test 'posRight' 'pos' positional argument partitioning.   , testGroup "arith"-    [ testCase "w/o args" . assert $ isLeft <$> unwrapAr []-    , testCase "w/ good args many" . assert $+    [ testCase " w/o args" . assert $ isLeft <$> unwrapAr []+    , testCase " w/ good args many" . assert $       isRight <$> unwrapAr [ "x^2+y*1", "x=2", "y=(11-1)/5" ]-    , testCase "w/ good args one" . assert $+    , testCase " w/ good args one" . assert $       isRight <$> unwrapAr [ "x^2", "x=2" ]-    , testCase "w/ bad args" . assert $+    , testCase " w/ bad args" . assert $       isLeft <$> unwrapAr [ "-pretty", "x^2", "x=2" ]     ]    -- With cipher we'll test subcommands.   , testGroup "cipher"-    [ testCase "w/o args" . assert $ isLeft <$> unwrapCi []-    , testCase "morse" . assert $+    [ testCase " w/o args" . assert $ isLeft <$> unwrapCi []+    , testCase " morse" . assert $       isRight <$> withInput ["bob"] (unwrapCi [ "morse" ])-    , testCase "rot" . assert $+    , testCase " rot" . assert $       isRight <$> withInput ["bob"] (unwrapCi [ "rot" ])     ]    -- With cp we'll test 'revPosLeft' 'revPos' positional argument partitioning.   , testGroup "cp"-    [ testCase "w/o args" . assert $ isLeft <$> unwrapCP []-    , testCase "w/ good args many" . assert $+    [ testCase " w/o args" . assert $ isLeft <$> unwrapCP []+    , testCase " w/ good args many" . assert $       isRight <$> unwrapCP [ "-d", "cmdtheline.cabal", "LICENSE", "test" ]-    , testCase "w/ good args one" . assert $+    , testCase " w/ good args one" . assert $       isRight <$> unwrapCP [ "-d", "cmdtheline.cabal", "foo" ]     ]   ]