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

import Control.Monad
import qualified Data.Bool as Bool
import Data.Proxy
import qualified Data.Text as Text
import Data.Type.Equality ((:~:)(Refl))
import Prelude hiding ((&&), not, (||))

import Language.Symantic.Parsing
import Language.Symantic.Parsing.Grammar
import Language.Symantic.Typing
import Language.Symantic.Compiling
import Language.Symantic.Interpreting
import Language.Symantic.Transforming.Trans
import Language.Symantic.Lib.Lambda

-- * Class 'Sym_Bool'
class Sym_Bool term where
	bool ::      Bool -> term Bool
	not  :: term Bool -> term Bool
	(&&) :: term Bool -> term Bool -> term Bool
	(||) :: term Bool -> term Bool -> term Bool
	xor  :: term Bool -> term Bool -> term Bool
	xor x y = (x || y) && not (x && y)
	
	default bool :: Trans t term =>        Bool -> t term Bool
	default not  :: Trans t term => t term Bool -> t term Bool
	default (&&) :: Trans t term => t term Bool -> t term Bool -> t term Bool
	default (||) :: Trans t term => t term Bool -> t term Bool -> t term Bool
	
	bool = trans_lift . bool
	not  = trans_map1 not
	(&&) = trans_map2 (&&)
	(||) = trans_map2 (||)

infixr 2 ||
infixr 2 `xor`
infixr 3 &&

type instance Sym_of_Iface (Proxy Bool) = Sym_Bool
type instance Consts_of_Iface (Proxy Bool) = Proxy Bool ': Consts_imported_by Bool
type instance Consts_imported_by Bool =
 [ Proxy Bounded
 , Proxy Enum
 , Proxy Eq
 , Proxy Ord
 , Proxy Show
 ]

instance Sym_Bool HostI where
	bool = HostI
	not  = liftM Bool.not
	(&&) = liftM2 (Bool.&&)
	(||) = liftM2 (Bool.||)
instance Sym_Bool TextI where
	bool o = TextI $ \_p _v ->
		Text.pack (show o)
	not  = textI1 "not"
	(&&) = textI_infix "&&"    (infixR 3)
	(||) = textI_infix "||"    (infixR 2)
	xor  = textI_infix "`xor`" (infixR 2)
instance (Sym_Bool r1, Sym_Bool r2) => Sym_Bool (DupI r1 r2) where
	bool b = bool b `DupI` bool b
	not  = dupI1 (Proxy @Sym_Bool) not
	(&&) = dupI2 (Proxy @Sym_Bool) (&&)
	(||) = dupI2 (Proxy @Sym_Bool) (||)
	xor  = dupI2 (Proxy @Sym_Bool) xor

instance
 ( Read_TypeNameR Type_Name cs rs
 , Inj_Const cs Bool
 ) => Read_TypeNameR Type_Name cs (Proxy Bool ': rs) where
	read_typenameR _cs (Type_Name "Bool") k = k (ty @Bool)
	read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
instance Show_Const cs => Show_Const (Proxy Bool ': cs) where
	show_const ConstZ{} = "Bool"
	show_const (ConstS c) = show_const c

instance -- Proj_ConC
 ( Proj_Const cs Bool
 , Proj_Consts cs (Consts_imported_by Bool)
 ) => Proj_ConC cs (Proxy Bool) where
	proj_conC _ (TyConst q :$ TyConst c)
	 | Just Refl <- eq_skind (kind_of_const c) SKiType
	 , Just Refl <- proj_const c (Proxy @Bool)
	 = case () of
		 _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con
		   | Just Refl <- proj_const q (Proxy @Enum)    -> Just Con
		   | Just Refl <- proj_const q (Proxy @Eq)      -> Just Con
		   | Just Refl <- proj_const q (Proxy @Ord)     -> Just Con
		   | Just Refl <- proj_const q (Proxy @Show)    -> Just Con
		 _ -> Nothing
	proj_conC _c _q = Nothing
data instance TokenT meta (ts::[*]) (Proxy Bool)
 = Token_Term_Bool Bool
 | Token_Term_Bool_not
 | Token_Term_Bool_and
 | Token_Term_Bool_or
 | Token_Term_Bool_xor
deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Bool))
deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Bool))
instance -- CompileI
 ( Inj_Const (Consts_of_Ifaces is) Bool
 , Inj_Const (Consts_of_Ifaces is) (->)
 ) => CompileI is (Proxy Bool) where
	compileI tok _ctx k =
		case tok of
		 Token_Term_Bool b -> k (ty @Bool) $ TermO $ \_c -> bool b
		 Token_Term_Bool_not -> op1_from not
		 Token_Term_Bool_and -> op2_from (&&)
		 Token_Term_Bool_or  -> op2_from (||)
		 Token_Term_Bool_xor -> op2_from xor
		where
		op1_from
		 (op::forall term. Sym_Bool term => term Bool -> term Bool) =
			k (ty @Bool ~> ty @Bool) $ TermO $ \_c -> lam op
		op2_from
			(op::forall term. Sym_Bool term => term Bool -> term Bool -> term Bool) =
			k (ty @Bool ~> ty @Bool ~> ty @Bool) $ TermO $ \_c -> lam $ lam . op
instance -- TokenizeT
 Inj_Token meta ts Bool =>
 TokenizeT meta ts (Proxy Bool) where
	tokenizeT _t = mempty
	 { tokenizers_infix = tokenizeTMod []
		 [ tokenize0 "False" infixN5 $  Token_Term_Bool False
		 , tokenize0 "True"  infixN5 $  Token_Term_Bool True
		 , tokenize0 "not"   infixN5    Token_Term_Bool_not
		 , tokenize0 "and"   (infixR 3) Token_Term_Bool_and
		 , tokenize0 "or"    (infixR 2) Token_Term_Bool_or
		 , tokenize0 "xor"   (infixR 2) Token_Term_Bool_xor
		 ]
	 }
instance Gram_Term_AtomsT meta ts (Proxy Bool) g