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