diff --git a/README.md b/README.md index cb56715..af1c40c 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ lish ========== +[![Build Status](https://travis-ci.org/yogsototh/lish.svg?branch=master)](https://travis-ci.org/yogsototh/lish) + This project is an experimental LISP flavoured Shell ## Build diff --git a/lish.cabal b/lish.cabal index 89b8177..b031b3f 100644 --- a/lish.cabal +++ b/lish.cabal @@ -38,6 +38,7 @@ library , Data.Stack build-depends: base >= 4.8 && < 5 , containers + , data-fix , haskeline , parsec >= 3 && < 4 , pipes @@ -66,6 +67,7 @@ test-suite lish-test , tasty-smallcheck >= 0.8 , lish , protolude + , data-fix test-suite lish-doctest type: exitcode-stdio-1.0 diff --git a/src-test/Lish/Test/Parser.hs b/src-test/Lish/Test/Parser.hs index 823d82f..295b551 100644 --- a/src-test/Lish/Test/Parser.hs +++ b/src-test/Lish/Test/Parser.hs @@ -5,11 +5,11 @@ where import Protolude +import Data.Fix import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.SmallCheck - import Lish.Parser import Lish.Types @@ -22,13 +22,13 @@ parseTests = ] simpleCommand :: Text -> Assertion -simpleCommand t = parseCmd t @?= Right (Atom t) +simpleCommand t = parseCmd t @?= Right (Fix (Atom t)) propAtom :: [Char] -> Bool propAtom s = s == "" || fromMaybe '0' (head s) `elem` ("0123456789([])" :: [Char]) || case s of - "true" -> parseCmd t == Right (Bool True) - "false" -> parseCmd t == Right (Bool False) - _ -> parseCmd t == Right (Atom t) + "true" -> parseCmd t == Right (Fix (Bool True)) + "false" -> parseCmd t == Right (Fix (Bool False)) + _ -> parseCmd t == Right (Fix (Atom t)) where t = toS s diff --git a/src/Data/Stack.hs b/src/Data/Stack.hs index c3b54df..f36e551 100644 --- a/src/Data/Stack.hs +++ b/src/Data/Stack.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + module Data.Stack ( Stack , pop @@ -8,10 +10,10 @@ module Data.Stack ) where -import Protolude +import Protolude -- | Stack data structure -data Stack a = Stack [a] deriving (Eq,Show) +data Stack a = Stack ![a] deriving (Eq,Show) instance Functor Stack where fmap f (Stack xs) = Stack (fmap f xs) @@ -24,33 +26,34 @@ instance Alternative Stack where empty = Stack [] (<|>) (Stack xs) (Stack ys) = Stack (xs <|> ys) --- | push to the stack +-- | O(1) Push to the stack -- --- >>> push empty 0 +-- >>> push 0 empty -- Stack [0] -- --- >>> push (push empty 0) 1 +-- >>> empty & push 0 & push 1 -- Stack [1,0] -push :: Stack a -> a -> Stack a -push (Stack xs) x = Stack (x:xs) +push :: a -> Stack a -> Stack a +push x (Stack xs) = Stack (x:xs) -- | pop an element from the stack -- --- >>> pop (push empty 0) +-- >>> pop empty +-- Nothing +-- +-- >>> pop (push 0 empty) -- Just (0,Stack []) -- --- >>> pop (push (push empty 0) 1) +-- >>> pop (empty & push 0 & push 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 +pop _ = Nothing -- | get the element at the top of the stack -- --- >>> top (push empty 'c') +-- >>> top (push 'c' empty) -- Just 'c' -- -- >>> top empty @@ -63,7 +66,7 @@ top stk = fmap fst (pop stk) -- >>> size empty -- 0 -- --- >>> size (push (push empty 0) 1) +-- >>> size (empty & push 0 & push 1) -- 2 size :: Stack a -> Int size (Stack l) = length l diff --git a/src/Lish/Balanced.hs b/src/Lish/Balanced.hs index 2b5c64e..6848dc0 100644 --- a/src/Lish/Balanced.hs +++ b/src/Lish/Balanced.hs @@ -17,9 +17,9 @@ 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)) 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 ')' diff --git a/src/Lish/Core.hs b/src/Lish/Core.hs index 3bbd823..e76cf39 100644 --- a/src/Lish/Core.hs +++ b/src/Lish/Core.hs @@ -1,12 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -- | Lish core module Lish.Core ( runLish ) where +import Data.Fix import qualified Data.Map.Strict as Map import GHC.IO.Handle (hGetContents) import Pipes @@ -16,7 +16,7 @@ import System.Console.Haskeline import System.Environment (getEnvironment) import Text.Parsec (ParseError) -import Lish.Balanced (checkBalanced, Balanced(..)) +import Lish.Balanced (Balanced (..), checkBalanced) import Lish.Eval (reduceLambda) import Lish.Parser (parseCmd) import Lish.Types @@ -59,7 +59,7 @@ mainLoop mc env previousPartialnput = do case checkBalanced exprs empty of Unbalanced c -> mainLoop (Just c) env exprs Balanced -> do - newenv <- eval env (parseCmd ("(" <> exprs <> ")")) + newenv <- eval env (fmap unFix (parseCmd ("(" <> exprs <> ")"))) mainLoop Nothing newenv "" _ -> panic "That should NEVER Happens, please file bug" @@ -86,7 +86,7 @@ evalReduced (WaitingStream (Just h)) = do let splittedLines = lines cmdoutput producer = mapM_ yield splittedLines runEffect (for producer (lift . putStrLn)) -evalReduced x = putStrLn (repr x) +evalReduced x = putStrLn (pprint (Fix x)) -- | Evaluate the parsed expr eval :: Env -> Either ParseError SExp -> InputT IO Env diff --git a/src/Lish/Eval.hs b/src/Lish/Eval.hs index 1425a73..4153d0b 100644 --- a/src/Lish/Eval.hs +++ b/src/Lish/Eval.hs @@ -9,6 +9,7 @@ module Lish.Eval where import qualified Control.Exception as Exception +import Data.Fix import qualified Data.Map.Strict as Map import Protolude import System.Process hiding (env) @@ -23,10 +24,10 @@ infer _ Void = return LVoid infer _ (Num _) = return LNum infer _ (Bool _) = return LBool infer _ (Str _) = return LStr -infer ctx (List (expr:exprs)) = do +infer ctx (List ((Fix expr):exprs)) = do case infer ctx expr of Left terr -> Left terr - Right t -> case mapM (\e -> checkType ctx e t) exprs of + Right t -> case mapM (\e -> checkType ctx e t) (map unFix exprs) of Left terror -> Left terror Right _ -> return $ LList t infer ctx (Atom a) = case Map.lookup a ctx of @@ -34,13 +35,13 @@ infer ctx (Atom a) = case Map.lookup a ctx of Nothing -> Left . TypeError $ "Undefined atom: " <> toS a infer ctx (Fn parameters fnbody _ (ptypes,retType)) = do let newCtx = Map.union ctx (Map.fromList (zip parameters ptypes)) - checkType newCtx fnbody retType + checkType newCtx (unFix fnbody) retType return $ LFn ptypes retType -infer ctx (Lambda ((Fn fnparams _ _ (ptypes,retType)):exprs)) = +infer ctx (Lambda ((Fix (Fn fnparams _ _ (ptypes,retType))):exprs)) = if length fnparams /= length exprs then Left (TypeError "Fn applied to the wrong number of parameters") else do - inferedTypes <- mapM (infer ctx) exprs + inferedTypes <- mapM (infer ctx) (map unFix exprs) if inferedTypes /= ptypes then Left . TypeError $ "Expected " <> show ptypes <> " bug got " <> show inferedTypes @@ -60,11 +61,12 @@ checkType ctx expr ty = infer ctx expr >>= \ inferedType -> -- its real type should be something isomorphic to -- (SExp,Environment) -> IO (SExp, Environment) reduceLambda :: SExp -> StateT Env IO SExp -reduceLambda (Lambda (expr:exprs)) = do +reduceLambda (Lambda (Fix expr:fexprs)) = do + let exprs = map unFix fexprs reduced <- reduceLambda expr redred <- reduceLambda reduced if redred /= reduced - then reduceLambda (Lambda (reduced:exprs)) + then reduceLambda (Lambda . map Fix $ (reduced:exprs)) else do -- DEBUG --env <- get -- DEBUG --liftIO $ do @@ -85,11 +87,11 @@ reduceLambda (Lambda (expr:exprs)) = do Just x -> return x Nothing -> do reducedArgs <- mapM reduceLambda exprs - executeShell (Lambda ((Atom f):reducedArgs)) + executeShell (Lambda . map Fix $ ((Atom f):reducedArgs)) f@(Fn _ _ _ _) -> applyFn f exprs s -> do reducedArgs <- mapM reduceLambda exprs - executeShell (Lambda (s:reducedArgs)) + executeShell (Lambda . map Fix $ (s:reducedArgs)) reduceLambda (Atom x) = do env <- get case Map.lookup x env of @@ -106,7 +108,7 @@ applyFn (Fn par bod clos _) args = currentEnv <- get -- Run the function in its own closure fmap fst $ liftIO $ - runStateT (reduceLambda bod) (Map.union currentEnv localClosure) + runStateT (reduceLambda (unFix bod)) (Map.union currentEnv localClosure) where bindVars oldenv newvars = Map.union oldenv (Map.fromList newvars) applyFn x _ = return x @@ -138,8 +140,8 @@ shellErr errmsg = do -- | Execute a shell command executeShell :: SExp -> StateT Env IO SExp executeShell (Lambda args) = do - res <- (mapM toArg args) >>= return . catMaybes - let argsHandle = (filter isJust (map toStdIn args)) + res <- (mapM toArg (map unFix args)) >>= return . catMaybes + let argsHandle = (filter isJust (map toStdIn (map unFix args))) stdinhandle = case argsHandle of (Just h:_) -> UseHandle h _ -> Inherit diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs index ece0206..1c31bde 100644 --- a/src/Lish/InternalCommands.hs +++ b/src/Lish/InternalCommands.hs @@ -7,6 +7,7 @@ module Lish.InternalCommands ) where +import Data.Fix import qualified Data.Map.Strict as Map import qualified Data.Text as Text import GHC.IO.Handle (hGetContents) @@ -132,13 +133,13 @@ fn reducer (p:bodies) = do let parameters = map fromAtom args if all isJust parameters then return (Fn { params = catMaybes parameters - , body = Lambda $ (Atom "do"):bodies + , body = Fix . Lambda . map Fix $ (Atom "do"):bodies , closure = mempty , types = ([],LCommand) }) else return Void _ -> return Void - where fromAtom (Atom a) = Just a + where fromAtom (Fix (Atom a)) = Just a fromAtom _ = Nothing fn _ _ = return Void diff --git a/src/Lish/Parser.hs b/src/Lish/Parser.hs index 874a3d3..66ef9ff 100644 --- a/src/Lish/Parser.hs +++ b/src/Lish/Parser.hs @@ -5,44 +5,45 @@ module Lish.Parser ( parseCmd ) where +import Data.Fix import Protolude hiding (for, many, optional, try, (<|>)) import Text.Parsec import Text.Parsec.Text import Lish.Types -parseCmd :: Text -> Either ParseError SExp +parseCmd :: Text -> Either ParseError Expr parseCmd = parse parseExpr "S-Expr" -parseExpr :: Parser SExp +parseExpr :: Parser Expr parseExpr = parseLambda <|> parseList <|> parseNumber <|> parseAtom <|> parseString -parseNumber :: Parser SExp -parseNumber = (Num . fromMaybe 0 . readMaybe) <$> many1 digit +parseNumber :: Parser Expr +parseNumber = (Fix . Num . fromMaybe 0 . readMaybe) <$> many1 digit -parseAtom :: Parser SExp +parseAtom :: Parser Expr parseAtom = do frst <- (noneOf " \t()[]\"") rest <- many (noneOf " \t()[]") case frst:rest of - "true" -> return (Bool True) - "false" -> return (Bool False) - x -> return (Atom (toS x)) + "true" -> return . Fix $ Bool True + "false" -> return . Fix $ Bool False + x -> return . Fix $ Atom (toS x) -parseString :: Parser SExp -parseString = (Str . toS) <$> between (char '"') - (char '"') - (many (noneOf "\"")) +parseString :: Parser Expr +parseString = (Fix . Str . toS) <$> between (char '"') + (char '"') + (many (noneOf "\"")) -parseSExps :: Parser [SExp] -parseSExps = sepEndBy parseExpr spaces +parseExprs :: Parser [Expr] +parseExprs = sepEndBy parseExpr spaces -parseLambda :: Parser SExp -parseLambda = Lambda <$> between (char '(') (char ')') parseSExps +parseLambda :: Parser Expr +parseLambda = Fix . Lambda <$> between (char '(') (char ')') parseExprs -parseList :: Parser SExp -parseList = List <$> between (char '[') (char ']') parseSExps +parseList :: Parser Expr +parseList = Fix . List <$> between (char '[') (char ']') parseExprs diff --git a/src/Lish/Types.hs b/src/Lish/Types.hs index 4c964ca..049809f 100644 --- a/src/Lish/Types.hs +++ b/src/Lish/Types.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Lish types module Lish.Types - ( SExp(..) + ( SExp + , Expr + , ExprF(..) , show , repr + , pprint , Env , CmdStream , Command @@ -15,28 +19,32 @@ module Lish.Types ) where -import qualified Data.Map.Strict as Map +import Data.Fix +import Data.Map.Strict (Map) import qualified Data.Text as Text import GHC.IO.Handle (Handle) import GHC.Show (Show (..)) import Protolude hiding (show) -data SExp = Atom Text - | Num Integer - | Bool Bool - | Str Text - | List [SExp] - | Lambda [SExp] - | Void - -- only exists during evaluation - | Fn { params :: [Text] - , body :: SExp - , closure :: Env - , types :: ([LishType],LishType) - } - | Stream CmdStream - | WaitingStream CmdStream - deriving (Eq,Show) +data ExprF a = Atom Text + | Num Integer + | Bool Bool + | Str Text + | List [a] + | Lambda [a] + | Void + -- only exists during evaluation + | Fn { params :: [Text] + , body :: a + , closure :: Env + , types :: ([LishType],LishType) + } + | Stream CmdStream + | WaitingStream CmdStream + deriving (Eq,Show,Functor) + +type Expr = Fix ExprF +type SExp = ExprF Expr data LishType = LCommand | LNum @@ -47,21 +55,24 @@ data LishType = LCommand | LVoid deriving (Eq,Show) -type Context = Map.Map Text LishType +type Context = Map Text LishType -repr :: SExp -> Text +repr :: ExprF Text -> Text repr (Atom s) = s repr (Num n) = toS $ show n repr (Bool b) = if b then "true" else "false" repr (Str s) = "\"" <> toS s <> "\"" -repr (List sexprs) = "[" <> (Text.intercalate " " (map repr sexprs)) <> "]" -repr (Lambda sexprs) = "(" <> (Text.intercalate " " (map repr sexprs)) <> ")" +repr (List sexprs) = "[" <> (Text.intercalate " " sexprs) <> "]" +repr (Lambda sexprs) = "(" <> (Text.intercalate " " sexprs) <> ")" repr Void = "ε" repr (Fn p _ _ _) = "(λ" <> (Text.intercalate "." p) <> ". ... )" repr (Stream _) = "" repr (WaitingStream _) = "" +pprint :: Expr -> Text +pprint = cata repr + type CmdStream = Maybe Handle -type Env = Map.Map Text SExp +type Env = Map Text SExp type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand diff --git a/stack.yaml b/stack.yaml index 8c81be8..b285d50 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,6 +41,7 @@ packages: # (e.g., acme-missiles-0.3) extra-deps: - haskeline-0.7.3.1 +- data-fix-0.0.3 # Override default flag values for local packages and extra-deps flags: {}