.gitignore

@@ -0,0 +1,25 @@
+# ---> 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.*
+

README.md

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

src/Language/Epsilon/Eval.hs

@@ -1,42 +0,0 @@
-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

src/Language/Epsilon/Parser.hs

@@ -1,75 +0,0 @@
-{-# 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

src/Language/Epsilon/Prims.hs

@@ -1,99 +0,0 @@
-{-# 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
-

src/Language/Epsilon/Types.hs

@@ -1,59 +0,0 @@
-{-# 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

src/Main.hs

@@ -1,28 +0,0 @@
-{-# 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
-    

test.eps

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