Language/Symantic/Expr/Bool/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.Bool.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.Functor.Identity
  16 -- import Control.Monad.IO.Class (MonadIO(..))
  17 import Data.Proxy (Proxy(..))
  18 import Data.Text (Text)
  19 import Data.Type.Equality ((:~:)(Refl))
  20 import Prelude hiding ((&&), not, (||))
  21
  22 import Language.Symantic.Repr
  23 import Language.Symantic.Expr
  24 import Language.Symantic.Type
  25 import Language.Symantic.Trans
  26
  27 import AST.Test
  28
  29 -- * Class 'Sym_Bool_Vars'
  30
  31 -- | A few boolean variables.
  32 class Sym_Bool_Vars repr where
  33         x :: repr Bool
  34         y :: repr Bool
  35         z :: repr Bool
  36 instance Sym_Bool_Vars (Repr_Text fun) where
  37         x = Repr_Text $ \_p _v -> "x"
  38         y = Repr_Text $ \_p _v -> "y"
  39         z = Repr_Text $ \_p _v -> "z"
  40 instance -- Trans_Boo_Const
  41  ( Sym_Bool repr
  42  , Sym_Bool_Vars repr
  43  ) => Sym_Bool_Vars (Trans_Bool_Const repr) where
  44         x = trans_lift x
  45         y = trans_lift y
  46         z = trans_lift z
  47
  48 -- * Expressions
  49 e1 = bool True && bool False
  50 e2 = (bool True && bool False) ||  (bool True && bool True)
  51 e3 = (bool True ||  bool False) && (bool True ||  bool True)
  52 e4 = bool True && not (bool False)
  53 e5 = bool True && not x
  54 e6 = x `xor` y
  55 e7 = (x `xor` y) `xor` z
  56 e8 = x `xor` (y `xor` bool True)
  57
  58 -- * Tests
  59 type Ex lam = Expr_Root
  60  (   Expr_Lambda_App lam
  61  .|. Expr_Lambda_Val lam
  62  .|. Expr_Bool
  63  )
  64 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  65
  66 (==>) ast expected =
  67         testCase (show ast) $
  68         case ex_from ast of
  69          Left err -> Left err @?= snd `Arrow.left` expected
  70          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  71                 case expected of
  72                  Left (_, err) -> Right ("…"::String) @?= Left err
  73                  Right (ty_expected::Type_Root_of_Expr (Ex Identity) h, _::h, _::Text) ->
  74                         (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
  75                         case ty `eq_type` ty_expected of
  76                          Nothing -> Monad.return $ Left $
  77                                 error_expr (Proxy::Proxy (Ex Identity)) $
  78                                 Error_Expr_Type_mismatch ast
  79                                  (Exists_Type ty)
  80                                  (Exists_Type ty_expected)
  81                          Just Refl -> do
  82                                 let h = runIdentity $ host_from_expr r
  83                                 Monad.return $
  84                                         Right
  85                                          ( ty
  86                                          , h
  87                                          , text_from_expr r
  88                                          -- , (text_from_expr :: Repr_Text Identity h -> Text) r
  89                                          )
  90
  91 tests :: TestTree
  92 tests = testGroup "Bool" $
  93  [ AST "bool" [AST "True" []] ==> Right
  94          ( type_bool
  95          , True
  96          , "True" )
  97  , AST "int" [AST "1" []] ==> Left (Proxy::Proxy Int,
  98         Error_Expr_Alt_Curr $
  99         Error_Expr_Unsupported $ AST "int" [AST "1" []])
 100  , AST "xor"
 101          [ AST "bool" [AST "True" []]
 102          , AST "bool" [AST "True" []]
 103          ] ==> Right
 104          ( type_bool
 105          , False
 106          , "xor True True" )
 107  , AST "app"
 108          [ AST "val"
 109                  [ AST "x" []
 110                  , AST "Bool" []
 111                  , AST "var" [AST "x" []]
 112                  ]
 113          , AST "bool" [AST "True" []]
 114          ] ==> Right
 115          ( type_bool
 116          , True
 117          , "(\\x0 -> x0) True" )
 118  , let ast = AST "app"
 119          [ AST "bool" [AST "True" []]
 120          , AST "bool" [AST "True" []]
 121          ] in ast ==> Left (Proxy::Proxy Bool,
 122         Error_Expr_Alt_Curr $
 123         Error_Expr_Type_mismatch ast
 124          (Exists_Type (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
 125          ::Type_Root (Type_Var0 :|: Type_Var1 :|: Type_Fun Identity :|: Type_Bool)
 126                      (Lambda Identity Var0 Var0)))
 127          (Exists_Type type_bool))
 128  , AST "app"
 129          [ AST "val"
 130                  [ AST "x" []
 131                  , AST "Bool" []
 132                  , AST "xor"
 133                          [ AST "var" [AST "x" []]
 134                          , AST "bool" [AST "True" []]
 135                          ]
 136                  ]
 137          , AST "bool" [AST "True" []]
 138          ] ==> Right
 139          ( type_bool
 140          , False
 141          , "(\\x0 -> xor x0 True) True" )
 142  , AST "let_val"
 143          [ AST "x" []
 144          , AST "bool" [AST "True" []]
 145          , AST "xor"
 146                  [ AST "var" [AST "x" []]
 147                  , AST "bool" [AST "True" []]
 148                  ]
 149          ] ==> Right
 150          ( type_bool
 151          , False
 152          , "let x0 = True in xor x0 True" )
 153  ]