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