blob: d386d0ebd52fdc918b0f64c77742c14346263f3d (
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
140
141
142
143
144
145
146
147
148
149
150
151
152
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
|
