Compare commits

..

No commits in common. "da15fa64688654dec67f2393ab978aefdf643bbf" and "dc6ca57a6b063481095062ff24abaae0fbf1ec34" have entirely different histories.

8 changed files with 305 additions and 28 deletions

25
.gitignore vendored
View File

@ -1,25 +0,0 @@
# ---> Haskell
dist
dist-*
cabal-dev
*.o
*.hi
*.hie
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
cabal.project.local~
.HTF/
.ghc.environment.*

View File

@ -1,3 +0,0 @@
# epsilon
unfinished lisp-ish

View File

@ -0,0 +1,42 @@
module Language.Epsilon.Eval (eval) where
import Control.Monad.Except (throwError)
import Data.Text (Text)
import Language.Epsilon.Types
import qualified Language.Epsilon.Prims as Prims
prims = ("eval", Prim PrimFn eval) : Prims.prims
eval :: Value -> EvalM Value
eval (Snoc f x) = apply f x
eval (Symbol s) = maybe (throwError (Unbound s)) return $ lookup s prims
eval (Quote q) = return q
eval x = return x
apply :: Value -> Value -> EvalM Value
apply (Snoc f x) y = do
f' <- apply f x
apply f' y
apply (Fn v f) x = do
x' <- eval x
eval $ subst v x' f
apply (Macro v f) x = eval (subst v x f) >>= eval
apply (Prim PrimFn f) x = eval x >>= f >>= eval
apply (Prim PrimMacro f) x = f x
apply Nil x = eval x
apply f x = throwError $ BadApply f x
subst :: Ident -> Value -> Value -> Value
subst i e (Snoc a d) = Snoc (subst i e a) (subst i e d)
subst i e expr@(Fn v b)
| i == v = expr
| otherwise = Fn v $ subst i e b
subst i e expr@(Macro v b)
| i == v = expr
| otherwise = Macro v $ subst i e b
subst _ _ (Quote q) = Quote q
subst i e expr@(Symbol i')
| i == i' = e
| otherwise = expr
subst _ _ expr = expr

View File

@ -0,0 +1,75 @@
{-# LANGUAGE
BlockArguments, ApplicativeDo, OverloadedStrings, LambdaCase,
TypeApplications
#-}
module Language.Epsilon.Parser (parse) where
import Control.Arrow
import Control.Applicative (liftA2)
import Control.Monad
import Data.Char
import Data.Functor
import Data.Text (Text)
import Text.Parsec hiding (parse)
import qualified Text.Parsec as P
import Text.Parsec.Char
import qualified Data.Text as T
import Language.Epsilon.Types
type Parser = Parsec Text ()
parse :: FilePath -> Text -> Either ParseError Value
parse = P.parse (value <* eof)
value :: Parser Value
value = parens do end <- option Nil $ try $ value <* dot
es <- many value
pure $ foldl Snoc end es
<|> Quote <$ quote <*> value
<|> do sign <- option "" $ pure <$> char '-'
ds <- many1 digit
let intPart = sign ++ ds
Float . read . (intPart ++) <$> liftA2 (:) (char '.') (many1 digit)
<|> pure (Int $ read intPart)
<* spaces
<|> Char <$ char '?' <*> strChar '\'' <* spaces
<|> Str . T.pack <$ char '"' <*> many1 (strChar '"') <* char '"' <* spaces
<|> Symbol . T.pack <$> many1 (satisfy symbolChar) <* spaces
where symbolChar c = not (isSpace c) && notElem @[] c "()\"'?"
strChar :: Char -> Parser Char
strChar c = noneOf [c, '\\'] <|> char '\\' *> esc where
esc :: Parser Char
esc = anyChar >>= \case
c' | c' == c -> pure c
'\\' -> pure '\\'
'\n' -> spaces *> strChar c -- skip all following whitespace
'n' -> pure '\n'
'e' -> pure '\ESC'
'b' -> pure '\DEL'
'0' -> pure '\NUL'
't' -> pure '\t'
'x' -> hexChar 2
'u' -> hexChar 4
'U' -> hexChar 8
hexChar :: Int -> Parser Char
hexChar n = chr . parseHex <$> replicateM n hexDigit where
parseHex :: String -> Int
parseHex = foldr (\d n -> parseHexDigit d + n*16) 0
parseHexDigit :: Char -> Int
parseHexDigit = toLower >>> \case
'0' -> 0; '1' -> 1; '2' -> 2; '3' -> 3
'4' -> 4; '5' -> 5; '6' -> 6; '7' -> 7
'8' -> 8; '9' -> 9; 'a' -> 10; 'b' -> 11
'c' -> 12; 'd' -> 13; 'e' -> 14; 'f' -> 15
_ -> 0
parens :: Parser a -> Parser a
parens p = char '(' *> spaces *> p <* char ')' <* spaces
dot, quote :: Parser ()
dot = void $ char '.' <* spaces
quote = void $ char '\'' <* spaces

View File

@ -0,0 +1,99 @@
{-# LANGUAGE
BlockArguments, OverloadedStrings, LambdaCase, UnicodeSyntax, RankNTypes
#-}
module Language.Epsilon.Prims (prims) where
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Language.Epsilon.Types
import Language.Epsilon.Parser
prims :: Env
prims =
[ ("quote", prim (pure . Quote))
, ("fn", prim $ withSym \arg -> pure $ Macro "body" $ Fn arg "body")
, ("macro", prim $ withSym \arg -> pure $ Macro "body" $ Macro arg "body")
, ("snoc", primFn \a -> pure $ primFn \d -> pure $ Quote $ Snoc a d)
, ("car", primFn $ withSnoc \a _ -> pure a)
, ("cdr", primFn $ withSnoc \_ d -> pure d)
, ("+", binop (+))
, ("-", binop (-))
, ("*", binop (*))
, ("/", binopFrac (/))
, ("%", binopInt mod)
, ("//", binopInt div)
, ("getln", primIO (Str <$> T.getLine))
, ("getch", primIO (Char <$> getChar))
, ("println", primFn $ withString \s -> pure $ primIO (Nil <$ T.putStrLn s))
, ("printch", primFn $ withChar \c -> pure $ primIO (Nil <$ putChar c))
, ("length", primFn $ withString (pure . Int . T.length))
, ("read", primFn $ withString $ either (throwError . ReadError) (pure . Quote) . parse "<read>")
]
binop :: ( a. Num a => a -> a -> a) -> Value
binop f = primFn \case
Int i -> pure $ primFn \case
Int j -> pure $ Int (i `f` j)
Float n -> pure $ Float (fromIntegral i `f` n)
v -> throwError $ TypeError v
Float m -> pure $ primFn \case
Int j -> pure $ Float (m `f` fromIntegral j)
Float n -> pure $ Float (m `f` n)
v -> throwError $ TypeError v
v -> throwError $ TypeError v
binopFrac :: ( a. Fractional a => a -> a -> a) -> Value
binopFrac f = Fn "x" $ Fn "y" $ p `Snoc` "x" `Snoc` "y" where
p = prim \case
Int i -> pure $ prim \case
Int j -> pure $ Float (fromIntegral i `f` fromIntegral j)
Float n -> pure $ Float (fromIntegral i `f` n)
v -> throwError $ TypeError v
Float m -> pure $ prim \case
Int j -> pure $ Float (m `f` fromIntegral j)
Float n -> pure $ Float (m `f` n)
v -> throwError $ TypeError v
v -> throwError $ TypeError v
binopInt :: ( a. Integral a => a -> a -> a) -> Value
binopInt f = Fn "x" $ Fn "y" $ p `Snoc` "x" `Snoc` "y" where
p = prim \case
Int i -> pure $ prim \case
Int j -> pure $ Int (i `f` j)
v -> throwError $ TypeError v
v -> throwError $ TypeError v
prim :: (Value -> EvalM Value) -> Value
prim = Prim PrimMacro
primFn :: (Value -> EvalM Value) -> Value
primFn = Prim PrimFn
primIO :: IO Value -> Value
primIO io = primFn \k -> Snoc k <$> liftIO io
withSym :: (Ident -> EvalM Value) -> Value -> EvalM Value
withSym k = \case
Symbol s -> k s
v -> throwError $ TypeError v
withSnoc :: (Value -> Value -> EvalM Value) -> Value -> EvalM Value
withSnoc k = \case
Snoc a d -> k a d
e -> throwError $ TypeError e
withString :: (Text -> EvalM Value) -> Value -> EvalM Value
withString k = \case
Str s -> k s
e -> throwError $ TypeError e
withChar :: (Char -> EvalM Value) -> Value -> EvalM Value
withChar k = \case
Char c -> k c
e -> throwError $ TypeError e

View File

@ -0,0 +1,59 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving,
MultiParamTypeClasses #-}
module Language.Epsilon.Types where
import Text.Parsec
import Data.Text (Text, pack, unpack)
import Data.String (IsString, fromString)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Except (MonadError)
import Control.Monad.Trans.Except (ExceptT)
type Ident = Text
type Env = [(Ident, Value)]
newtype EvalM a = EvalM { runEvalM :: ExceptT Error IO a }
deriving (Functor, Applicative, Monad, MonadIO)
deriving instance MonadError Error EvalM
data PrimType = PrimFn | PrimMacro -- should args/result be evaluated?
data Value
= Snoc Value Value
| Nil
| Fn Ident Value
| Macro Ident Value
| Prim PrimType (Value -> EvalM Value)
| Quote Value
| Symbol Text
| Int Int
| Float Double
| Str Text
| Char Char
instance Show Value where
show (Snoc a d) = "(" ++ show a ++ " . " ++ show d ++ ")"
show Nil = "()"
show (Fn i v) = "(fn " ++ unpack i ++ " " ++ show v ++ ")"
show (Macro i v) = "(macro " ++ unpack i ++ " " ++ show v ++ ")"
show (Prim _ _) = "<primitive>"
show (Quote v) = "'" ++ show v
show (Symbol s) = unpack s
show (Int i) = show i
show (Float f) = show f
show (Str s) = show s
show (Char c) = show c
instance IsString Value where
fromString = Symbol . pack
infixl 5 `Snoc`
data Error
= Unbound Ident
| BadApply Value Value
| TypeError Value
| ReadError ParseError
deriving Show

28
src/Main.hs 100644
View File

@ -0,0 +1,28 @@
{-# LANGUAGE LambdaCase #-}
module Main where
import Control.Monad.Trans.Except (runExceptT)
import Data.Text (Text)
import qualified Data.Text.IO as T
import System.Environment (getArgs)
import Language.Epsilon.Parser (parse)
import Language.Epsilon.Types (runEvalM)
import Language.Epsilon.Eval (eval)
main :: IO ()
main = getArgs >>= \case
[] -> T.getContents >>= go "<stdin>"
[x] -> T.readFile x >>= go x
_ -> putStrLn "not sure what to do with these cli args"
go :: FilePath -> Text -> IO ()
go fp s =
case parse fp s of
Left pe -> print pe
Right ast -> do
runExceptT (runEvalM $ eval ast) >>= \case
Left e -> print e
Right res -> print res

2
test.eps 100644
View File

@ -0,0 +1,2 @@
(getln read)