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_Bool
  41  .|. Expr_Functor
  42  .|. Expr_Applicative
  43  )
  44 ex_from = root_expr_from (Proxy::Proxy Ex)
  45
  46 (==>) ast expected =
  47         testCase (show ast) $
  48         case ex_from ast of
  49          Left err -> Left err @?= Prelude.snd `Arrow.left` expected
  50          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  51                 case expected of
  52                  Left (_, err) -> Right ("…"::String) @?= Left err
  53                  Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
  54                         (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
  55                         case ty `eq_type` ty_expected of
  56                          Nothing -> Monad.return $ Left $
  57                                 error_expr (Proxy::Proxy Ex) $
  58                                 Error_Expr_Type_mismatch ast
  59                                  (Exists_Type ty)
  60                                  (Exists_Type ty_expected)
  61                          Just Refl -> do
  62                                 let h = host_from_expr r
  63                                 Monad.return $
  64                                         Right
  65                                          ( ty
  66                                          , h
  67                                          , text_from_expr r
  68                                          -- , (text_from_expr :: Repr_Text h -> Text) r
  69                                          )
  70
  71 tests :: TestTree
  72 tests = testGroup "Applicative"
  73  [ AST "<*>"
  74          [ AST "<$>"
  75                  [ AST "\\"
  76                          [ AST "x" [], AST "Int" []
  77                          , AST "\\"
  78                                  [ AST "y" [], AST "Int" []
  79                                  , AST "+" [ AST "var" [AST "x" []]
  80                                            , AST "var" [AST "y" []] ]
  81                                  ]
  82                          ]
  83                  , AST "just" [ AST "int" [AST "1" []] ]
  84                  ]
  85          , AST "just" [ AST "int" [AST "2" []] ]
  86          ] ==> Right
  87          ( type_maybe type_int
  88          , Just 3
  89          , "fmap (\\x0 -> (\\x1 -> x0 + x1)) (just 1) <*> just 2" )
  90  ]