clac-0.4.0: src-exec/clac.hs

{-# LANGUAGE GADTs              #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE StandaloneDeriving #-}

{- |
Module     : $Header$
Description: clac.
Copyright  : (c) Alexander Berntsen 2015
License    : GPL-3

Maintainer : alexander@plaimi.net
-} module Main where

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
  (
  readMay,
  )
import System.IO
  (
  hFlush,
  stdout,
  )

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 ()
main = execParser o >>= calc where o = info (helper <*> ops)
                                     ( fullDesc
                                    <> progDesc "simple CLI RPN calculator"
                                    <> header   "clac" )