hsilop-0.2.0.0: src/Main.hs

{-# LANGUAGE ViewPatterns, LambdaCase #-}

import Control.Monad                   (foldM)
import Data.List                       (isPrefixOf)
import Text.Read                       (readMaybe)
import Text.Printf                     (printf)
import System.Directory                (createDirectoryIfMissing)
import System.FilePath                 (takeDirectory)
import System.Environment.XDG.BaseDir  (getUserDataFile)
import System.Console.Haskeline
import System.Console.Haskeline.Completion


-- | Run calculator
main :: IO ()
main = settings >>= flip runInputT repl


-- | Program main loop
repl :: InputT IO ()
repl = getInputLine "ꟼ " >>= \case
  Nothing  -> return ()
  Just ""  -> repl
  Just exp -> outputStrLn (result (rpn exp) ++ "\n") >> repl


-- | Program settings
-- add function name completion and history
settings :: IO (Settings IO)
settings = do
  path <- getUserDataFile "hsilop" "history"
  createDirectoryIfMissing True (takeDirectory path)
  return $ Settings (completeWord Nothing "\t " complete) (Just path) True
  where
    names      = map fst monad ++ map fst nilad
    complete x = return $ map simpleCompletion (filter (isPrefixOf x) names)


-- | 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 = fmap head . foldM parse [] . words 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"


-- Functions --

-- | Dyadic
-- i.e. operators
dyad :: [(String, Double -> Double -> Double)]
dyad = [ ("+", (+))
       , ("-", (-))
       , ("*", (*))
       , ("/", (/))
       , ("^", (**)) ]

-- | Monadic
-- i.e. single argument functions
monad :: [(String, Double -> Double)]
monad = [ ("sin"  , sin )
        , ("asin" , asin)
        , ("cos"  , cos )
        , ("acos" , acos)
        , ("tan"  , tan )
        , ("atan" , atan)
        , ("ln"   , log )
        , ("sqrt" , sqrt)
        , ("abs"  , abs ) 
        , ("sgn"  , signum)
        , ("floor", fromIntegral . floor)
        , ("ceil" , fromIntegral . ceiling) ]

-- | Niladic
-- i.e. constants
nilad :: [(String, Double)]
nilad = [ ("pi" , pi)
        , ("e"  , exp 1)
        , ("phi", (1 + sqrt 5)/2) ]