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 Control.Arrow (left)
  14 import Data.Proxy (Proxy(..))
  15 import Data.Text (Text)
  16 import Data.Type.Equality ((:~:)(Refl))
  17 import Prelude hiding ((&&), not, (||), (==), fmap, (+))
  18
  19 import Language.Symantic.Type
  20 import Language.Symantic.Expr as Expr
  21 import Language.Symantic.Repr
  22
  23 import AST.Test
  24
  25 -- * Expressions
  26 t = bool True
  27 f = bool False
  28 e1 = fmap (val $ \x -> x + int 1) (list $ int <$> [0..3])
  29
  30 -- * Tests
  31 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_List lam .|. Expr_Functor lam .|. Expr_Int .|. Expr_Bool)
  32 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  33
  34 (==>) ast expected =
  35         testCase (show ast) $
  36         case ex_from ast of
  37          Left err -> Left err @?= snd `left` expected
  38          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  39                 case expected of
  40                  Left (_, err) -> Right ("…"::String) @?= Left err
  41                  Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
  42                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  43                         case ty `eq_type` ty_expected of
  44                          Nothing -> return $ Left $
  45                                 error_expr (Proxy::Proxy (Ex IO)) $
  46                                 Error_Expr_Type_mismatch ast
  47                                  (Exists_Type ty)
  48                                  (Exists_Type ty_expected)
  49                          Just Refl -> do
  50                                 h <- host_from_expr r
  51                                 return $
  52                                         Right
  53                                          ( ty
  54                                          , h
  55                                          , text_from_expr r
  56                                          -- , (text_from_expr :: Repr_String IO h -> Text) r
  57                                          )
  58
  59 tests :: TestTree
  60 tests = testGroup "Functor"
  61  [ AST "fmap"
  62          [ AST "val"
  63                  [ AST "x" []
  64                  , AST "Int" []
  65                  , AST "+" [ AST "var" [AST "x" []]
  66                            , AST "int" [AST "1" []] ]
  67                  ]
  68          , AST "list"
  69                  [ AST "Int" []
  70                  , AST "int" [AST "1" []]
  71                  , AST "int" [AST "2" []]
  72                  , AST "int" [AST "3" []]
  73                  ]
  74          ] ==> Right
  75          ( type_list type_int
  76          , [2,3,4]
  77          , "fmap (\\x0 -> x0 + 1) [1, 2, 3]" )
  78  ]