{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Expr.Int.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, (||), (+), negate)

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

import AST.Test

-- * Class 'Sym_Int_Vars'

-- | A few boolean variables.
class Sym_Int_Vars repr where
	x :: repr Int
	y :: repr Int
	z :: repr Int
instance Sym_Int_Vars Repr_Text where
	x = Repr_Text $ \_p _v -> "x"
	y = Repr_Text $ \_p _v -> "y"
	z = Repr_Text $ \_p _v -> "z"

-- * Expressions
e1 = int 1 + int 0
e2 = (int 1 + int 0) + negate (int 1 + int 1)
e3 = (int 1 + negate (int 0)) + (int 1 + negate (int 1))
e4 = int 0 + negate (int 1)
e5 = int 1 + negate x
e6 = x + y
e7 = (x + y) + z
e8 = x + (y + int 1)

-- * Tests
type Ex = Expr_Root
 (   Expr_Lambda
 .|. Expr_Int
 )
ex_from = root_expr_from (Proxy::Proxy Ex)

(==>) ast expected =
	testCase (show ast) $
	case ex_from ast of
	 Left err -> Left err @?= snd `Arrow.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 Ex h, _::h, _::Text) ->
			(Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
			case ty `eq_type` ty_expected of
			 Nothing -> Monad.return $ Left $
				error_expr (Proxy::Proxy Ex) $
				Error_Expr_Type_mismatch ast
				 (Exists_Type ty)
				 (Exists_Type ty_expected)
			 Just Refl -> do
				let h = host_from_expr r
				Monad.return $
					Right
					 ( ty
					 , h
					 , text_from_expr r
					 -- , (text_from_expr :: Repr_Text h -> Text) r
					 )

tests :: TestTree
tests = testGroup "Int" $
 [ AST "int" [AST "1" []] ==> Right
	 ( type_int
	 , 1
	 , "1" )
 , AST "bool" [AST "True" []] ==> Left (Proxy::Proxy Bool,
	Error_Expr_Alt_Curr $
	Error_Expr_Unsupported $ AST "bool" [AST "True" []])
 , AST "+"
	 [ AST "int" [AST "1" []]
	 , AST "int" [AST "1" []]
	 ] ==> Right
	 ( type_int
	 , 2
	 , "1 + 1" )
 , let ast = AST "$"
	 [ AST "int" [AST "1" []]
	 , AST "int" [AST "1" []]
	 ] in ast ==> Left (Proxy::Proxy Int,
	Error_Expr_Alt_Curr $
	Error_Expr_Type_mismatch ast
	 (Exists_Type (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
	 ::Type_Root (Type_Var0 :|: Type_Var1 :|: Type_Fun :|: Type_Int)
	             ((->) Var0 Var0)))
	 (Exists_Type type_int))
 , AST "$"
	 [ AST "\\"
		 [ AST "x" []
		 , AST "Int" []
		 , AST "var" [AST "x" []]
		 ]
	 , AST "int" [AST "1" []]
	 ] ==> Right
	 ( type_int
	 , 1
	 , "(\\x0 -> x0) 1" )
 , AST "$"
	 [ AST "\\"
		 [ AST "x" []
		 , AST "Int" []
		 , AST "+"
			 [ AST "var" [AST "x" []]
			 , AST "int" [AST "1" []]
			 ]
		 ]
	 , AST "int" [AST "1" []]
	 ] ==> Right
	 ( type_int
	 , 2
	 , "(\\x0 -> x0 + 1) 1" )
 , AST "let"
	 [ AST "x" []
	 , AST "int" [AST "1" []]
	 , AST "+"
		 [ AST "var" [AST "x" []]
		 , AST "int" [AST "1" []]
		 ]
	 ] ==> Right
	 ( type_int
	 , 2
	 , "let x0 = 1 in x0 + 1" )
 ]