]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Expr/Functor/Test.hs
init
[haskell/symantic.git] / Language / Symantic / Expr / Functor / Test.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeOperators #-}
6 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
7
8 module Expr.Functor.Test where
9
10 import Test.Tasty
11 import Test.Tasty.HUnit
12
13 import qualified Control.Arrow as Arrow
14 import qualified Control.Monad as Monad
15 import Data.Functor.Identity
16 import Data.Proxy (Proxy(..))
17 import Data.Text (Text)
18 import Data.Type.Equality ((:~:)(Refl))
19 import Prelude hiding ((&&), not, (||), (==), fmap, (+))
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 = fmap (val $ \x -> x + int 1) (list $ int Prelude.<$> [1..3])
31
32 -- * Tests
33 type Ex lam = Expr_Root
34 ( Expr_Lambda_App lam
35 .|. Expr_Lambda_Val lam
36 .|. Expr_Maybe lam
37 .|. Expr_List lam
38 .|. Expr_Functor lam
39 .|. Expr_Int
40 .|. Expr_Bool
41 )
42 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
43
44 (==>) ast expected =
45 testCase (show ast) $
46 case ex_from ast of
47 Left err -> Left err @?= snd `Arrow.left` expected
48 Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
49 case expected of
50 Left (_, err) -> Right ("…"::String) @?= Left err
51 Right (ty_expected::Type_Root_of_Expr (Ex Identity) h, _::h, _::Text) ->
52 (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
53 case ty `eq_type` ty_expected of
54 Nothing -> Monad.return $ Left $
55 error_expr (Proxy::Proxy (Ex Identity)) $
56 Error_Expr_Type_mismatch ast
57 (Exists_Type ty)
58 (Exists_Type ty_expected)
59 Just Refl -> do
60 let h = runIdentity $ host_from_expr r
61 Monad.return $
62 Right
63 ( ty
64 , h
65 , text_from_expr r
66 -- , (text_from_expr :: Repr_Text Identity h -> Text) r
67 )
68
69 tests :: TestTree
70 tests = testGroup "Functor"
71 [ AST "fmap"
72 [ AST "val"
73 [ AST "x" []
74 , AST "Int" []
75 , AST "+" [ AST "var" [AST "x" []]
76 , AST "int" [AST "1" []] ]
77 ]
78 , AST "list"
79 [ AST "Int" []
80 , AST "int" [AST "1" []]
81 , AST "int" [AST "2" []]
82 , AST "int" [AST "3" []]
83 ]
84 ] ==> Right
85 ( type_list type_int
86 , [2,3,4]
87 , "fmap (\\x0 -> x0 + 1) [1, 2, 3]" )
88 ]