Syntax.hs 10.2 KB
Newer Older
Sven Keidel's avatar
Sven Keidel committed
1
2
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
3
4
5
6
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
Sven Keidel's avatar
Sven Keidel committed
7
{-# LANGUAGE OverloadedStrings #-}
Tomislav Pree's avatar
Tomislav Pree committed
8
{-# LANGUAGE DeriveGeneric #-}
9
10
module Syntax where

Sven Keidel's avatar
Sven Keidel committed
11
import           Data.Text (Text)
12
13
14
import           Data.Hashable
import           Data.Label
import           Data.String
15
import           Data.GraphViz.Attributes
Sven Keidel's avatar
Sven Keidel committed
16
17
import           Data.Text.Prettyprint.Doc hiding (list)
import           Data.Text.Prettyprint.Doc.Render.Text
18

Sven Keidel's avatar
Sven Keidel committed
19
20
21
import           Control.Monad.State
import           Control.DeepSeq
import           GHC.Generics
22

Tomislav Pree's avatar
Tomislav Pree committed
23
import Data.Aeson (ToJSON, FromJSON)
24
-- Literals of Scheme
Tomislav Pree's avatar
Tomislav Pree committed
25

26
data Literal
27
  = Int Int
28
  | Float Double
29
  | Rational Rational
30
31
  | Bool Bool
  | Char Char --single character and single quotation (')
32
33
  | String Text -- any amount of chars and double quotation (")
  | Symbol Text
34
  | Quote Literal
35
  -- | DottedList [Literal] Literal
Sven Keidel's avatar
Sven Keidel committed
36
  deriving (Eq,Generic,NFData)
Tomislav Pree's avatar
Tomislav Pree committed
37
38
instance ToJSON Literal 
instance FromJSON Literal
39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
data Op1
-- | Check operations
  = IsNumber -- (number? z)
  | IsInteger -- (integer? z)
  | IsFloat -- (float? z)
  | IsRational -- (rational? z)
  | IsZero -- (zero? z)
  | IsPositive -- (positive? z)
  | IsNegative -- (negative? z)
  | IsOdd -- (odd? z)
  | IsEven-- (even? z)
  | IsNull -- (null? z)
  | IsCons -- (cons? z)
  | IsBoolean -- (boolean? z)
-- | Numeric Operations
55
56
57
58
59
60
61
62
63
64
65
66
67
  | Abs -- (abs z)
  | Floor -- (floor z)
  | Ceiling -- (ceiling z)
  | Log -- (log z) base e
-- | Boolean operations
  | Not -- (not z)
-- | List operations
  | Car -- (car z)
  | Cdr -- (cdr z)
  | Caar -- (caar z)
  | Cadr -- (cadr z)
  | Cddr -- (cddr z)
  | Caddr -- (caddr z)
68
  | Cadddr -- (cadddr z)
69
70
71
72
73
-- | String Operations
  | NumberToString -- (number->string z)
  | StringToSymbol -- (string->symbol z)
  | SymbolToString -- (symbol->string z)
-- | Miscellaneous operations
74
  -- | Error -- (error z)
75
  | Random -- (random z)
Sven Keidel's avatar
Sven Keidel committed
76
  deriving (Eq,Generic,NFData)
Tomislav Pree's avatar
Tomislav Pree committed
77
78
instance ToJSON Op1
instance FromJSON Op1
79

80
data Op2
81
82
83
84
85
86
-- | Equivalence predicates
  = Eqv -- (eq? z) / (eqv? z)
-- | Numerical operations
  | Quotient -- (quotient z1 z2)
  | Remainder -- (remainder z1 z2)
  | Modulo -- (modulo z1 z2)
87
88
-- | String operations
  | StringRef -- (string-ref z1 z2)
Sven Keidel's avatar
Sven Keidel committed
89
  deriving (Eq,Generic,NFData)
Tomislav Pree's avatar
Tomislav Pree committed
90
91
instance ToJSON Op2 
instance FromJSON Op2
92

93
data OpVar
94
-- | Numerical operations
95
96
97
98
99
  = Equal -- (= z1 z2 z3 ...)
  | Smaller -- (< z1 z2 z3 ...)
  | Greater -- (> z1 z2 z3 ...)
  | SmallerEqual -- (<= z1 z2 z3 ...)
  | GreaterEqual -- (>= z1 z2 z3 ...)
100
101
102
103
104
105
  | Max -- (max z1 z2 z3 ...)
  | Min -- (max z1 z2 z3 ...)
  | Add -- (+) (+ z) (+ z1 z2 z3 ...)
  | Mul -- (*) (* z) (* z1 z2 z3 ...)
  | Sub -- (- z) (- z1 z2 z3 ...)
  | Div -- (/ z) (/ z1 z2 z3 ...)
Sven Keidel's avatar
Sven Keidel committed
106
107
108
  | Gcd -- (gcd z1 z2 z3 ...)
  | Lcm -- (lcm z1 z2 z3 ...)
  | StringAppend -- (string-append z1 z2 z3 ...)
109
-- | List operations
Sven Keidel's avatar
Sven Keidel committed
110
  deriving (Eq,Generic,NFData)
Tomislav Pree's avatar
Tomislav Pree committed
111
112
instance ToJSON OpVar
instance FromJSON OpVar
113
114
115
116
117
118
119


-- | Expressions of Scheme. Each expression has a label, with which the
-- expression can be uniquely identified.
data Expr
-- | Expressions for inner representation and evaluation
  = Lit Literal Label
120
  | Nil Label -- (nil)
121
122
123
  | Cons Expr Expr Label -- (cons z1 z2)

  -- | List_ [Expr] Label -- (list z1 z2 z3 ...)
124
125
126
127
128
129
130
131
132
133
134
135
  | Begin [Expr] Label
  | App Expr [Expr] Label
  | Apply [Expr] Label
-- | Scheme expressions
  | Var Text Label
  | Set Text Expr Label
  | Define Text Expr Label
  | Lam [Text] [Expr] Label
  | If Expr Expr Expr Label
  | Let [(Text, Expr)] [Expr] Label
  | LetRec [(Text, Expr)] [Expr] Label
-- | Scheme standard procedures
136
137
138
  | Op1 Op1 Expr Label
  | Op2 Op2 Expr Expr Label
  | OpVar OpVar [Expr] Label
139
  | Error String Label
Sven Keidel's avatar
Sven Keidel committed
140
  | Breakpoint Expr -- breakpoint z
Sven Keidel's avatar
Sven Keidel committed
141
  deriving (Generic,NFData)
142

Tomislav Pree's avatar
Tomislav Pree committed
143
144
145
instance ToJSON Expr 
instance FromJSON Expr 

Sven Keidel's avatar
Sven Keidel committed
146
147
instance Eq Expr where
  e1 == e2 = label e1 == label e2
148

Tomislav Pree's avatar
Tomislav Pree committed
149
type LExpr = State Label Expr 
150

151
152
-- Smart constructors that build labeled Scheme expressions.
-- | Expressions for inner representation and evaluation
153
lit :: Literal -> LExpr
154
lit x = Lit x <$> fresh
155
list :: [LExpr] -> LExpr
156
157
list [] = Nil <$> fresh
list (x : xs) = Cons <$> x <*> list xs <*> fresh
158
159
-- list_ :: [State Label Expr] -> State Label Expr 
-- list_ xs = List_ <$> (sequence xs) <*> fresh 
160
cons :: LExpr -> LExpr ->LExpr
161
cons e1 e2 = Cons <$> e1 <*> e2 <*> fresh
162
begin :: [LExpr] -> LExpr
163
begin es = Begin <$> sequence es <*> fresh
164
app :: LExpr -> [LExpr] -> LExpr
165
app e1 e2 = App <$> e1 <*> sequence e2 <*> fresh
166
-- | Scheme expressions
167
var_ :: Text -> LExpr
168
var_ x = Var x <$> fresh
169
set :: Text -> LExpr -> LExpr
170
set t e = Set t <$> e <*> fresh
171
lam :: [Text] -> [LExpr] -> LExpr
172
lam xs es = Lam xs <$> sequence es <*> fresh
173
if_ :: LExpr -> LExpr -> LExpr -> LExpr
174
if_ e1 e2 e3 = If <$> e1 <*> e2 <*> e3 <*> fresh
175
define :: Text -> LExpr -> LExpr
176
define t e = Define t <$> e <*> fresh
177
let_ :: [(Text, LExpr)] -> [LExpr] -> LExpr
178
let_ bnds body = Let <$> sequence [(v,) <$> e | (v,e) <- bnds] <*> sequence body <*> fresh
179
let_rec :: [(Text, LExpr)] -> [LExpr] -> LExpr
180
let_rec bnds body = LetRec <$> sequence [(v,) <$> e | (v,e) <- bnds] <*> sequence body <*> fresh
181
-- | Scheme standard procedures
182
op1_ :: Op1 -> LExpr -> LExpr
183
op1_ operation e1 = Op1 operation <$> e1 <*> fresh
184
op2_ :: Op2 -> LExpr -> LExpr -> LExpr
185
op2_ operation e1 e2 = Op2 operation <$> e1 <*> e2 <*> fresh
186
opvar_ :: OpVar -> [LExpr] -> LExpr
Sven Keidel's avatar
Sven Keidel committed
187
opvar_ operation es = OpVar operation <$> sequence es <*> fresh
188
189
error_ :: String -> LExpr
error_ err = Error err <$> fresh
Sven Keidel's avatar
Sven Keidel committed
190
191
breakpoint :: LExpr -> LExpr
breakpoint e = Breakpoint <$> e
192

193

Sven Keidel's avatar
Sven Keidel committed
194
instance Show Literal where show = show . pretty
195

Sven Keidel's avatar
Sven Keidel committed
196
197
instance Pretty Literal where
  pretty e0 = case e0 of
198
    Int x -> pretty x
Sven Keidel's avatar
Sven Keidel committed
199
    Float x -> pretty x
200
    Rational x -> pretty (show x)
Sven Keidel's avatar
Sven Keidel committed
201
202
203
204
    Bool x -> pretty x
    Char x -> squotes (pretty x)
    String x -> dquotes (pretty x)
    Symbol x -> pretty x
205
    Quote x -> "'" <> pretty x
206
    -- DottedList xs x -> showString ("DottedList ") . showList(xs) . showString (" . ") . shows (x)
207

208
instance Show Op1 where show = show . pretty
Sven Keidel's avatar
Sven Keidel committed
209

210
instance Pretty Op1 where
Sven Keidel's avatar
Sven Keidel committed
211
  pretty e0 = case e0 of
212
213
214
215
216
217
218
219
220
221
222
223
    IsNumber -> "number?"
    IsInteger -> "integer?"
    IsFloat -> "float?"
    IsRational -> "rational?"
    IsZero -> "zero?"
    IsPositive -> "positive?"
    IsNegative -> "negative?"
    IsOdd -> "odd?"
    IsEven -> "even?"
    IsBoolean -> "boolean?"
    IsNull -> "null?"
    IsCons -> "cons?"
Sven Keidel's avatar
Sven Keidel committed
224
225
226
227
228
229
230
231
232
233
234
    Abs -> "abs"
    Floor -> "floor"
    Ceiling -> "ceiling"
    Log -> "log"
    Not -> "not"
    Car -> "car"
    Cdr -> "cdr"
    Caar -> "caar"
    Cadr -> "cadr"
    Cddr -> "cddr"
    Caddr -> "caddr"
Sven Keidel's avatar
Sven Keidel committed
235
    Cadddr -> "cadddr"
236
    -- Error -> "error"
237
    Random -> "random"
238
239
240
    StringToSymbol -> "string->symbol"
    SymbolToString -> "symbol->string"
    NumberToString -> "number->string"
Sven Keidel's avatar
Sven Keidel committed
241

242
instance Show Op2 where show = show . pretty
243

244
instance Pretty Op2 where
Sven Keidel's avatar
Sven Keidel committed
245
246
247
248
249
  pretty e0 = case e0 of
    Eqv -> "eq?"
    Quotient -> "quotient "
    Remainder -> "remainder "
    Modulo -> "modulo "
250
    StringRef -> "string-ref "
251

252
instance Show OpVar where show = show . pretty
Sven Keidel's avatar
Sven Keidel committed
253

254
instance Pretty OpVar where
Sven Keidel's avatar
Sven Keidel committed
255
  pretty e0 = case e0 of
256
257
258
259
260
    Equal -> "="
    Smaller -> "<"
    Greater -> ">"
    SmallerEqual -> "<="
    GreaterEqual -> ">="
Sven Keidel's avatar
Sven Keidel committed
261
262
263
264
265
266
267
268
    Max -> "max"
    Min -> "min"
    Add -> "+"
    Mul -> "*"
    Sub -> "-"
    Div -> "/"
    Gcd -> "gcd"
    Lcm -> "lcm"
Sven Keidel's avatar
Sven Keidel committed
269
    StringAppend -> "string-append"
270
    -- List_ -> showString ("list")
271

Sven Keidel's avatar
Sven Keidel committed
272
273
274
instance Show Expr where show = show . pretty

instance Pretty Expr where
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
  pretty e = flatAlt (prettyExpr e) (parens (showTopLvl e <> "..."))

prettyExpr :: Expr -> Doc ann
prettyExpr e0 = case e0 of
  Lit x _ -> pretty x
  Nil _ -> "nil"
  Cons e1 e2 _ -> parens $ "cons" <+> prettyExpr e1 <+> prettyExpr e2
  Begin es _-> parens $ "begin" <+> prettyExprList es
  App e1 e2 _ -> parens $ prettyExpr e1 <+> prettyExprList e2
  Apply e _ -> parens $ prettyExprList e
  Var x _ -> pretty x
  Set t e _ -> parens $ "set!" <+> pretty t <+> prettyExpr e
  Define t e _ -> parens $ "define" <+> pretty t <+> prettyExpr e
  Lam xs e2 _ -> parens $ "lambda" <+> hsep (map pretty xs) <> "." <+> prettyExprList e2
  If e1 e2 e3 _ -> parens $ "if" <+> prettyExpr e1 <+> prettyExpr e2 <+> prettyExpr e3
  Let bnds body _ -> parens $ "let" <+> brackets (align (vcat [ pretty var <+> prettyExpr expr | (var,expr) <- bnds])) <+> prettyExprList body
  LetRec bnds body _ -> parens $ "letrec" <+> brackets (align (vcat [ pretty var <+> prettyExpr expr | (var,expr) <- bnds])) <+> pretty body
  Op1 op1 e _ -> parens $ pretty op1 <+> prettyExpr e
  Op2 op2 e1 e2 _ -> parens $ pretty op2 <> prettyExpr e1 <+> prettyExpr e2
  OpVar opvar es _ -> parens $ pretty opvar <+> prettyExprList es
295
  Error err _ -> parens $ "error " <+> dquotes (pretty err)
296
297
298

prettyExprList :: [Expr] -> Doc ann
prettyExprList expr = hsep (map prettyExpr expr)
299

Sven Keidel's avatar
Sven Keidel committed
300
showTopLvl :: Expr -> Doc ann
301
showTopLvl e = case e of
302
303
304
305
306
    Lit x _ -> pretty x
    Nil _ -> "nil"
    Cons {} -> "cons"
    Begin {} -> "begin"
    App {} -> "app"
Sven Keidel's avatar
Sven Keidel committed
307
308
    -- Apply {} -> "apply"
    Apply e' _ -> pretty e'
Sven Keidel's avatar
Sven Keidel committed
309
    Var x _ -> pretty x
310
311
    Set t _ _ -> "set!" <+> pretty t
    Define t _ _ -> "define" <+> pretty t
Sven Keidel's avatar
Sven Keidel committed
312
313
    Lam xs _ _ -> "λ" <+> hsep (map pretty xs)
    If e1 _ _ _ -> "if" <+> pretty e1
314
315
    Let {} -> "let"
    LetRec {} -> "letrec"
Sven Keidel's avatar
Sven Keidel committed
316
317
318
    Op1 op1 e1 _ -> pretty op1 <+> showTopLvl e1
    Op2 op2 e1 e2 _ -> pretty op2 <+> showTopLvl e1 <> "," <> showTopLvl e2
    OpVar opvar es _ -> pretty opvar <+> hsep (map showTopLvl es)
319
    Error _ _ -> "error"
Sven Keidel's avatar
Sven Keidel committed
320
321
322
323

controlFlow :: Expr -> Maybe Expr
controlFlow e = case e of
  App {} -> Just e
324
  LetRec {} -> Just e
Sven Keidel's avatar
Sven Keidel committed
325
  _ -> Nothing
Tobias Leon Hombücher's avatar
comment    
Tobias Leon Hombücher committed
326

327
328
329
instance IsString (State Label Expr) where
  fromString = var_ . fromString

330
instance Labellable Expr where
331
  toLabelValue a = textLabelValue $ renderLazy $ layoutPretty defaultLayoutOptions $ showTopLvl a
332
333
334
335

instance HasLabel Expr where
  label e = case e of
    Lit _ l -> l
336
    Nil l -> l
337
    Cons _ _ l -> l
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
    Begin _ l -> l
    App _ _ l -> l
    Apply _ l -> l
  -- | Scheme expressions
    Var _ l -> l
    Set _ _ l -> l
    Define _ _ l -> l
    Lam _ _ l -> l
    If _ _ _ l -> l
    Let _ _ l -> l
    LetRec _ _ l -> l
  -- | Scheme standard procedures
    Op1 _ _ l -> l
    Op2 _ _ _ l -> l
    OpVar _ _ l -> l
353
    Error _ l -> l
354
355

instance Hashable Expr where
356
  hashWithSalt s e = s `hashWithSalt` label e