summaryrefslogtreecommitdiff
path: root/Biz/Language/Bs/Expr.hs
blob: 2452622fdf6a4711ec59933acc96034209436025 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

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 expr ->
      textStrict "not a function"
        <$$> pretty expr
    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