Multiline commands

.gitignore

@@ -1,2 +1,3 @@
 /tutorial.md
 /.stack-work/
+.lish-history

lish.cabal

@@ -29,11 +29,13 @@ library
   ghc-options:       -Wall -Werror -O2
   hs-source-dirs:    src
   exposed-modules:   Lib
+                   , Lish.Balanced
                    , Lish.Core
                    , Lish.Eval
                    , Lish.InternalCommands
                    , Lish.Parser
                    , Lish.Types
+                   , Data.Stack
   build-depends:     base >= 4.8 && < 5
                    , containers
                    , haskeline

src-test/Lish/Test/Parser.hs

@@ -4,6 +4,7 @@ module Lish.Test.Parser
 where
 
 import Protolude
+
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.SmallCheck

src/Data/Stack.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Data.Stack
+  ( Stack
+  , pop
+  , top
+  , push
+  , size
+  )
+  where
+
+import Protolude
+
+-- | Stack data structure
+data Stack a = Stack [a] deriving (Eq,Show)
+
+instance Functor Stack where
+  fmap f (Stack xs) = Stack (fmap f xs)
+
+instance Applicative Stack where
+  pure x = Stack [x]
+  (Stack xs) <*> (Stack ys) = Stack (xs <*> ys)
+
+instance Alternative Stack where
+  empty = Stack []
+  (<|>) (Stack xs) (Stack ys) = Stack (xs <|> ys)
+
+-- | push to the stack
+--
+-- >>> push empty 0
+-- Stack [0]
+--
+-- >>> push (push empty 0) 1
+-- Stack [1,0]
+push :: Stack a -> a -> Stack a
+push (Stack xs) x = Stack (x:xs)
+
+-- | pop an element from the stack
+--
+-- >>> pop (push empty 0)
+-- Just (0,Stack [])
+--
+-- >>> pop (push (push empty 0) 1)
+-- Just (1,Stack [0])
+--
+-- >>> pop empty
+-- Nothing
+pop :: Stack a -> Maybe (a, Stack a)
+pop (Stack (x:xs)) = Just (x, Stack xs)
+pop _ = Nothing
+
+-- | get the element at the top of the stack
+--
+-- >>> top (push empty 'c')
+-- Just 'c'
+--
+-- >>> top empty
+-- Nothing
+top :: Stack a -> Maybe a
+top stk = fmap fst (pop stk)
+
+-- | return the size of the stack
+--
+-- >>> size empty
+-- 0
+--
+-- >>> size (push (push empty 0) 1)
+-- 2
+size :: Stack a -> Int
+size (Stack l) = length l

src/Lish/Balanced.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Check if a Lish expression is correctly balanced
+module Lish.Balanced
+  ( checkBalanced
+  , Stack
+  , Balanced(..)
+  )
+  where
+
+import Protolude
+import qualified Data.Text as T
+import Data.Stack (Stack, pop, push)
+
+data Balanced = Balanced | Unbalanced Char deriving (Eq, Show)
+
+checkBalanced :: Text -> Stack Char -> Balanced
+checkBalanced (T.uncons -> Just ('(',suf)) stk = checkBalanced suf (push stk '(')
+checkBalanced (T.uncons -> Just ('[',suf)) stk = checkBalanced suf (push stk '[')
+checkBalanced (T.uncons -> Just ('{',suf)) stk = checkBalanced suf (push stk '{')
+
+checkBalanced (T.uncons -> Just (')',suf)) (pop -> Just ('(',stk)) = checkBalanced suf stk
+checkBalanced (T.uncons -> Just (')',_)) _ = Unbalanced ')'
+checkBalanced (T.uncons -> Just (']',suf)) (pop -> Just ('[',stk)) = checkBalanced suf stk
+checkBalanced (T.uncons -> Just (']',_)) _ = Unbalanced ']'
+checkBalanced (T.uncons -> Just ('}',suf)) (pop -> Just ('{',stk)) = checkBalanced suf stk
+checkBalanced (T.uncons -> Just ('}',_)) _ = Unbalanced '}'
+
+checkBalanced (T.uncons -> Just (_,suf)) stk = checkBalanced suf stk
+checkBalanced _ (pop -> Just (x,_)) = Unbalanced x
+checkBalanced _ _ = Balanced

src/Lish/Core.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns      #-}
 -- | Lish core
 module Lish.Core
   (
@@ -15,15 +16,17 @@ import           System.Console.Haskeline
 import           System.Environment       (getEnvironment)
 import           Text.Parsec              (ParseError)
 
-import           Lish.Eval
-import           Lish.Parser
+import           Lish.Balanced            (checkBalanced, Balanced(..))
+import           Lish.Eval                (reduceLambda)
+import           Lish.Parser              (parseCmd)
 import           Lish.Types
 
 -- | Start an interactive lish shell
 runLish :: IO ()
 runLish = do
   env <- toEnv <$> getEnvironment
-  runInputT defaultSettings (mainLoop env)
+  runInputT (defaultSettings { historyFile = Just ".lish-history" })
+    (mainLoop Nothing env "")
 
 -- | System Environment -> LISH Env
 toEnv :: [(String,String)] -> Env
@@ -33,20 +36,40 @@ toEnv env =
   Map.fromList
 
 -- | Main REPL loop / Interpreter
-mainLoop :: Env -> InputT IO ()
-mainLoop env = do
-  let prompt = case Map.lookup "PROMPT" env of
-                 Just (Str p) -> p
-                 _            -> ":€ > "
-  maybeLine <- getInputLine (toS prompt)
+-- the first argument is a @Maybe Char@ it contains the char in the stack
+-- that verify if the expression is balanced.
+-- So if the first argument is not Nothing, it means we are in the middle
+-- of a multiline expression.
+mainLoop :: Maybe Char -- ^ Check to know if we are in the middle of the writting of a multiline expression
+         -> Env -- ^ The Lish environement
+         -> Text -- ^ The previous partial input (if in the middle of a multiline expression)
+         -> InputT IO ()
+mainLoop mc env previousPartialnput = do
+  maybeLine <- getInputLine (toS (prompt mc env))
   case maybeLine of
-    -- EOF / control-d
-    Nothing -> outputStrLn "bye bye!"
-    Just "exit" -> outputStrLn "bye bye!"
-    Just "logout" -> outputStrLn "bye bye!"
+    x | x `elem` [ Nothing -- EOF / control-d
+                 , Just "bye"
+                 , Just "exit"
+                 , Just "logout"] -> outputStrLn "bye bye!"
+
     Just line -> do
-      newenv <- eval env (parseCmd ("(" <> toS line <> ")"))
-      mainLoop newenv
+      let exprs = previousPartialnput
+                  <> (if isJust mc then " " else "")
+                  <> toS line
+      case checkBalanced exprs empty of
+        Unbalanced c -> mainLoop (Just c) env exprs
+        Balanced -> do
+          newenv <- eval env (parseCmd ("(" <> exprs <> ")"))
+          mainLoop Nothing newenv ""
+
+    _ -> panic "That should NEVER Happens, please file bug"
+
+prompt :: Maybe Char -> Env -> Text
+prompt mc env = case mc of
+                  Just _ -> ">>> "
+                  Nothing -> case Map.lookup "PROMPT" env of
+                     Just (Str p) -> p
+                     _            -> ":€ > "
 
 -- | Eval the reduced form
 evalReduced :: SExp -> IO ()

src/Lish/Eval.hs

@@ -3,8 +3,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 -- | Lish parser
 module Lish.Eval
-  ( reduceLambda
-  , checkType
+  ( checkType
+  , reduceLambda
   )
   where
 

src/Lish/Parser.hs

@@ -2,10 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 -- | Lish parser
 module Lish.Parser
-  (parseCmd)
+  ( parseCmd )
   where
 
-import           Protolude   hiding (for, many, (<|>), optional)
+import           Protolude        hiding (for, many, optional, try, (<|>))
 import           Text.Parsec
 import           Text.Parsec.Text
 
@@ -29,9 +29,9 @@ parseAtom = do
   frst <- (noneOf " \t()[]\"")
   rest <- many (noneOf " \t()[]")
   case frst:rest of
-    "true" -> return (Bool True)
+    "true"  -> return (Bool True)
     "false" -> return (Bool False)
-    x -> return (Atom (toS x))
+    x       -> return (Atom (toS x))
 
 parseString :: Parser SExp
 parseString = (Str . toS) <$> between (char '"')