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

import Data.Monoid (Monoid)
import Prelude hiding (Monoid(..))
import qualified Data.Monoid as Monoid

import Language.Symantic
import Language.Symantic.Lib.Function (a0)

-- * Class 'Sym_Monoid'
type instance Sym Monoid = Sym_Monoid
class Sym_Monoid term where
	mempty  :: Monoid a => term a
	mappend :: Monoid a => term a -> term a -> term a
	default mempty  :: Sym_Monoid (UnT term) => Trans term => Monoid a => term a
	default mappend :: Sym_Monoid (UnT term) => Trans term => Monoid a => term a -> term a -> term a
	mempty  = trans mempty
	mappend = trans2 mappend

-- Interpreting
instance Sym_Monoid Eval where
	mempty  = Eval  Monoid.mempty
	mappend = eval2 Monoid.mappend
instance Sym_Monoid View where
	mempty  = view0 "mempty"
	mappend = view2 "mappend"
instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (Dup r1 r2) where
	mempty  = dup0 @Sym_Monoid mempty
	mappend = dup2 @Sym_Monoid mappend

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

-- Typing
instance NameTyOf Monoid where
	nameTyOf _c = ["Monoid"] `Mod` "Monoid"
instance FixityOf Monoid
instance ClassInstancesFor Monoid
instance TypeInstancesFor Monoid

-- Compiling
instance Gram_Term_AtomsFor src ss g Monoid
instance (Source src, SymInj ss Monoid) => ModuleFor src ss Monoid where
	moduleFor = ["Monoid"] `moduleWhere`
	 [ "mempty"  := teMonoid_mempty
	 , "mappend" := teMonoid_mappend
	 ]

-- ** 'Type's
tyMonoid :: Source src => Type src vs a -> Type src vs (Monoid a)
tyMonoid a = tyConstLen @(K Monoid) @Monoid (lenVars a) `tyApp` a

-- ** 'Term's
teMonoid_mempty :: TermDef Monoid '[Proxy a] (Monoid a #> a)
teMonoid_mempty = Term (tyMonoid a0) a0 $ teSym @Monoid $ mempty

teMonoid_mappend :: TermDef Monoid '[Proxy a] (Monoid a #> (a -> a -> a))
teMonoid_mappend = Term (tyMonoid a0) (a0 ~> a0 ~> a0) $ teSym @Monoid $ lam2 mappend