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 Control.Arrow (left)
  14 import Data.Proxy (Proxy(..))
  15 import Data.Text (Text)
  16 import Data.Type.Equality ((:~:)(Refl))
  17 import Prelude hiding (maybe, not, (&&))
  18
  19 import Language.Symantic.Repr
  20 import Language.Symantic.Expr
  21 import Language.Symantic.Type
  22
  23 import AST.Test
  24
  25 -- * Expressions
  26 e1 = if_ (bool True) (bool False) (bool True)
  27 e2 = if_ (bool True && bool True) (bool False) (bool True)
  28
  29 -- * Tests
  30 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_If .|. Expr_Bool)
  31 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  32
  33 (==>) ast expected =
  34         testCase (show ast) $
  35         case ex_from ast of
  36          Left err -> Left err @?= snd `left` expected
  37          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  38                 case expected of
  39                  Left (_, err) -> Right ("…"::String) @?= Left err
  40                  Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
  41                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  42                         case ty `type_eq` ty_expected of
  43                          Nothing -> return $ Left $
  44                                 error_expr (Proxy::Proxy (Ex IO)) $
  45                                 Error_Expr_Type_mismatch ast
  46                                  (Exists_Type ty)
  47                                  (Exists_Type ty_expected)
  48                          Just Refl -> do
  49                                 h <- host_from_expr r
  50                                 return $
  51                                         Right
  52                                          ( ty
  53                                          , h
  54                                          , text_from_expr r
  55                                          -- , (text_from_expr :: Repr_String IO h -> String) r
  56                                          )
  57
  58 tests :: TestTree
  59 tests = testGroup "If"
  60  [ AST "if"
  61          [ AST "bool" [AST "True" []]
  62          , AST "bool" [AST "False" []]
  63          , AST "bool" [AST "True" []]
  64          ] ==> Right
  65          ( type_bool
  66          , False
  67          , "if True then False else True" )
  68  ]