{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.Typing.Type where

import Control.Applicative (Applicative(..))
import qualified Data.Char as Char
import Data.Monoid ((<>))
import Data.Proxy
import Data.Maybe (fromMaybe, isJust)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Type.Equality
import qualified Data.Kind as K

import Language.Symantic.Typing.Kind
import Language.Symantic.Typing.Constant
import Language.Symantic.Parsing

-- * Type 'Type'

-- | /Type of terms/.
--
-- * @cs@: /type constants/, fixed at compile time.
-- * @h@: indexed Haskell type.
--
-- * 'TyConst': /type constant/, selected amongst @cs@.
-- * @(:$)@: /type application/.
--
-- See also: https://ghc.haskell.org/trac/ghc/wiki/Typeable
-- Which currently concludes:
-- "Why kind equalities, then? Given the fact that Richard's branch
-- doesn't solve this problem, what is it good for?
-- It still works wonders in the mono-kinded case,
-- such as for decomposing ->.
-- It's just that poly-kinded constructors are still a pain."
data Type (cs::[K.Type]) (h::k) where
	TyConst :: TyConst cs c -> Type cs c
	(:$) :: Type cs f -> Type cs x -> Type cs (f x)
	-- TODO: TyVar :: SKind k -> Type cs (v::k)
infixl 9 :$

-- | 'Type' constructor to be used
-- with @TypeApplications@
-- and @NoMonomorphismRestriction@.
ty :: forall c cs. Inj_TyConst cs c => Type cs c
ty = TyConst inj_TyConst
 -- NOTE: The forall brings @c@ first in the type variables,
 -- which is convenient to use @TypeApplications@.

instance TestEquality (Type cs) where
	testEquality = eq_Type
instance Eq (Type cs h) where
	_x == _y = True
instance Show_TyConst cs => Show (Type cs h) where
	show = show_Type
-- deriving instance Show_TyConst cs => Show (Type cs h)

kind_of :: Type cs (h::k) -> SKind k
kind_of t =
	case t of
	 TyConst c -> kind_of_TyConst c
	 f :$ _x ->
		case kind_of f of
		 _kx `SKiArrow` kf -> kf

eq_Type
 :: Type cs (x::k) -> Type cs (y::k) -> Maybe (x:~:y)
eq_Type (TyConst x) (TyConst y)
 | Just Refl <- testEquality x y
 = Just Refl
eq_Type (xf :$ xx) (yf :$ yx)
 | Just Refl <- eq_skind (kind_of xf) (kind_of yf)
 , Just Refl <- eq_Type xf yf
 , Just Refl <- eq_Type xx yx
 = Just Refl
eq_Type _ _ = Nothing

eq_Kind_Type
 :: Type cs (x::kx) -> Type cs (y::ky) -> Maybe (kx:~:ky)
eq_Kind_Type (TyConst x) (TyConst y)
 | Just Refl <- eq_Kind_TyConst x y
 = Just Refl
eq_Kind_Type (xf :$ xx) (yf :$ yx)
 | Just Refl <- eq_Kind_Type xf yf
 , Just Refl <- eq_Kind_Type xx yx
 = Just Refl
eq_Kind_Type _x _y = Nothing

show_Type :: Show_TyConst cs => Type cs h -> String
show_Type (TyConst c) = show c
show_Type (f@(:$){} :$ a@(:$){}) = "(" <> show_Type f <> ") (" <> show_Type a <> ")"
show_Type (f@(:$){} :$ a) = "(" <> show_Type f <> ") " <> show_Type a
show_Type (f :$ a@(:$){}) = show_Type f <> " (" <> show_Type a <> ")"
show_Type (f :$ a) = show_Type f <> " " <> show_Type a
-- show_Type (TyVar v) = "t" <> show (integral_from_peano v::Integer)

-- | Cons a @new_c@ to @cs@.
lift_Type :: Type cs c -> Type (new_c ': cs) c
lift_Type (TyConst c) = TyConst (TyConstS c)
lift_Type (f :$ a) = lift_Type f :$ lift_Type a

-- * Type 'EType'
-- | Existential for 'Type'.
data EType cs = forall h. EType (Type cs h)

instance Eq (EType cs) where
	EType x == EType y
	 | Just Refl <- eq_Kind_Type x y
	 = isJust $ eq_Type x y
	_x == _y = False
instance Show_TyConst cs => Show (EType cs) where
	show (EType t) = show t

-- * Type 'KType'
-- | Existential for 'Type' of a known 'Kind'.
data KType cs k = forall (h::k). KType (Type cs h)

instance Eq (KType cs ki) where
	KType x == KType y = isJust $ eq_Type x y
instance Show_TyConst cs => Show (KType cs ki) where
	show (KType t) = show_Type t

-- * Type 'Token_Type'
type Token_Type = Type '[] ()

-- * Type 'TyName'
newtype TyName = TyName Text
 deriving (Eq, Ord, Show)
instance IsString TyName where
	fromString = TyName . fromString

data instance TokenT meta ts (Proxy Token_Type)
 = Token_Type TyName [EToken meta ts]
deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Token_Type))
deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Token_Type))

instance
 ( Read_TyNameR TyName cs rs
 , Inj_TyConst cs Token_Type
 ) => Read_TyNameR TyName cs (Proxy Token_Type ': rs) where
	read_TyNameR _rs (TyName "Type") k = k (ty @Token_Type)
	read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
instance Show_TyConst cs => Show_TyConst (Proxy Token_Type ': cs) where
	show_TyConst TyConstZ{} = "Type"
	show_TyConst (TyConstS c) = show_TyConst c

-- * Class 'Compile_Type'
-- | Try to build a 'Type' from name data.
class Compile_Type ts cs where
	compile_Type
	 :: ( MonoLift (Error_Type meta ts) err
	    , MonoLift (Con_Kind meta ts) err )
	 => EToken meta ts
	 -> (forall k h. Type cs (h::k) -> Either err ret)
	 -> Either err ret

compile_EType
 :: Read_TyName TyName cs
 => EToken meta '[Proxy Token_Type]
 -> Either (Error_Type meta '[Proxy Token_Type]) (EType cs)
compile_EType tok = compile_Type tok (Right . EType)

-- ** Type 'Con_Kind'
data Con_Kind meta ts
 =   Con_Kind_Eq    (At meta ts EKind) (At meta ts EKind)
 |   Con_Kind_Arrow (At meta ts EKind)
deriving instance (Eq_TokenR meta ts ts) => Eq (Con_Kind meta ts)
deriving instance (Show_TokenR meta ts ts) => Show (Con_Kind meta ts)

check_Kind
 :: MonoLift (Con_Kind meta ts) err
 => At meta ts (SKind x)
 -> At meta ts (SKind y)
 -> ((x :~: y) -> Either err ret) -> Either err ret
check_Kind x y k =
	case unAt x `eq_skind` unAt y of
	 Just Refl -> k Refl
	 Nothing -> Left $ olift $
		Con_Kind_Eq (EKind <$> x) (EKind <$> y)

check_Kind_arrow
 :: MonoLift (Con_Kind meta ts) err
 => At meta ts (SKind x)
 -> (forall a b. (x :~: (a -> b)) -> SKind a -> SKind b -> Either err ret)
 -> Either err ret
check_Kind_arrow x k =
	case unAt x of
	 a `SKiArrow` b -> k Refl a b
	 _ -> Left $ olift $
		Con_Kind_Arrow (EKind <$> x)

-- ** Type 'Error_Type'
data Error_Type meta ts
 =   Error_Type_Token_invalid    (EToken meta ts)
 |   Error_Type_Constant_unknown (At meta ts TyName)
 |   Error_Type_Con_Kind  (Con_Kind meta ts)
deriving instance (Eq_TokenR meta ts ts) => Eq (Error_Type meta ts)
deriving instance (Show_TokenR meta ts ts) => Show (Error_Type meta ts)

-- * Class 'Read_TyName'
type Read_TyName raw cs = Read_TyNameR raw cs cs

read_TyName
 :: forall raw cs ret.
 Read_TyNameR raw cs cs
 => raw -> (forall k c. Type cs (c::k) -> Maybe ret)
 -> Maybe ret
read_TyName = read_TyNameR (Proxy @cs)

-- ** Class 'Read_TyNameR'
class Read_TyNameR raw cs rs where
	read_TyNameR
	 :: Proxy rs -> raw -> (forall k c. Type cs (c::k) -> Maybe ret)
	 -> Maybe ret

instance Read_TyNameR raw cs '[] where
	read_TyNameR _cs _c _k = Nothing

-- TODO: move each of these to a dedicated module.
instance
 ( Read_TyNameR TyName cs rs
 , Inj_TyConst cs Fractional
 ) => Read_TyNameR TyName cs (Proxy Fractional ': rs) where
	read_TyNameR _cs (TyName "Fractional") k = k (ty @Fractional)
	read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
instance
 ( Read_TyNameR TyName cs rs
 , Inj_TyConst cs []
 , Inj_TyConst cs Char
 ) => Read_TyNameR TyName cs (Proxy String ': rs) where
	read_TyNameR _cs (TyName "String") k = k (ty @[] :$ ty @Char)
	read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k

instance
 ( Read_TyName TyName cs
 , Proj_Token ts Token_Type
 ) => Compile_Type ts cs where
	compile_Type
	 :: forall meta err ret.
	 ( MonoLift (Error_Type meta ts) err
	 , MonoLift (Con_Kind meta ts) err
	 ) => EToken meta ts
	 -> (forall k h. Type cs (h::k) -> Either err ret)
	 -> Either err ret
	compile_Type tok@(proj_etoken -> Just (Token_Type cst args)) kk =
		fromMaybe (Left $ olift $ Error_Type_Constant_unknown $ At (Just tok) cst) $
		read_TyName cst $ \typ -> Just $
		go args typ kk
		where
		go :: [EToken meta ts]
		 -> Type cs h
		 -> (forall k' h'. Type cs (h'::k') -> Either err ret)
		 -> Either err ret
		go [] typ k = k typ
		go (tok_x:tok_xs) ty_f k =
			compile_Type tok_x $ \(ty_x::Type cs (h'::k')) ->
			check_Kind_arrow
			 (At (Just tok) $ kind_of ty_f) $ \Refl ki_f_a _ki_f_b ->
			check_Kind
			 (At (Just tok) ki_f_a)
			 (At (Just tok_x) $ kind_of ty_x) $ \Refl ->
			go tok_xs (ty_f :$ ty_x) k
	compile_Type tok _k = Left $ olift $ Error_Type_Token_invalid tok

-- * Type 'Types'
data Types cs (hs::[K.Type]) where
	TypesZ :: Types cs '[]
	TypesS :: Type  cs h
	       -> Types cs hs
	       -> Types cs (Proxy h ': hs)
infixr 5 `TypesS`

eTypes :: Types cs hs -> [EType cs]
eTypes TypesZ = []
eTypes (TypesS t ts) = EType t : eTypes ts

-- | Build the left spine of a 'Type'.
spine_of_Type
 :: Type cs h
 -> (forall kc (c::kc) hs. TyConst cs c -> Types cs hs -> ret) -> ret
spine_of_Type (TyConst c) k = k c TypesZ
spine_of_Type (f :$ a) k = spine_of_Type f $ \c as -> k c (a `TypesS` as)

-- * Type 'UnProxy'
type family UnProxy (x::K.Type) :: k where
	UnProxy (Proxy x) = x

-- * Class 'MonoLift'
class MonoLift a b where
	olift :: a -> b
instance MonoLift
 (Error_Type meta ts)
 (Error_Type meta ts) where
	olift = id
instance
 MonoLift (Con_Kind meta ts) (Error_Type meta ts) where
	olift = olift . Error_Type_Con_Kind

-- * Class 'Gram_Type'
type TokType meta = EToken meta '[Proxy Token_Type]
class
 ( Alt g
 , Alter g
 , App g
 , Try g
 , Gram_CF g
 , Gram_Rule g
 , Gram_Terminal g
 , Gram_Lexer g
 , Gram_Op g
 , Gram_Meta meta g
 ) => Gram_Type meta g where
	g_type :: CF g (TokType meta)
	g_type = rule "type" $ g_type_fun
	g_type_fun :: CF g (TokType meta)
	g_type_fun = rule "type_fun" $
		infixrG g_type_list (metaG $ op <$ symbol "->")
		where op meta a b = inj_EToken meta $ Token_Type (TyName "(->)") [a, b]
	g_type_list :: CF g (TokType meta)
	g_type_list = rule "type_list" $
		metaG $ inside f
		 (symbol "[") (option [] (pure <$> g_type)) (symbol "]")
		 (const <$> g_type_tuple2)
		where f a meta = inj_EToken meta $ Token_Type (TyName "[]") a
	g_type_tuple2 :: CF g (TokType meta)
	g_type_tuple2 = rule "type_tuple2" $
		try (parens (infixrG g_type (metaG $ op <$ symbol ","))) <+> g_type_app
		where op meta a b = inj_EToken meta $ Token_Type (TyName "(,)") [a, b]
	g_type_app :: CF g (TokType meta)
	g_type_app = rule "type_app" $
		f <$> some g_type_atom
		where
		f :: [TokType meta] -> TokType meta
		f (EToken (TokenZ meta (Token_Type a as)):as') =
			EToken $ TokenZ meta $ Token_Type a $ as <> as'
		f _ = error "Oops, the impossible happened"
	g_type_atom :: CF g (TokType meta)
	g_type_atom = rule "type_atom" $
		try (parens g_type) <+>
		g_type_name <+>
		g_type_symbol
	g_type_name :: CF g (TokType meta)
	g_type_name = rule "type_name" $
		metaG $ lexeme $
		(\c cs meta -> EToken $ TokenZ meta $ Token_Type (TyName $ Text.pack $ c:cs) [])
		 <$> unicat (Unicat Char.UppercaseLetter)
		 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
	g_type_symbol :: CF g (TokType meta)
	g_type_symbol = rule "type_symbol" $
		metaG $ (f <$>) $
		parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
		where
		f s meta = inj_EToken meta $ (`Token_Type` []) $
			TyName $ Text.concat ["(", Text.pack s, ")"]
		g_ok = unicat <$>
		 [ Unicat_Symbol
		 , Unicat_Punctuation
		 , Unicat_Mark
		 ]
		g_ko = char <$> ['(', ')', '`']

deriving instance Gram_Type meta g => Gram_Type meta (CF g)
instance Gram_Type meta EBNF
instance Gram_Type meta RuleDef

-- | List of the rules of 'Gram_Type'.
gram_type :: Gram_Type meta g => [CF g (TokType meta)]
gram_type =
 [ g_type
 , g_type_fun
 , g_type_list
 , g_type_tuple2
 , g_type_app
 , g_type_atom
 , g_type_name
 , g_type_symbol
 ]