Add line completion and history

src/Main.hs

@@ -1,25 +1,42 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, LambdaCase #-}
 
-import Data.List
+import Control.Monad                   (foldM)
-import Data.Maybe
+import Data.List                       (isPrefixOf)
-import Text.Read
+import Text.Read                       (readMaybe)
-import Text.Printf
+import Text.Printf                     (printf)
-import Control.Monad
+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 = runInputT defaultSettings repl
+main = settings >>= flip runInputT repl
 
+
+-- | Program main loop
 repl :: InputT IO ()
-repl = do
+repl = getInputLine "ꟼ " >>= \case
-  line <- getInputLine "ꟼ "
+  Nothing  -> return ()
-  case fromMaybe "" line of
+  Just ""  -> repl
-    "q" -> return ()
+  Just exp -> outputStrLn (result (rpn exp) ++ "\n") >> repl
-    ""  -> outputStrLn "" >> repl
-    exp -> outputStrLn (result (rpn exp) ++ "\n") >> repl
 
 
--- Pretty print RPN result/errors
+-- | 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
@@ -27,9 +44,9 @@ result (Right x)  = printf format x where
          | otherwise            = "∘ %.10f"
 
 
--- Solve a RPN expression
+-- | Solve a RPN expression
 rpn :: String -> Either String Double
-rpn = foldM parse [] . words >=> return . head where 
+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)
@@ -37,14 +54,20 @@ rpn = foldM parse [] . words >=> return . head where
   parse _        _                              = Left "syntax error"
 
 
--- dyadic functions
+-- Functions --
+
+-- | Dyadic
+-- i.e. operators
+dyad :: [(String, Double -> Double -> Double)]
 dyad = [ ("+", (+))
        , ("-", (-))
        , ("*", (*))
        , ("/", (/))
        , ("^", (**)) ]
 
--- monadic functions
+-- | Monadic
+-- i.e. single argument functions
+monad :: [(String, Double -> Double)]
 monad = [ ("sin"  , sin )
         , ("asin" , asin)
         , ("cos"  , cos )
@@ -53,12 +76,14 @@ monad = [ ("sin"  , sin )
         , ("atan" , atan)
         , ("ln"   , log )
         , ("sqrt" , sqrt)
+        , ("abs"  , abs ) 
         , ("sgn"  , signum)
-        , ("abs"  , abs) 
         , ("floor", fromIntegral . floor)
         , ("ceil" , fromIntegral . ceiling) ]
 
--- niladic functions
+-- | Niladic
+-- i.e. constants
+nilad :: [(String, Double)]
 nilad = [ ("pi" , pi)
         , ("e"  , exp 1)
         , ("phi", (1 + sqrt 5)/2) ]