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 Control.Arrow (left)
  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, (||), (==), (<$>), (+), 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 = val (\x -> val $ \y -> x + y)
  31  <$> just (int 1)
  32  <*> just (int 2)
  33
  34 -- * Tests
  35 type Ex lam = Expr_Root
  36  (   Expr_Lambda_App lam
  37  .|. Expr_Lambda_Val lam
  38  .|. Expr_List lam
  39  .|. Expr_Maybe lam
  40  .|. Expr_Int
  41  .|. Expr_Bool
  42  .|. Expr_Functor lam
  43  .|. Expr_Applicative lam
  44  )
  45 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  46
  47 (==>) ast expected =
  48         testCase (show ast) $
  49         case ex_from ast of
  50          Left err -> Left err @?= snd `left` expected
  51          Right (Exists_Type_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 Identity) h, _::h, _::Text) ->
  55                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  56                         case ty `eq_type` ty_expected of
  57                          Nothing -> return $ Left $
  58                                 error_expr (Proxy::Proxy (Ex Identity)) $
  59                                 Error_Expr_Type_mismatch ast
  60                                  (Exists_Type ty)
  61                                  (Exists_Type ty_expected)
  62                          Just Refl -> do
  63                                 let h = runIdentity $ host_from_expr r
  64                                 return $
  65                                         Right
  66                                          ( ty
  67                                          , h
  68                                          , text_from_expr r
  69                                          -- , (text_from_expr :: Repr_String Identity h -> Text) r
  70                                          )
  71
  72 tests :: TestTree
  73 tests = testGroup "Applicative"
  74  [ AST "<*>"
  75          [ AST "<$>"
  76                  [ AST "val"
  77                          [ AST "x" [], AST "Int" []
  78                          , AST "val"
  79                                  [ AST "y" [], AST "Int" []
  80                                  , AST "+" [ AST "var" [AST "x" []]
  81                                            , AST "var" [AST "y" []] ]
  82                                  ]
  83                          ]
  84                  , AST "just" [ AST "int" [AST "1" []] ]
  85                  ]
  86          , AST "just" [ AST "int" [AST "2" []] ]
  87          ] ==> Right
  88          ( type_maybe type_int
  89          , Just 3
  90          , "fmap (\\x0 -> (\\x1 -> x0 + x1)) (just 1) <*> just 2" )
  91  ]