Language/LOL/Symantic/Expr/If/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   7 module Expr.If.Test where
   8
   9 import Test.Tasty
  10 import Test.Tasty.HUnit
  11
  12 import Control.Arrow (left)
  13 import Data.Proxy (Proxy(..))
  14 import Data.Text (Text)
  15 import Data.Type.Equality ((:~:)(Refl))
  16 import Prelude hiding (maybe, not)
  17
  18 import Language.LOL.Symantic.Repr
  19 import Language.LOL.Symantic.AST
  20 import Language.LOL.Symantic.Expr
  21 import Language.LOL.Symantic.Type
  22
  23 -- * Expressions
  24 e1 = if_ (bool True)
  25          (bool False)
  26          (bool True)
  27
  28 -- * Tests
  29 (==>) ast expected =
  30         testCase (show ast) $
  31         case expr_lambda_if_bool_from (Proxy::Proxy IO) ast of
  32          Left err -> Left err @?= snd `left` expected
  33          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  34                 case expected of
  35                  Left (_, err) -> Right ("…"::String) @?= Left err
  36                  Right (ty_expected::Type_Root_of_Expr (Expr_Lambda_If_Bool IO) h, _::h, _::Text) ->
  37                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  38                         case ty `type_eq` ty_expected of
  39                          Nothing -> return $ Left $
  40                                 error_expr (Proxy::Proxy (Expr_Lambda_If_Bool IO)) $
  41                                 Error_Expr_Type_mismatch ast
  42                                  (Exists_Type ty)
  43                                  (Exists_Type ty_expected)
  44                          Just Refl -> do
  45                                 h <- host_from_expr r
  46                                 return $
  47                                         Right
  48                                          ( ty
  49                                          , h
  50                                          , text_from_expr r
  51                                          -- , (text_from_expr :: Repr_String IO h -> String) r
  52                                          )
  53
  54 tests :: TestTree
  55 tests = testGroup "If"
  56  [ AST "if"
  57          [ AST "bool" [AST "True" []]
  58          , AST "bool" [AST "False" []]
  59          , AST "bool" [AST "True" []]
  60          ] ==> Right
  61          ( type_bool
  62          , False
  63          , "if True then False else True" )
  64  ]