100 lines
3.1 KiB
Haskell
100 lines
3.1 KiB
Haskell
{-# 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
|
|
|