diff --git a/clac.cabal b/clac.cabal --- a/clac.cabal +++ b/clac.cabal @@ -1,5 +1,5 @@ name: clac -version: 0.2.0 +version: 0.3.0 synopsis: Simple CLI RPN calculator description: Simple CLI RPN calculator. license: GPL-3 @@ -15,8 +15,13 @@ main-is: clac.hs other-extensions: GADTs RankNTypes - build-depends: base >=4.7 && <4.8, - plailude >=0.3 && <0.5, - safe >=0.3 && <0.4 + StandaloneDeriving + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + optparse-applicative >=0.11 && <0.12, + plailude >=0.3 && <0.5, + pretty-tree >=0.1 && <0.2, + safe >=0.3 && <0.4, + split >=0.2 && <0.3 hs-source-dirs: 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,71 +1,170 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {- | -Module : $Header$ -Description : clac. -Copyright : (c) Alexander Berntsen 2015 -License : GPL-3 +Module : $Header$ +Description: clac. +Copyright : (c) Alexander Berntsen 2015 +License : GPL-3 -Maintainer : alexander@plaimi.net +Maintainer : alexander@plaimi.net -} module Main where import Control.Applicative ( - (<|>), (<$>), + (<|>), + (<*>), ) -import Safe +import Control.Arrow ( - readMay, + second, ) -import System.Environment +import Control.Monad ( - getArgs, + when, ) +import Data.List + ( + find, + ) +import Data.List.Split + ( + splitOn, + ) +import Data.Monoid + ( + (<>), + mempty, + ) +import Data.Tree + ( + Tree (Node), + ) +import Data.Tree.Pretty + ( + drawVerticalTree, + ) +import Options.Applicative + ( + Parser, + execParser, + fullDesc, + header, + help, + helper, + info, + long, + many, + progDesc, + short, + strArgument, + switch, + ) +import Safe + ( + readMay, + ) -import Plailude +data Opt = MkOpt {h :: Bool + ,v :: Bool + ,e :: [String] + } data StackItem a where Snum :: forall a. Fractional a => a -> StackItem a - Sop :: Op -> 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. Fractional a => a -> a -> a) -> Op Uop :: (forall a. Floating a => a -> a) -> Op + C :: (forall a. Floating a => a) -> Op + Neq :: Op -os :: [(String, (StackItem Double, String))] -os = [ ( "+", ( Sop (Bop (+)), "+:\t\taddition" )) - , ( "-", ( Sop (Bop (-)), "-:\t\tsubtraction" )) - , ( "*", ( Sop (Bop (*)), "*:\t\tmultiplication" )) - , ( "/", ( Sop (Bop (/)), "/:\t\tdivision" )) - , ( "neg", ( Sop (Uop negate), "neg:\t\tnegation" )) - , ( "sin", ( Sop (Uop sin), "sin:\t\tsine function" )) - , ( "cos", ( Sop (Uop cos), "cos:\t\tcosine function" )) - , ( "tan", ( Sop (Uop tan), "tan:\t\ttangent function" )) - , ( "atan", ( Sop (Uop atan), "arctan:\t\tarctangent function" )) +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 (Uop negate) "neg", "neg:\t\tnegation" ) + ,( 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 (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 + Just q -> q:ac Nothing -> ac p :: String -> Maybe (StackItem Double) -p m = (fmap fst .: lookup) m os <|> Snum <$> (readMay m :: Maybe Double) +p m = (Sop <$> find ((== m) . desc) (fst <$> os)) + <|> Snum <$> (readMay m :: Maybe Double) +t :: [StackItem Double] -> Tree String +t (Sop (Dop (Bop _) i):j:k) = Node i [t k, t [j]] +t (Sop (Dop (Uop _) i):j) = Node i [t j] +t (Sop (Dop (C _ ) i):_) = Node i [] +t (Snum i:_) = Node (show i) [] +t _ = Node "¯\\_(ツ)_/¯" [] + s :: [StackItem Double] -> [StackItem Double] -> Maybe Double -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 (n:ss) ts = s ss (n : ts) -s [] (Snum n:_) = Just n -s _ _ = Nothing +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 . (((,) . flip s []) + <*> (t . reverse))) . foldr b [] + +calc :: Opt -> IO () +calc o = do + cs <- if null (e o) then getContents else return [] + let es = splitOn [","] $ words cs ++ case e o of + [a] -> words a + _ -> e o + if h o + then mapM_ putStrLn $ "OPERATORS":"=========":map snd os + else + mapM_ (\(solution, tree) -> do + when (v o) $ putStrLn $ "\n\n" ++ tree + print solution + putStrLn $ replicate (length $ show solution) '=') $ sa es + main :: IO () -main = do - as <- getArgs - bs <- if null as then getContents else return [] - if "help" `elem` as - then mapM_ putStrLn $ "OPERATORS" : "=========" : [h | (_, (_, h)) <- os] - else print . flip s [] . foldr b [] $ as ++ words bs +main = execParser o >>= calc + where o = + info (helper <*> ops) + ( fullDesc + <> progDesc "simple CLI RPN calculator" + <> header "clac" )