clac 0.4.0 → 0.5.0
raw patch · 6 files changed
+460/−162 lines, 6 filesdep +dspdep ~plailude
Dependencies added: dsp
Dependency ranges changed: plailude
Files
- clac.cabal +8/−5
- src-exec/clac.hs +7/−157
- src/Clac/CliParser.hs +56/−0
- src/Clac/IO.hs +159/−0
- src/Clac/REPL.hs +72/−0
- src/Clac/Stack.hs +158/−0
clac.cabal view
@@ -1,5 +1,5 @@ name: clac-version: 0.4.0+version: 0.5.0 synopsis: Simple CLI RPN calculator description: Simple CLI RPN calculator. license: GPL-3@@ -13,15 +13,18 @@ executable clac main-is: clac.hs+ other-modules: Clac.CliParser+ Clac.IO+ Clac.REPL+ Clac.Stack other-extensions: GADTs- RankNTypes- StandaloneDeriving build-depends: base >=4.7 && <4.8, containers >=0.5 && <0.6,+ dsp >=0.2 && <0.3, optparse-applicative >=0.11 && <0.12,- plailude >=0.5 && <0.6,+ plailude >=0.6 && <0.7, pretty-tree >=0.1 && <0.2, safe >=0.3 && <0.4, split >=0.2 && <0.3- hs-source-dirs: src-exec+ hs-source-dirs: src src-exec default-language: Haskell2010
src-exec/clac.hs view
@@ -1,10 +1,6 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}- {- | Module : $Header$-Description: clac.+Description: The main entry point for clac. Copyright : (c) Alexander Berntsen 2015 License : GPL-3 @@ -13,179 +9,33 @@ import Control.Applicative (- (<$>),- (<|>), (<*>), )-import Control.Arrow- (- second,- )-import Control.Monad- (- when,- )-import Data.List- (- find,- )-import Data.List.Split- (- splitOn,- ) import Data.Monoid ( (<>),- mempty, )-import Data.Tree- (- Tree (Node),- Forest,- )-import Data.Tree.Pretty- (- drawVerticalTree,- ) import Options.Applicative (- Parser, execParser, fullDesc, header,- help, helper, info,- long,- many, progDesc,- short,- strArgument,- switch, )-import Safe++import Clac.CliParser (- readMay,+ ops, )-import System.IO+import Clac.IO (- hFlush,- stdout,+ calc ) -import Plailude---data Opt = MkOpt {h :: Bool- ,v :: Bool- ,e :: [String]- }--data StackItem a where- Snum :: forall a. Fractional a => a -> StackItem a- Sop :: OpDesc -> StackItem a-deriving instance Show a => Show (StackItem a)--data OpDesc = Dop {op :: Op- ,desc :: String- }-instance Show OpDesc where- show (Dop _ a) = a--data Op where- Bop :: (forall a. Floating a => a -> a -> a) -> Op- Uop :: (forall a. Floating a => a -> a) -> Op- C :: (forall a. Floating a => a) -> Op- Neq :: Op--ops :: Parser Opt-ops = MkOpt <$> switch ( long "operations"- <> short 'o'- <> help "Print all operations" )- <*> switch ( long "verbose"- <> short 'v'- <> help "Verbose output" )- <*> many (strArgument mempty)--os :: [(OpDesc, String)]-os = [( Dop (Bop (+)) "+", "+:\t\taddition" )- ,( Dop (Bop (-)) "-", "-:\t\tsubtraction" )- ,( Dop (Bop (*)) "*", "*:\t\tmultiplication" )- ,( Dop (Bop (*)) "x", "*:\t\tmultiplication" )- ,( Dop (Bop (/)) "/", "/:\t\tdivision" )- ,( Dop (Bop (**)) "^", "^:\t\tpower of" )- ,( Dop (Bop logBase) "log-n", "log-n:\t\tlog-n: log rhs / log lhs" )- ,( Dop (Uop negate) "neg", "neg:\t\tnegation" )- ,( Dop (Uop abs) "abs", "abs:\t\tabsolute value" )- ,( Dop (Uop log) "ln", "ln:\t\tnatural logarithm" )- ,( Dop (Uop $ logBase 10) "lg", "ln:\t\tcommon logarithm" )- ,( Dop (Uop sin) "sin", "sin:\t\tsine function" )- ,( Dop (Uop cos) "cos", "cos:\t\tcosine function" )- ,( Dop (Uop tan) "tan", "tan:\t\ttangent function" )- ,( Dop (Uop asin) "asin", "asine:\t\tarcsine function" )- ,( Dop (Uop acos) "acos", "acosine:\tarccosine function" )- ,( Dop (Uop atan) "atan", "arctan:\t\tarctangent function" )- ,( Dop (Uop sqrt) "sqrt", "sqrt:\t\tsquare root function" )- ,( Dop (C pi) "pi", "pi:\t\tpi constant" )- ,( Dop Neq ",", ",:\t\tstart a new equation" )- ]--b :: String -> [StackItem Double] -> [StackItem Double]-b x ac = case p x of- Just q -> q:ac- Nothing -> ac--p :: String -> Maybe (StackItem Double)-p i = (Sop <$> find ((== i) . desc) (fst <$> os))- <|> Snum <$> (readMay i :: Maybe Double)--t :: Show a => [StackItem a] -> Forest String -> Tree String-t (Sop (Dop (Bop _) o):ss) (n:m:ts) = t ss (Node o [m, n]:ts)-t (Sop (Dop (Uop _) o):ss) (m:ts) = t ss (Node o [m]:ts)-t (Sop (Dop (C _) c):ss) ts = t ss (Node c []:ts)-t (Snum n:ss) ts = t ss (Node (show n) []:ts)-t [] (n:_) = n-t _ _ = Node "¯\\_(ツ)_/¯" []--s :: Floating a => [StackItem a] -> [StackItem a] -> Maybe a-s (Sop (Dop (Bop o) _):ss) (Snum n:Snum m:ts) = s ss (Snum (m `o` n):ts)-s (Sop (Dop (Uop o) _):ss) (Snum m:ts) = s ss (Snum (o m):ts)-s (Sop (Dop (C c) _):ss) ts = s ss (Snum c:ts)-s (n:ss) ts = s ss (n:ts)-s [] (Snum n:_) = Just n-s _ _ = Nothing--sa :: [[String]] -> [(Maybe Double, String)]-sa = map $ (second drawVerticalTree . (((,) . (`s` []))- <*> (`t` []))) . foldr b []--f :: Show a => Opt -> [(a, String)] -> IO ()-f o = mapM_ (\(solution, tree) -> do- when (v o) $ putStrLn $ "\n\n" ++ tree- print solution- putStrLn $ replicate (length $ show solution) '=')--repl :: Opt -> IO a-repl o = do- putStr ">"- hFlush stdout- l <- getLine- f o . sa . splitOn [","] . words $ l- repl o--clac :: Opt -> [[String]] -> IO ()-clac o [[]] = repl o- ~+~ (getContents >>= \cs -> clac o (splitOn [","] . words $ cs))-clac o es = f o . sa $ es--calc :: Opt -> IO ()-calc o = if h o- then mapM_ putStrLn $ "OPERATORS":"=========":map snd os- else clac o $ splitOn [","] $ case e o of- [a] -> words a- _ -> e o- main :: IO ()+-- | Parse the command line options, and start clac with 'calc'. main = execParser o >>= calc where o = info (helper <*> ops) ( fullDesc <> progDesc "simple CLI RPN calculator"
+ src/Clac/CliParser.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs #-}++{- |+Module : $Header$+Description: Command line parser options.+Copyright : (c) Alexander Berntsen 2015+License : GPL-3++Maintainer : alexander@plaimi.net+-} module Clac.CliParser where++import Control.Applicative+ (+ (<$>),+ (<*>),+ )+import Data.Monoid+ (+ (<>),+ mempty,+ )+import Options.Applicative+ (+ Parser,+ help,+ long,+ many,+ short,+ strArgument,+ switch,+ )++-- | The command line options for clac. 'h' is whether the user wants help.+-- 'r' is whether the user wants to print the repl help. 'v' is whether the+-- user wants verbose mode. Everything else is attempted parsed as an+-- equation.+data Opt where+ MkOpt :: {h :: Bool+ ,r :: Bool+ ,v :: Bool+ ,e :: [String]+ }+ -> Opt++ops :: Parser Opt+-- | The parser for the line options for clac.+ops = MkOpt <$> switch ( long "operations"+ <> short 'o'+ <> help "Print all operations" )+ <*> switch ( long "repl operations"+ <> short 'r'+ <> help "Print repl operations" )+ <*> switch ( long "verbose"+ <> short 'v'+ <> help "Verbose output" )+ <*> many (strArgument mempty)
+ src/Clac/IO.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++{- |+Module : $Header$+Description: IO Operations for clac.+Copyright : (c) Alexander Berntsen 2015+License : GPL-3++Maintainer : alexander@plaimi.net+-} module Clac.IO where++import Control.Applicative+ (+ (<$>),+ )+import Control.Monad+ (+ when,+ )+import Data.List.Split+ (+ splitOn,+ )+import Data.Maybe+ (+ mapMaybe,+ )+import System.IO+ (+ hFlush,+ stdout,+ )++import Plailude++import Clac.CliParser+ (+ Opt,+ e,+ h,+ r,+ v,+ )+import Clac.REPL+ (+ inlet,+ repAns,+ repLets,+ unlet,+ )+import Clac.Stack+ (+ os,+ sa,+ )++f :: Show a => Opt -> [(a, String)] -> IO ()+-- | Formats an answer and optionally (if the verbose option is set) its+-- answer tree for printing. Puts '='s under the answer.+f o = mapM_ (\(solution, tree) -> do+ when (v o) $ putStrLn $ "\n\n" ++ tree+ print solution+ putStrLn $ replicate (length $ show solution) '=')++repl :: (Floating a, Real a, Read a, Show a)+ => Opt -> [(String, String)] -> [a] -> IO b+-- | Run a REPL (Read-Evaluate-Print-Loop).+--+-- Prompts the user for input, solves it with 'sa' after checking if there+-- were multiple equations per the 'Neq' operator, and prints it using 'f'.+-- Prints an answer tree if the verbose option is activated.+--+-- > 1 1 + , 2 2 + -- this is turned into [["1","1","+"],["2","2","+"]]+--+-- There is a let stack. The user may add things to the let stack with #let.+-- The stack may be printed with #lets. Variables may also be unlet with+-- #unlet and #unletall.+--+-- > #let a = 1 -- the let stack is now [("a", "1")], i.e. a bound to 1+-- > #let b = 2 -- the let stack is now [("b","2"),("a","1")]+-- > #let c = 3 -- the let stack is now [("c","3"),("b","2"),("a","1")]+-- > #lets -- prints [("c","3"),("b","2"),("a","1")]+-- > #unlet a -- the let stack is now [("c","3"),("b","2")]+-- > #unletall -- the stack is now empty+--+-- 'repl' runs 'repLets' to reduce an application of a variable bound by let+-- with its value.+--+-- > #let a = 1+-- > a a + -- this is turned into [["1","1","+"]]+--+-- There is an ans stack. Every answer is added to this automatically. The ans+-- function lets the user use these answers. #ans prints the stack.+--+-- > 1 -- ans stack is now [1.0]+-- > 0 ans -- this is turned into [["1"]]+-- > #ans -- prints [1.0]+repl o lets ans = do+ putStr ">"+ hFlush stdout+ l <- words <$> getLine+ case l of+ ("#ans":_) -> print ans >> repl o lets ans+ ("#lets":_) -> print lets >> repl o lets ans+ ["#let", x, "=", y] -> repl o (inlet x y lets) ans+ ["#unlet", x] -> repl o (unlet x lets) ans+ ("#unletall":_) -> repl o [] ans+ _ -> do+ let ss = sa . splitOn [","] . repAns ans . repLets lets $ l+ f o ss+ repl o lets (mapMaybe fst ss ++ ans)++clac :: Opt -> [[String]] -> IO ()+-- | Run the calculator.+--+-- If an equation is given as an argument to the program, it is solved with+-- 'sa', and formatted and printed by 'f'.+--+-- > $ clac 1 1 ++-- > Just 2.0+-- > ========+--+-- If there is STDIN waiting, 'clac' calls itself with the equation in STDIN+-- as an argument.+--+-- > $ echo 1 1 + | clac+-- > Just 2.0+-- > ========+--+-- If there is there is nothing to solve, it starts the REPL with 'repl'.+--+-- > $ clac+-- > >+--+-- The REPL should be started with GNU rlwrap or similar software for an+-- optimal experience.+--+-- > $ rlwrap clac+-- > >+clac o [[]] = repl o [] []+ ~+~ (getContents >>= \cs -> clac o (splitOn [","] . words $ cs))+clac o es = f o . sa $ es++calc :: Opt -> IO ()+-- | Check what flags the user has given, if any, and run the program+-- accordingly. Prints various help output, or runs the calculator with+-- 'clac'.+calc o | h o = mapM_ putStrLn $ "OPERATORS":"=========":map snd os+ | r o = mapM_ putStrLn ["REPL OPERATIONS","==============="+ ,"#lets:\tprint the let stack"+ ,"#unletall:\tempty the let stack"+ ,"#let:\t#'let a = b', bind a to b"+ ,"#unlet:\t'#unlet v', remove the let binding v"+ ,"#ans:\tprint the answer stack"+ ,"ans:\tanswer operator, use the n-th last ans"+ ]+ | otherwise = clac o $ splitOn [","] $ case e o of+ [a] -> words a+ _ -> e o
+ src/Clac/REPL.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++{- |+Module : $Header$+Description: Functions for clac's Read-Evaluate-Print-Loop.+Copyright : (c) Alexander Berntsen 2015+License : GPL-3++Maintainer : alexander@plaimi.net+-} module Clac.REPL where++import Safe+ (+ readMay,+ )++import Plailude++inlet :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+-- | Insert a let into the given stack of lets. If the variable is already+-- bound, update it by 'unlet'ing it first, and then let it.+--+-- > #let a = 1 -- stack is [("a","1")], i.e. a bound to 1+-- > #let a = 2 -- stack is [("a","2")]+inlet k n ls = case lookup k ls of+ Just _ -> (k, n) : unlet k ls+ Nothing -> (k, n) : ls++unlet :: Eq a => a -> [(a, b)] -> [(a, b)]+-- | Remove a let binding from the given stack of lets. Noop if there's+-- nothing to unlet.+--+-- > #let a = 1 -- stack is [("a", "1")], i.e. a bound to 1+-- > #let b = 2 -- stack is [("b","2"),("a", "1")]+-- > #unlet a -- stack is [("b","2")]+unlet k = go []+ where go u [] = u+ go u (l@(m,_):ls) | m == k = u ++ ls+ | otherwise = go (u ++ [l]) ls++repLets :: Eq a => [(a, a)] -> [a] -> [a]+-- | Matches the passed in let bindings with the passed in equation, and+-- reduces any found bindings with their value.+--+-- > #let a = 1+-- > a a + -- this is turned into [["1","1","+"]]+repLets lets = go []+ where go as [] = as+ go as (l:bs) = case lookup l lets of+ Just m -> go (as ++ [m]) bs+ Nothing -> go (as ++ [l]) bs++get :: Show a => [a] -> String -> String+-- | Used the passed in 'String' as an Integer index into the passed in stack+-- of answers. Breaks the equation if the string can't be parsed.+--+-- > 0 -- stack is now [0.0]+-- > 0 ans -- gets 0.0 from the stack+-- > 3 ans -- stack is now [0.0,0.0], no 3rd element -- broken equation+get as i = maybe "bork" show $ ((as !?) . floor) =<< readMay i++repAns :: Show a => [a] -> [String] -> [String]+-- | Matches the passed in ans stack with the passed in equation, and+-- reduces any found applications of the ans function with the value+--+-- > 1 -- ans stack is now [1.0]+-- > 0 ans -- this is turned into [["1"]]+repAns ans = go []+ where go as [] = as+ go as (n:m:bs) | m == "ans" = go [] (as ++ (ans `get` n) : bs)+ | otherwise = go (as ++ [n] ++ [m]) bs+ go as [a] = as ++ [a]
+ src/Clac/Stack.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE GADTs #-}++{- |+Module : $Header$+Description: Functionality for generating & manipulating a stack.+Copyright : (c) Alexander Berntsen 2015+License : GPL-3++Maintainer : alexander@plaimi.net+-} module Clac.Stack where++import Control.Applicative+ (+ (<$>),+ (<|>),+ (<*>),+ )+import Control.Arrow+ (+ second,+ )+import Data.Fixed+ (+ mod',+ )+import Data.List+ (+ find,+ )+import Data.Tree+ (+ Tree (Node),+ Forest,+ )+import Data.Tree.Pretty+ (+ drawVerticalTree,+ )+import Numeric.Special.Trigonometric+ (+ acot,+ acoth,+ acsc,+ acsch,+ asec,+ asech,+ cot,+ coth,+ csc,+ csch,+ sec,+ sech,+ )+import Safe+ (+ readMay,+ )+-- | A stack item. 'Snum' is usually a number. 'Sop' is an 'Op' and a 'String'+-- description of the 'Op'.+data StackItem a where+ Snum :: Show a => a -> StackItem a+ Sop :: {op :: Op a+ ,desc :: String+ }+ -> StackItem a+-- | 'show' of an 'Snum' is 'show' of its parametre. 'show' of an 'Sop' is+-- its 'desc'.+instance Show (StackItem a) where+ show (Snum a) = show a+ show (Sop _ a) = a++-- | An operator for the stack. 'Bop' is a binary operator. 'Uop' is a unary+-- operator. 'C' is a constant. 'Neq' is the next equation operator.+data Op a where+ Bop :: (a -> a -> a) -> Op a+ Uop :: (a -> a) -> Op a+ C :: a -> Op a+ Neq :: Op a++os :: (Floating a, Real a) => [(StackItem a, String)]+-- | List of all the valid operators, with their description.+os = [( Sop (Bop (+)) "+", "+:\t\taddition" )+ ,( Sop (Bop (-)) "-", "-:\t\tsubtraction" )+ ,( Sop (Bop (*)) "*", "*:\t\tmultiplication" )+ ,( Sop (Bop (*)) "x", "*:\t\tmultiplication" )+ ,( Sop (Bop (/)) "/", "/:\t\tdivision" )+ ,( Sop (Bop (**)) "^", "^:\t\tpower of" )+ ,( Sop (Bop mod') "%", "%:\t\tmodulo" )+ ,( Sop (Bop mod') "mod", "mod:\t\tmodulo" )+ ,( Sop (Bop logBase) "log-n", "log-n:\t\tlog-n: log rhs / log lhs" )+ ,( Sop (Uop negate) "neg", "neg:\t\tnegation" )+ ,( Sop (Uop abs) "abs", "abs:\t\tabsolute value" )+ ,( Sop (Uop log) "ln", "ln:\t\tnatural logarithm" )+ ,( Sop (Uop $ logBase 10) "lg", "ln:\t\tcommon logarithm" )+ ,( Sop (Uop sin) "sin", "sin:\t\tsine function" )+ ,( Sop (Uop cos) "cos", "cos:\t\tcosine function" )+ ,( Sop (Uop tan) "tan", "tan:\t\ttangent function" )+ ,( Sop (Uop asin) "asin", "asine:\t\tarcsine function" )+ ,( Sop (Uop acos) "acos", "acosine:\tarccosine function" )+ ,( Sop (Uop atan) "atan", "arctan:\t\tarctangent function" )+ ,( Sop (Uop csc) "csc", "csc:\t\tcosecant function" )+ ,( Sop (Uop sec) "sec", "sec:\t\tsecant function" )+ ,( Sop (Uop cot) "cot", "cot:\t\tcotangent function" )+ ,( Sop (Uop acsc) "acsc", "acsc:\t\tarccosecant function" )+ ,( Sop (Uop asec) "asec", "asec:\t\tarcsecant function" )+ ,( Sop (Uop acot) "acot", "acot:\t\tarccotangent function" )+ ,( Sop (Uop csch) "csch", "csch:\t\thb-cosecant function" )+ ,( Sop (Uop sech) "sech", "sech:\t\thb-secant function" )+ ,( Sop (Uop coth) "coth", "coth:\t\thb-cotangent function" )+ ,( Sop (Uop acsch) "acsch", "acsch:\t\thb-arccosecant function" )+ ,( Sop (Uop asech) "asech", "asech:\t\thb-arcsecant function" )+ ,( Sop (Uop acoth) "acoth", "acoth:\t\thb-arccotangent function" )+ ,( Sop (Uop sqrt) "sqrt", "sqrt:\t\tsquare root function" )+ ,( Sop (C pi) "pi", "pi:\t\tpi constant" )+ ,( Sop (C (exp 1)) "e", "e:\t\tEuler's number constant" )+ ,( Sop Neq ",", ",:\t\tstart a new equation" )+ ]++b :: (Floating a, Real a, Read a, Show a)+ => String -> [StackItem a] -> [StackItem a]+-- | Build a [@'StackItem' a@]. Parse each item of the passed in equation+-- 'String' with 'p' and put it on the accumulator if valid.+b x ac = case p x of+ Just q -> q:ac+ Nothing -> ac++p :: (Floating a, Real a, Read a, Show a) => String -> Maybe (StackItem a)+-- | Parse a 'String'. Try to look it up in 'os' as a 'Sop'. If that's+-- unsuccessful, try to read it as an 'Snum'. If that's unsuccessful, return+-- 'Nothing'.+p i = find ((== i) . desc) (fst <$> os) <|> Snum <$> readMay i++t :: Show a => [StackItem a] -> Forest String -> Tree String+-- | Generate an answer tree for the passed in [@'StackItem' a@]. Unrecognised+-- tokens are represented with a dejected but carefree emote.+t (Sop (Bop _) o:ss) (n:m:ts) = t ss (Node o [m, n]:ts)+t (Sop (Uop _) o:ss) (m:ts) = t ss (Node o [m]:ts)+t (Sop (C _) c:ss) ts = t ss (Node c []:ts)+t (Snum n:ss) ts = t ss (Node (show n) []:ts)+t [] (n:_) = n+t _ _ = Node "¯\\_(ツ)_/¯" []++s :: Show a => [StackItem a] -> [StackItem a] -> Maybe a+-- | Solve a [@'StackItem' a@].+s (Sop (Bop o) _:ss) (Snum n:Snum m:ts) = s ss (Snum (m `o` n):ts)+s (Sop (Uop o) _:ss) (Snum m:ts) = s ss (Snum (o m):ts)+s (Sop (C c) _:ss) ts = s ss (Snum c:ts)+s (n:ss) ts = s ss (n:ts)+s [] (Snum n:_) = Just n+s _ _ = Nothing++sa :: (Floating a, Real a, Show a, Read a)+ => [[String]] -> [(Maybe a, String)]+-- | Solve a bunch of equations with 's', and return a+-- [(@'Maybe' a@, 'String')] with the solution (if there was one), and a tree+-- representing the solution.+sa = map $ (second drawVerticalTree . (((,) . (`s` []))+ <*> (`t` []))) . foldr b []