{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic for 'Char'.
module Language.Symantic.Lib.Char where

import Control.Monad (liftM)
import qualified Data.Char as Char
import Data.Proxy
import qualified Data.Text as Text
import Data.Type.Equality ((:~:)(Refl))

import Language.Symantic.Parsing hiding (char)
import qualified Language.Symantic.Grammar as Gram
import Language.Symantic.Typing
import Language.Symantic.Compiling
import Language.Symantic.Interpreting
import Language.Symantic.Transforming
import Language.Symantic.Lib.Lambda

-- * Class 'Sym_Char'
class Sym_Char term where
	char :: Char -> term Char
	char_toUpper :: term Char -> term Char
	char_toLower :: term Char -> term Char
	
	default char :: Trans t term => Char -> t term Char
	default char_toUpper :: Trans t term => t term Char -> t term Char
	default char_toLower :: Trans t term => t term Char -> t term Char
	
	char = trans_lift . char
	char_toUpper = trans_map1 char_toUpper
	char_toLower = trans_map1 char_toLower

type instance Sym_of_Iface (Proxy Char) = Sym_Char
type instance TyConsts_of_Iface (Proxy Char) = Proxy Char ': TyConsts_imported_by Char
type instance TyConsts_imported_by Char =
 [ Proxy Bounded
 , Proxy Enum
 , Proxy Eq
 , Proxy Ord
 , Proxy Show
 ]

instance Sym_Char HostI where
	char = HostI
	char_toUpper = liftM Char.toUpper
	char_toLower = liftM Char.toLower
instance Sym_Char TextI where
	char a = TextI $ \_p _v ->
		Text.pack (show a)
	char_toUpper = textI1 "Char.toUpper"
	char_toLower = textI1 "Char.toLower"
instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where
	char x = char x `DupI` char x
	char_toUpper = dupI1 (Proxy @Sym_Char) char_toUpper
	char_toLower = dupI1 (Proxy @Sym_Char) char_toLower

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

instance -- Proj_TyConC
 ( Proj_TyConst cs Char
 , Proj_TyConsts cs (TyConsts_imported_by Char)
 ) => Proj_TyConC cs (Proxy Char) where
	proj_TyConC _ (TyConst q :$ TyConst c)
	 | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
	 , Just Refl <- proj_TyConst c (Proxy @Char)
	 = case () of
		 _ | Just Refl <- proj_TyConst q (Proxy @Bounded) -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Enum)    -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Eq)      -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Ord)     -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Show)    -> Just TyCon
		 _ -> Nothing
	proj_TyConC _c _q = Nothing
data instance TokenT meta (ts::[*]) (Proxy Char)
 = Token_Term_Char Char
 | Token_Term_Char_toUpper
 | Token_Term_Char_toLower
deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Char))
deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Char))
instance -- CompileI
 ( Inj_TyConst (TyConsts_of_Ifaces is) Char
 , Inj_TyConst (TyConsts_of_Ifaces is) (->)
 ) => CompileI is (Proxy Char) where
	compileI tok _ctx k =
		case tok of
		 Token_Term_Char c -> k (ty @Char) $ TermO $ \_c -> char c
		 Token_Term_Char_toUpper -> from_op char_toUpper
		 Token_Term_Char_toLower -> from_op char_toLower
		where
		from_op (op::forall term. Sym_Char term => term Char -> term Char) =
			k (ty @Char ~> ty @Char) $ TermO $ \_c -> lam op
instance -- TokenizeT
 Inj_Token meta ts Char =>
 TokenizeT meta ts (Proxy Char) where
	tokenizeT _t = mempty
	 { tokenizers_infix = tokenizeTMod [Mod_Name "Char"]
		 [ tokenize0 "toLower" infixN5 Token_Term_Char_toLower
		 , tokenize0 "toUpper" infixN5 Token_Term_Char_toUpper
		 ]
	 }
instance -- Gram_Term_AtomsT
 ( Alt g
 , Gram_Rule g
 , Gram_Lexer g
 , Gram_Meta meta g
 , Inj_Token meta ts Char
 ) => Gram_Term_AtomsT meta ts (Proxy Char) g where
	term_atomsT _t =
	 [ rule "term_char" $
		lexeme $ metaG $
		(\c meta -> ProTok $ inj_EToken meta $ Token_Term_Char c)
		 <$> Gram.between tickG tickG (
			Gram.cf_of_Terminal (Gram.any `Gram.but` tickG) Gram.<+>
			'\'' <$ Gram.string "\\'"
		 )
	 ]
		where
		tickG :: Gram_Terminal g' => g' Char
		tickG = Gram.char '\''