real initial commit

src/Language/Epsilon/Eval.hs

@@ -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

src/Language/Epsilon/Parser.hs

@@ -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

src/Language/Epsilon/Prims.hs

@@ -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
+

src/Language/Epsilon/Types.hs

@@ -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

src/Main.hs

@@ -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
+    

test.eps

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