]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Expr/Maybe/Test.hs
init
[haskell/symantic.git] / Language / Symantic / Expr / Maybe / Test.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeOperators #-}
7 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
8 module Expr.Maybe.Test where
9
10 import Test.Tasty
11 import Test.Tasty.HUnit
12
13 import Control.Arrow (left)
14 import Data.Proxy (Proxy(..))
15 import Data.Text (Text)
16 import Data.Type.Equality ((:~:)(Refl))
17 import Prelude hiding (maybe, not)
18
19 import Language.Symantic.Repr
20 import Language.Symantic.Expr
21 import Language.Symantic.Type
22
23 import AST.Test
24
25 -- * Expressions
26 e1 = maybe (bool True) (val not) (just $ bool True)
27
28 -- * Tests
29 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_Maybe lam .|. Expr_Bool)
30 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
31
32 (==>) ast expected =
33 testCase (show ast) $
34 case ex_from ast of
35 Left err -> Left err @?= snd `left` expected
36 Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
37 case expected of
38 Left (_, err) -> Right ("…"::String) @?= Left err
39 Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
40 (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
41 case ty `eq_type` ty_expected of
42 Nothing -> return $ Left $
43 error_expr (Proxy::Proxy (Ex IO)) $
44 Error_Expr_Type_mismatch ast
45 (Exists_Type ty)
46 (Exists_Type ty_expected)
47 Just Refl -> do
48 h <- host_from_expr r
49 return $
50 Right
51 ( ty
52 , h
53 , text_from_expr r
54 -- , (text_from_expr :: Repr_String IO h -> Text) r
55 )
56
57 tests :: TestTree
58 tests = testGroup "Maybe"
59 [ AST "just" [AST "bool" [AST "True" []]] ==> Right
60 ( type_maybe type_bool
61 , Just True
62 , "just True" )
63 , AST "just"
64 [ AST "let_val"
65 [ AST "x" []
66 , AST "bool" [AST "True" []]
67 , AST "var" [AST "x" []]
68 ]
69 ] ==> Right
70 ( type_maybe type_bool
71 , Just True
72 , "just (let x0 = True in x0)" )
73 , AST "maybe"
74 [ AST "bool" [AST "True" []]
75 , AST "val"
76 [ AST "x" []
77 , AST "Bool" []
78 , AST "not" [AST "var" [AST "x" []]]
79 ]
80 , AST "nothing"
81 [ AST "Bool" []
82 ]
83 ] ==> Right
84 ( type_bool
85 , True
86 , "maybe True (\\x0 -> !x0) nothing" )
87 , AST "maybe"
88 [ AST "bool" [AST "False" []]
89 , AST "val"
90 [ AST "x" []
91 , AST "Bool" []
92 , AST "not" [AST "var" [AST "x" []]]
93 ]
94 , AST "just"
95 [ AST "bool" [AST "True" []]
96 ]
97 ] ==> Right
98 ( type_bool
99 , False
100 , "maybe False (\\x0 -> !x0) (just True)" )
101 ]