{-# 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.String (IsString(..))
import Data.Text (Text)
import qualified Data.Char as Char

import Language.Symantic.Grammar
import Language.Symantic.Typing.Variable

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

-- ** Type 'NameConst'
type NameConst = NameTy

-- ** Type 'NameFam'
type NameFam = NameTy

-- * Type 'AST_Type'
-- | /Abstract Syntax Tree/ of 'Token_Type'.
type AST_Type src = BinTree (Token_Type src) -- (EToken src '[Proxy K.Type])

-- ** Type 'Token_Type'
data Token_Type src
 =   Token_Type_Const (At src NameTy)
 |   Token_Type_Var   (At src NameVar)
 -- deriving (Eq, Show)
instance Source src => Eq (Token_Type src) where
	Token_Type_Const (At _ x) == Token_Type_Const (At _ y) = x == y
	Token_Type_Var   (At _ x) == Token_Type_Var   (At _ y) = x == y
	_ == _ = False
instance Source src => Show (Token_Type src) where
	showsPrec p (Token_Type_Const (At _ x)) =
		showParen (p >= 10) $
		showString "Token_Type_Const" .
		showChar ' ' . showsPrec 10 x
	showsPrec p (Token_Type_Var (At _ x)) =
		showParen (p >= 10) $
		showString "Token_Type_Var" .
		showChar ' ' . showsPrec 10 x

-- * Class 'Gram_Type'
-- | Read an 'AST_Type' from a textual source.
class
 ( Gram_Source src g
 , Gram_Terminal g
 , Gram_Rule g
 , Gram_Alt g
 , Gram_Try g
 , Gram_App g
 , Gram_AltApp g
 , Gram_CF g
 , Gram_Comment g
 , Gram_Op g
 ) => 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 (g_source $ op <$ symbol "->")
		where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
	-- 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" $
		g_source $ inside mk
		 (symbol "[") (optional g_type) (symbol "]")
		 (const <$> g_type_tuple2)
		where
		mk Nothing  src = tok src
		mk (Just a) src = BinTree2 (tok src) a
		tok src = BinTree0 $ Token_Type_Const $ At src "[]"
	g_type_tuple2 :: CF g (AST_Type src)
	g_type_tuple2 = rule "type_tuple2" $
		try (parens (infixrG (g_type) (g_source $ op <$ symbol ","))) <+> (g_type_app)
		where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(,)")
	g_type_app :: CF g (AST_Type src)
	g_type_app = rule "type_app" $
		foldl1' BinTree2 <$> 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_const <+>
		g_type_name_var <+>
		g_type_symbol
	g_type_name_const :: CF g (AST_Type src)
	g_type_name_const = rule "type_name_const" $
		lexeme $ g_source $
		(\n ns src -> BinTree0 $ Token_Type_Const $ At src $ fromString $ n:ns)
		 <$> unicat (Unicat Char.UppercaseLetter)
		 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
	g_type_name_var :: CF g (AST_Type src)
	g_type_name_var = rule "type_name_var" $
		lexeme $ g_source $
		(\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
		 <$> unicat (Unicat Char.LowercaseLetter)
		 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
	g_type_symbol :: CF g (AST_Type src)
	g_type_symbol = rule "type_symbol" $
		g_source $ (mk <$>) $
		parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
		where
		mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ 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 Gram_Source src EBNF => Gram_Type src EBNF
instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF

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