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

import Control.Monad
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as Semigroup
import Data.Monoid (mempty)
import Data.Proxy

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

-- * Class 'Sym_Semigroup'
class Sym_Semigroup term where
	(<>)   :: Semigroup a => term a -> term a -> term a
	stimes :: (Semigroup a, Integral b) => term b -> term a -> term a
	-- sconcat :: NonEmpty a -> a
	default (<>)   :: (Trans t term, Semigroup a) => t term a -> t term a -> t term a
	default stimes :: (Trans t term, Semigroup a, Integral b) => t term b -> t term a -> t term a
	(<>)   = trans_map2 (<>)
	stimes = trans_map2 stimes

type instance Sym_of_Iface (Proxy Semigroup) = Sym_Semigroup
type instance TyConsts_of_Iface (Proxy Semigroup) = Proxy Semigroup ': TyConsts_imported_by Semigroup
type instance TyConsts_imported_by Semigroup = '[Proxy Integral]

instance Sym_Semigroup HostI where
	(<>)   = liftM2 (Semigroup.<>)
	stimes = liftM2 Semigroup.stimes
instance Sym_Semigroup TextI where
	(<>)   = textI_infix "-" (infixR 6)
	stimes = textI2 "stimes"
instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (DupI r1 r2) where
	(<>)   = dupI2 @Sym_Semigroup (<>)
	stimes = dupI2 @Sym_Semigroup stimes

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

instance Proj_TyConC cs (Proxy Semigroup)
data instance TokenT meta (ts::[*]) (Proxy Semigroup)
 = Token_Term_Semigroup_sappend (EToken meta ts)
 | Token_Term_Semigroup_stimes  (EToken meta ts) (EToken meta ts)
deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Semigroup))
deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Semigroup))
instance -- CompileI
 ( Read_TyName TyName (TyConsts_of_Ifaces is)
 , Inj_TyConst (TyConsts_of_Ifaces is) Semigroup
 , Inj_TyConst (TyConsts_of_Ifaces is) (->)
 , Inj_TyConst (TyConsts_of_Ifaces is) Integral
 , Proj_TyCon  (TyConsts_of_Ifaces is)
 , Compile is
 ) => CompileI is (Proxy Semigroup) where
	compileI tok ctx k =
		case tok of
		 Token_Term_Semigroup_sappend tok_a ->
			-- (<>) :: Semigroup a => a -> a -> a
			compileO tok_a ctx $ \ty_a (TermO x) ->
			check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
			k (ty_a ~> ty_a) $ TermO $
			 \c -> lam $ \y -> (<>) (x c) y
		 Token_Term_Semigroup_stimes tok_b tok_a ->
			-- stimes :: (Semigroup a, Integral b) => b -> a -> a
			compileO tok_b ctx $ \ty_b (TermO b) ->
			compileO tok_a ctx $ \ty_a (TermO a) ->
			check_TyCon (At (Just tok_a) (ty @Integral :$ ty_b)) $ \TyCon ->
			check_TyCon (At (Just tok_a) (ty @Semigroup :$ ty_a)) $ \TyCon ->
			k ty_a $ TermO $
			 \c -> stimes (b c) (a c)
instance -- TokenizeT
 Inj_Token meta ts Semigroup =>
 TokenizeT meta ts (Proxy Semigroup) where
	tokenizeT _t = mempty
	 { tokenizers_infix = tokenizeTMod []
		 [ tokenize1 "<>" (infixR 6)  Token_Term_Semigroup_sappend
		 , tokenize2 "stimes" infixN5 Token_Term_Semigroup_stimes
		 ]
	 }
instance Gram_Term_AtomsT meta ts (Proxy Semigroup) g