diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cmdtheline.cabal b/cmdtheline.cabal new file mode 100644 --- /dev/null +++ b/cmdtheline.cabal @@ -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 + 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 . + + +Homepage: http://github.com/eli-frey/cmdtheline +License: MIT +License-file: LICENSE +Author: Eli Frey +Maintainer: Eli Frey +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 diff --git a/doc/examples/FizzBuzz.hs b/doc/examples/FizzBuzz.hs new file mode 100644 --- /dev/null +++ b/doc/examples/FizzBuzz.hs @@ -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 " + ] + } + +main = run ( term, termInfo ) diff --git a/doc/examples/cipher.hs b/doc/examples/cipher.hs new file mode 100644 --- /dev/null +++ b/doc/examples/cipher.hs @@ -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 " + ] + , 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 ] diff --git a/doc/examples/cp.hs b/doc/examples/cp.hs new file mode 100644 --- /dev/null +++ b/doc/examples/cp.hs @@ -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 " + ] + } + +main = run ( cpTerm, termInfo ) diff --git a/doc/examples/fail.hs b/doc/examples/fail.hs new file mode 100644 --- /dev/null +++ b/doc/examples/fail.hs @@ -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 " + ] + } + +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 diff --git a/doc/examples/grep.hs b/doc/examples/grep.hs new file mode 100644 --- /dev/null +++ b/doc/examples/grep.hs @@ -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 " + ] + } + +main = run grepTerm diff --git a/doc/examples/hello.hs b/doc/examples/hello.hs new file mode 100644 --- /dev/null +++ b/doc/examples/hello.hs @@ -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 ) diff --git a/doc/examples/poly.hs b/doc/examples/poly.hs new file mode 100644 --- /dev/null +++ b/doc/examples/poly.hs @@ -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 '-' 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 +-- 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 '=' 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 " + ] + } + +main = run polyTerm diff --git a/src/System/Console/CmdTheLine.hs b/src/System/Console/CmdTheLine.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine.hs @@ -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 + 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 + . + +> 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 diff --git a/src/System/Console/CmdTheLine/Arg.hs b/src/System/Console/CmdTheLine/Arg.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Arg.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/ArgVal.hs b/src/System/Console/CmdTheLine/ArgVal.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/ArgVal.hs @@ -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 ' % '" + + pp = rational + +instance ArgVal (Maybe (Ratio Integer)) where + parser = just + pp = maybePP diff --git a/src/System/Console/CmdTheLine/CmdLine.hs b/src/System/Console/CmdTheLine/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/CmdLine.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Common.hs b/src/System/Console/CmdTheLine/Common.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Common.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Err.hs b/src/System/Console/CmdTheLine/Err.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Err.hs @@ -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 + ] diff --git a/src/System/Console/CmdTheLine/Help.hs b/src/System/Console/CmdTheLine/Help.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Help.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Manpage.hs b/src/System/Console/CmdTheLine/Manpage.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Manpage.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Term.hs b/src/System/Console/CmdTheLine/Term.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Term.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Trie.hs b/src/System/Console/CmdTheLine/Trie.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Trie.hs @@ -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