Language/Symantic/Expr/MonoFunctor/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.MonoFunctor.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.Proxy (Proxy(..))
  16 import Data.Text (Text)
  17 import Data.Type.Equality ((:~:)(Refl))
  18 import Prelude hiding ((&&), not, (||), (==), fmap, (+))
  19
  20 import Language.Symantic.Type
  21 import Language.Symantic.Expr as Expr
  22 import Language.Symantic.Repr
  23
  24 import AST.Test
  25
  26 -- * Expressions
  27 t = bool True
  28 f = bool False
  29 e1 = omap (lam $ \x -> x + int 1) (list $ int Prelude.<$> [1..3])
  30 e2 = omap (lam char_toUpper) (text "abcde")
  31
  32 -- * Tests
  33 type Ex = Expr_Root
  34  (   Expr_Lambda
  35  .|. Expr_Maybe
  36  .|. Expr_List
  37  .|. Expr_MonoFunctor
  38  .|. Expr_Int
  39  .|. Expr_Integer
  40  .|. Expr_Num
  41  .|. Expr_Bool
  42  .|. Expr_Char
  43  .|. Expr_Text
  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 "MonoFunctor"
  74  [ AST "omap"
  75          [ AST "\\"
  76                  [ AST "x" []
  77                  , AST "Int" []
  78                  , AST "+" [ AST "var" [AST "x" []]
  79                            , AST "int" [AST "1" []] ]
  80                  ]
  81          , AST "list"
  82                  [ AST "Int" []
  83                  , AST "int" [AST "1" []]
  84                  , AST "int" [AST "2" []]
  85                  , AST "int" [AST "3" []]
  86                  ]
  87          ] ==> Right
  88          ( type_list type_int
  89          , [2,3,4]
  90          , "omap (\\x0 -> x0 + 1) [1, 2, 3]" )
  91  , AST "omap"
  92          [ AST "\\"
  93                  [ AST "x" []
  94                  , AST "Char" []
  95                  , AST "char_toUpper" [ AST "var" [AST "x" []] ]
  96                  ]
  97          , AST "text" [ AST "abcde" [] ]
  98          ] ==> Right
  99          ( type_text
 100          , "ABCDE"
 101          , "omap (\\x0 -> char_toUpper x0) \"abcde\"" )
 102  ]