{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Expr.Bool.Test where

import Test.Tasty
import Test.Tasty.HUnit

-- import Data.Functor.Identity (Identity)
-- import Control.Monad.IO.Class (MonadIO(..))
import Data.Proxy (Proxy(..))
import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding (and, or)

import TFHOE.Repr
import TFHOE.Raw
import TFHOE.Expr
import TFHOE.Type
-- import TFHOE.Expr.Trans

-- * Class 'Expr_Bool_Vars'

-- | A few boolean variables.
class Expr_Bool_Vars repr where
	x :: repr Bool
	y :: repr Bool
	z :: repr Bool
instance Expr_Bool_Vars (Repr_String fun) where
	x = Repr_String $ \_p _v -> "x"
	y = Repr_String $ \_p _v -> "y"
	z = Repr_String $ \_p _v -> "z"
{-
instance -- Trans_Boo_Const
 ( Expr_Bool_Vars repr
 , Expr_Lit repr
 ) => Expr_Bool_Vars (Trans_Bool_Const repr) where
	x = trans_lift x
	y = trans_lift y
	z = trans_lift z
-}

-- * 'Expr's
e1 = bool True `and` bool False
e2 = (bool True `and` bool False) `or`  (bool True `and` bool True)
e3 = (bool True `or`  bool False) `and` (bool True `or`  bool True)
e4 = bool True `and` neg (bool False)
e5 = bool True `and` neg x
e6 = x `xor` y
e7 = (x `xor` y) `xor` z
e8 = x `xor` (y `xor` bool True)

(==>) raw expected@(ty_expected::Type_Fun_Bool_Int IO Type_End h, _::h, _::String) =
	testCase (show raw) $
		(>>= (@?= Right expected)) $
		case expr_fun_bool_int_from Proxy Proxy raw of
		 Left err -> return $ Left err
		 Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
			case ty `type_eq` ty_expected of
			 Nothing -> return $ Left "Type mismatch"
			 Just Refl -> do
				h <- host_repr r
				return $
					Right
					 ( ty
					 , h
					 , string_repr r
					 -- , (string_repr :: Repr_String IO h -> String) r
					 )

tests :: TestTree
tests = testGroup "Bool" $
 [ Raw "bool" [Raw "True" []] ==>
	 ( Type_Fun_Next Type_Bool
	 , True
	 , "True" )
 , Raw "xor"
	 [ Raw "bool" [Raw "True" []]
	 , Raw "bool" [Raw "True" []]
	 ] ==>
	 ( Type_Fun_Next Type_Bool
	 , False
	 , "(True | True) & !(True & True)" )
 , Raw "app"
	 [ Raw "val"
		 [ Raw "x" []
		 , Raw "Bool" []
		 , Raw "var" [Raw "x" []]
		 ]
	 , Raw "bool" [Raw "True" []]
	 ] ==>
	 ( Type_Fun_Next Type_Bool
	 , True
	 , "(\\x0 -> x0) True" )
 , Raw "app"
	 [ Raw "val"
		 [ Raw "x" []
		 , Raw "Bool" []
		 , Raw "xor"
			 [ Raw "var" [Raw "x" []]
			 , Raw "bool" [Raw "True" []]
			 ]
		 ]
	 , Raw "bool" [Raw "True" []]
	 ] ==>
	 ( Type_Fun_Next Type_Bool
	 , False
	 , "(\\x0 -> (x0 | True) & !(x0 & True)) True" )
 ]

{-
-- * Bool
raw_ty_bool :: Raw
raw_ty_bool = Raw "Bool" []

ty_bool
 :: forall repr.
 Either Error_Type (Type_Fun_Bool_End repr Bool)
ty_bool = type_from raw_ty_bool $ \(ty::Type_Fun_Bool_End repr h) ->
	case ty of
	 Type_Fun_Next Type_Bool -> Right ty
	 _ -> Left "error"

-- ** Bool -> Bool
raw_ty_bool2bool :: Raw
raw_ty_bool2bool = Raw "->" [Raw "Bool" [], Raw "Bool" []]

ty0_bool2bool
 :: forall repr.
 Either Error_Type (Type_Fun_Bool_End repr (repr Bool -> repr Bool))
ty0_bool2bool = type_from raw_ty_bool2bool $ \(ty::Type_Fun_Bool_End repr h) ->
	case ty of
	 Type_Fun
	  (Type_Fun_Next Type_Bool)
	  (Type_Fun_Next Type_Bool) -> Right ty
	 _ -> Left "error"

-- ** Bool -> Bool
raw_xor_true :: Raw
raw_xor_true =
	Raw "lam"
	 [ Raw "x" []
	 , raw_ty_bool
	 , Raw "xor"
		 [ Raw "var" [Raw "x" []]
		 , Raw "bool" [Raw "True" []]
		 ]
	 ]

expr_bool_xor_true
 :: forall repr. MonadIO repr =>
 Either Error_Type (repr (Repr_Host repr Bool -> Repr_Host repr Bool))
expr_bool_xor_true =
	expr_fun_bool_int_from
	 (Proxy::Proxy Type_End)
	 raw_xor_true $ \ty (repr::Repr_Host repr h) ->
		case ty of
		 Type_Fun
		  (Type_Fun_Next Type_Bool)
		  (Type_Fun_Next Type_Bool) ->
			Right $ meta_repr repr
		 _ -> Left "error"
-}