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  ]