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