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