hsilop/hsilop.hs

{-# LANGUAGE ViewPatterns #-}

import Data.List
import Data.Maybe
import Text.Read
import Text.Printf
import Control.Monad
import System.Console.Haskeline

main :: IO ()
main = runInputT defaultSettings repl

repl :: InputT IO ()
repl = do
  line <- getInputLine "ꟼ "
  case fromMaybe "" line of
    "q" -> return ()
    ""  -> outputStrLn "" >> repl
    exp -> outputStrLn (result (rpn exp) ++ "\n") >> repl


-- Pretty print RPN result/errors
result :: Either String Double -> String
result (Left err) = "Ꞥ∘ " ++ err
result (Right x)  = printf format x where
  format | ceiling x == floor x = "∘ %.0f"
         | otherwise            = "∘ %.10f"


-- Solve a RPN expression
rpn :: String -> Either String Double
rpn = foldM parse [] . words >=> return . head where 
  parse (y:x:xs) (flip lookup dyad  -> Just f) = Right (f x y : xs)
  parse (x:xs)   (flip lookup monad -> Just f) = Right (f x : xs)
  parse xs       (flip lookup nilad -> Just k) = Right (k : xs)
  parse xs       (readMaybe -> Just x) = Right (x : xs)
  parse _        _                     = Left "syntax error"


-- dyadic functions
dyad = [ ("+", (+))
       , ("-", (-))
       , ("*", (*))
       , ("/", (/))
       , ("^", (**)) ]

-- monadic functions
monad = [ ("sin"  , sin )
        , ("asin" , asin)
        , ("cos"  , cos )
        , ("acos" , acos)
        , ("tan"  , tan )
        , ("atan" , atan)
        , ("ln"   , log )
        , ("sqrt" , sqrt)
        , ("sgn"  , signum)
        , ("abs"  , abs) 
        , ("floor", fromIntegral . floor)
        , ("ceil" , fromIntegral . ceiling) ]

-- niladic functions
nilad = [ ("pi" , pi)
        , ("e"  , exp 1)
        , ("phi", (1 + sqrt 5)/2) ]