{-# 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 Data.Type.Equality ((:~:)(Refl))
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 $ \_p _v -> "mempty"
	mappend = repr_text_app2 "mappend"

-- | '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 ast_x ast_y ex ast ctx k =
 -- mappend :: Monoid a => a -> a -> a
	expr_from (Proxy::Proxy root) ast_x ctx $
	 \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
	expr_from (Proxy::Proxy root) ast_y ctx $
	 \(ty_y::ty h_y) (Forall_Repr_with_Context y) ->
	check_type0_eq ex ast ty_x ty_y $ \Refl ->
	check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_x $ \Dict ->
	k ty_x $ Forall_Repr_with_Context $
	 \c -> mappend (x c) (y c)