Use catamorphism
This commit is contained in:
parent
bc7bacdbfe
commit
20caf8f394
11 changed files with 106 additions and 83 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
-- Just (0,Stack [])
|
||||
--
|
||||
-- >>> pop (push (push empty 0) 1)
|
||||
-- Just (1,Stack [0])
|
||||
--
|
||||
-- >>> pop empty
|
||||
-- Nothing
|
||||
--
|
||||
-- >>> pop (push 0 empty)
|
||||
-- Just (0,Stack [])
|
||||
--
|
||||
-- >>> pop (empty & push 0 & push 1)
|
||||
-- Just (1,Stack [0])
|
||||
--
|
||||
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
|
||||
|
|
|
@ -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 ')'
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 _) = "<stream>"
|
||||
repr (WaitingStream _) = "<w-stream>"
|
||||
|
||||
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
|
||||
|
|
|
@ -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: {}
|
||||
|
|
Loading…
Reference in a new issue