{-# 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 Control.Arrow (left)
-- import Data.Functor.Identity (Identity)
-- import Control.Monad.IO.Class (MonadIO(..))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding (and, not, or)

import Language.Symantic.Repr
import Language.Symantic.Expr
import Language.Symantic.Type
import Language.Symantic.Trans

import AST.Test

-- * Class 'Sym_Bool_Vars'

-- | A few boolean variables.
class Sym_Bool_Vars repr where
	x :: repr Bool
	y :: repr Bool
	z :: repr Bool
instance Sym_Bool_Vars (Repr_Text fun) where
	x = Repr_Text $ \_p _v -> "x"
	y = Repr_Text $ \_p _v -> "y"
	z = Repr_Text $ \_p _v -> "z"
instance -- Trans_Boo_Const
 ( Sym_Bool repr
 , Sym_Bool_Vars repr
 ) => Sym_Bool_Vars (Trans_Bool_Const repr) where
	x = trans_lift x
	y = trans_lift y
	z = trans_lift z

-- * Expressions
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` not (bool False)
e5 = bool True `and` not x
e6 = x `xor` y
e7 = (x `xor` y) `xor` z
e8 = x `xor` (y `xor` bool True)

-- * Tests
{-
(==>)
 :: forall h ast root.
 ( Eq h, Eq ast, Show h, Show ast
 , root ~ Expr_Lambda_Bool IO
 , Expr_from ast (Expr_Lambda IO root)
 , Expr_from ast (Expr_Bool      root)
 ) => ast
 -- -> (Type_Fun_Bool IO h, h, String)
 -> Either (Proxy h, Error_of_Expr ast root)
           (Type_Fun_Bool IO h, h, String)
 -> TestTree
-}
(==>) ast expected =
	testCase (show ast) $
	case expr_lambda_bool_from (Proxy::Proxy IO) ast of
	 Left err -> Left err @?= snd `left` expected
	 Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
		case expected of
		 Left (_, err) -> Right ("…"::String) @?= Left err
		 Right (ty_expected::Type_Root_of_Expr (Expr_Lambda_Bool IO) h, _::h, _::Text) ->
			(>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
			case ty `type_eq` ty_expected of
			 Nothing -> return $ Left $
				error_expr (Proxy::Proxy (Expr_Lambda_Bool IO)) $
				Error_Expr_Type_mismatch ast
				 (Exists_Type ty)
				 (Exists_Type ty_expected)
			 Just Refl -> do
				h <- host_from_expr r
				return $
					Right
					 ( ty
					 , h
					 , text_from_expr r
					 -- , (text_from_expr :: Repr_Text IO h -> String) r
					 )

tests :: TestTree
tests = testGroup "Bool" $
 [ AST "bool" [AST "True" []] ==> Right
	 ( type_bool
	 , True
	 , "True" )
 , AST "int" [AST "1" []] ==> Left (Proxy::Proxy Int,
	Error_Expr_Alt_Curr $
	Error_Expr_Unsupported $ AST "int" [AST "1" []])
 , AST "xor"
	 [ AST "bool" [AST "True" []]
	 , AST "bool" [AST "True" []]
	 ] ==> Right
	 ( type_bool
	 , False
	 , "(True | True) & !(True & True)" )
 , AST "app"
	 [ AST "val"
		 [ AST "x" []
		 , AST "Bool" []
		 , AST "var" [AST "x" []]
		 ]
	 , AST "bool" [AST "True" []]
	 ] ==> Right
	 ( type_bool
	 , True
	 , "(\\x0 -> x0) True" )
 , let ast = AST "app"
	 [ AST "bool" [AST "True" []]
	 , AST "bool" [AST "True" []]
	 ] in ast ==> Left (Proxy::Proxy Bool,
	Error_Expr_Alt_Curr $
	Error_Expr_Type_mismatch ast
	 (Exists_Type (type_var SZero `type_fun` type_var (SSucc SZero)
	 ::Type_Fun_Bool IO (IO Zero -> IO (Succ Zero))))
	 (Exists_Type type_bool))
 , AST "app"
	 [ AST "val"
		 [ AST "x" []
		 , AST "Bool" []
		 , AST "xor"
			 [ AST "var" [AST "x" []]
			 , AST "bool" [AST "True" []]
			 ]
		 ]
	 , AST "bool" [AST "True" []]
	 ] ==> Right
	 ( type_bool
	 , False
	 , "(\\x0 -> (x0 | True) & !(x0 & True)) True" )
 , AST "let_val"
	 [ AST "x" []
	 , AST "bool" [AST "True" []]
	 , AST "xor"
		 [ AST "var" [AST "x" []]
		 , AST "bool" [AST "True" []]
		 ]
	 ] ==> Right
	 ( type_bool
	 , False
	 , "let x0 = True in (x0 | True) & !(x0 & True)" )
 ]