Browse Source

Multiline commands

wip
parent
commit
bc7bacdbfe
Signed by: yogsototh GPG Key ID: 7B19A4C650D59646
  1. 1
      .gitignore
  2. 2
      lish.cabal
  3. 1
      src-test/Lish/Test/Parser.hs
  4. 69
      src/Data/Stack.hs
  5. 33
      src/Lish/Balanced.hs
  6. 53
      src/Lish/Core.hs
  7. 4
      src/Lish/Eval.hs
  8. 8
      src/Lish/Parser.hs

1
.gitignore

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

2
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

1
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

69
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

33
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

53
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 ()

4
src/Lish/Eval.hs

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

8
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 '"')

Loading…
Cancel
Save