packages feed

cmdtheline (empty) → 0.1.0.0

raw patch · 21 files changed

+3021/−0 lines, 21 filesdep +basedep +containersdep +data-defaultsetup-changed

Dependencies added: base, containers, data-default, directory, parsec, pretty, process

Files

+ LICENSE view
@@ -0,0 +1,18 @@+Copyright © 2012 Vincent Elisha Lee Frey++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,33 @@+CmdTheLine v0.1+===============++Command line option parsing with applicative functors.++Installation+------------+To install, do++    cabal install++Depends+-------+All dependencies are provided by the [Haskell+Platform](http://hackage.haskell.org/platform). See cmdtheline.cabal for library+dependencies.++Docs+----+If you have enabled documentation in your cabal `config` file, after+installation you should have a copy of the documentation locally.  Otherwise+see the [Hackage repo](http://hackage.haskell.org/package/cmdtheline).++Bugs+----+Please report bugs to the+[issue tracker](http://github.com/eli-frey/cmdtheline/issues).++LICENSE+-------+MIT - See file 'LICENSE' for details.++Copyright © 2012 Vincent Elisha Lee Frey
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cmdtheline.cabal view
@@ -0,0 +1,52 @@+Name: cmdtheline+Version: 0.1.0.0+Synopsis: Declaritive command-line option parsing and documentation library.+Description:+  CmdTheLine aims to remove tedium from the definition of command-line+  programs, producing usage, help and man pages with little effort.+  .+  The inspiration was found in Daniel Bunzli's+  <http://erratique.ch/software/cmdliner> library.+  .+  CmdTheLine uses applicative functors to provide a declarative, compositional+  mechanism for defining command-line programs by lifting regular Haskell+  functions over argument parsers.+  .+  Suggestions, comments, and bug reports are appreciated. Please see the+  bug and issue tracker at <http://github.com/eli-frey/cmdtheline>.+++Homepage:      http://github.com/eli-frey/cmdtheline+License:       MIT+License-file:  LICENSE+Author:        Eli Frey+Maintainer:    Eli Frey <eli.lee.frey gmail com>+Stability:     Experimental+Category:      Console+Cabal-version: >=1.6+Build-type:    Simple++Extra-source-files: doc/examples/*.hs, README.md++Source-repository head+  type:     git+  location: git://github.com/eli-frey/cmdtheline.git++Library+  hs-source-dirs: src+  extensions:     FlexibleInstances+  build-depends:  base >= 4.5 && < 5, containers >= 0.4 && < 0.5,+                  parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,+                  process >= 1.1, directory >= 1.1, data-default >= 0.4++  exposed-modules: System.Console.CmdTheLine,+                   System.Console.CmdTheLine.Arg,+                   System.Console.CmdTheLine.ArgVal,+                   System.Console.CmdTheLine.Term++  other-modules:   System.Console.CmdTheLine.Common,+                   System.Console.CmdTheLine.Err,+                   System.Console.CmdTheLine.Help,+                   System.Console.CmdTheLine.Trie,+                   System.Console.CmdTheLine.Manpage,+                   System.Console.CmdTheLine.CmdLine
+ doc/examples/FizzBuzz.hs view
@@ -0,0 +1,69 @@+import System.Console.CmdTheLine+import Control.Applicative++import System.Exit ( exitSuccess )++data Verbosity = Verbose | Normal | Silent++fizzBuzz :: Verbosity -> String -> String -> Int -> IO ()+fizzBuzz verb fizz buzz n = do+  case verb of+    Verbose -> putStrLn $ concat+      [ "FizzBuzz: Printing the result of FizzBuzz over the numbers 1 to ", show n+      , "\nFizz = ", fizz, "\nBuzz = ", buzz+      ]+    Silent  -> exitSuccess+    _       -> return ()++  mapM_ fizzAndBuzzOr [1..n]+  where+  fizzAndBuzzOr n = putStrLn output+    where+    output = case fizz' ++ buzz' of+      ""  -> show n+      str -> str++    fizz' = if (n `mod` 3) == 0 then fizz else ""+    buzz' = if (n `mod` 5) == 0 then buzz else ""+++-- A flag that can appear many times on the command line, only the last of+-- which will be counted.+verbosity :: Term Verbosity+verbosity = lastOf $ vFlagAll [Normal] [ ( Verbose, verbose )+                                       , ( Silent,  silent  )+                                       ]+  where+  verbose =(optInfo [ "verbose", "v" ])+          { argDoc  = "Give verbose output." }++  silent  =(optInfo [ "quiet", "silent", "q", "s" ])+          { argDoc  = "Provide no output." }++fizz, buzz :: Term String+fizz = opt "Fizz" $ (optInfo [ "Fizz", "fizz", "f" ])+     { argDoc = "A string to print in the 'Fizz' case." }++buzz = opt "Buzz" $ (optInfo [ "Buzz", "buzz", "b" ])+     { argDoc = "A string to print in the 'Buzz' case." }++times :: Term Int+times = opt 100 $ (optInfo [ "times", "t" ])+      { argName = "TIMES"+      , argDoc  = "Run $(mname) for the numbers 1 to $(argName)."+      }++term :: Term (IO ())+term = fizzBuzz <$> verbosity <*> fizz <*> buzz <*> times++termInfo :: TermInfo+termInfo = def+  { termName = "FizzBuzz"+  , version  = "v1.0"+  , termDoc  = "An implementation of the world renowned FizzBuzz algorithm."+  , man      = [ S "BUGS"+               , P "Email bug reports to <sirFrancisDrank@example.com>"+               ]+  }++main = run ( term, termInfo )
+ doc/examples/cipher.hs view
@@ -0,0 +1,222 @@+import System.Console.CmdTheLine+import Control.Applicative+import Data.Default++import Data.Char ( isUpper, isAlpha, isAlphaNum, isSpace+                 , toLower+                 )+import Data.List ( intersperse )++import System.IO+import System.Exit++infixr 2 <||>+-- Split a value between predicates and 'or' the results together+(<||>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+p <||> p' = (||) <$> p <*> p'+++--+-- Rot+--++data Cycle a = Cycle+  { backward :: (Cycle a)+  , at       :: a+  , forward  :: (Cycle a)+  }++fromList :: [a] -> Cycle a+fromList [] = error "Cycle must have at least one element"+fromList xs = first+  where+  ( first, last ) = go last xs first++  go :: Cycle a -> [a] -> Cycle a -> ( Cycle a, Cycle a )+  go prev []       next = ( next, prev )+  go prev (x : xs) next = ( this, last )+    where+    this        = Cycle prev x rest+    (rest,last) = go this xs next++-- Return a Cycle centered on x.+seekTo :: Eq a => a -> Cycle a -> Cycle a+seekTo x xs+  | x == at xs = xs+  | otherwise  = seekTo x $ forward xs+ +-- Seek n places forwards or backwards.+seek :: Bool -> Int -> Cycle a -> Cycle a+seek _    0 xs = xs+seek back n xs = seek back (n - 1) (dir xs)+  where+  dir = if back then backward else forward++lowers = fromList ['a'..'z']+uppers = fromList ['A'..'Z']++rot :: Bool -> Int -> Maybe String -> IO ()+rot back n mStr = do+  input <- case mStr of+    Nothing  -> getContents+    Just str -> return str++  putStrLn $ map rotChar input+  where+  rotChar c = if isAlpha c then c' else c+    where+    c'    = at . seek back n $ seekTo c cycle+    cycle = if isUpper c then uppers else lowers+++--+-- Morse+--++switch ( x, y ) = ( y, x )++fromCode = map switch toCode+toCode =+  [ ( 'a', ".-"    ), ( 'b', "-..."  ), ( 'c', "-.-."  ), ( 'd', "-.."   )+  , ( 'e', "."     ), ( 'f', "..-."  ), ( 'g', "--."   ), ( 'h', "...."  )+  , ( 'i', ".."    ), ( 'j', ".---"  ), ( 'k', "-.-"   ), ( 'l', ".-.."  )+  , ( 'm', "--"    ), ( 'n', "-."    ), ( 'o', "---"   ), ( 'p', ".--."  )+  , ( 'q', "--.-"  ), ( 'r', ".-."   ), ( 's', "..."   ), ( 't', "-"     )+  , ( 'u', "..-"   ), ( 'v', "...-"  ), ( 'w', ".--"   ), ( 'x', "-..-"  )+  , ( 'y', "-.--"  ), ( 'z', "--.."  ), ( '1', ".----" ), ( '2', "..---" )+  , ( '3', "...--" ), ( '4', "....-" ), ( '5', "....." ), ( '6', "-...." )+  , ( '7', "--..." ), ( '8', "---.." ), ( '9', "----." ), ( '0', "-----" )+  , ( ' ', "/"     )+  ]++fromMorse, toMorse :: [String] -> Maybe String+fromMorse    = mapM (`lookup` fromCode)++toMorse strs = sepCat " / " <$> mapM convertLetters strs+  where+  convertLetters chars = sepCat " " <$> mapM (`lookup` toCode) chars++  sepCat sep = concat . intersperse sep++morse :: Bool -> Maybe String -> IO ()+morse from mStr = do+  input <- case mStr of+    Nothing  -> getContents+    Just str -> return str++  if all pred input+     then return ()+     else do hPutStrLn stderr err+             exitFailure++  convert input+  where+  pred = if from then (== '/') <||> (== '-') <||> (== '.') <||> isSpace+                 else isAlphaNum <||> isSpace++  err = if from+    then "cipher: morse input must be all spaces, '/'s, '-'s, and '.'s."+    else "cipher: morse input must be alphanumeric and/or spaces"++  convert str = maybe badConvert putStrLn . convert' . words $ map toLower str+    where+    badConvert = hPutStrLn stderr err >> exitFailure+      where+      err = if from then "cipher: could not convert from morse"+                    else "cipher: could not convert to morse"++    convert' = if from then fromMorse else toMorse+++--+-- Terms+--++-- The heading under which to place common options.+comOpts = "COMMON OPTIONS"++-- A modified default 'TermInfo' to be shared by commands.+def' :: TermInfo+def' = def+  { man =+      [ S comOpts+      , P "These options are common to all commands."+      , S "MORE HELP"+      , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+      , S "BUGS"+      , P "Email bug reports to <snideHighland@example.com>"+      ]+  , stdOptSection = comOpts+  }++-- 'input' is a common option. We set its 'argSection' field to 'comOpts' so+-- that it is placed under that heading instead of the default '"OPTIONS"'+-- heading, which we will reserve for command-specific options.+input = opt Nothing (optInfo [ "input", "i" ])+      { argName    = "INPUT"+      , argDoc     = "For specifying input on the command line.  If present, "+                  ++ "input is not read form standard-in."+      , argSection = comOpts+      }+++rotTerm = ( rot <$> back <*> n <*> input, termInfo )+  where+  back = flag (optInfo [ "back", "b" ])+       { argName = "BACK"+       , argDoc  = "Rotate backwards instead of forwards."+       }++  n    = opt 13 (optInfo [ "n" ])+       { argName = "N"+       , argDoc  = "How many places to rotate by."+       }++  termInfo = def'+    { termName = "rot"+    , termDoc  = "Rotate the input characters by N."+    , man      = [ S "DESCRIPTION"+                 , P $ "Rotate input gathered from INPUT or standard-in N "+                    ++ "places.  The input must be composed totally of "+                    ++ "alphabetic characters and spaces."+                 ] ++ man def'+    }+++morseTerm = ( morse <$> from <*> input, termInfo )+  where+  from = flag (optInfo [ "from", "f" ])+       { argName   = "FROM"+       , argDoc    = "Convert from morse-code to the Latin alphabet. "+                  ++ "If absent, convert from Latin alphabet to morse-code."+       }++  termInfo = def'+    { termName = "morse"+    , termDoc  = "Convert to and from morse-code."+    , man      = [ S "DESCRIPTION"+                 , P desc+                 ] ++ man def'+    }++  desc = concat+    [ "Converts input gathered from INPUT or standard in to and from morse "+    , "code. 'dah' is represented by '-', 'dit' by '.'.  Each morse character "+    , "is separated from the next by one or more ' '.  Morse words are "+    , "separated by a '/'."+    ]+++defaultTerm = ( ret $ const (Left $ HelpFail Pager Nothing) <$> input+              , termInfo+              )+  where+  termInfo = def'+    { termName      = "cipher"+    , version       = "v1.0"+    , termDoc       = doc+    }++  doc = "An implementation of the morse-code and rotational(Caesar) ciphers."++main = runChoice defaultTerm  [ rotTerm, morseTerm ]
+ doc/examples/cp.hs view
@@ -0,0 +1,102 @@+import System.Console.CmdTheLine+import Control.Applicative++import System.Directory ( copyFile+                        , doesFileExist+                        , doesDirectoryExist+                        )+import System.FilePath  ( takeFileName+                        , pathSeparator+                        , hasTrailingPathSeparator+                        )++import System.IO+import System.Exit ( exitFailure )++sep = [pathSeparator]++infixr 1 ?+-- Like C's ternary operator. 'predicate ? then-clause $ else-clause'.+-- Nice for nested, if-elseif style boolean bifurcation.+(?) True  = const+(?) False = flip const++cp :: Bool -> [String] -> String -> IO ()+cp dry sources dest =+  chooseTactic =<< doesDirectoryExist dest+  where+  chooseTactic isDir = +    singleFile ? singleCopy isDir $+    not isDir  ? notDirErr $+    mapM_ copySourcesToDir sources++  singleFile = length sources == 1++  -- Errors+  notDirErr = do+    hPutStrLn stderr $ "cp: target '" ++ dest ++ "' is not a directory"+    exitFailure++  notFileErr str = do+    hPutStrLn stderr $ "cp: '" ++ str ++ "': no such file"+    exitFailure++  -- Tactics+  singleCopy isDir = do+    choose =<< doesFileExist filePath+    where+    choose isFile =+      isFile && isDir ? copyToDir  filePath $+      isFile          ? copyToFile filePath $+      notFileErr filePath++    filePath = head sources++  copySourcesToDir filePath = do+    isFile <- doesFileExist filePath+    isFile ? copyToDir  filePath+           $ notFileErr filePath++  -- File copying+  copyToDir filePath = if dry+    then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest' ]+    else copyFile filePath dest'+    where+    dest'           = withTrailingSep ++ takeFileName filePath+    withTrailingSep = hasTrailingPathSeparator dest ? dest $ dest ++ sep++  copyToFile filePath = if dry+    then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest ]+    else copyFile filePath dest+++-- An example of using the 'rev' and 'Left' variants of 'pos'.+cpTerm = cp <$> dry <*> sources <*> dest+  where+  dry = flag (optInfo [ "dry", "d" ])+      { argName = "DRY"+      , argDoc  = "Perform a dry run.  Print what would be copied, but do not "+               ++ "copy it."+      }++  sources = nonEmpty $ revPosLeft 0 [] posInfo+          { argName = "SOURCES"+          , argDoc  = "Source file(s) to copy."+          }++  dest    = required $ revPos 0 Nothing posInfo+          { argName = "DEST"+          , argDoc  = "Destination of the copy. Must be a directory if there "+                   ++ "is more than one $(i,SOURCE)."+          }++termInfo = def+  { termName = "cp"+  , version  = "v1.0"+  , termDoc  = "Copy files from SOURCES to DEST."+  , man      = [ S "BUGS"+               , P "Email bug reports to <portManTwo@example.com>"+               ]+  }++main = run ( cpTerm, termInfo )
+ doc/examples/fail.hs view
@@ -0,0 +1,84 @@+import System.Console.CmdTheLine+import Control.Applicative++import Text.PrettyPrint ( fsep   -- Paragraph fill a list of 'Doc'.+                        , text   -- Make a 'String' into a 'Doc'.+                        , quotes -- Quote a 'Doc'.+                        , (<+>)  -- Glue two 'Doc' together with a space.+                        )++import Data.List ( intersperse )+++cmdNames = [ "msg", "usage", "help", "success" ]++failMsg, failUsage, success :: [String] -> Err String+failMsg   strs = Left  . MsgFail   . fsep $ map text strs+failUsage strs = Left  . UsageFail . fsep $ map text strs+success   strs = Right . concat $ intersperse " " strs++help :: String -> Err String+help name+  | any (== name) cmdNames = Left . HelpFail Pager $ Just name+  | name == ""             = Left $ HelpFail Pager Nothing+  | otherwise              =+    Left . UsageFail $ quotes (text name) <+> text "is not the name of a command"++noCmd :: Err String+noCmd = Left $ HelpFail Pager Nothing+++def' = def+  { stdOptSection = "COMMON OPTIONS"+  , man =+      [ S "COMMON OPTIONS"+      , P "These options are common to all commands."+      , S "MORE HELP"+      , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+      , S "BUGS"+      , P "Email bug reports to <dogWalter@example.com>"+      ]+  }++input :: Term [String]+input = nonEmpty $ posAny [] posInfo+      { argName = "INPUT"+      , argDoc  = "Some input you would like printed to the screen on failure "+               ++ "or success."+      }++cmds :: [( Term String, TermInfo )]+cmds =+  [ ( ret $ failMsg <$> input+    , def' { termName = "msg"+           , termDoc  = "Print a failure message."+           }+    )++  , ( ret $ failUsage <$> input+    , def' { termName = "usage"+           , termDoc  = "Print a usage message."+           }+    )++  , ( ret $ success <$> input+    , def' { termName = "success"+           , termDoc  = "Print a message to the screen"+           }+    )++  , ( ret $ help <$> (pos 0 "" posInfo { argName = "TERM" })+    , def' { termName = "help"+           , termDoc  = "Display help for a command."+           }+    )+  ]++noCmdTerm = ( ret $ pure noCmd+            , def' { termName = "fail"+                   , termDoc  = "A program demoing CmdTheLine's user "+                             ++ "error functionality."+                   }+            )++main = putStrLn =<< execChoice noCmdTerm cmds
+ doc/examples/grep.hs view
@@ -0,0 +1,28 @@+import System.Console.CmdTheLine+import Control.Applicative++import Data.List ( intersperse )++import System.Cmd  ( system )+import System.Exit ( exitWith )++grep :: String -> [String] -> IO ()+grep pattern dests = do+  exitWith =<< system (concat . intersperse " " $ [ "grep", pattern ] ++ dests)++-- An example of using the 'pos' and 'posRight' Terms.+grepTerm = ( grep <$> pattern <*> files, termInfo )+  where+  pattern  = required $ pos 0 Nothing posInfo { argName = "PATTERN" }+  files    = posRight 0 [] posInfo { argName = "FILE"    }+  termInfo = def+    { termName = "grep"+    , version  = "2.5"+    , termDoc  = "Search for PATTERN in FILE(s) or standard in."+    , man      =+      [ S "BUGS"+      , P "Please send bug reports to <throatWobblerMangrove@example.com>"+      ]+    }++main = run grepTerm
+ doc/examples/hello.hs view
@@ -0,0 +1,26 @@+import System.Console.CmdTheLine+import Control.Applicative++-- Define a flag argument under the names '--silent' and '-s'+silent :: Term Bool+silent = flag $ optInfo [ "silent", "s" ]++-- Define the 0th positional argument, defaulting to the value '"world"' in+-- absence.+greeted :: Term String+greeted = pos 0 "world" posInfo { argName = "GREETED" }++hello :: Bool -> String -> IO ()+hello silent str =+  if silent+     then return ()+     else putStrLn $ "Hello, " ++ str ++ "!"++term :: Term (IO ())+term = hello <$> silent <*> greeted++termInfo :: TermInfo+termInfo = def { termName = "Hello", version = "1.0" }++main :: IO ()+main = run ( term, termInfo )
+ doc/examples/poly.hs view
@@ -0,0 +1,189 @@+-- We need 'FlexibleInstances to instance 'ArgVal' for 'Maybe Exp' and+-- '( String, Exp )'.+{-# LANGUAGE FlexibleInstances #-}++import Prelude hiding ( exp )+import System.Console.CmdTheLine hiding ( eval )+import Control.Applicative       hiding ( (<|>) )++import Control.Monad ( guard )+import Data.Char     ( isAlpha )+import Data.Function ( on )++import Text.Parsec+import qualified Text.PrettyPrint as PP++import qualified Data.Map as M++import System.IO++type Parser a = Parsec String () a++data Bin = Pow+         | Mul+         | Div+         | Add+         | Sub++prec :: Bin -> Int+prec b = case b of+  Pow -> 3+  Mul -> 2+  Div -> 2+  Add -> 1+  Sub -> 1++assoc :: Bin -> Assoc+assoc b = case b of+  Pow -> R+  _   -> L++toFunc :: Bin -> (Int -> Int -> Int)+toFunc b = case b of+  Pow -> (^)+  Mul -> (*)+  Div -> div+  Add -> (+)+  Sub -> (-)++data Exp = IntExp Int+         | VarExp String+         | BinExp Bin Exp Exp++instance ArgVal Exp where+  parser = fromParsec onErr exp+    where+    onErr str =  PP.text "invalid expression" PP.<+> PP.quotes (PP.text str)++  pp = pretty 0++instance ArgVal (Maybe Exp) where+  parser = just+  pp = maybePP++data Assoc = L | R++type Env = M.Map String Exp++instance ArgVal ( String, Exp ) where+  parser = pair '='+  pp     = pairPP '='++catParsers :: [Parser String] -> Parser String+catParsers = foldl (liftA2 (++)) (return "")++integer :: Parser Int+integer = read <$> catParsers [ option "" $ string "-", many1 digit ]++tok p = p <* spaces++parens = between op cp+  where+  op = tok $ char '('+  cp = tok $ char ')'++-- Parse a terminal expression.+term :: Parser Exp+term = parens exp <|> int <|> var+  where+  int = tok $ IntExp <$> try integer -- Try so '-<not-digits>' won't fail.+  var = tok $ VarExp <$> many1 (satisfy isAlpha)++-- Parse a binary operator.+bin :: Parser Bin+bin = choice [ pow, mul, div, add, sub ]+  where+  pow = tok $ Pow <$ char '^'+  mul = tok $ Mul <$ char '*'+  div = tok $ Div <$ char '/'+  add = tok $ Add <$ char '+'+  sub = tok $ Sub <$ char '-'++exp :: Parser Exp+exp = e 0++-- Precedence climbing expressions.  See+-- <www.engr.mun.ca/~theo/Misc/exp_parsing.htm> for further information.+e :: Int -> Parser Exp+e p = do+  t <- term+  try (go t) <|> return t+  where+  go e1 = do+    b <- bin+    guard $ prec b >= p++    let q = case assoc b of+          R -> prec b+          L -> prec b + 1+    e2 <- e q++    let expr = BinExp b e1 e2+    try (go expr) <|> return expr++-- Beta reduce by replacing variables in 'e' with values in 'env'.+beta :: Env -> Exp -> Maybe Exp+beta env e = case e of+  VarExp str     -> M.lookup str env+  int@(IntExp _) -> return int+  BinExp b e1 e2 -> (liftA2 (BinExp b) `on` beta env) e1 e2++eval :: Exp -> Int+eval e = case e of+  VarExp str     -> error $ "saw VarExp " ++ str ++ " while evaluating"+  IntExp i       -> i+  BinExp b e1 e2 -> (toFunc b `on` eval) e1 e2++pretty :: Int -> Exp -> PP.Doc+pretty p e = case e of+  VarExp str     -> PP.text str+  IntExp i       -> PP.int i+  BinExp b e1 e2 -> let q = prec b+                    in  parensOrNot q $ PP.cat [ pretty q e1, ppBin b, pretty q e2 ]+  where+  parensOrNot q = if q < p then PP.parens else id++ppBin :: Bin -> PP.Doc+ppBin b = case b of+  Pow -> PP.char '^'+  Mul -> PP.char '*'+  Div -> PP.char '/'+  Add -> PP.char '+'+  Sub -> PP.char '-'++poly :: Bool -> [( String, Exp )] -> Exp -> IO ()+poly pp assoc e = if pp+  then maybe badEnv (print . pretty 0) $ beta (M.fromList assoc) e+  else maybe badEnv (print . eval) $ beta (M.fromList assoc) e+  where+  badEnv = hPutStrLn stderr "poly: bad environment"++polyTerm = ( poly <$> pp <*> env <*> e, ti )+  where+  pp = flag (optInfo [ "pretty", "p" ])+     { argName = "PP"+     , argDoc  = "If present, pretty print instead of evaluating EXP."+     }++  env = nonEmpty $ posRight 0 [] posInfo+      { argName = "ENV"+      , argDoc  = "One or more assignments of the form '<name>=<exp>' to be "+               ++ "substituted in the input expression."+      }++  e = required $ pos 0 Nothing posInfo+    { argName = "EXP"+    , argDoc  = "An arithmetic expression to be evaluated."+    }++  ti = def+     { termName = "exp"+     , version  = "0.3"+     , termDoc  = "Evaluate mathematical functions demonstrating precedence "+               ++ "climbing and instantiating 'ArgVal'."+     , man      = [ S "BUGS"+                  , P "Email bug reports to <fitsCarolDo@example.com>"+                  ]+     }++main = run polyTerm
+ src/System/Console/CmdTheLine.hs view
@@ -0,0 +1,130 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine+  ( module System.Console.CmdTheLine.Term+  , module System.Console.CmdTheLine.Arg+  , module System.Console.CmdTheLine.ArgVal++  -- * Terms+  -- $term+  , Term()+  , TermInfo(..)+  , Default(..)++  -- * Manpages+  , ManBlock(..)++  -- * Argument information+  , ArgInfo( argDoc, argName, argSection )++  -- * User error reporting+  -- $err+  , Fail(..), HelpFormat(..), Err, ret+  )+  where++import Data.Default+import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.Term+import System.Console.CmdTheLine.Arg+import System.Console.CmdTheLine.ArgVal++import Control.Monad    ( join )++{-$term++  CmdTheLine is centered around the 'Term' Applicative Functor.  It allows us+  to define command line programs like the following.++> import System.Console.CmdTheLine+> import Control.Applicative+>+> -- Define a flag argument under the names '--silent' and '-s'+> silent :: Term Bool+> silent = flag $ optInfo [ "silent", "s" ]+>+> -- Define the 0th positional argument, defaulting to the value '"world"' in+> -- absence.+> greeted :: Term String+> greeted = pos 0 "world" posInfo { argName = "GREETED" }+> +> hello :: Bool -> String -> IO ()+> hello silent str =+>   if silent+>      then return ()+>      else putStrLn $ "Hello, " ++ str ++ "!"+>+> term :: Term (IO ())+> term = foo <$> silent <*> greeted+> +> termInfo :: TermInfo+> termInfo = def { termName = "Hello", version = "1.0" }+> +> main :: IO ()+> main = run ( term, termInfo )++  CmdTheLine then generates usage, help in the form of man-pages, and manages+  all the related tedium of getting values from the command line into our+  program so we can go on thinking in regular Haskell functions.++  See the accompanying examples(including the above) provided under the+  @doc/examples@ directory of the distributed package, or go to+  <http://github.com/eli-frey/cmdtheline> and peruse them there.++-}++{-$err++  There is nothing stopping you from printing and formating your own error+  messages.  However, some of the time you will want more tight integration+  with the library.  That is what 'Fail', the 'Err' monad, and 'ret' are for.++  Here is a snippet of an example program that can be found at+  @doc\/examples\/fail.hs@ in the library distribution tarball, or at+  <http://github.com/eli-frey/cmdtheline>.++> import System.Console.CmdTheLine+> import Control.Applicative+>+> import Text.PrettyPrint ( fsep   -- Paragraph fill a list of 'Doc'.+>                         , text   -- Make a 'String' into a 'Doc'.+>                         , quotes -- Quote a 'Doc'.+>                         , (<+>)  -- Glue two 'Doc' together with a space.+>                         )+>+> import Data.List ( intersperse )+>+> failMsg, failUsage, success :: [String] -> Err String+> failMsg   strs = Left  . MsgFail   . fsep $ map text strs+> failUsage strs = Left  . UsageFail . fsep $ map text strs+> success   strs = Right . concat $ intersperse " " strs+>+> help :: String -> Err String+> help name+>   | any (== name) cmdNames = Left . HelpFail Pager $ Just name+>   | name == ""             = Left $ HelpFail Pager Nothing+>   | otherwise              =+>     Left . UsageFail $ quotes (text name) <+> text "is not the name of a command"+>+> noCmd :: Err String+> noCmd = Left $ HelpFail Pager Nothing++  We can now turn any of these functions into a @Term String@ by lifting into+  'Term' and passing the result to 'ret' to fold the 'Err' monad into the+  library.  Here is an example of what it might look like to do this with @noCmd@.++> noCmdTerm :: Term (Err String)+> noCmdTerm = pure noCmd+>+> prepedNoCmdTerm :: Term String+> prepedNoCmdTerm = ret noCmdTerm+-}++-- | 'ret' @term@ folds @term@'s 'Err' context into the library to be handled+-- internally and as seamlessly as other error messages that are built in.+ret :: Term (Err a) -> Term a+ret (Term ais yield) = Term ais yield'+  where+  yield' ei cl = join $ yield ei cl
+ src/System/Console/CmdTheLine/Arg.hs view
@@ -0,0 +1,421 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Arg+  (+  -- * Creating ArgInfos+    optInfo, posInfo++  -- * Optional arguments+  -- $opt++  -- ** Flag options+  , flag, flagAll, vFlag, vFlagAll++  -- ** Assignable options+  , opt, defaultOpt, optAll, defaultOptAll++  -- * Positional arguments+  -- $pos+  , pos, revPos, posAny, posLeft, posRight, revPosLeft, revPosRight++  -- * Constraining Terms+  , required, nonEmpty, lastOf+  ) where++import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.CmdLine ( optArg, posArg )+import System.Console.CmdTheLine.ArgVal  ( ArgVal(..) )+import qualified System.Console.CmdTheLine.Err  as E+import qualified System.Console.CmdTheLine.Trie as T++import Control.Applicative+import Text.PrettyPrint++import Data.List     ( sort, sortBy )+import Data.Function ( on )+++argFail :: Doc -> Err a+argFail = Left . MsgFail++-- | Initialize an 'ArgInfo' by providing a list of names.  The fields+-- @argName@(found at "System.Console.CmdTheLine#argName"),+-- @argDoc@(found at "System.Console.CmdTheLine#argDoc"), and+-- @argSection@(found at "System.Console.CmdTheLine#argSection")+-- can then be manipulated post-mortem, as in+--+-- > inf =(optInfo    [ "i", "insufflation" ])+-- >     { argName    = "INSUFFERABLE"+-- >     , argDoc     = "in the haunted house's harrow"+-- >     , argSection = "NOT FOR AUGHT"+-- >     }+--+-- Names of one character in length will be prefixed by @-@ on the+-- command line, while longer names will be prefixed by @--@.+--+-- This function is meant to be used with optional arguments produced by 'flag',+-- 'opt', and friends-- not with positional arguments.  Positional arguments+-- provided with names will yield a run-time error, halting any and all program+-- runs.  Use 'posInfo' for positional arguments.+--+-- Likewise, if an optional argument is created with an 'ArgInfo' produced by+-- passing an empty list of names to 'optInfo', a run-time error will occur.+-- All optional arguments must have names.+optInfo :: [String] -> ArgInfo+optInfo names = ArgInfo+  { absence    = Present ""+  , argDoc     = ""+  , argName    = ""+  , argSection = defaultSection+  , posKind    = PosAny+  , optKind    = FlagKind+  , optNames   = map dash names+  , repeatable = False+  }+  where+  defaultSection+    | names == [] = "ARGUMENTS"+    | otherwise   = "OPTIONS"++  dash "" =+    error "System.Console.CmdTheLine.Arg.optInfo recieved empty string as name"++  dash str@[_] = "-"  ++ str+  dash str     = "--" ++ str++-- | As 'optInfo' but for positional arguments, which by virtue of their+-- positions require no names.  If a positional argument is created with a+-- name, a run-time error will occur halting any and all program runs.+--+-- If you mean to create an optional argument, use 'optInfo', and be sure to+-- give it a non-empty list of names to avoid these errors.+posInfo :: ArgInfo+posInfo = optInfo []+++{- $opt++  An optional argument is specified on the command line by a /name/ possibly+  followed by a /value/.++  The name of an option can be /short/ or /long/.++  * A /short/ name is a dash followed by a single alphanumeric character:+    @-h@, @-q@, @-I@.++  * A /long/ name is two dashes followed by alphanumeric characters and dashes:+    @--help@, @--silent@, @--ignore-case@.++  More than one name may refer to the same optional argument.  For example in+  a given program the names @-q@, @--quiet@, and @--silent@ may all stand for+  the same boolean argument indicating the program to be quiet.  Long names can+  be specified by any non-ambiguous prefix.++  There are three ways to assign values to an optional argument on the command+  line.++  * As the next token on the command line: @-o a.out@, @--output a.out@.++  * Glued to a short name: @-oa.out@.++  * Glued to a long name after an equal character: @--output=a.out@.++  Glued forms are necessary if the value itself starts with a dash, as is the+  case for negative numbers, @--min=-10@.++-}++--+-- Flags+--++-- | Create a command line flag that can appear at most once on the+-- command line.  Yields @False@ in absence and @True@ in presence.+flag :: ArgInfo -> Term Bool+flag ai =+  if isPos ai+     then error E.errNotPos+     else Term [ai] yield+  where+  yield _ cl = case optArg cl ai of+    []                  -> Right   False+    [( _, _, Nothing )] -> Right   True+    [( _, f, Just v  )] -> argFail $ E.flagValue f v++    (( _, f, _ ) :+     ( _, g, _ ) :+     _           ) -> argFail $ E.optRepeated f g++-- | As 'flag' but may appear an infinity of times. Yields a list of @True@s+-- as long as the number of times present.+flagAll :: ArgInfo -> Term [Bool]+flagAll ai+  | isPos ai  = error E.errNotPos+  | otherwise = Term [ai'] yield+  where+  ai' = ai { repeatable = True }++  yield _ cl = case optArg cl ai' of+    [] -> Right []+    xs -> mapM truth xs++  truth ( _, f, mv ) = case mv of+    Nothing -> Right   True+    Just v  -> argFail $ E.flagValue f v++-- | 'vFlag' @v [ ( v1, ai1 ), ... ]@ is an argument that can be present at most+-- once on the command line. It takes on the value @vn@ when appearing as+-- @ain@.+vFlag :: a -> [( a, ArgInfo )] -> Term a+vFlag v assoc = Term (map flag assoc) yield+  where+  flag ( _, ai )+    | isPos ai  = error E.errNotPos+    | otherwise = ai++  yield _ cl = go Nothing assoc+    where+    go mv [] = case mv of+      Nothing       -> Right v+      Just ( _, v ) -> Right v++    go mv (( v, ai ) : rest) = case optArg cl ai of+      []                  -> go mv rest++      [( _, f, Nothing )] -> case mv of+        Nothing       -> go (Just ( f, v )) rest+        Just ( g, _ ) -> argFail $ E.optRepeated g f++      [( _, f, Just v )]  -> argFail $ E.flagValue f v++      (( _, f, _ ) :+       ( _, g, _ ) :+       _           ) -> argFail $ E.optRepeated g f++-- | 'vFlagAll' @vs assoc@ is as 'vFlag' except that it can be present an+-- infinity of times.  In absence, @vs@ is yielded.  When present, each+-- value is collected in the order they appear.+vFlagAll :: [a] -> [( a, ArgInfo)] -> Term [a]+vFlagAll vs assoc = Term (map flag assoc) yield+  where+  flag ( _, ai ) +    | isPos ai  = error E.errNotOpt+    | otherwise = ai { repeatable = True }++  yield _ cl = do+    result <- foldl addLookup (Right []) assoc+    case result of+      [] -> return vs+      _  -> return . map snd $ sortBy (compare `on` fst) result+    where+    addLookup acc ( v, ai ) = case optArg cl ai of+      [] -> acc+      xs -> (++) <$> mapM flagVal xs <*> acc+      where+      flagVal ( pos, f, mv ) = case mv of+        Nothing -> Right   ( pos, v )+        Just v  -> argFail $ E.flagValue f v+   ++--+-- Options+--++parseOptValue :: ArgVal a => String -> String -> Err a+parseOptValue f v = case parser v of+  Left  e -> Left  . UsageFail $ E.optParseValue f e+  Right v -> Right v++mkOpt :: ArgVal a => Maybe a -> a -> ArgInfo -> Term a+mkOpt vopt v ai+  | isPos ai  = error E.errNotOpt+  | otherwise = Term [ai'] yield+    where+    ai' = ai { absence = Present . show $ pp v+             , optKind = case vopt of+                 Nothing -> OptKind+                 Just dv -> OptVal . show $ pp dv+             }+    yield _ cl = case optArg cl ai' of+      []                  -> Right v+      [( _, f, Just v )]  -> parseOptValue f v++      [( _, f, Nothing )] -> case vopt of+        Nothing   -> argFail $ E.optValueMissing f+        Just optv -> Right   optv++      (( _, f, _ ) :+       ( _, g, _ ) :+       _           ) -> argFail $ E.optRepeated g f++-- | 'opt' @v ai@ is an optional argument that yields @v@ in absence, or an+-- assigned value in presence.  If the option is present, but no value is+-- assigned, it is considered a user-error and usage is printed on exit.+opt :: ArgVal a => a -> ArgInfo -> Term a+opt = mkOpt Nothing++-- | 'defaultOpt' @def v ai@ is as 'opt' except if it is present and no value is+-- assigned on the command line, @def@ is the result.+defaultOpt :: ArgVal a => a -> a -> ArgInfo -> Term a+defaultOpt x = mkOpt $ Just x++mkOptAll :: ( ArgVal a, Ord a ) => Maybe a -> [a] -> ArgInfo -> Term [a]+mkOptAll vopt vs ai+  | isPos ai  = error E.errNotOpt+  | otherwise = Term [ai'] yield+    where+    ai' = ai { absence    = Present ""+             , repeatable = True+             , optKind    = case vopt of+                 Nothing -> OptKind+                 Just dv -> OptVal . show $ pp dv+             }++    yield _ cl = case optArg cl ai' of+      [] -> Right vs+      xs -> map snd . sortBy (compare `on` fst) <$> mapM parse xs++    parse ( pos, f, mv' ) = case mv' of+      Just v  -> (,) pos <$> parseOptValue f v+      Nothing -> case vopt of+        Nothing -> argFail $ E.optValueMissing f+        Just dv -> Right   ( pos, dv )++-- | 'optAll' @vs ai@ is like 'opt' except that it yields @vs@ in absence and+-- can appear an infinity of times.  The values it is assigned on the command+-- line are accumulated in the order they appear.+optAll :: ( ArgVal a, Ord a ) => [a] -> ArgInfo -> Term [a]+optAll = mkOptAll Nothing++-- | 'defaultOptAll' @def vs ai@ is like 'optAll' except that if it is present+-- without being assigned a value, the value @def@ takes its place in the list+-- of results.+defaultOptAll :: ( ArgVal a, Ord a ) => a -> [a] -> ArgInfo -> Term [a]+defaultOptAll x = mkOptAll $ Just x+++{- $pos++  Positional arguments are tokens on the command line that are not option names+  or the values being assigned to an optional argument.++  Since positional arguments may be mistaken as the optional value of an+  optional argument or they may need to look like an optional name, anything+  that follows the special token @--@(with spaces on both sides) on the command+  line is considered to be a positional argument.++  Positional arguments are listed in documentation sections iff they are+  assigned both an @argName@ and an @argDoc@.++-}++--+-- Positional arguments.+--++parsePosValue :: ArgVal a => ArgInfo -> String -> Err a+parsePosValue ai v = case parser v of+  Left  e -> Left  . UsageFail $ E.posParseValue ai e+  Right v -> Right v++mkPos :: ArgVal a => Bool -> Int -> a -> ArgInfo -> Term a+mkPos rev pos v ai = Term [ai'] yield+  where+  ai' = ai { absence = Present . show $ pp v+           , posKind = PosN rev pos+           }+  yield _ cl = case posArg cl ai' of+    []  -> Right v+    [v] -> parsePosValue ai' v+    _   -> error "saw list with more than one member in pos converter"++-- | 'pos' @n v ai@ is an argument defined by the @n@th positional argument+-- on the command line. If absent the value @v@ is returned.+pos :: ArgVal a => Int -> a -> ArgInfo -> Term a+pos    = mkPos False++-- | 'revPos' @n v ai@ is as 'pos' but counting from the end of the command line+-- to the front.+revPos :: ArgVal a => Int -> a -> ArgInfo -> Term a+revPos = mkPos True++posList :: ArgVal a => PosKind -> [a] -> ArgInfo -> Term [a]+posList kind vs ai+  | isOpt ai  = error E.errNotPos+  | otherwise = Term [ai'] yield+    where+    ai' = ai { posKind = kind }+    yield _ cl = case posArg cl ai' of+      [] -> Right vs+      xs -> mapM (parsePosValue ai') xs++-- | 'posAny' @vs ai@ yields a list of all positional arguments or @vs@ if none+-- are present.+posAny :: ArgVal a => [a] -> ArgInfo -> Term [a]+posAny = posList PosAny++-- | 'posLeft' @n vs ai@ yield a list of all positional arguments to the left of+-- the @n@th positional argument or @vs@ if there are none.+posLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+posLeft = posList . PosL False++-- | 'posRight' @n vs ai@ is as 'posLeft' except yielding all values to the right+-- of the @n@th positional argument.+posRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+posRight = posList . PosR False++-- | 'revPosLeft' @n vs ai@ is as 'posLeft' except @n@ counts from the end of the+-- command line to the front.+revPosLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+revPosLeft = posList . PosL True++-- | 'revPosRight' @n vs ai@ is as 'posRight' except @n@ counts from the end of+-- the command line to the front.+revPosRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+revPosRight = posList . PosR True+++--+-- Arguments as terms.+--++absent = map (\ ai -> ai { absence = Absent })++-- | 'required' @term@ converts @term@ so that it fails in the 'Nothing' and+-- yields @a@ in the 'Just'.+--+-- This is used for required positional arguments.  There is nothing+-- stopping you from using it with optional arguments, except that they+-- would no longer be optional and it would be confusing from a user's+-- perspective.+required :: Term (Maybe a) -> Term a+required (Term ais yield) = Term ais' yield'+  where+  ais' = absent ais+  yield' ei cl = case yield ei cl of+    Left  e  -> Left  e+    Right mv -> maybe (argFail . E.argMissing $ head ais') Right mv++-- | 'nonEmpty' @term@ is a term that fails if its result is empty. Intended+-- for non-empty lists of positional arguments.+nonEmpty :: Term [a] -> Term [a]+nonEmpty (Term ais yield) = Term ais' yield'+  where+  ais' = absent ais+  yield' ei cl = case yield ei cl of+    Left  e  -> Left    e+    Right [] -> argFail . E.argMissing $ head ais'+    Right xs -> Right   xs++-- | 'lastOf' @term@ is a term that fails if its result is empty and evaluates+-- to the last element of the resulting list otherwise.  Intended for lists+-- of flags or options where the last takes precedence.+lastOf :: Term [a] -> Term a+lastOf (Term ais yield) = Term ais yield'+  where+  yield' ei cl = case yield ei cl of+    Left e   -> Left    e+    Right [] -> argFail . E.argMissing $ head ais+    Right xs -> Right   $ last xs
+ src/System/Console/CmdTheLine/ArgVal.hs view
@@ -0,0 +1,292 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+{-# LANGUAGE FlexibleInstances #-}+module System.Console.CmdTheLine.ArgVal+  (+  -- * Parsing values from the command line+    ArgVal(..), ArgParser, ArgPrinter++  -- ** Helpers for instantiating ArgVal+  , fromParsec+  , enum+  -- *** Maybe values+  , just, maybePP+  -- *** List values+  , list, listPP+  -- *** Tuple values+  , pair, pairPP+  , triple, triplePP+  , quadruple, quadruplePP+  , quintuple, quintuplePP+  ) where++import System.Console.CmdTheLine.Common ( splitOn )+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.Ratio    ( Ratio )+import Data.Default++import Control.Applicative hiding ( (<|>), empty )+import Text.Parsec         hiding ( char )+import Text.PrettyPrint++-- | The type of parsers of individual command line argument values.+type ArgParser  a = String -> Either Doc a++-- | The type of printers of values retrieved from the command line.+type ArgPrinter a = a -> Doc++decPoint      = string "."+digits        = many1 digit+concatParsers = foldl (liftA2 (++)) $ return []+sign          = option "" $ string "-"++pInteger  :: ( Read a, Integral a ) => Parsec String () a+pFloating :: ( Read a, Floating a ) => Parsec String () a+pInteger      = read <$> concatParsers [ sign, digits ]+pFloating     = read <$> concatParsers [ sign, digits, decPoint, digits ]++-- | 'fromParsec' @onErr p@ makes an 'ArgParser' from @p@ using @onErr@ to+-- produce meaningful error messages.  On failure, @onErr@ will receive a+-- raw string of the value found on the command line.+fromParsec :: ( String -> Doc) -> Parsec String () a -> ArgParser a+fromParsec onErr p str = either (const . Left $ onErr str) Right+                       $ parse p "" str++-- | A parser of 'Maybe' values of 'ArgVal' instances. A convenient default+-- that merely lifts the 'ArgVal' instance's parsed value with 'Just'.+just :: ArgVal a => ArgParser (Maybe a)+just = either Left (Right . Just) . parser++-- | A printer of 'Maybe' values of 'ArgVal' instances. A convenient default+-- that prints nothing on the 'Nothing' and just the value on the 'Just'.+maybePP :: ArgVal a => ArgPrinter (Maybe a)+maybePP = maybe empty id . fmap pp++-- | A parser of enumerated values conveyed as an association list of+-- @( string, value )@ pairs.  Unambiguous prefixes of @string@ map to+-- @value@.+enum :: [( String, a )] -> ArgParser a+enum assoc str = case T.lookup str trie of+  Right v           -> Right v+  Left  T.Ambiguous -> Left  $ E.ambiguous "enum value" str ambs+  Left  T.NotFound  -> Left  . E.invalidVal (text str) $ text "expected" <+> alts+  where+  ambs = sort $ T.ambiguities trie str+  alts = E.alts $ map fst assoc+  trie = T.fromList assoc++-- | @'list' sep@ creates a parser of lists of an 'ArgVal' instance separated+-- by @sep@.+list :: ArgVal a => Char -> ArgParser [a]+list sep str = either (Left . E.element "list" str)+                      Right+                      . sequence $ unfoldr parseElem str+  where+  parseElem []  = Nothing+  parseElem str = Just . first parser $ splitOn sep str++-- | @'listPP' sep@ creates a pretty printer of lists of an 'ArgVal' instance+-- seperated by @sep@.+listPP :: ArgVal a => Char -> ArgPrinter [a]+listPP sep = fsep . punctuate (char sep) . map pp++-- | @'pair' sep@ creates a parser of pairs of 'ArgVal' instances separated+-- by @sep@.+pair :: ( ArgVal a, ArgVal b ) => Char -> ArgParser ( a, b )+pair sep str = do+  case yStr of+    [] -> Left $ E.sepMiss sep str+    _  -> return ()+  case ( eX, eY ) of+    ( Right x, Right y ) -> Right ( x, y )+    ( Left  e, _       ) -> Left $ E.element "pair" xStr e+    ( _,       Left e  ) -> Left $ E.element "pair" yStr e+  where+  ( eX, eY ) = parser *** parser $ xyStr+  xyStr@( xStr, yStr ) = splitOn sep str++-- | @'pairPP' sep@ creates a pretty printer of pairs of 'ArgVal' instances+-- separated by @sep@+pairPP :: ( ArgVal a, ArgVal b ) => Char -> ArgPrinter ( a, b )+pairPP sep ( x, y ) = pp x <> char sep <+> pp y++-- | @'triple' sep@ creates a parser of triples of 'ArgVal' instances separated+-- by @sep@.+triple :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgParser ( a, b, c )+triple sep str = do+  [ xStr, yStr, zStr ] <-+    if length strs == 3+       then Right strs+       else Left  $ E.sepMiss sep str+  case ( parser xStr, parser yStr, parser zStr ) of+    ( Right x, Right y, Right z ) -> Right ( x, y, z )+    ( Left  e, _     ,  _       ) -> Left $ E.element "pair" xStr e+    ( _,       Left e,  _       ) -> Left $ E.element "pair" yStr e+    ( _,       _     ,  Left e  ) -> Left $ E.element "pair" zStr e+  where+  strs = unfoldr split str++  split []  = Nothing+  split str = Just $ splitOn sep str++-- | @'triplePP' sep@ creates a pretty printer of triples of 'ArgVal' instances+-- separated by @sep@+triplePP :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgPrinter ( a, b, c )+triplePP sep ( x, y, z ) = pp x <> char sep <+> pp y <> char sep <+> pp z++-- | @'quadruple' sep@ creates a parser of quadruples of 'ArgVal' instances+-- separated by @sep@.+quadruple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>+  Char -> ArgParser ( a, b, c, d )+quadruple sep str = do+  [ xStr, yStr, zStr, wStr ] <-+    if length strs == 4+       then Right strs+       else Left  $ E.sepMiss sep str++  case ( parser xStr, parser yStr, parser zStr, parser wStr ) of+    ( Right x, Right y, Right z, Right w ) -> Right ( x, y, z, w )+    ( Left  e, _     ,  _      , _       ) -> Left $ E.element "pair" xStr e+    ( _,       Left e,  _      , _       ) -> Left $ E.element "pair" yStr e+    ( _,       _     ,  Left e , _       ) -> Left $ E.element "pair" zStr e+    ( _,       _     ,  _      , Left e  ) -> Left $ E.element "pair" wStr e+  where+  strs = unfoldr split str++  split []  = Nothing+  split str = Just $ splitOn sep str++-- | @'quadruplePP' sep@ creates a pretty printer of quadruples of 'ArgVal'+-- instances separated by @sep@+quadruplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>+  Char -> ArgPrinter ( a, b, c, d )+quadruplePP sep ( x, y, z, w ) =+  pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+> pp w++-- | @'quintuple' sep@ creates a parser of quintuples of 'ArgVal' instances+-- separated by @sep@.+quintuple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>+  Char -> ArgParser ( a, b, c, d, e )+quintuple sep str = do+  [ xStr, yStr, zStr, wStr, vStr ] <-+    if length strs == 3+       then Right strs+       else Left  $ E.sepMiss sep str+  case ( parser xStr, parser yStr, parser zStr, parser wStr, parser vStr ) of+    ( Right x, Right y, Right z, Right w, Right v ) -> Right ( x, y, z, w, v )+    ( Left  e, _     ,  _      , _      , _       ) ->+      Left $ E.element "pair" xStr e+    ( _,       Left e,  _      , _      , _       ) ->+      Left $ E.element "pair" yStr e+    ( _,       _     ,  Left e , _      , _       ) ->+      Left $ E.element "pair" zStr e+    ( _,       _     ,  _      , Left e , _       ) ->+      Left $ E.element "pair" wStr e+    ( _,       _     ,  _      , _      , Left e  ) ->+      Left $ E.element "pair" vStr e+  where+  strs = unfoldr split str++  split []  = Nothing+  split str = Just $ splitOn sep str++-- | @'quintuplePP' sep@ creates a pretty printer of quintuples of 'ArgVal'+-- instances separated by @sep@+quintuplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>+  Char -> ArgPrinter ( a, b, c, d, e )+quintuplePP sep ( x, y, z, w, v ) =+  pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+>+    pp w <> char sep <+> pp v++invalidVal = E.invalidVal `on` text++-- | The class of values that can be parsed from the command line. Instances+-- must provide both 'parser' and 'pp'.+class ArgVal a where+  parser :: ArgParser  a -- ^ A parser of instance values.+  pp     :: ArgPrinter a -- ^ A pretty printer for instance values.++instance ArgVal Bool where+  parser   = fromParsec onErr+           $ (True <$ string "true") <|> (False <$ string "false")+    where+    onErr str = E.invalidVal (text str) $ E.alts [ "true", "false" ]++  pp True  = text "true"+  pp False = text "false"++instance ArgVal (Maybe Bool) where+  parser = just+  pp     = maybePP++instance ArgVal [Char] where+  parser = Right+  pp = text++instance ArgVal (Maybe [Char]) where+  parser = just+  pp     = maybePP++instance ArgVal Int where+  parser = fromParsec onErr pInteger+    where+    onErr str = invalidVal str "expected an integer"+  pp = int++instance ArgVal (Maybe Int) where+  parser = just+  pp     = maybePP++instance ArgVal Integer where+  parser = fromParsec onErr pInteger+    where+    onErr str = invalidVal str "expected an integer"+  pp = integer++instance ArgVal (Maybe Integer) where+  parser = just+  pp     = maybePP++instance ArgVal Float where+  parser = fromParsec onErr pFloating+    where+    onErr str = invalidVal str "expected a floating point number"+  pp = float++instance ArgVal (Maybe Float) where+  parser = just+  pp     = maybePP++instance ArgVal Double where+  parser = fromParsec onErr pFloating+    where+    onErr str = invalidVal str "expected a floating point number"+  pp = double++instance ArgVal (Maybe Double) where+  parser = just+  pp     = maybePP++instance ArgVal (Ratio Integer) where+  parser = fromParsec onErr+         $ read <$> concatParsers [ int <* spaces+                                  , string "%"+                                  , spaces >> int+                                  ]+    where+    int = concatParsers [ sign, digits ]+    onErr str =+      invalidVal str "expected a ratio in the form '<numerator> % <denominator>'"++  pp = rational++instance ArgVal (Maybe (Ratio Integer)) where+  parser = just+  pp     = maybePP
+ src/System/Console/CmdTheLine/CmdLine.hs view
@@ -0,0 +1,162 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.CmdLine+  ( create, optArg, posArg ) where++import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.Err as E++import Control.Applicative+import Control.Arrow ( second )++import Text.PrettyPrint+import Text.Parsec as P++import qualified System.Console.CmdTheLine.Trie as T+import qualified Data.Map as M++import Data.List     ( sort )+import Data.Function ( on )+++optArg :: CmdLine -> ArgInfo -> [( Int, String, Maybe String )]+optArg cl ai = case M.lookup ai cl of+  Nothing  -> error "ArgInfo passed to optArg does not index CmdLine"+  Just arg -> case arg of+    Opt opt -> opt+    _       -> error "ArgInfo passed to optArg indexes to positional argument"++posArg :: CmdLine -> ArgInfo -> [String]+posArg cl ai = case M.lookup ai cl of+  Nothing  -> error "ArgInfo passed to posArg does not index CmdLine"+  Just arg -> case arg of+    Pos opt -> opt+    _       -> error "ArgInfo passed to posArg indexes to positional argument"++{- Returns a trie mapping the names of optional arguments to their ArgInfo, a+ - list with all ArgInfo for positional arguments, and a CmdLine mapping each+ - ArgInfo to an empty list of Arg.+ -}+argInfoIndexes :: [ArgInfo] -> ( T.Trie ArgInfo, [ArgInfo], CmdLine )+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+                  , posAis+                  , M.insert ai (Opt []) cl+                  )+    where+    add t name = T.add t name ai++parseOptArg :: String -> ( String, Maybe String )+parseOptArg str+  -- 'str' is a short name.+  | str !! 1 /= '-' =+    if length str == 2+       then ( str,        Nothing )           -- No glued argument.+       else ( take 2 str, Just $ drop 2 str ) -- Glued argument.++  -- 'str' is a long name.+  | otherwise       = case P.parse assignment "" str of+    Left _       -> ( str, Nothing ) --  No glued argument+    Right result -> result           --  Glued argument+    where+    assignment = do+      label <- P.many1 $ P.satisfy (/= '=')+      value <- optionMaybe $ P.char '=' >> P.many1 P.anyChar+      return ( label, value )++{- Returns an updated CmdLine according to the options found in 'args'+ - with the trie index 'optTrie'.  Positional arguments are returned in order.+ -}+parseArgs :: T.Trie ArgInfo -> CmdLine -> [String]+          -> Err ( CmdLine, [String] )+parseArgs optTrie cl args = second (reverse . (++ rest)) <$> go 1 cl [] args+  where+  -- Everything after '"--"' is a position argument.+  ( args', rest ) = splitOn "--" args+  go k cl posArgs args = case args of+    []         -> Right ( cl, posArgs )+    str : rest ->+      if isOpt str+         then asignOptValue str rest+         else go (k + 1) cl (str : posArgs) rest+    where+    isOpt str = length str > 1 && head str == '-'++    asignOptValue str rest = either handleErr addOpt $ T.lookup name optTrie+      where+      ( name, value ) = parseOptArg str++      addOpt ai = go (k + 1) cl' posArgs rest'+        where+        cl'     = M.insert ai optArgs cl+        optArgs = Opt $ ( k, name, value' ) : optArg cl ai++        ( value', rest' )+          -- If the next string can't be assigned to this argument, don't+          -- skip it.+          | value /= Nothing || optKind ai == FlagKind ||+            rest == []       || isOpt (head rest)      = ( value, rest )+          -- Else the next string is the value of this argument, consume it.+          | otherwise                                  = ( Just $ head rest+                                                         , tail rest+                                                         )++      handleErr T.NotFound  = Left $ UsageFail unknown+      handleErr T.Ambiguous = Left $ UsageFail ambiguous++      unknown   = E.unknown   "option" name+      ambiguous = E.ambiguous "option" name ambs+        where+        ambs = sort $ T.ambiguities optTrie name+++{- Returns an updated CmdLine in which each positional arg mentioned in the+ - list index 'posInfo', is given a value according to the list of positional+ - argument values 'args'.+ -}+processPosArgs :: [ArgInfo] -> ( CmdLine, [String] ) -> Err CmdLine+processPosArgs _       ( cl, [] ) = Right cl+processPosArgs posInfo ( cl, args )+  | last <= maxSpec = Right cl'+  | otherwise       = Left  $ UsageFail excess+  where+  last   = length args - 1+  excess = E.posExcess . map text $ takeEnd (last - maxSpec) args++  ( cl', maxSpec ) = foldl go ( cl, -1 ) posInfo++  takeEnd n = reverse . take n . reverse++  go ( cl, maxSpec ) ai = ( cl', maxSpec' )+    where+    cl'               = M.insert ai arg cl+    ( arg, maxSpec' ) = case posKind ai of+      PosAny       -> ( Pos args, last )+      PosN rev pos -> result rev pos False indexPositions+      PosL rev pos -> result rev pos False take+      PosR rev pos -> result rev pos True  (takeEnd . (last -))++    indexPositions pos args = [args !! pos]++    result rev pos maxIsLast getPositions+      | pos' < 0 || cmp pos' last = ( Pos [], maxSpec'' )+      | otherwise                 = ( Pos $ getPositions pos' args+                                    , maxSpec''+                                    )+      where+      pos'      = if rev       then last - pos else pos+      cmp       = if maxIsLast then (>=)       else (>)+      maxSpec'' = if maxIsLast then last       else max pos' maxSpec++create :: [ArgInfo] -> [String] -> Err CmdLine+create ais args = processPosArgs posAis =<< parseArgs optTrie cl args+  where+  ( optTrie, posAis, cl ) = argInfoIndexes ais
+ src/System/Console/CmdTheLine/Common.hs view
@@ -0,0 +1,207 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Common where++import Data.Default+import Data.Function    ( on )+import Text.PrettyPrint ( Doc )++import qualified Data.Map as M++data Absence = Absent+             | Present String+               deriving ( Eq )++data OptKind = FlagKind+             | OptKind+             | OptVal String+               deriving ( Eq )++data PosKind = PosAny+             | PosN Bool Int+             | PosL Bool Int+             | PosR Bool Int+               deriving ( Eq, Ord )++-- | Information about an argument.  The following fields are exported for your+-- use.+--+-- #argName# +--+-- [@argName@] :: 'String' A name to be used in the documentation to+-- refer to the argument's value. Defaults to @\"\"@.+--+-- #argDoc# +--+-- [@argDoc@] :: 'String' A documentation string for the argument.+-- Defaults to @\"\"@.+--+-- #argSection# +--+-- [@argSection@] :: 'String' The section under which to place the argument's+-- documentation.  Defaults to @\"OPTIONS\"@ for optional arguments and+-- @\"ARGUMENTS\"@ for positional arguments.+data ArgInfo = ArgInfo+  { absence    :: Absence+  , argDoc     :: String+  , argName    :: String+  , argSection :: String+  , posKind    :: PosKind+  , optKind    :: OptKind+  , optNames   :: [String]+  , repeatable :: Bool+  }++instance Eq ArgInfo where+  ai == ai'+    | isPos ai && isPos ai' = ((==) `on` posKind) ai ai'+    | isOpt ai && isOpt ai' = ((==) `on` optNames) ai ai'+    | otherwise             = False++-- This Ord instance works for placing in 'Data.Map's, but not much else.+instance Ord ArgInfo where+  compare ai ai'+    | isPos ai && isPos ai' = (compare `on` posKind) ai ai'+    | isOpt ai && isOpt ai' = (compare `on` optNames) ai ai'+    | isOpt ai && isPos ai' = LT+    | otherwise             = GT+++data Arg = Opt [( Int          -- The position were the argument was found.+                , String       -- The name by which the argument was supplied.+                , Maybe String -- If present, a value assigned to the argument.+                )]+         | Pos [String]        -- A list of positional arguments++type CmdLine = M.Map ArgInfo Arg++isOpt, isPos :: ArgInfo -> Bool+isOpt ai = optNames ai /= []+isPos ai = optNames ai == []++{- |+  Any 'String' argument to a 'ManBlock' constructor may contain the+  following significant forms for a limited kind of meta-programing.++  * $(i,text): italicizes @text@.++  * $(b,text): bolds @text@.++  * $(mname): evaluates to the name of the default term if there are choices+    of commands, or the only term otherwise.++  * $(tname): evaluates to the name of the currently evaluating term.++  Additionally, text inside the content portion of an 'I' constructor may+  contain one of the following significant forms.++  * $(argName): evaluates to the name of the argument being documented.++-}+data ManBlock = S String        -- ^ A section title.+              | P String        -- ^ A paragraph.+              | I String String -- ^ A label-content pair. As in an argument+                                --   definition and its accompanying+                                --   documentation.+              | NoBlank         -- ^ Suppress the normal blank line following+                                --   a 'P' or an 'I'.+                deriving ( Eq )++type Title = ( String, Int, String, String, String )++type Page = ( Title, [ManBlock] )++-- | Information about a 'Term'.  It is recommended that 'TermInfo's be+-- created by customizing the 'Data.Default' instance, as in+--+-- > termInfo = def+-- >   { termName = "caroline-no"+-- >   , termDoc  = "carry a line off"+-- >   }+data TermInfo = TermInfo+  {+  -- | The name of the command or program represented by the term. Defaults to+  -- @\"\"@.+    termName      :: String++  -- | Documentation for the term. Defaults to @\"\"@.+  , termDoc       :: String++  -- | The section under which to place the terms documentation.+  -- Defaults to @\"COMMANDS\"@.+  , termSection   :: String++  -- | The section under which to place a term's argument's+  -- documentation by default. Defaults to @\"OPTIONS\"@.+  , stdOptSection :: String++  -- | A version string.  Must be left blank for commands. Defaults to @\"\"@.+  , version       :: String++  -- | A list of 'ManBlock's to append to the default @[ManBlock]@. Defaults+  -- to @[]@.+  , man           :: [ManBlock]+  } deriving ( Eq )++instance Default TermInfo where+  def = TermInfo+    { termName      = ""+    , version       = ""+    , termDoc       = ""+    , termSection   = "COMMANDS"+    , stdOptSection = "OPTIONS"+    , man           = []+    }++type Command = ( TermInfo, [ArgInfo] )++data EvalInfo = EvalInfo+  { term    :: Command   -- The chosen term for this run.+  , main    :: Command   -- The default term.+  , choices :: [Command] -- A list of command-terms.+  }++data EvalKind = Simple   -- The program has no commands.+              | Main     -- The default program is running.+              | Choice   -- A command has been chosen.++-- | The format to print help in.+data HelpFormat = Pager | Plain | Groff++data Fail =+          -- | An arbitrary message to be printed on failure.+            MsgFail   Doc++          -- | A message to be printed along with the usage on failure.+          | UsageFail Doc++          -- | A format to print the help in and an optional name of the term+          -- to print help for.  If 'Nothing' is supplied, help will be printed+          -- for the currently evaluating term.+          | HelpFail  HelpFormat (Maybe String)++-- | A monad for values in the context of possibly failing with a helpful+-- message.+type Err a = Either Fail a++type Yield a = EvalInfo -> CmdLine -> Err a++-- | The underlying Applicative of the library.  A @Term@ represents a value+-- in the context of being computed from the command line arguments.+data Term a = Term [ArgInfo] (Yield a)++evalKind :: EvalInfo -> EvalKind+evalKind ei+  | choices ei == []               = Simple+  | fst (term ei) == fst (main ei) = Main+  | otherwise                      = Choice++descCompare :: Ord a => a -> a -> Ordering+descCompare = flip compare++splitOn sep xs = ( left, rest' )+  where+  rest' = if rest == [] then rest else tail rest -- Skip the 'sep'.+  ( left, rest ) = span (/= sep) xs
+ src/System/Console/CmdTheLine/Err.hs view
@@ -0,0 +1,116 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Err where++import System.Console.CmdTheLine.Common+import qualified System.Console.CmdTheLine.Help as H++import Text.PrettyPrint+import Data.List ( intersperse )++import System.IO++hsepMap :: (a -> Doc) -> [a] -> Doc+hsepMap f = hsep . map f++doc `leadBy` str = str $+$ nest 0 doc++errArgv     = text "argv array must have at least one element"+errNotOpt   = "Option argument without name"+errNotPos   = "Positional argument with a name"+errHelp doc = text "term error, help requested for unknown command" <+> doc+++alts []    = error "alts called on empty list"+alts [x]   = 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 kind s exp = hsep+  [ text "invalid", text kind, quotes s<>char ',', exp ]++invalidVal = invalid "value"++no kind s = sep [ text "no", quotes $ s, kind ]++notDir  s = quotes (s) <+> text "is not a directory"++isDir   s = quotes (s) <+> text "is a directory"++element kind str exp = fsep+  [ text "invalid element in", text kind, parens . quotes $ text str, exp ]++sepMiss sep str = invalidVal (text str) $+  hsep [ text "missing a", quotes $ char sep, text "separator" ]++unknown kind v = sep [ text "unknown", text kind, quotes $ text v ]++ambiguous kind s ambs = hsep+  [ text kind, quotes $ text s, text "ambiguous, could be", alts ambs ]++posExcess excess = text "too many arguments, don't know what to do with"+               <+> hsepMap prep excess+  where+  prep = (<> text ",") . quotes++flagValue f v = hsep+  [ text "option", quotes $ text f+  , text "is a flag, it cannot take the argument", quotes $ text v+  ]++optValueMissing f = hsep+  [ text "option", quotes $ text f, text "needs an argument" ]+optParseValue f e = sep [ text "option" <+> (quotes (text f)<>char ':'), e ]+optRepeated f f'+  | f == f' = hsep+    [ text "option", quotes $ text f, text "cannot be repeated" ]+  | otherwise         = hsep+    [ text "options", quotes $ text f, text "and", quotes $ text f'+    , text "cannot be present at the same time"+    ]++posParseValue :: ArgInfo -> Doc -> Doc+posParseValue ai e+  | argName ai == "" = e+  | otherwise        = case posKind ai of+    (PosN _ _) -> hsep [ name, arg, e ]+    _          -> hsep [ name<>text "...", arg, e ]+    where+    name = text $ argName ai+    arg  = text "arguments:"++argMissing :: ArgInfo -> Doc+argMissing ai+  | isOpt ai  = hsepMap text [ "required option", longName $ optNames ai ]+  | otherwise =+    if name == ""+       then text "a required argument is missing"+       else hsepMap text [ "required argument", name, "is missing" ]+    where+    name = argName ai++    longName (x : xs)+      | length x > 2 || xs == [] = x+      | otherwise                = longName xs++print :: Handle -> EvalInfo -> Doc -> IO ()+print h ei e = hPrint h $ (text . termName . fst $ main ei) <> char ':' <+> e++prepTryHelp :: EvalInfo -> String+prepTryHelp ei =+  if execName == mainName+     then concat [ "Try '", execName, " --help' for more information." ]+     else concat [ "Try '", execName, " --help' or '"+                 , mainName, " --help' for more information" ]+  where+  execName = H.invocation '-' ei+  mainName = termName . fst $ main ei++printUsage :: Handle -> EvalInfo -> Doc -> IO ()+printUsage h ei e = hPrint h $ sep+  [ text ((termName . fst $ main ei) ++ ":") <+> e+  , sep [ text "Usage:", text $ H.prepSynopsis ei ]+  , text $ prepTryHelp ei+  ]
+ src/System/Console/CmdTheLine/Help.hs view
@@ -0,0 +1,262 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Help where++import System.Console.CmdTheLine.Common+import qualified System.Console.CmdTheLine.Manpage as Man++import Control.Applicative+import Control.Arrow       ( first, second )++import Data.Char     ( toUpper, toLower )+import Data.List     ( intersperse, sort, sortBy, partition )+import Data.Function ( on )+import Data.Maybe    ( catMaybes )++import System.IO+++invocation :: Char -> EvalInfo -> String+invocation sep ei = case evalKind ei of+  Choice -> progName ++ [sep] ++ choiceName+  _      -> progName+  where+  progName   = termName . fst $ main ei+  choiceName = termName . fst $ term ei++title :: EvalInfo -> Title+title ei = ( invocName, 1, "", leftFooter, centerHeader )+  where+  invocName = map toUpper $ invocation '-' ei++  leftFooter = prog ++ ver+    where+    ver = case version . fst $ main ei of+      ""  -> ""+      str -> ' ' : str ++  centerHeader = prog ++ " Manual"++  prog = capitalize progName+    where+    capitalize = (:) <$> toUpper . head <*> drop 1+    progName   = termName . fst $ main ei++nameSection :: EvalInfo -> [ManBlock]+nameSection ei =+  [ S "NAME"+  , P $ invocation '-' ei ++ prep (termDoc . fst $ term ei)+  ]+  where+  prep "" = ""+  prep doc = " - " ++ doc++synopsis :: EvalInfo -> String+synopsis ei = case evalKind ei of+  Main   -> concat [ "$(b,", invocation ' ' ei, ") $(i,COMMAND) ..." ]+  _      -> concat [ "$(b,", invocation ' ' ei, ") [$(i,OPTION)]... ", args ]+  where+  args = concat . intersperse " " $ map snd args'+    where+    args' = sortBy revCmp . foldl formatPos [] . snd $ term ei++  formatPos acc ai+    | isOpt ai  = acc+    | otherwise = ( posKind ai, v'' ) : acc+    where+    v | argName ai == "" = "$(i,ARG)"+      | otherwise        = concat [ "$(i,", argName ai, ")" ]++    v' | absence ai == Absent = v+       | otherwise            = concat [ "[", v, "]" ]++    v'' = v' ++ followedBy++    followedBy = case posKind ai of+      PosN _ _ -> ""+      _        -> "..."++  revCmp ( p, _ ) ( p', _ ) = case ( p', p ) of+    ( _,             PosAny    ) -> LT+    ( PosAny,        _         ) -> GT+    ( PosL  _     _, PosR  _ _ ) -> LT+    ( PosR  _     _, PosL  _ _ ) -> GT+    ( p, p' ) -> bifurcate+    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++      | 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'++    getPos x = case x of+      PosL  _ pos -> pos+      PosR  _ pos -> pos+      PosN  _ pos -> pos++    getBool x = case x of+      PosL  b _ -> b+      PosR  b _ -> b+      PosN  b _ -> b++synopsisSection :: EvalInfo -> [ManBlock]+synopsisSection ei = [ S "SYNOPSIS", P (synopsis ei) ]++makeArgLabel :: ArgInfo -> String+makeArgLabel ai+  | isPos ai  = concat [ "$(i,", argName ai, ")" ]+  | otherwise = concat . intersperse ", " $ map (fmtName var) names+  where+  var | argName ai == "" = "VAL"+      | otherwise        = argName ai++  names = sort $ optNames ai++  fmtName var = case optKind ai of+    FlagKind   -> \ name -> concat [ "$(b,", name, ")" ]+    OptKind    -> mkOptMacro+    OptVal   _ -> mkOptValMacro+    where+    mkOptValMacro name = concat [ "$(b,", name, ")[", sep, "$(i,", var, ")]" ]+      where+      sep | length name > 2 = "="+          | otherwise       = ""++    mkOptMacro name = concat [ "$(b,", name, ")", sep, "$(i,", var, ")" ]+      where+      sep | length name > 2 = "="+          | otherwise       = " "++makeArgItems :: EvalInfo -> [( String, ManBlock )]+makeArgItems ei = map format xs+  where+  xs = sortBy revCmp . filter isArgItem . snd $ term ei++  isArgItem ai = not $ isPos ai && (argName ai == "" || argDoc ai == "")++  revCmp ai' ai = if secCmp /= EQ then secCmp else compare' ai ai'+    where+    secCmp = (compare `on` argSection) ai ai'++    compare' = case ( isOpt ai, isOpt ai' ) of+      ( True,  True  ) -> compare `on` key . optNames+      ( False, False ) -> compare `on` map toLower . argName+      ( True,  False ) -> const $ const LT+      ( False, True  ) -> const $ const GT++    key names+      | k !! 1 == '-' = drop 2 k+      | otherwise     = k+      where+      k = map toLower . head $ sortBy descCompare names++  format ai = ( argSection ai, I label text )+    where+    label = makeArgLabel ai ++ argvDoc+    text  = substDocName (argName ai) (argDoc ai)++    argvDoc = case ( absent, optvOpt ) of+      ( "", "" ) -> ""+      ( s,  "" ) -> concat [ " (", s, ")" ]+      ( "", s  ) -> concat [ " (", s, ")" ]+      ( s,  s' ) -> concat [ " (", s, ", ", s', ")" ]+++    absent = case absence ai of+      Absent     -> ""+      Present "" -> ""+      Present v  -> "absent=" ++ v++    optvOpt = case optKind ai of+      OptVal v -> "default=" ++ v+      _        -> ""++  substDocName argName =+    Man.substitute (const id) [( "argName", ("$(i," ++ argName ++ ")") )]++makeCmdItems :: EvalInfo -> [( String, ManBlock )]+makeCmdItems ei = case evalKind ei of+  Simple -> []+  Choice -> []+  Main   -> sortBy (descCompare `on` fst) . foldl addCmd [] $ choices ei+  where+  addCmd acc ( ti, _ ) = ( termSection 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+  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+                      in  S s' : result++  merge ( acc, secName ) ( secName', item )+    | secName == secName' = ( item : acc,             secName  )+    | otherwise           = ( item : S secName : acc, secName' )++mergeItems :: [( String, ManBlock )] -> [ManBlock]+           -> ( [( String, ManBlock )], [Maybe ManBlock] )+mergeItems items blocks = ( orphans, marked )+  where+  ( 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+    sec@(S _) -> transition sec+    t         -> ( Just t : acc, toInsert, mark, items )+    where+    transition sec@(S str) = ( acc', toInsert', mark', is' )+      where+      ( toInsert', is' ) = first (map snd) $ partition ((== str) . fst) items+      acc'               = Just sec : marked+      mark'              = str == "DESCRIPTION"++    marked = if mark then Nothing : acc' else acc'+      where+      acc' = map Just toInsert ++ acc++text :: EvalInfo -> [ManBlock]+text ei = mergeOrphans . mergeItems items . man . fst $ term ei+  where+  cmds  = makeCmdItems ei+  args  = makeArgItems ei+  cmp   = descCompare `on` fst+  items = sortBy cmp $ cmds ++ args++eiSubst ei =+  [ ( "tname", termName . fst $ term ei )+  , ( "mname", termName . fst $ main ei )+  ]++page :: EvalInfo -> ( Title, [ManBlock] )+page ei = ( title ei, nameSection ei ++ synopsisSection ei ++ text ei )++print :: HelpFormat -> Handle -> EvalInfo -> IO ()+print fmt h ei = Man.print (eiSubst ei) fmt h (page ei)++prepSynopsis :: EvalInfo -> String+prepSynopsis ei = escape $ synopsis ei+  where+  escape = Man.substitute Man.plainEsc $ eiSubst ei++printVersion :: Handle -> EvalInfo -> IO ()+printVersion h ei = case version . fst $ main ei of+  ""  -> error "printVersion called on EvalInfo without version"+  str -> hPutStrLn h str
+ src/System/Console/CmdTheLine/Manpage.hs view
@@ -0,0 +1,234 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Manpage where++import System.Console.CmdTheLine.Common++import Control.Applicative hiding ( (<|>), many, empty )++import System.Cmd         ( system )+import System.Environment ( getEnv, getProgName )+import System.Directory   ( findExecutable, getTemporaryDirectory, removeFile )+import System.Exit        ( ExitCode(..) )+import System.IO.Error    ( isDoesNotExistError )+import System.IO++import Control.Exception ( handle, throw, IOException, SomeException )++import Data.Maybe ( catMaybes )+import Data.Char  ( isSpace )+import Data.List  ( subsequences, words )++import Text.Parsec+import Text.PrettyPrint hiding ( char )++type Subst = [( String, String )] -- An association list of+                                  -- ( replacing, replacement ) pairs.++paragraphIndent = 7+labelIndent     = 4++mkPrepTokens :: Bool -> String -> String+mkPrepTokens roff = either (error . ("printTokens: "++) . show) id+                  . parse process ""+  where+  process      = concat <$> many (squashSpaces <|> dash <|> otherChars) +  squashSpaces = many1 Text.Parsec.space >> return " "+  dash         = char '-' >> if roff then return "\\-" else return "-"+  otherChars   = many1 $ satisfy (\ x -> not $ isSpace x || x == '-')++-- `subsitute assoc input` where `assoc` is an association list of+-- `( replacing, replacement )` pairs.  Replaces all occurances of+-- `"$(" ++ replacing ++ ")"` in `input` with `replacement`.+--+-- TODO: return `Either String String` and produce more informative errors+-- downstream.+substitute :: (Char -> String -> String) -> Subst -> String -> String+substitute esc assoc = either (error . show) id . parse subst ""+  where+  subst = fmap concat scan++  scan = many $ try (string "\\$") <|> try replace <|> pure <$> anyChar++  replace = do+    string "$("+    replacement <- try escape <|> choice replacers <|> safeChars+    char ')'+    return replacement++  escape = do+    c <- anyChar+    char ','+    str <- try replace <|> safeChars+    return $ esc c str++  safeChars = many1 $ satisfy (/= ')')++  replacers = map mkReplacer assoc+  mkReplacer ( replacing, replacement ) = replacement <$ string replacing+++--+-- Plain text output+--++plainEsc :: Char -> String -> String+plainEsc 'g' _   = ""+plainEsc _   str = str++prepPlainBlocks :: Subst -> [ManBlock] -> String+prepPlainBlocks subst = show . go empty+  where+  escape     = substitute plainEsc subst+  prepTokens = mkPrepTokens False . escape++  pFill = fsep . map text . words++  go :: Doc -> [ManBlock] -> Doc+  go acc []             = acc+  go acc (block : rest) = go acc' rest+    where+    acc' = case block of+      NoBlank     -> acc+      P str       -> acc $+$ nest paragraphIndent (pFill $ prepTokens str)+                         $+$ text ""+      S str       -> acc $+$ text (prepTokens str)+      I label str -> prepLabel label str++    prepLabel label str =+      acc $+$ nest paragraphIndent (text $ prepTokens label')+       `juxt` content+          $+$ text ""+      where+      juxt -- juxtapose+        | ll < labelIndent = (<+>)+        | otherwise        = ($$)++      content+        | str == ""        = empty+        | ll < labelIndent = doc (labelIndent - ll)+        | otherwise        = doc (paragraphIndent + labelIndent)++      doc n  = nest n (pFill $ prepTokens str)+      label' = escape label+      ll     = length label'++printPlainPage :: Subst -> Handle -> Page -> IO ()+printPlainPage subst h ( _, blocks ) =+  hPutStrLn h $ prepPlainBlocks subst blocks+++--+-- Groff output+--++groffEsc :: Char -> String -> String+groffEsc c str = case c of+ 'i' -> "\\fI" ++ str ++ "\\fR"+ 'b' -> "\\fB" ++ str ++ "\\fR"+ 'p' -> ""+ _   -> str++prepGroffBlocks :: Subst -> [ManBlock] -> String+prepGroffBlocks subst blocks = prep =<< blocks+  where+  escape     = substitute groffEsc subst+  prepTokens = mkPrepTokens True . escape+  prep block = case block of+    P str       -> "\n.P\n" ++ prepTokens str+    S str       -> "\n.SH " ++ prepTokens str+    I label str -> "\n.TP 4\n" ++ prepTokens label ++ "\n" ++ prepTokens str+    NoBlank     -> "\n.sp -1"++printGroffPage :: Subst -> Handle -> Page -> IO ()+printGroffPage subst h page = hPutStr h $ unlines+  [ ".\\\" Pipe this output to groff -man -Tascii | less"+  , ".\\\""+  , concat [ ".TH \"", n, "\" ", show s+           , " \"", a1, "\" \"", a2, "\" \"", a3, "\"" ]+  , ".\\\" Disable hyphenation and ragged-right"+  , ".nh"+  , ".ad l" ++ prepGroffBlocks subst blocks+  ]+  where+  ( ( n, s, a1, a2, a3 ), blocks ) = page+++--+-- Pager output+--++printToTempFile :: (Handle -> Page -> IO ()) -> Page+                -> IO (Maybe String)+printToTempFile print v = handle handler $ do+  progName <- getProgName+  tempDir  <- getTemporaryDirectory++  let fileName = tempDir ++ "/" ++ progName ++ ".out"++  h        <- openFile fileName ReadWriteMode++  print h v+  hFlush h++  return $ Just fileName+  where+  handler :: SomeException -> IO (Maybe String)+  handler = const $ return Nothing++printToPager :: (HelpFormat -> Handle -> Page -> IO ())+             -> Handle -> Page -> IO ()+printToPager print h page = do+  pagers <- do+    name <- handle handler $ pure <$> getEnv "PAGER"++    return $ name ++ [ "less", "more" ]+  +  found <- catMaybes <$> mapM findExecutable pagers++  case found of+    []        -> print Plain h page+    pager : _ -> do+      roffs <- catMaybes <$> mapM findExecutable [ "groff", "nroff" ]++      mCmd <- case roffs of+        []       -> (fmap . fmap) (naked pager)+                  $ printToTempFile (print Plain) page++        roff : _ -> (fmap . fmap) (preped roff pager)+                  $ printToTempFile (print Groff) page++      case mCmd of+        Nothing               -> print Plain h page+        Just ( cmd, tmpFile ) -> do+          exitStatus <- system cmd+          case exitStatus of+            ExitSuccess   -> return ()+            ExitFailure _ -> print Plain h page+          removeFile tmpFile+  where+  preped roff pager tmpFile = ( cmd, tmpFile )+    where+    cmd = concat [ roff, " -man -Tascii < ", tmpFile, " | ", pager ]++  naked pager tmpFile = ( cmd, tmpFile )+    where+    cmd = pager ++ " < " ++ tmpFile++  handler :: IOException -> IO [String]+  handler e+    | isDoesNotExistError e = return []+    | otherwise             = throw e+++--+-- Interface+--++print :: Subst -> HelpFormat -> Handle -> Page -> IO ()+print subst fmt = case fmt of+  Pager -> printToPager   (System.Console.CmdTheLine.Manpage.print subst)+  Plain -> printPlainPage subst+  Groff -> printGroffPage subst
+ src/System/Console/CmdTheLine/Term.hs view
@@ -0,0 +1,271 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Term+  (+  -- * Evaluating Terms+  -- ** Simple command line programs+    eval, exec, run++  -- ** Multi-command command line programs+  , evalChoice, execChoice, runChoice+  ) where++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 Data.List    ( find, sort )+import Data.Maybe   ( fromJust )++import System.Environment ( getArgs )+import System.Exit        ( exitFailure )+import System.IO++import Text.PrettyPrint+import Text.Parsec+++--+-- EvalErr+--++data EvalFail = Help  HelpFormat (Maybe String)+              | Usage Doc+              | Msg   Doc+              | Version++type EvalErr = Either EvalFail++fromFail :: Fail -> EvalErr a+fromFail (MsgFail   d)         = Left $ Msg   d+fromFail (UsageFail d)         = Left $ Usage d+fromFail (HelpFail  fmt mName) = Left $ Help  fmt mName++fromErr :: Err a -> EvalErr a+fromErr = either fromFail return++printEvalErr :: EvalInfo -> EvalFail -> IO ()+printEvalErr ei fail = case fail of+  Usage doc -> do E.printUsage   stderr ei doc+                  exitFailure+  Msg   doc -> do E.print        stderr ei doc+                  exitFailure+  Version   -> H.printVersion stdout ei+  Help fmt mName -> either print (H.print fmt stdout) (eEi mName)+  where+  -- Either we are in the default term, or the commands name is in `mName`.+  eEi = maybe (Right ei { term = main ei }) process++  -- Either the command name exists, or else it does not and we're in trouble.+  process name = do+    cmd' <- case find (\ ( i, _ ) -> termName i == name) (choices ei) of+      Just x  -> Right x+      Nothing -> Left  $ E.errHelp (text name)+    return ei { term = cmd' } +++--+-- 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 [] (\ _ _ -> Right 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+  parser = enum [ ( "pager", Pager )+                , ( "plain", Plain )+                , ( "groff", Groff )+                ]++  pp Pager = text "pager"+  pp Plain = text "plain"+  pp Groff = text "groff"++instance ArgVal (Maybe HelpFormat) where+  parser = just++  pp = maybePP++addStdOpts :: EvalInfo -> ( Yield (Maybe HelpFormat)+                          , Maybe (Yield Bool)+                          , EvalInfo+                          )+addStdOpts ei = ( hLookup, vLookup, ei' )+  where+  ( args, vLookup ) = case version . fst $ main ei of+    "" -> ( [],  Nothing )+    _  -> ( ais, Just lookup )+    where+    Term ais lookup = flag (optInfo ["version"])+                    { argSection = section+                    , argDoc     = "Show version information."+                    }++  ( args', hLookup ) = ( ais ++ args, lookup )+    where+    Term ais lookup = defaultOpt (Just Pager) Nothing (optInfo ["help"])+                    { argSection = section+                    , argName    = "FMT"+                    , argDoc     = doc+                    }++  section = stdOptSection . fst $ term ei+  doc     = "Show this help in format $(argName) (pager, plain, or groff)."++  addArgs = second (args' ++)+  ei'     = ei { term = addArgs $ term ei+               , main = addArgs $ main ei+               , choices = map addArgs $ choices ei+               }+++--+-- Evaluation of Terms+--++evalTerm :: EvalInfo -> Yield a -> [String] -> IO a+evalTerm ei yield args = either handleErr return $ do+  ( cl, mResult ) <- fromErr $ do+    cl      <- create (snd $ term ei') args+    mResult <- helpArg ei' cl++    return ( cl, mResult )++  let success = fromErr $ yield ei' cl++  case ( mResult, versionArg ) of+    ( Just fmt, _         ) -> Left $ Help fmt mName+    ( Nothing,  Just vArg ) -> case vArg ei' cl of+                                    Left  e     -> fromFail e+                                    Right True  -> Left Version+                                    Right False -> success+    _                       -> success+  where+  ( helpArg, versionArg, ei' ) = addStdOpts ei++  mName = if defName == evalName+             then Nothing+             else Just evalName++  defName  = termName . fst $ main ei'+  evalName = termName . fst $ term ei'++  handleErr e = do printEvalErr ei' e+                   exitFailure+++chooseTerm :: TermInfo -> [( TermInfo, a )] -> [String]+           -> Err ( TermInfo, [String] )+chooseTerm ti _       []              = Right ( ti, [] )+chooseTerm ti choices args@( arg : rest )+  | length arg > 1 && head arg == '-' = Right ( ti, args )++  | otherwise = case T.lookup arg index of+    Right choice      -> Right ( choice, rest )+    Left  T.NotFound  -> Left . UsageFail $ E.unknown   com arg+    Left  T.Ambiguous -> Left . UsageFail $ E.ambiguous com arg ambs+    where+    index = foldl add T.empty choices+    add acc ( choice, _ ) = T.add acc (termName choice) choice++    com  = "command"+    ambs = sort $ T.ambiguities index arg++mkCommand :: ( Term a, TermInfo ) -> Command+mkCommand ( Term ais _, ti ) = ( ti, ais )+ +-- Prep an EvalInfo suitable for catching errors raised by 'chooseTerm'.+chooseTermEi :: ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> EvalInfo+chooseTermEi mainTerm choices = EvalInfo command command eiChoices+  where+  command   = mkCommand mainTerm+  eiChoices = map mkCommand choices+++--+-- User-Facing Functionality+--++-- | 'eval' @args ( term, termInfo )@ allows the user to pass @args@ directly to+-- the evaluation mechanism.  This is useful if some kind of pre-processing is+-- required.  If you do not need to pre-process command line arguments, use one+-- of 'exec' or 'run'.  On failure the program exits.+eval :: [String] -> ( Term a, TermInfo ) -> IO a+eval args termPair@( term, _ ) = evalTerm ei yield args+  where+  (Term _ yield) = term+  command = mkCommand termPair+  ei = EvalInfo command command []++-- | 'exec' @( term, termInfo )@ executes a command line program, directly+-- grabbing the command line arguments from the environment and returning the+-- result upon successful evaluation of @term@.  On failure the program exits.+exec :: ( Term a, TermInfo ) -> IO a+exec term = do+  args <- getArgs+  eval args term++-- | 'run' @( term, termInfo )@ runs a @term@ containing an 'IO' action,+-- performs the action, and returns the result on success. On failure the+-- program exits.+run :: ( Term (IO a), TermInfo ) -> IO a+run term = do+  action <- exec term+  action++-- | 'evalChoice' @args mainTerm choices@ is analogous to 'eval', but for+-- programs that provide a choice of commands.+evalChoice :: [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO a+evalChoice args mainTerm@( term, termInfo ) choices = do+  ( chosen, args' ) <- either handleErr return . fromErr+                     $ chooseTerm termInfo eiChoices args++  let (Term ais yield) = fst . fromJust . find ((== chosen) . snd)+                       $ mainTerm : choices++      ei = EvalInfo ( chosen, ais ) mainEi eiChoices++  evalTerm ei yield args'+  where+  mainEi    = mkCommand mainTerm+  eiChoices = map mkCommand choices++  -- Only handles errors caused by chooseTerm.+  handleErr e = do printEvalErr (chooseTermEi mainTerm choices) e+                   exitFailure++-- | Analogous to 'exec', but for programs that provide a choice of commands.+execChoice :: ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO a+execChoice main choices = do+  args <- getArgs+  evalChoice args main choices++-- | Analogous to 'run', but for programs that provide a choice of commands.+runChoice :: ( Term (IO a), TermInfo ) -> [( Term (IO a), TermInfo )] -> IO a+runChoice main choices = do+  action <- execChoice main choices+  action
+ src/System/Console/CmdTheLine/Trie.hs view
@@ -0,0 +1,101 @@+{- Copyright © 2012, Vincent Elisha Lee Frey.  All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Trie where++import qualified Data.Map as M++{-+ - This implementation maps any non-ambiguous prefix of a key to its value.+ -}++type CMap = M.Map Char++data Value a = Pre a -- Value bound by a prefix key.+             | 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)++data Trie a = Trie+  { val   :: Value a+  , succs :: CMap (Trie a)+  } deriving (Eq)++data LookupFail = Ambiguous | NotFound deriving (Show)++empty :: Trie a+empty = Trie Nil M.empty++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. -})+  where+  go t k len i v preV =+    if i == len+       then Trie (Key v) (succs t)+       else Trie newVal  newSuccs+    where+    newVal = case val t of+      Amb       -> Amb+      Pre _     -> Amb+      v@(Key _) -> v+      Nil       -> preV++    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)++findNode :: String -> Trie a -> Maybe (Trie a)+findNode k t = go t k (length k) 0+  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)+++lookup :: String -> Trie a -> Either LookupFail a+lookup k t = case findNode k t of+  Nothing -> Left NotFound+  Just t' -> case val t' of+    Key v -> Right v+    Pre v -> Right v+    Amb   -> Left  Ambiguous+    Nil   -> Left  NotFound++ambiguities :: Trie a -> String -> [String]+ambiguities t pre = case findNode pre t of+  Nothing -> []+  Just t' -> case val t' of+    Amb -> go [] pre $ M.toList (succs t') : []+    _   -> []++  where+  go acc pre assocs = case assocs of+    []        -> error "saw lone empty list while searching for ambiguities"+    [[]]      -> acc+    [] : rest -> go acc (init pre) rest+    _         -> descend assocs+    where+    descend ((top : bottom) : rest) = go acc' pre' assocs'+      where+      ( c, t'' ) = top++      assocs'    = M.toList (succs t'') : bottom : rest++      pre'       = pre ++ return c+      acc'       = case val t'' of+        Key _ -> pre' : acc+        Nil   -> error "saw Nil on descent"+        _     -> acc++fromList :: [( String, a )] -> Trie a+fromList assoc = foldl consume empty assoc+  where+  consume t ( k, v ) = add t k v