Language/Symantic/Expr/If/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   8 module Expr.If.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 (maybe, not, (&&), Monad(..))
  19
  20 import Language.Symantic.Repr
  21 import Language.Symantic.Expr
  22 import Language.Symantic.Type
  23
  24 import AST.Test
  25
  26 -- * Expressions
  27 e1 = if_ (bool True) (bool False) (bool True)
  28 e2 = if_ (bool True && bool True) (bool False) (bool True)
  29
  30 -- * Tests
  31 type Ex = Expr_Root
  32  (   Expr_Lambda
  33  .|. Expr_If
  34  .|. Expr_Bool
  35  )
  36 ex_from = root_expr_from (Proxy::Proxy Ex)
  37
  38 (==>) ast expected =
  39         testCase (show ast) $
  40         case ex_from ast of
  41          Left err -> Left err @?= Prelude.snd `Arrow.left` expected
  42          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  43                 case expected of
  44                  Left (_, err) -> Right ("…"::String) @?= Left err
  45                  Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
  46                         (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
  47                         case ty `eq_type` ty_expected of
  48                          Nothing -> Monad.return $ Left $
  49                                 error_expr (Proxy::Proxy Ex) $
  50                                 Error_Expr_Type_mismatch ast
  51                                  (Exists_Type ty)
  52                                  (Exists_Type ty_expected)
  53                          Just Refl -> do
  54                                 let h = host_from_expr r
  55                                 Monad.return $
  56                                         Right
  57                                          ( ty
  58                                          , h
  59                                          , text_from_expr r
  60                                          -- , (text_from_expr :: Repr_Text h -> Text) r
  61                                          )
  62
  63 tests :: TestTree
  64 tests = testGroup "If"
  65  [ AST "if"
  66          [ AST "bool" [AST "True" []]
  67          , AST "bool" [AST "False" []]
  68          , AST "bool" [AST "True" []]
  69          ] ==> Right
  70          ( type_bool
  71          , False
  72          , "if True then False else True" )
  73  ]