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

import qualified Data.Char as Char
import qualified Data.Text as Text

import Language.Symantic.Grammar hiding (char, any)
import qualified Language.Symantic.Grammar as Gram
import Language.Symantic
import Language.Symantic.Lib.List (tyList)

-- * Class 'Sym_Char'
type instance Sym (Proxy Char) = 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         :: Sym_Char (UnT term) => Trans term => Char -> term Char
	default char_toUpper :: Sym_Char (UnT term) => Trans term => term Char -> term Char
	default char_toLower :: Sym_Char (UnT term) => Trans term => term Char -> term Char
	
	char         = trans . char
	char_toUpper = trans1 char_toUpper
	char_toLower = trans1 char_toLower

-- Interpreting
instance Sym_Char Eval where
	char         = Eval
	char_toUpper = eval1 Char.toUpper
	char_toLower = eval1 Char.toLower
instance Sym_Char View where
	char a = View $ \_p _v ->
		Text.pack (show a)
	char_toUpper = view1 "Char.toUpper"
	char_toLower = view1 "Char.toLower"
instance (Sym_Char r1, Sym_Char r2) => Sym_Char (Dup r1 r2) where
	char x       = char x `Dup` char x
	char_toUpper = dup1 @Sym_Char char_toUpper
	char_toLower = dup1 @Sym_Char char_toLower

-- Transforming
instance (Sym_Char term, Sym_Lambda term) => Sym_Char (BetaT term)

-- Typing
instance ClassInstancesFor Char where
	proveConstraintFor _ (TyApp _ (TyConst _ _ q) z)
	 | Just HRefl <- proj_ConstKiTy @_ @Char z
	 = case () of
		 _ | Just Refl <- proj_Const @Bounded q -> Just Dict
		   | Just Refl <- proj_Const @Enum    q -> Just Dict
		   | Just Refl <- proj_Const @Eq      q -> Just Dict
		   | Just Refl <- proj_Const @Ord     q -> Just Dict
		   | Just Refl <- proj_Const @Show    q -> Just Dict
		 _ -> Nothing
	proveConstraintFor _c _q = Nothing
instance TypeInstancesFor Char

-- Compiling
instance
 ( Gram_Source src g
 , Gram_Alt g
 , Gram_Rule g
 , Gram_Comment g
 , Inj_Sym ss Char
 ) => Gram_Term_AtomsFor src ss g Char where
	g_term_atomsFor =
	 [ rule "teChar" $
		lexeme $ g_source $
		(\c src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teChar c)
		 <$> between tickG tickG (
			cf_of_Terminal (Gram.any `but` tickG) <+>
			'\'' <$ string "\\'"
		 )
	 ]
		where
		tickG :: Gram_Terminal g' => g' Char
		tickG = Gram.char '\''
instance (Source src, Inj_Sym ss Char) => ModuleFor src ss Char where
	moduleFor = ["Char"] `moduleWhere`
	 [ "toLower" := teChar_toLower
	 , "toUpper" := teChar_toUpper
	 ]

-- ** 'Type's
tyChar :: Source src => Inj_Len vs => Type src vs Char
tyChar = tyConst @(K Char) @Char

tyString :: Source src => Inj_Len vs => Type src vs String
tyString = tyList tyChar

-- ** 'Term's
teChar :: Source src => Inj_Sym ss Char => Char -> Term src ss ts '[] (() #> Char)
teChar b = Term noConstraint tyChar $ teSym @Char $ char b

teChar_toUpper, teChar_toLower :: TermDef Char '[] (() #> (Char -> Char))
teChar_toUpper = Term noConstraint (tyChar ~> tyChar) $ teSym @Char $ lam1 char_toUpper
teChar_toLower = Term noConstraint (tyChar ~> tyChar) $ teSym @Char $ lam1 char_toLower