cmdtheline 0.1.0.1 → 0.1.1
raw patch · 6 files changed
+208/−197 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- README.md +13/−0
- cmdtheline.cabal +1/−1
- doc/examples/arith.hs +190/−0
- doc/examples/poly.hs +0/−189
- src/System/Console/CmdTheLine/CmdLine.hs +1/−1
- src/System/Console/CmdTheLine/Term.hs +3/−6
README.md view
@@ -26,6 +26,19 @@ Please report bugs to the [issue tracker](http://github.com/eli-frey/cmdtheline/issues). ++Branches+--------++###master+The currently stable branch.++###dev+Bug fixes and aditions that don't break compatibility with master.++###0.2+The next release candidate.+ LICENSE ------- MIT - See file 'LICENSE' for details.
cmdtheline.cabal view
@@ -1,5 +1,5 @@ Name: cmdtheline-Version: 0.1.0.1+Version: 0.1.1 Synopsis: Declaritive command-line option parsing and documentation library. Description: CmdTheLine aims to remove tedium from the definition of command-line
+ doc/examples/arith.hs view
@@ -0,0 +1,190 @@+-- 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 '-'++arith :: Bool -> [( String, Exp )] -> Exp -> IO ()+arith 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 "arith: bad environment"++arithTerm = ( arith <$> 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 = "arith"+ , version = "0.3"+ , termDoc = "Evaluate mathematical functions demonstrating precedence "+ ++ "climbing and instantiating 'ArgVal' for tuples and Parsec "+ ++ "parsers."+ , man = [ S "BUGS"+ , P "Email bug reports to <fitsCarolDo@example.com>"+ ]+ }++main = run arithTerm
− doc/examples/poly.hs
@@ -1,189 +0,0 @@--- 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/CmdLine.hs view
@@ -77,7 +77,7 @@ -} parseArgs :: T.Trie ArgInfo -> CmdLine -> [String] -> Err ( CmdLine, [String] )-parseArgs optTrie cl args = second (reverse . (++ rest)) <$> go 1 cl [] args+parseArgs optTrie cl args = second ((++ rest) . reverse) <$> go 1 cl [] args' where -- Everything after '"--"' is a position argument. ( args', rest ) = splitOn "--" args
src/System/Console/CmdTheLine/Term.hs view
@@ -22,6 +22,7 @@ import Control.Applicative hiding ( (<|>), empty ) import Control.Arrow ( second )+import Control.Monad ( join ) import Data.List ( find, sort ) import Data.Maybe ( fromJust )@@ -233,9 +234,7 @@ -- 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+run = join . exec -- | 'evalChoice' @args mainTerm choices@ is analogous to 'eval', but for -- programs that provide a choice of commands.@@ -266,6 +265,4 @@ -- | 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+runChoice main = join . execChoice main