]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Expr/Int/Test.hs
init
[haskell/symantic.git] / Language / Symantic / Expr / Int / 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.Int.Test where
9
10 import Test.Tasty
11 import Test.Tasty.HUnit
12
13 import Control.Arrow (left)
14 -- import Data.Functor.Identity (Identity)
15 -- import Control.Monad.IO.Class (MonadIO(..))
16 import Data.Proxy (Proxy(..))
17 import Data.Text (Text)
18 import Data.Type.Equality ((:~:)(Refl))
19 import Prelude hiding ((&&), not, (||), (+), negate)
20
21 import Language.Symantic.Repr
22 import Language.Symantic.Expr
23 import Language.Symantic.Type
24 -- import Language.Symantic.Trans
25
26 import AST.Test
27
28 -- * Class 'Sym_Int_Vars'
29
30 -- | A few boolean variables.
31 class Sym_Int_Vars repr where
32 x :: repr Int
33 y :: repr Int
34 z :: repr Int
35 instance Sym_Int_Vars (Repr_Text fun) where
36 x = Repr_Text $ \_p _v -> "x"
37 y = Repr_Text $ \_p _v -> "y"
38 z = Repr_Text $ \_p _v -> "z"
39
40 -- * Expressions
41 e1 = int 1 + int 0
42 e2 = (int 1 + int 0) + negate (int 1 + int 1)
43 e3 = (int 1 + negate (int 0)) + (int 1 + negate (int 1))
44 e4 = int 0 + negate (int 1)
45 e5 = int 1 + negate x
46 e6 = x + y
47 e7 = (x + y) + z
48 e8 = x + (y + int 1)
49
50 -- * Tests
51 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_Int)
52 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
53
54 (==>) ast expected =
55 testCase (show ast) $
56 case ex_from ast of
57 Left err -> Left err @?= snd `left` expected
58 Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
59 case expected of
60 Left (_, err) -> Right ("…"::String) @?= Left err
61 Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
62 (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
63 case ty `eq_type` ty_expected of
64 Nothing -> return $ Left $
65 error_expr (Proxy::Proxy (Ex IO)) $
66 Error_Expr_Type_mismatch ast
67 (Exists_Type ty)
68 (Exists_Type ty_expected)
69 Just Refl -> do
70 h <- host_from_expr r
71 return $
72 Right
73 ( ty
74 , h
75 , text_from_expr r
76 -- , (text_from_expr :: Repr_Text IO h -> String) r
77 )
78
79 tests :: TestTree
80 tests = testGroup "Int" $
81 [ AST "int" [AST "1" []] ==> Right
82 ( type_int
83 , 1
84 , "1" )
85 , AST "bool" [AST "True" []] ==> Left (Proxy::Proxy Bool,
86 Error_Expr_Alt_Curr $
87 Error_Expr_Unsupported $ AST "bool" [AST "True" []])
88 , AST "+"
89 [ AST "int" [AST "1" []]
90 , AST "int" [AST "1" []]
91 ] ==> Right
92 ( type_int
93 , 2
94 , "1 + 1" )
95 , let ast = AST "app"
96 [ AST "int" [AST "1" []]
97 , AST "int" [AST "1" []]
98 ] in ast ==> Left (Proxy::Proxy Int,
99 Error_Expr_Alt_Curr $
100 Error_Expr_Type_mismatch ast
101 (Exists_Type (type_var SZero `type_fun` type_var (SSucc SZero)
102 ::Type_Root (Type_Var :|: Type_Fun IO :|: Type_Int)
103 (Lambda IO Zero (Succ Zero))))
104 (Exists_Type type_int))
105 , AST "app"
106 [ AST "val"
107 [ AST "x" []
108 , AST "Int" []
109 , AST "var" [AST "x" []]
110 ]
111 , AST "int" [AST "1" []]
112 ] ==> Right
113 ( type_int
114 , 1
115 , "(\\x0 -> x0) 1" )
116 , AST "app"
117 [ AST "val"
118 [ AST "x" []
119 , AST "Int" []
120 , AST "+"
121 [ AST "var" [AST "x" []]
122 , AST "int" [AST "1" []]
123 ]
124 ]
125 , AST "int" [AST "1" []]
126 ] ==> Right
127 ( type_int
128 , 2
129 , "(\\x0 -> x0 + 1) 1" )
130 , AST "let_val"
131 [ AST "x" []
132 , AST "int" [AST "1" []]
133 , AST "+"
134 [ AST "var" [AST "x" []]
135 , AST "int" [AST "1" []]
136 ]
137 ] ==> Right
138 ( type_int
139 , 2
140 , "let x0 = 1 in x0 + 1" )
141 ]