Add semi-working bs

1 files changed, 153 insertions, 0 deletions

diff --git a/lore/Language/Bs/Expr.hs b/lore/Language/Bs/Expr.hs
new file mode 100644
index 0000000..d386d0e
--- /dev/null
+++ b/lore/Language/Bs/Expr.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Language.Bs.Expr where
+
+import Data.String (String)
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Show
+import Protolude hiding (show)
+import qualified Text.PrettyPrint.Leijen.Text as PP
+import Text.PrettyPrint.Leijen.Text hiding ((<$>))
+
+type Ctx = Map Text Expr
+data Env = Env { env :: Ctx, fenv :: Ctx }
+    deriving (Eq)
+
+newtype Eval a = Eval { unEval :: ReaderT Env IO a }
+    deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)
+
+data IFunc = IFunc { fn :: [Expr] -> Eval Expr }
+    deriving (Typeable)
+
+instance Eq IFunc where
+    (==) _ _ = False
+
+data Expr
+  = Atom Text
+  | List [Expr]
+  | Numb Integer
+  | Tape Text
+  | IFun IFunc -- TODO: call this Kern
+  | Func IFunc Env
+  | Bool Bool
+  | Nil
+  deriving (Typeable, Eq)
+
+instance Show Expr where
+    show = T.unpack . ppexpr
+
+data LispErrorType
+  = NumArgs Integer [Expr]
+  | LengthOfList Text Int
+  | ExpectedList Text
+  | ParseError String
+  | TypeMismatch Text Expr
+  | BadSpecialForm Text
+  | NotFunction Expr
+  | UnboundVar Text
+  | Default Expr
+  | ReadFileError Text
+  deriving (Typeable)
+
+data LispError = LispError Expr LispErrorType
+
+instance Show LispErrorType where
+    show = T.unpack . ppexpr
+
+instance Show LispError where
+    show = T.unpack . ppexpr
+
+instance Exception LispErrorType
+instance Exception LispError
+
+ppexpr :: Pretty a => a -> Text
+ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x))
+
+--prettyList :: [Doc] -> Doc
+--prettyList = encloseSep lparen rparen PP.space
+
+instance Pretty Expr where
+    pretty v =
+        case v of
+            Atom a ->
+                textStrict a
+
+            List ls ->
+                prettyList $ fmap pretty ls
+
+            Numb n ->
+                integer n
+
+            Tape t ->
+                textStrict "\"" <> textStrict t <> textStrict "\""
+
+            IFun _ ->
+                textStrict "<internal function>"
+
+            Func _ _ ->
+                textStrict "<lambda function>"
+
+            Bool True ->
+                textStrict "#t"
+
+            Bool False ->
+                textStrict "#f"
+
+            Nil ->
+                textStrict "'()"
+
+instance Pretty LispErrorType where
+  pretty err = case err of
+      NumArgs i args ->
+          textStrict "number of arguments"
+          <$$> textStrict "expected"
+          <+> textStrict (T.pack $ show i)
+          <$$> textStrict "received"
+          <+> textStrict (T.pack $ show $ length args)
+
+
+      LengthOfList txt i ->
+          textStrict "length of list in:"
+          <+> textStrict txt
+          <$$> textStrict "length:"
+          <+> textStrict (T.pack $ show i)
+
+      ParseError txt ->
+          textStrict "cannot parse expr:"
+          <+> textStrict (T.pack txt)
+
+      TypeMismatch txt expr ->
+          textStrict "type mismatch:"
+          <$$> textStrict txt
+          <$$> pretty expr
+
+      BadSpecialForm txt ->
+          textStrict "bad special form:"
+          <$$> textStrict txt
+
+      NotFunction _ ->
+          textStrict "not a function"
+
+      UnboundVar txt ->
+          textStrict "unbound variable:"
+          <$$> textStrict txt
+
+      Default _ ->
+          textStrict "default error"
+
+      ReadFileError txt ->
+          textStrict "error reading file:"
+          <$$> textStrict txt
+
+      ExpectedList txt ->
+          textStrict "expected list:"
+          <$$> textStrict txt
+
+instance Pretty LispError where
+  pretty (LispError expr typ) =
+      textStrict "error evaluating:"
+      <$$> indent 4 (pretty expr)
+      <$$> pretty typ