{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Expr.Applicative.Test where

import Test.Tasty
import Test.Tasty.HUnit

import Control.Arrow (left)
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Applicative(..))

import Language.Symantic.Type
import Language.Symantic.Expr as Expr
import Language.Symantic.Repr

import AST.Test

-- * Expressions
t = bool True
f = bool False
e1 = val (\x -> val $ \y -> x + y)
 <$> just (int 1)
 <*> just (int 2)

-- * Tests
type Ex lam = Expr_Root
 (   Expr_Lambda_App lam
 .|. Expr_Lambda_Val lam
 .|. Expr_List lam
 .|. Expr_Maybe lam
 .|. Expr_Int
 .|. Expr_Bool
 .|. Expr_Functor lam
 .|. Expr_Applicative lam
 )
ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)

(==>) ast expected =
	testCase (show ast) $
	case ex_from 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 (Ex IO) h, _::h, _::Text) ->
			(>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
			case ty `eq_type` ty_expected of
			 Nothing -> return $ Left $
				error_expr (Proxy::Proxy (Ex 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_String IO h -> Text) r
					 )

tests :: TestTree
tests = testGroup "Applicative"
 [ AST "<*>"
	 [ AST "<$>"
		 [ AST "val"
			 [ AST "x" [], AST "Int" []
			 , AST "val"
				 [ AST "y" [], AST "Int" []
				 , AST "+" [ AST "var" [AST "x" []]
				           , AST "var" [AST "y" []] ]
				 ]
			 ]
		 , AST "just" [ AST "int" [AST "1" []] ]
		 ]
	 , AST "just" [ AST "int" [AST "2" []] ]
	 ] ==> Right
	 ( type_maybe type_int
	 , Just 3
	 , "fmap (\\x0 -> (\\x1 -> x0 + x1)) (just 1) <*> just 2" )
 ]