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