{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Expression for 'Monoid'.
module Language.Symantic.Expr.Monoid where

import Control.Monad
import Data.Monoid (Monoid)
import qualified Data.Monoid as Monoid
import Data.Proxy (Proxy(..))
import Prelude hiding ((<$>), Monoid(..))

import Language.Symantic.Type
import Language.Symantic.Repr
import Language.Symantic.Expr.Root
import Language.Symantic.Expr.Error
import Language.Symantic.Expr.From
import Language.Symantic.Trans.Common

-- * Class 'Sym_Monoid'
-- | Symantic.
class Sym_Monoid repr where
	mempty  :: Monoid a => repr a
	mappend :: Monoid a => repr a -> repr a -> repr a
	default mempty  :: (Trans t repr, Monoid a) => t repr a
	default mappend :: (Trans t repr, Monoid a) => t repr a -> t repr a -> t repr a
	mempty  = trans_lift mempty
	mappend = trans_map2 mappend
instance Sym_Monoid Repr_Host where
	mempty  = Repr_Host Monoid.mempty
	mappend = liftM2 Monoid.mappend
instance Sym_Monoid Repr_Text where
	mempty  = repr_text_app0 "mempty"
	mappend = repr_text_app2 "mappend"
instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (Repr_Dup r1 r2) where
	mempty  = repr_dup0 sym_Monoid mempty
	mappend = repr_dup2 sym_Monoid mappend

sym_Monoid :: Proxy Sym_Monoid
sym_Monoid = Proxy

-- | 'mappend' alias.
(<>) ::
 ( Sym_Monoid repr
 , Monoid a )
 => repr a -> repr a -> repr a
(<>) = mappend
infixr 6 <>

-- * Type 'Expr_Monoid'
-- | Expression.
data Expr_Monoid (root:: *)
type instance Root_of_Expr      (Expr_Monoid root)      = root
type instance Type_of_Expr      (Expr_Monoid root)      = No_Type
type instance Sym_of_Expr       (Expr_Monoid root) repr = Sym_Monoid repr
type instance Error_of_Expr ast (Expr_Monoid root)      = No_Error_Expr

-- | Parse 'mempty'.
mempty_from
 :: forall root ty ast hs ret.
 ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
 , Type0_From ast ty
 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
                   (Error_of_Expr ast root)
 , Root_of_Expr root ~ root
 , Type0_Constraint Monoid ty
 ) => ast
 -> ExprFrom ast (Expr_Monoid root) hs ret
mempty_from ast_a ex ast _ctx k =
 -- mempty :: Monoid a => a
	either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
	type0_from (Proxy::Proxy ty) ast_a $ \ty_a -> Right $
	check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_a $ \Dict ->
	k ty_a $ Forall_Repr_with_Context $
	const mempty

-- | Parse 'mappend'.
mappend_from
 :: forall root ty ast hs ret.
 ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
 , Type0_Eq ty
 , Expr_From ast root
 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
                   (Error_of_Expr ast root)
 , Root_of_Expr root ~ root
 , Type0_Constraint Monoid ty
 ) => ast -> ast
 -> ExprFrom ast (Expr_Monoid root) hs ret
mappend_from = class_op2_from mappend (Proxy::Proxy Monoid)

-- | Parse 'mappend', partially applied.
mappend_from1
 :: forall root ty ast hs ret.
 ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
 , Type0_Eq ty
 , Type0_Lift Type_Fun (Type_of_Expr root)
 , Expr_From ast root
 , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
                   (Error_of_Expr ast root)
 , Root_of_Expr root ~ root
 , Type0_Constraint Monoid ty
 ) => ast
 -> ExprFrom ast (Expr_Monoid root) hs ret
mappend_from1 = class_op2_from1 mappend (Proxy::Proxy Monoid)