]> 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 import Prelude hiding (and, not, or)
21
22 import Language.Symantic.Type
23 import Language.Symantic.Expr
24
25 tests :: TestTree
26 tests = testGroup "AST" $
27 [
28 ]
29
30 -- * Type 'AST'
31 data AST
32 = AST Text [AST]
33 deriving (Eq)
34 -- | Custom 'Show' instance a little bit more readable
35 -- than the automatically derived one.
36 instance Show AST where
37 showsPrec p ast@(AST f args) =
38 let n = Text.unpack f in
39 case ast of
40 AST _ [] -> showString n
41 AST "->" [a] ->
42 showParen (p >= prec_arrow) $
43 showString ("("++n++") ") .
44 showsPrec prec_arrow a
45 AST "->" [a, b] ->
46 showParen (p >= prec_arrow) $
47 showsPrec prec_arrow a .
48 showString (" "++n++" ") .
49 showsPrec prec_arrow b
50 _ ->
51 showString n .
52 showString "(" .
53 showString (List.intercalate ", " $ show <$> args) .
54 showString ")"
55 where prec_arrow = 1
56
57 instance -- Type_from AST Type_Var
58 ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
59 , Implicit_HBool (Is_Last_Type (Type_Var root) root)
60 ) => Type_from AST (Type_Var root) where
61 type_from ty ast _k =
62 Left $ error_type_unsupported ty ast
63 -- NOTE: no support so far.
64 instance -- Type_from AST Type_Unit
65 ( Type_Root_Lift Type_Unit root
66 , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
67 , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
68 ) => Type_from AST (Type_Unit root) where
69 type_from ty ast k =
70 case ast of
71 AST "()" asts ->
72 case asts of
73 [] -> k type_unit
74 _ -> Left $ error_type_lift $
75 Error_Type_Wrong_number_of_arguments ast 0
76 _ -> Left $ error_type_unsupported ty ast
77 instance -- Type_from AST Type_Bool
78 ( Type_Root_Lift Type_Bool root
79 , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
80 , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
81 ) => Type_from AST (Type_Bool root) where
82 type_from ty ast k =
83 case ast of
84 AST "Bool" asts ->
85 case asts of
86 [] -> k type_bool
87 _ -> Left $ error_type_lift $
88 Error_Type_Wrong_number_of_arguments ast 0
89 _ -> Left $ error_type_unsupported ty ast
90 instance -- Type_from AST Type_Int
91 ( Type_Root_Lift Type_Int root
92 , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
93 , Implicit_HBool (Is_Last_Type (Type_Int root) root)
94 ) => Type_from AST (Type_Int root) where
95 type_from ty ast k =
96 case ast of
97 AST "Int" asts ->
98 case asts of
99 [] -> k type_int
100 _ -> Left $ error_type_lift $
101 Error_Type_Wrong_number_of_arguments ast 0
102 _ -> Left $ error_type_unsupported ty ast
103 instance -- Type_from AST Type_Fun
104 ( Type_Eq root
105 , Type_from AST root
106 , Type_Root_Lift (Type_Fun lam) root
107 , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
108 , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
109 , Root_of_Type root ~ root
110 , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
111 ) => Type_from AST (Type_Fun lam root) where
112 type_from ty ast k =
113 case ast of
114 AST "->" asts ->
115 case asts of
116 [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
117 _ -> Left $ error_type_lift $
118 Error_Type_Wrong_number_of_arguments ast 2
119 _ -> Left $ error_type_unsupported ty ast
120 instance -- Type_from AST Type_Maybe
121 ( Type_Eq root
122 , Type_from AST root
123 , Type_Root_Lift Type_Maybe root
124 , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
125 , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
126 , Root_of_Type root ~ root
127 , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
128 ) => Type_from AST (Type_Maybe root) where
129 type_from ty ast k =
130 case ast of
131 AST "Maybe" asts ->
132 case asts of
133 [ast_a] ->
134 type_from (Proxy::Proxy root) ast_a $ \(ty_a::root h_a) ->
135 k (type_root_lift $ Type_Maybe ty_a
136 :: root (Maybe h_a))
137 _ -> Left $ error_type_lift $
138 Error_Type_Wrong_number_of_arguments ast 1
139 _ -> Left $ error_type_unsupported ty ast
140 instance -- Expr_from AST Expr_Bool
141 ( Type_from AST (Type_Root_of_Expr root)
142 , Expr_from AST root
143 , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
144 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
145 ( Type_Root_of_Expr root)
146 AST)
147 (Error_of_Expr AST root)
148 , Type_Unlift Type_Bool (Type_of_Expr root)
149 , Root_of_Expr root ~ root
150 , Implicit_HBool (Is_Last_Expr (Expr_Bool root) root)
151 ) => Expr_from AST (Expr_Bool root) where
152 expr_from ex ast =
153 case ast of
154 AST "bool" asts -> lit_from_AST bool type_bool asts ex ast
155 AST "not" asts -> op1_from_AST not type_bool asts ex ast
156 AST "and" asts -> op2_from_AST and type_bool asts ex ast
157 AST "or" asts -> op2_from_AST or type_bool asts ex ast
158 AST "xor" asts -> op2_from_AST xor type_bool asts ex ast
159 _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
160 instance -- Expr_from AST Expr_If
161 ( Type_from AST (Type_Root_of_Expr root)
162 , Expr_from AST root
163 , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
164 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
165 ( Type_Root_of_Expr root)
166 AST)
167 (Error_of_Expr AST root)
168 , Root_of_Expr root ~ root
169 , Implicit_HBool (Is_Last_Expr (Expr_If root) root)
170 ) => Expr_from AST (Expr_If root) where
171 expr_from ex ast ctx k =
172 case ast of
173 AST "if" asts ->
174 case asts of
175 [ast_cond, ast_ok, ast_ko] ->
176 if_from ast_cond ast_ok ast_ko ex ast ctx k
177 _ -> Left $ error_expr ex $
178 Error_Expr_Wrong_number_of_arguments ast 3
179 _ -> Left $ error_expr_unsupported ex ast
180 instance -- Expr_from AST Expr_When
181 ( Type_from AST (Type_Root_of_Expr root)
182 , Expr_from AST root
183 , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
184 , Type_Root_Lift Type_Unit (Type_Root_of_Expr root)
185 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
186 ( Type_Root_of_Expr root)
187 AST)
188 (Error_of_Expr AST root)
189 , Root_of_Expr root ~ root
190 , Implicit_HBool (Is_Last_Expr (Expr_When root) root)
191 ) => Expr_from AST (Expr_When root) where
192 expr_from ex ast ctx k =
193 case ast of
194 AST "when" asts ->
195 case asts of
196 [ast_cond, ast_ok] ->
197 when_from ast_cond ast_ok ex ast ctx k
198 _ -> Left $ error_expr ex $
199 Error_Expr_Wrong_number_of_arguments ast 2
200 _ -> Left $ error_expr_unsupported ex ast
201 instance -- Expr_from AST Expr_Int
202 ( Type_from AST (Type_Root_of_Expr root)
203 , Expr_from AST root
204 , Type_Root_Lift Type_Int (Type_Root_of_Expr root)
205 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
206 ( Type_Root_of_Expr root)
207 AST)
208 (Error_of_Expr AST root)
209
210 , Type_Unlift Type_Int (Type_of_Expr root)
211 , Root_of_Expr root ~ root
212 , Implicit_HBool (Is_Last_Expr (Expr_Int root) root)
213 ) => Expr_from AST (Expr_Int root) where
214 expr_from ex ast =
215 case ast of
216 AST "int" asts -> lit_from_AST int type_int asts ex ast
217 AST "neg" asts -> op1_from_AST neg type_int asts ex ast
218 AST "add" asts -> op2_from_AST add type_int asts ex ast
219 _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
220 instance -- Expr_from AST Expr_Lambda
221 ( Type_from AST (Type_Root_of_Expr root)
222 , Expr_from AST root
223 , Type_Root_Lift (Type_Fun lam) (Type_Root_of_Expr root)
224 , Error_Expr_Lift (Error_Expr_Lambda AST)
225 (Error_of_Expr AST root)
226 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
227 ( Type_Root_of_Expr root)
228 AST)
229 (Error_of_Expr AST root)
230 , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
231 ( Type_Root_of_Expr root)
232 AST)
233 (Error_of_Expr AST root)
234 , Type_Unlift (Type_Fun lam) (Type_of_Expr root)
235 , Root_of_Expr root ~ root
236 , Implicit_HBool (Is_Last_Expr (Expr_Lambda lam root) root)
237 ) => Expr_from AST (Expr_Lambda lam root) where
238 expr_from ex ast ctx k =
239 case ast of
240 AST "var" asts ->
241 case asts of
242 [AST name []] -> var_from name ex ast ctx k
243 _ -> Left $ error_expr ex $
244 Error_Expr_Wrong_number_of_arguments ast 1
245 AST "app" asts ->
246 case asts of
247 [ast_lam, ast_arg_actual] ->
248 app_from ast_lam ast_arg_actual ex ast ctx k
249 _ -> Left $ error_expr ex $
250 Error_Expr_Wrong_number_of_arguments ast 2
251 AST "inline" asts -> go_lam asts inline
252 AST "val" asts -> go_lam asts val
253 AST "lazy" asts -> go_lam asts lazy
254 AST "let_inline" asts -> go_let asts let_inline
255 AST "let_val" asts -> go_let asts let_val
256 AST "let_lazy" asts -> go_let asts let_lazy
257 _ -> Left $ error_expr_unsupported ex ast
258 where
259 go_lam asts
260 (lam::forall repr arg res. Sym_Lambda lam repr
261 => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
262 case asts of
263 [AST name [], ast_ty_arg, ast_body] ->
264 lam_from lam name ast_ty_arg ast_body ex ast ctx k
265 _ -> Left $ error_expr ex $
266 Error_Expr_Wrong_number_of_arguments ast 3
267 go_let asts
268 (let_::forall repr var res. Sym_Lambda lam repr
269 => repr var -> (repr var -> repr res) -> repr res) =
270 case asts of
271 [AST name [], ast_var, ast_body] ->
272 let_from let_ name ast_var ast_body ex ast ctx k
273 _ -> Left $ error_expr ex $
274 Error_Expr_Wrong_number_of_arguments ast 3
275 instance -- Expr_from AST Expr_Maybe
276 ( Type_from AST (Type_Root_of_Expr root)
277 , Expr_from AST root
278 , Type_Root_Lift (Type_Fun lam) (Type_Root_of_Expr root)
279 , Type_Root_Lift Type_Maybe (Type_Root_of_Expr root)
280 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
281 ( Type_Root_of_Expr root)
282 AST)
283 (Error_of_Expr AST root)
284 , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
285 ( Type_Root_of_Expr root)
286 AST)
287 (Error_of_Expr AST root)
288 , Type_Unlift (Type_Fun lam) (Type_of_Expr root)
289 , Type_Unlift Type_Maybe (Type_of_Expr root)
290 , Root_of_Expr root ~ root
291 , Implicit_HBool (Is_Last_Expr (Expr_Maybe lam root) root)
292 ) => Expr_from AST (Expr_Maybe lam root) where
293 expr_from ex ast ctx k =
294 case ast of
295 AST "maybe" asts ->
296 case asts of
297 [ast_n, ast_j, ast_m] -> maybe_from ast_n ast_j ast_m ex ast ctx k
298 _ -> Left $ error_expr ex $
299 Error_Expr_Wrong_number_of_arguments ast 3
300 AST "nothing" asts ->
301 case asts of
302 [ast_ty_a] -> nothing_from ast_ty_a ex ast ctx k
303 _ -> Left $ error_expr ex $
304 Error_Expr_Wrong_number_of_arguments ast 1
305 AST "just" asts ->
306 case asts of
307 [ast_a] -> just_from ast_a ex ast ctx k
308 _ -> Left $ error_expr ex $
309 Error_Expr_Wrong_number_of_arguments ast 1
310 _ -> Left $ error_expr_unsupported ex ast
311 instance -- Expr_from AST Expr_Eq
312 ( Type_from AST (Type_Root_of_Expr root)
313 , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
314 , Type_Constraint Eq (Type_Root_of_Expr root)
315 , Expr_from AST root
316 , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
317 ( Type_Root_of_Expr root)
318 AST)
319 (Error_of_Expr AST root)
320 , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
321 ( Type_Root_of_Expr root)
322 AST)
323 (Error_of_Expr AST root)
324 , Root_of_Expr root ~ root
325 , Implicit_HBool (Is_Last_Expr (Expr_Eq root) root)
326 ) => Expr_from AST (Expr_Eq root) where
327 expr_from ex ast ctx k =
328 case ast of
329 AST "eq" asts ->
330 case asts of
331 [ast_x, ast_y] -> eq_from ast_x ast_y ex ast ctx k
332 _ -> Left $ error_expr ex $
333 Error_Expr_Wrong_number_of_arguments ast 2
334 _ -> Left $ error_expr_unsupported ex ast
335
336 lit_from_AST
337 :: forall root ty lit ex ast hs ret.
338 ( ty ~ Type_Root_of_Expr ex
339 , root ~ Root_of_Expr ex
340 , ast ~ AST
341 , Read lit
342 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
343 (Error_of_Expr ast root)
344 ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
345 -> ty lit -> [ast]
346 -> Expr_From ast ex hs ret
347 lit_from_AST op ty_lit asts ex ast ctx k =
348 case asts of
349 [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
350 _ -> Left $ error_expr ex $
351 Error_Expr_Wrong_number_of_arguments ast 1
352
353 op1_from_AST
354 :: forall root ty lit ex ast hs ret.
355 ( ty ~ Type_Root_of_Expr ex
356 , root ~ Root_of_Expr ex
357 , ast ~ AST
358 , Type_Eq (Type_Root_of_Expr root)
359 , Expr_from ast root
360 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
361 (Error_of_Expr ast root)
362 , Root_of_Expr root ~ root
363 ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
364 -> ty lit -> [ast]
365 -> Expr_From ast ex hs ret
366 op1_from_AST op ty_lit asts ex ast ctx k =
367 case asts of
368 [ast_x] -> op1_from op ty_lit ast_x ex ast ctx k
369 _ -> Left $ error_expr ex $
370 Error_Expr_Wrong_number_of_arguments ast 1
371
372 op2_from_AST
373 :: forall root ty lit ex ast hs ret.
374 ( ty ~ Type_Root_of_Expr ex
375 , root ~ Root_of_Expr ex
376 , ast ~ AST
377 , Type_Eq (Type_Root_of_Expr root)
378 , Expr_from ast root
379 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
380 (Error_of_Expr ast root)
381 , Root_of_Expr root ~ root
382 ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
383 -> ty lit -> [ast]
384 -> Expr_From ast ex hs ret
385 op2_from_AST op ty_lit asts ex ast ctx k =
386 case asts of
387 [ast_x, ast_y] -> op2_from op ty_lit ast_x ast_y ex ast ctx k
388 _ -> Left $ error_expr ex $
389 Error_Expr_Wrong_number_of_arguments ast 2