diff --git a/clac.cabal b/clac.cabal --- a/clac.cabal +++ b/clac.cabal @@ -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 diff --git a/src-exec/clac.hs b/src-exec/clac.hs --- a/src-exec/clac.hs +++ b/src-exec/clac.hs @@ -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" diff --git a/src/Clac/CliParser.hs b/src/Clac/CliParser.hs new file mode 100644 --- /dev/null +++ b/src/Clac/CliParser.hs @@ -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) diff --git a/src/Clac/IO.hs b/src/Clac/IO.hs new file mode 100644 --- /dev/null +++ b/src/Clac/IO.hs @@ -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 diff --git a/src/Clac/REPL.hs b/src/Clac/REPL.hs new file mode 100644 --- /dev/null +++ b/src/Clac/REPL.hs @@ -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] diff --git a/src/Clac/Stack.hs b/src/Clac/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Clac/Stack.hs @@ -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 []