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

import Test.Tasty
import Test.Tasty.HUnit

import qualified Control.Arrow as Arrow
import qualified Control.Monad as Monad
-- import Control.Monad.IO.Class (MonadIO(..))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding ((&&), not, (||))

import Language.Symantic.Typing
import Language.Symantic.Compiling
import Language.Symantic.Interpreting

-- * 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 TextI where
	x = TextI $ \_p _v -> "x"
	y = TextI $ \_p _v -> "y"
	z = TextI $ \_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
-}

-- * Terms
te1 = bool True && bool False
te2 = (bool True && bool False) ||  (bool True && bool True)
te3 = (bool True ||  bool False) && (bool True ||  bool True)
te4 = bool True && not (bool False)
te5 = bool True && not x
te6 = x `xor` y
te7 = (x `xor` y) `xor` z
te8 = x `xor` (y `xor` bool True)

-- * Tests
type Ifaces =
 [ Proxy (->)
 , Proxy Bool
 ]
type Consts = Consts_of_Ifaces Ifaces

(==>) (ast::Syntax Text) expected =
	testCase (show ast) $
	case root_term_from ast of
	 Left err -> Left err @?= Prelude.snd `Arrow.left` expected
	 Right (ETerm ty (Term te)::ETerm Ifaces) ->
		case expected of
		 Left (_, err) -> Right ("…"::Text) @?= Left err
		 Right (ty_expected::Type Consts h, _::h, _::Text) ->
			(Monad.>>= (@?= (\(_::Type Consts h, err) -> err) `Arrow.left` expected)) $
			case ty `eq_type` ty_expected of
			 Nothing -> Monad.return $ Left $
				Error_Term_Type_mismatch
				 (At Nothing $ EType ty)
				 (At Nothing $ EType ty_expected)
			 Just Refl -> do
				let h = host_from_term te
				Monad.return $
					Right
					 ( ty
					 , h
					 , text_from_term te
					 -- , (text_from_expr :: Repr_Text h -> Text) r
					 )

tests :: TestTree
tests = testGroup "Bool" $
 [ syTrue ==> Right (tyBool, True, "True")
 , Syntax "xor" [syTrue, syTrue] ==> Right
	 (tyBool, False, "((\\x0 -> (\\x1 -> x0 `xor` x1)) True) True")
 , syApp
	 (syLam (Syntax "x" []) syBool
		 (Syntax "x" []))
	 syTrue ==> Right
	 (tyBool, True, "(\\x0 -> x0) True")
 , syApp
	 (syLam (Syntax "x" []) syBool
		 (Syntax "xor"
			 [ Syntax "x" []
			 , syTrue
			 ]))
	 syTrue ==> Right
	 (tyBool, False, "(\\x0 -> ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) True) True" )
 , syLet (Syntax "x" []) syTrue
	 (Syntax "xor"
		 [ Syntax "x" []
		 , syTrue
		 ]) ==> Right
	 (tyBool, False, "let x0 = True in ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) True")
 , testGroup "Error_Term" $
	 [ syApp syTrue syTrue ==> Left (tyBool,
		Error_Term_Type_is_not_an_application $ At (Just syTrue) $
		EType tyBool)
	 , syApp
		 (syLam
			 (Syntax "x" []) syBool
			 (Syntax "xor"
				 [ Syntax "x" []
				 , syTrue
				 ])
			 )
		 syBool ==> Left (tyBool,
		Error_Term_unknown $ At (Just syBool) $
		"Bool")
	 , let sy = Syntax " "
		 [ syLam (Syntax "x" []) syBool
			 (Syntax "x" [])
		 ] in sy ==> Left (tyBool,
		Error_Term_Syntax $ Error_Syntax_more_arguments_needed $
		At (Just sy) 2)
	 , let sy = Syntax " "
		 [ syLam (Syntax "x" []) syBool
			 (Syntax "x" [])
		 , syTrue
		 , syTrue
		 ] in sy ==> Left (tyBool,
		Error_Term_Type_is_not_an_application $
		At (Just sy) $ EType tyBool)
	 , let sy =
			syLam (Syntax "x" []) (syBool .> syBool)
			 (Syntax " " [Syntax "x" [], syTrue]) in
		syApp sy syTrue ==> Left (tyBool,
		Error_Term_Type_mismatch
		 (At (Just sy) $ EType $ (tyBool ~> tyBool))
		 (At (Just $ syTrue) $ EType tyBool)
		 )
	 ]
 ]