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