{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.Typing.Grammar where

import Control.Applicative (Applicative(..))
import Data.List (foldl1')
import Data.Proxy
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Char as Char
import qualified Data.Kind as K
import qualified Data.Text as Text

import Language.Symantic.Parsing

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

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

instance
 ( Compile_TyNameR TyName cs rs
 , Inj_TyConst cs K.Type
 ) => Compile_TyNameR TyName cs (Proxy K.Type ': rs) where
	compile_TyNameR _rs src (TyName "Type") k = k (tySourced @K.Type src)
	compile_TyNameR _rs src raw k = compile_TyNameR (Proxy @rs) src raw k
instance Show_TyConst cs => Show_TyConst (Proxy K.Type ': cs) where
	show_TyConst TyConstZ{} = "Type"
	show_TyConst (TyConstS c) = show_TyConst c
-}

-- * Type 'AST_Type'
type AST_Type src = BinTree (EToken src '[Proxy K.Type])

data instance TokenT ss (Proxy K.Type)
 = Token_Type_Name TyName

deriving instance Eq_Token   ss => Eq   (TokenT ss (Proxy K.Type))
deriving instance Show_Token ss => Show (TokenT ss (Proxy K.Type))

-- * Class 'Gram_Type'
-- | Read an 'AST_Type' from a textual source.
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 (Text_of_Source src) g
 , Inj_Source (Text_of_Source src) src
 ) => Gram_Type src g where
	g_type :: CF g (AST_Type src)
	g_type = rule "type" $ g_type_fun
	g_type_fun :: CF g (AST_Type src)
	g_type_fun = rule "type_fun" $
		infixrG g_type_list (sourceG $ op <$ symbol "->")
		where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(->)")
	-- TODO: maybe not harcoding g_type_list and g_type_tuple2
	g_type_list :: CF g (AST_Type src)
	g_type_list = rule "type_list" $
		sourceG $ inside f
		 (symbol "[") (optional (g_type)) (symbol "]")
		 (const <$> g_type_tuple2)
		where
		n src = BinTree0 $ inj_EToken src $ Token_Type_Name "[]"
		f Nothing  src = n src
		f (Just a) src = BinTree1 (n src) a
	g_type_tuple2 :: CF g (AST_Type src)
	g_type_tuple2 = rule "type_tuple2" $
		try (parens (infixrG g_type (sourceG $ op <$ symbol ","))) <+> g_type_app
		where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(,)")
	g_type_app :: CF g (AST_Type src)
	g_type_app = rule "type_app" $
		foldl1' BinTree1 <$> some g_type_atom
	g_type_atom :: CF g (AST_Type src)
	g_type_atom = rule "type_atom" $
		try (parens g_type) <+>
		g_type_name <+>
		g_type_symbol
	g_type_name :: CF g (AST_Type src)
	g_type_name = rule "type_name" $
		sourceG $ lexeme $
		(\c cs src -> BinTree0 $ inj_EToken src $ Token_Type_Name $ fromString $ c:cs)
		 <$> unicat (Unicat Char.UppercaseLetter)
		 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
	g_type_symbol :: CF g (AST_Type src)
	g_type_symbol = rule "type_symbol" $
		sourceG $ (f <$>) $
		parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
		where
		f s src = BinTree0 $ inj_EToken src $ (Token_Type_Name) $
			TyName $ Text.concat ["(", Text.pack s, ")"]
		g_ok = unicat <$>
		 [ Unicat_Symbol
		 , Unicat_Punctuation
		 , Unicat_Mark
		 ]
		g_ko = char <$> ['(', ')', '`']

deriving instance Gram_Type src g => Gram_Type src (CF g)
instance
 ( Inj_Source (Text_of_Source src) src
 ) => Gram_Type src EBNF
instance
 ( Inj_Source (Text_of_Source src) src
 ) => Gram_Type src RuleDef

-- | List of the rules of 'Gram_Type'.
gram_type :: Gram_Type src g => [CF g (AST_Type src)]
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
 ]