Browse Source

Use catamorphism

wip
parent
commit
20caf8f394
Signed by: yogsototh GPG Key ID: 7B19A4C650D59646
  1. 2
      README.md
  2. 2
      lish.cabal
  3. 10
      src-test/Lish/Test/Parser.hs
  4. 31
      src/Data/Stack.hs
  5. 6
      src/Lish/Balanced.hs
  6. 8
      src/Lish/Core.hs
  7. 26
      src/Lish/Eval.hs
  8. 5
      src/Lish/InternalCommands.hs
  9. 37
      src/Lish/Parser.hs
  10. 57
      src/Lish/Types.hs
  11. 1
      stack.yaml

2
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

2
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

10
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

31
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

6
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 ')'

8
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

26
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

5
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

37
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

57
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 _) = "<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

1
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: {}

Loading…
Cancel
Save