]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/AST/Test.hs
init
[haskell/symantic.git] / Language / Symantic / AST / Test.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE Rank2Types #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE UndecidableInstances #-}
10 -- | Abstract Syntax Tree.
11 module AST.Test where
12
13 import Test.Tasty
14 -- import Test.Tasty.HUnit
15
16 import qualified Data.List as List
17 import Data.Proxy (Proxy(..))
18 import Data.Text (Text)
19 import qualified Data.Text as Text
20
21 import Language.Symantic.Type
22 import Language.Symantic.Expr as Expr
23
24 tests :: TestTree
25 tests = testGroup "AST" $
26 [
27 ]
28
29 -- * Type 'AST'
30 data AST
31 = AST Text [AST]
32 deriving (Eq)
33 -- | Custom 'Show' instance a little bit more readable
34 -- than the automatically derived one.
35 instance Show AST where
36 showsPrec p ast@(AST f args) =
37 let n = Text.unpack f in
38 case ast of
39 AST _ [] -> showString n
40 AST "->" [a] ->
41 showParen (p >= prec_arrow) $
42 showString ("("++n++") ") .
43 showsPrec prec_arrow a
44 AST "->" [a, b] ->
45 showParen (p >= prec_arrow) $
46 showsPrec prec_arrow a .
47 showString (" "++n++" ") .
48 showsPrec prec_arrow b
49 _ ->
50 showString n .
51 showString "(" .
52 showString (List.intercalate ", " $ show Prelude.<$> args) .
53 showString ")"
54 where prec_arrow = 1
55
56 -- ** Parsing utilities
57 from_ast0
58 :: forall ty ast ex hs ret.
59 ( ty ~ Type_Root_of_Expr ex
60 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
61 (Error_of_Expr ast (Root_of_Expr ex))
62 ) => [ast]
63 -> Expr_From ast ex hs ret
64 -> Expr_From ast ex hs ret
65 from_ast0 asts k' ex ast ctx k =
66 case asts of
67 [] -> k' ex ast ctx k
68 _ -> Left $ error_expr ex $
69 Error_Expr_Wrong_number_of_arguments ast 0
70
71 from_ast1
72 :: forall ty ast ex hs ret.
73 ( ty ~ Type_Root_of_Expr ex
74 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
75 (Error_of_Expr ast (Root_of_Expr ex))
76 ) => [ast] -> (ast -> Expr_From ast ex hs ret)
77 -> Expr_From ast ex hs ret
78 from_ast1 asts k' ex ast ctx k =
79 case asts of
80 [ast_0] -> k' ast_0 ex ast ctx k
81 _ -> Left $ error_expr ex $
82 Error_Expr_Wrong_number_of_arguments ast 1
83
84 from_ast2
85 :: forall ty ast ex hs ret.
86 ( ty ~ Type_Root_of_Expr ex
87 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
88 (Error_of_Expr ast (Root_of_Expr ex))
89 ) => [ast] -> (ast -> ast -> Expr_From ast ex hs ret)
90 -> Expr_From ast ex hs ret
91 from_ast2 asts k' ex ast ctx k =
92 case asts of
93 [ast_0, ast_1] -> k' ast_0 ast_1 ex ast ctx k
94 _ -> Left $ error_expr ex $
95 Error_Expr_Wrong_number_of_arguments ast 2
96
97 from_ast3
98 :: forall ty ast ex hs ret.
99 ( ty ~ Type_Root_of_Expr ex
100 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
101 (Error_of_Expr ast (Root_of_Expr ex))
102 ) => [ast] -> (ast -> ast -> ast -> Expr_From ast ex hs ret)
103 -> Expr_From ast ex hs ret
104 from_ast3 asts k' ex ast ctx k =
105 case asts of
106 [ast_0, ast_1, ast_2] -> k' ast_0 ast_1 ast_2 ex ast ctx k
107 _ -> Left $ error_expr ex $
108 Error_Expr_Wrong_number_of_arguments ast 3
109
110 lit_from_AST
111 :: forall root ty lit ex ast hs ret.
112 ( ty ~ Type_Root_of_Expr ex
113 , root ~ Root_of_Expr ex
114 , ast ~ AST
115 , Read lit
116 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
117 (Error_of_Expr ast root)
118 ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
119 -> ty lit -> [ast]
120 -> Expr_From ast ex hs ret
121 lit_from_AST op ty_lit asts ex ast ctx k =
122 case asts of
123 [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
124 _ -> Left $ error_expr ex $
125 Error_Expr_Wrong_number_of_arguments ast 1
126
127 op1_from_AST
128 :: forall root ty lit ex ast hs ret.
129 ( ty ~ Type_Root_of_Expr ex
130 , root ~ Root_of_Expr ex
131 , ast ~ AST
132 , Eq_Type (Type_Root_of_Expr root)
133 , Expr_from ast root
134 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
135 (Error_of_Expr ast root)
136 , Root_of_Expr root ~ root
137 ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
138 -> ty lit -> [ast]
139 -> Expr_From ast ex hs ret
140 op1_from_AST op ty_lit asts ex ast ctx k =
141 case asts of
142 [ast_x] -> op1_from op ty_lit ast_x ex ast ctx k
143 _ -> Left $ error_expr ex $
144 Error_Expr_Wrong_number_of_arguments ast 1
145
146 op2_from_AST
147 :: forall root ty lit ex ast hs ret.
148 ( ty ~ Type_Root_of_Expr ex
149 , root ~ Root_of_Expr ex
150 , ast ~ AST
151 , Eq_Type (Type_Root_of_Expr root)
152 , Expr_from ast root
153 , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
154 (Error_of_Expr ast root)
155 , Root_of_Expr root ~ root
156 ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
157 -> ty lit -> [ast]
158 -> Expr_From ast ex hs ret
159 op2_from_AST op ty_lit asts ex ast ctx k =
160 case asts of
161 [ast_x, ast_y] -> op2_from op ty_lit ast_x ast_y ex ast ctx k
162 _ -> Left $ error_expr ex $
163 Error_Expr_Wrong_number_of_arguments ast 2
164
165 instance -- Type_from AST Type_Var0
166 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
167 , Implicit_HBool (Is_Last_Type (Type_Var0 root) root)
168 ) => Type_from AST (Type_Var0 root) where
169 type_from ty ast _k =
170 Left $ error_type_unsupported ty ast
171 -- NOTE: no support so far.
172 instance -- Type_from AST Type_Var1
173 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
174 , Implicit_HBool (Is_Last_Type (Type_Var1 root) root)
175 ) => Type_from AST (Type_Var1 root) where
176 type_from ty ast _k =
177 Left $ error_type_unsupported ty ast
178 -- NOTE: no support so far.
179 instance -- Type_from AST Type_Unit
180 ( Lift_Type_Root Type_Unit root
181 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
182 , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
183 ) => Type_from AST (Type_Unit root) where
184 type_from ty ast k =
185 case ast of
186 AST "()" asts ->
187 case asts of
188 [] -> k type_unit
189 _ -> Left $ lift_error_type $
190 Error_Type_Wrong_number_of_arguments ast 0
191 _ -> Left $ error_type_unsupported ty ast
192 instance -- Type_from AST Type_Bool
193 ( Lift_Type_Root Type_Bool root
194 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
195 , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
196 ) => Type_from AST (Type_Bool root) where
197 type_from ty ast k =
198 case ast of
199 AST "Bool" asts ->
200 case asts of
201 [] -> k type_bool
202 _ -> Left $ lift_error_type $
203 Error_Type_Wrong_number_of_arguments ast 0
204 _ -> Left $ error_type_unsupported ty ast
205 instance -- Type_from AST Type_Int
206 ( Lift_Type_Root Type_Int root
207 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
208 , Implicit_HBool (Is_Last_Type (Type_Int root) root)
209 ) => Type_from AST (Type_Int root) where
210 type_from ty ast k =
211 case ast of
212 AST "Int" asts ->
213 case asts of
214 [] -> k type_int
215 _ -> Left $ lift_error_type $
216 Error_Type_Wrong_number_of_arguments ast 0
217 _ -> Left $ error_type_unsupported ty ast
218 instance -- Type_from AST Type_Ordering
219 ( Lift_Type_Root Type_Ordering root
220 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
221 , Implicit_HBool (Is_Last_Type (Type_Ordering root) root)
222 ) => Type_from AST (Type_Ordering root) where
223 type_from ty ast k =
224 case ast of
225 AST "Ordering" asts ->
226 case asts of
227 [] -> k type_ordering
228 _ -> Left $ lift_error_type $
229 Error_Type_Wrong_number_of_arguments ast 0
230 _ -> Left $ error_type_unsupported ty ast
231 instance -- Type_from AST Type_Fun
232 ( Eq_Type root
233 , Type_from AST root
234 , Lift_Type_Root (Type_Fun lam) root
235 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
236 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
237 , Root_of_Type root ~ root
238 , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
239 ) => Type_from AST (Type_Fun lam root) where
240 type_from ty ast k =
241 case ast of
242 AST "->" asts ->
243 case asts of
244 [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
245 _ -> Left $ lift_error_type $
246 Error_Type_Wrong_number_of_arguments ast 2
247 _ -> Left $ error_type_unsupported ty ast
248 instance -- Type_from AST Type_Maybe
249 ( Eq_Type root
250 , Type_from AST root
251 , Lift_Type_Root Type_Maybe root
252 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
253 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
254 , Root_of_Type root ~ root
255 , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
256 ) => Type_from AST (Type_Maybe root) where
257 type_from ty ast k =
258 case ast of
259 AST "Maybe" asts ->
260 case asts of
261 [ast_a] ->
262 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
263 k (type_maybe ty_a)
264 _ -> Left $ lift_error_type $
265 Error_Type_Wrong_number_of_arguments ast 1
266 _ -> Left $ error_type_unsupported ty ast
267 instance -- Type_from AST Type_List
268 ( Eq_Type root
269 , Type_from AST root
270 , Lift_Type_Root Type_List root
271 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
272 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
273 , Root_of_Type root ~ root
274 , Implicit_HBool (Is_Last_Type (Type_List root) root)
275 ) => Type_from AST (Type_List root) where
276 type_from ty ast k =
277 case ast of
278 AST "[]" asts ->
279 case asts of
280 [ast_a] ->
281 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
282 k (type_list ty_a)
283 _ -> Left $ lift_error_type $
284 Error_Type_Wrong_number_of_arguments ast 1
285 _ -> Left $ error_type_unsupported ty ast
286
287 instance -- Type1_from AST Type_Bool
288 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
289 , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
290 ) => Type1_from AST (Type_Bool root)
291 instance -- Type1_from AST Type_Int
292 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
293 , Implicit_HBool (Is_Last_Type (Type_Int root) root)
294 ) => Type1_from AST (Type_Int root)
295 instance -- Type1_from AST Type_Unit
296 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
297 , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
298 ) => Type1_from AST (Type_Unit root)
299 instance -- Type1_from AST Type_Ordering
300 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
301 , Implicit_HBool (Is_Last_Type (Type_Ordering root) root)
302 ) => Type1_from AST (Type_Ordering root)
303 instance -- Type1_from AST Type_Var0
304 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
305 , Implicit_HBool (Is_Last_Type (Type_Var0 root) root)
306 ) => Type1_from AST (Type_Var0 root)
307 instance -- Type1_from AST Type_Var1
308 ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
309 , Implicit_HBool (Is_Last_Type (Type_Var1 root) root)
310 ) => Type1_from AST (Type_Var1 root)
311 instance -- Type1_from AST Type_Maybe
312 ( Type_from AST root
313 , Lift_Type_Root Type_Maybe root
314 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
315 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
316 , Root_of_Type root ~ root
317 , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
318 ) => Type1_from AST (Type_Maybe root) where
319 type1_from ty ast k =
320 case ast of
321 AST "Maybe" asts ->
322 case asts of
323 [] -> k (Proxy::Proxy Maybe) type_maybe
324 _ -> Left $ lift_error_type $
325 Error_Type_Wrong_number_of_arguments ast 0
326 _ -> Left $ error_type_unsupported ty ast
327 instance -- Type1_from AST Type_List
328 ( Eq_Type root
329 , Type_from AST root
330 , Lift_Type_Root Type_List root
331 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
332 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
333 , Root_of_Type root ~ root
334 , Implicit_HBool (Is_Last_Type (Type_List root) root)
335 ) => Type1_from AST (Type_List root) where
336 type1_from ty ast k =
337 case ast of
338 AST "[]" asts ->
339 case asts of
340 [] -> k (Proxy::Proxy []) type_list
341 _ -> Left $ lift_error_type $
342 Error_Type_Wrong_number_of_arguments ast 0
343 _ -> Left $ error_type_unsupported ty ast
344 instance -- Type1_from AST Type_Fun
345 ( Eq_Type root
346 , Type_from AST root
347 , Lift_Type_Root (Type_Fun lam) root
348 , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
349 , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
350 , Root_of_Type root ~ root
351 , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
352 ) => Type1_from AST (Type_Fun lam root) where
353 type1_from ty ast k =
354 case ast of
355 AST "->" asts ->
356 case asts of
357 [ast_arg] ->
358 type_from (Proxy::Proxy root) ast_arg $ \(ty_arg::root h_arg) ->
359 k (Proxy::Proxy (Lambda lam h_arg)) $
360 type_fun ty_arg
361 _ -> Left $ lift_error_type $
362 Error_Type_Wrong_number_of_arguments ast 1
363 _ -> Left $ error_type_unsupported ty ast
364
365 instance -- Expr_from AST Expr_Bool
366 ( Eq_Type (Type_Root_of_Expr root)
367 , Type_from AST (Type_Root_of_Expr root)
368 , Expr_from AST root
369 , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
370 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
371 , Unlift_Type Type_Bool (Type_of_Expr root)
372 , Root_of_Expr root ~ root
373 , Implicit_HBool (Is_Last_Expr (Expr_Bool root) root)
374 ) => Expr_from AST (Expr_Bool root) where
375 expr_from ex ast =
376 case ast of
377 AST "bool" asts -> lit_from_AST bool type_bool asts ex ast
378 AST "not" asts -> op1_from_AST Expr.not type_bool asts ex ast
379 AST "&&" asts -> op2_from_AST (Expr.&&) type_bool asts ex ast
380 AST "||" asts -> op2_from_AST (Expr.||) type_bool asts ex ast
381 AST "xor" asts -> op2_from_AST Expr.xor type_bool asts ex ast
382 _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
383 instance -- Expr_from AST Expr_If
384 ( Eq_Type (Type_Root_of_Expr root)
385 , Type_from AST (Type_Root_of_Expr root)
386 , Expr_from AST root
387 , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
388 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
389 , Root_of_Expr root ~ root
390 , Implicit_HBool (Is_Last_Expr (Expr_If root) root)
391 ) => Expr_from AST (Expr_If root) where
392 expr_from ex ast ctx k =
393 case ast of
394 AST "if" asts -> from_ast3 asts if_from ex ast ctx k
395 _ -> Left $ error_expr_unsupported ex ast
396 instance -- Expr_from AST Expr_When
397 ( Eq_Type (Type_Root_of_Expr root)
398 , Type_from AST (Type_Root_of_Expr root)
399 , Expr_from AST root
400 , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
401 , Lift_Type_Root Type_Unit (Type_Root_of_Expr root)
402 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
403 , Root_of_Expr root ~ root
404 , Implicit_HBool (Is_Last_Expr (Expr_When root) root)
405 ) => Expr_from AST (Expr_When root) where
406 expr_from ex ast ctx k =
407 case ast of
408 AST "when" asts -> from_ast2 asts when_from ex ast ctx k
409 _ -> Left $ error_expr_unsupported ex ast
410 instance -- Expr_from AST Expr_Int
411 ( Eq_Type (Type_Root_of_Expr root)
412 , Type_from AST (Type_Root_of_Expr root)
413 , Expr_from AST root
414 , Lift_Type_Root Type_Int (Type_Root_of_Expr root)
415 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
416 , Unlift_Type Type_Int (Type_of_Expr root)
417 , Root_of_Expr root ~ root
418 , Implicit_HBool (Is_Last_Expr (Expr_Int root) root)
419 ) => Expr_from AST (Expr_Int root) where
420 expr_from ex ast =
421 case ast of
422 AST "int" asts -> lit_from_AST int type_int asts ex ast
423 AST "abs" asts -> op1_from_AST Expr.abs type_int asts ex ast
424 AST "negate" asts -> op1_from_AST Expr.negate type_int asts ex ast
425 AST "+" asts -> op2_from_AST (Expr.+) type_int asts ex ast
426 AST "-" asts -> op2_from_AST (Expr.-) type_int asts ex ast
427 AST "*" asts -> op2_from_AST (Expr.*) type_int asts ex ast
428 AST "mod" asts -> op2_from_AST Expr.mod type_int asts ex ast
429 _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
430 instance -- Expr_from AST Expr_Lambda
431 ( Eq_Type (Type_Root_of_Expr root)
432 , Type_from AST (Type_Root_of_Expr root)
433 , Expr_from AST root
434 , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
435 , Lift_Error_Expr (Error_Expr_Lambda AST) (Error_of_Expr AST root)
436 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
437 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
438 , Root_of_Expr root ~ root
439 , Implicit_HBool (Is_Last_Expr (Expr_Lambda_App lam root) root)
440 ) => Expr_from AST (Expr_Lambda_App lam root) where
441 expr_from ex ast ctx k =
442 case ast of
443 AST "var" asts ->
444 case asts of
445 [AST name []] -> var_from name ex ast ctx k
446 _ -> Left $ error_expr ex $
447 Error_Expr_Wrong_number_of_arguments ast 1
448 AST "app" asts -> from_ast2 asts app_from ex ast ctx k
449 _ -> Left $ error_expr_unsupported ex ast
450 instance -- Expr_from AST Expr_Lambda_Inline
451 ( Eq_Type (Type_Root_of_Expr root)
452 , Type_from AST (Type_Root_of_Expr root)
453 , Expr_from AST root
454 , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
455 , Lift_Error_Expr (Error_Expr_Lambda AST) (Error_of_Expr AST root)
456 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
457 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
458 , Root_of_Expr root ~ root
459 , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Inline lam root) root)
460 ) => Expr_from AST (Expr_Lambda_Inline lam root) where
461 expr_from ex ast ctx k =
462 case ast of
463 AST "inline" asts -> go_lam asts inline
464 AST "let_inline" asts -> go_let asts let_inline
465 _ -> Left $ error_expr_unsupported ex ast
466 where
467 go_lam asts
468 (lam::forall repr arg res. Sym_Lambda_Inline lam repr
469 => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
470 case asts of
471 [AST name [], ast_ty_arg, ast_body] ->
472 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
473 _ -> Left $ error_expr ex $
474 Error_Expr_Wrong_number_of_arguments ast 3
475 go_let asts
476 (let_::forall repr var res. Sym_Lambda_Inline lam repr
477 => repr var -> (repr var -> repr res) -> repr res) =
478 case asts of
479 [AST name [], ast_var, ast_body] ->
480 let_from let_ name ast_var ast_body ex ast ctx k
481 _ -> Left $ error_expr ex $
482 Error_Expr_Wrong_number_of_arguments ast 3
483 instance -- Expr_from AST Expr_Lambda_Val
484 ( Eq_Type (Type_Root_of_Expr root)
485 , Type_from AST (Type_Root_of_Expr root)
486 , Expr_from AST root
487 , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
488 , Lift_Error_Expr (Error_Expr_Lambda AST) (Error_of_Expr AST root)
489 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
490 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
491 , Root_of_Expr root ~ root
492 , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Val lam root) root)
493 ) => Expr_from AST (Expr_Lambda_Val lam root) where
494 expr_from ex ast ctx k =
495 case ast of
496 AST "val" asts -> go_lam asts val
497 AST "let_val" asts -> go_let asts let_val
498 _ -> Left $ error_expr_unsupported ex ast
499 where
500 go_lam asts
501 (lam::forall repr arg res. Sym_Lambda_Val lam repr
502 => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
503 case asts of
504 [AST name [], ast_ty_arg, ast_body] ->
505 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
506 _ -> Left $ error_expr ex $
507 Error_Expr_Wrong_number_of_arguments ast 3
508 go_let asts
509 (let_::forall repr var res. Sym_Lambda_Val lam repr
510 => repr var -> (repr var -> repr res) -> repr res) =
511 case asts of
512 [AST name [], ast_var, ast_body] ->
513 let_from let_ name ast_var ast_body ex ast ctx k
514 _ -> Left $ error_expr ex $
515 Error_Expr_Wrong_number_of_arguments ast 3
516 instance -- Expr_from AST Expr_Lambda_Lazy
517 ( Eq_Type (Type_Root_of_Expr root)
518 , Type_from AST (Type_Root_of_Expr root)
519 , Expr_from AST root
520 , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
521 , Lift_Error_Expr (Error_Expr_Lambda AST) (Error_of_Expr AST root)
522 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
523 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
524 , Root_of_Expr root ~ root
525 , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Lazy lam root) root)
526 ) => Expr_from AST (Expr_Lambda_Lazy lam root) where
527 expr_from ex ast ctx k =
528 case ast of
529 AST "lazy" asts -> go_lam asts lazy
530 AST "let_lazy" asts -> go_let asts let_lazy
531 _ -> Left $ error_expr_unsupported ex ast
532 where
533 go_lam asts
534 (lam::forall repr arg res. Sym_Lambda_Lazy lam repr
535 => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
536 case asts of
537 [AST name [], ast_ty_arg, ast_body] ->
538 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
539 _ -> Left $ error_expr ex $
540 Error_Expr_Wrong_number_of_arguments ast 3
541 go_let asts
542 (let_::forall repr var res. Sym_Lambda_Lazy lam repr
543 => repr var -> (repr var -> repr res) -> repr res) =
544 case asts of
545 [AST name [], ast_var, ast_body] ->
546 let_from let_ name ast_var ast_body ex ast ctx k
547 _ -> Left $ error_expr ex $
548 Error_Expr_Wrong_number_of_arguments ast 3
549 instance -- Expr_from AST Expr_Maybe
550 ( Eq_Type (Type_Root_of_Expr root)
551 , Type_from AST (Type_Root_of_Expr root)
552 , Expr_from AST root
553 , Lift_Type (Type_Fun lam) (Type_of_Expr root)
554 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
555 , Lift_Type Type_Maybe (Type_of_Expr root)
556 , Unlift_Type Type_Maybe (Type_of_Expr root)
557 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
558 , Root_of_Expr root ~ root
559 , Implicit_HBool (Is_Last_Expr (Expr_Maybe lam root) root)
560 ) => Expr_from AST (Expr_Maybe lam root) where
561 expr_from ex ast ctx k =
562 case ast of
563 AST "maybe" asts -> from_ast3 asts maybe_from ex ast ctx k
564 AST "nothing" asts -> from_ast1 asts nothing_from ex ast ctx k
565 AST "just" asts -> from_ast1 asts just_from ex ast ctx k
566 _ -> Left $ error_expr_unsupported ex ast
567 instance -- Expr_from AST Expr_Eq
568 ( Eq_Type (Type_Root_of_Expr root)
569 , Type_from AST (Type_Root_of_Expr root)
570 , Lift_Type Type_Bool (Type_of_Expr root)
571 , Constraint_Type Eq (Type_Root_of_Expr root)
572 , Expr_from AST root
573 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
574 , Root_of_Expr root ~ root
575 , Implicit_HBool (Is_Last_Expr (Expr_Eq root) root)
576 ) => Expr_from AST (Expr_Eq root) where
577 expr_from ex ast ctx k =
578 case ast of
579 AST "==" asts -> from_ast2 asts eq_from ex ast ctx k
580 _ -> Left $ error_expr_unsupported ex ast
581 instance -- Expr_from AST Expr_Ord
582 ( Eq_Type (Type_Root_of_Expr root)
583 , Type_from AST (Type_Root_of_Expr root)
584 , Lift_Type Type_Ordering (Type_of_Expr root)
585 , Constraint_Type Ord (Type_Root_of_Expr root)
586 , Expr_from AST root
587 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
588 , Root_of_Expr root ~ root
589 , Implicit_HBool (Is_Last_Expr (Expr_Ord root) root)
590 ) => Expr_from AST (Expr_Ord root) where
591 expr_from ex ast ctx k =
592 case ast of
593 AST "compare" asts -> from_ast2 asts compare_from ex ast ctx k
594 _ -> Left $ error_expr_unsupported ex ast
595 instance -- Expr_from AST Expr_List
596 ( Eq_Type (Type_Root_of_Expr root)
597 , Type_from AST (Type_Root_of_Expr root)
598 , Expr_from AST root
599 , Lift_Type (Type_Fun lam) (Type_of_Expr root)
600 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
601 , Lift_Type Type_List (Type_of_Expr root)
602 , Unlift_Type Type_List (Type_of_Expr root)
603 , Lift_Type Type_Bool (Type_of_Expr root)
604 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
605 , Root_of_Expr root ~ root
606 , Implicit_HBool (Is_Last_Expr (Expr_List lam root) root)
607 ) => Expr_from AST (Expr_List lam root) where
608 expr_from ex ast ctx k =
609 case ast of
610 AST "[]" asts -> from_ast1 asts list_empty_from ex ast ctx k
611 AST ":" asts -> from_ast2 asts list_cons_from ex ast ctx k
612 AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast ctx k
613 AST "list" asts ->
614 case asts of
615 ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
616 _ -> Left $ error_expr ex $
617 Error_Expr_Wrong_number_of_arguments ast 1
618 _ -> Left $ error_expr_unsupported ex ast
619 instance -- Expr_from AST Expr_Map
620 ( Eq_Type (Type_Root_of_Expr root)
621 , Type_from AST (Type_Root_of_Expr root)
622 , Expr_from AST root
623 , Lift_Type (Type_Fun lam) (Type_of_Expr root)
624 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
625 , Lift_Type Type_Map (Type_of_Expr root)
626 , Unlift_Type Type_Map (Type_of_Expr root)
627 , Lift_Type Type_List (Type_of_Expr root)
628 , Unlift_Type Type_List (Type_of_Expr root)
629 , Lift_Type Type_Tuple2 (Type_of_Expr root)
630 , Unlift_Type Type_Tuple2 (Type_of_Expr root)
631 , Constraint_Type Ord (Type_Root_of_Expr root)
632 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
633 , Root_of_Expr root ~ root
634 , Implicit_HBool (Is_Last_Expr (Expr_Map lam root) root)
635 ) => Expr_from AST (Expr_Map lam root) where
636 expr_from ex ast ctx k =
637 case ast of
638 AST "map_from_list" asts -> from_ast1 asts map_from_list_from ex ast ctx k
639 AST "map_map" asts -> from_ast2 asts map_map_from ex ast ctx k
640 _ -> Left $ error_expr_unsupported ex ast
641 instance -- Expr_from AST Expr_Functor
642 ( Eq_Type (Type_Root_of_Expr root)
643 , Type_from AST (Type_Root_of_Expr root)
644 , Expr_from AST root
645 , String_from_Type (Type_Root_of_Expr root)
646 -- , Lift_Type Type_Var1 (Type_of_Expr root)
647 , Lift_Type (Type_Fun lam) (Type_of_Expr root)
648 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
649 , Unlift_Type1 (Type_of_Expr root)
650 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
651 , Constraint_Type1 Functor (Type_Root_of_Expr root)
652 , Root_of_Expr root ~ root
653 , Implicit_HBool (Is_Last_Expr (Expr_Functor lam root) root)
654 ) => Expr_from AST (Expr_Functor lam root) where
655 expr_from ex ast ctx k =
656 case ast of
657 AST "fmap" asts -> from_ast2 asts fmap_from ex ast ctx k
658 AST "<$>" asts -> from_ast2 asts fmap_from ex ast ctx k
659 _ -> Left $ error_expr_unsupported ex ast
660 instance -- Expr_from AST Expr_Applicative
661 ( Eq_Type (Type_Root_of_Expr root)
662 , Type1_from AST (Type_Root_of_Expr root)
663 , Expr_from AST root
664 , String_from_Type (Type_Root_of_Expr root)
665 -- , Lift_Type Type_Var1 (Type_of_Expr root)
666 , Lift_Type (Type_Fun lam) (Type_of_Expr root)
667 , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
668 , Eq_Type1 (Type_Root_of_Expr root)
669 , Unlift_Type1 (Type_of_Expr root)
670 , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
671 , Constraint_Type1 Applicative (Type_Root_of_Expr root)
672 , Root_of_Expr root ~ root
673 , Implicit_HBool (Is_Last_Expr (Expr_Applicative lam root) root)
674 ) => Expr_from AST (Expr_Applicative lam root) where
675 expr_from ex ast ctx k =
676 case ast of
677 AST "pure" asts -> from_ast2 asts pure_from ex ast ctx k
678 AST "<*>" asts -> from_ast2 asts ltstargt_from ex ast ctx k
679 _ -> Left $ error_expr_unsupported ex ast