Language/Symantic/Expr/Monoid.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 -- | Expression for 'Monoid'.
  13 module Language.Symantic.Expr.Monoid where
  14
  15 import Control.Monad
  16 import Data.Monoid (Monoid)
  17 import qualified Data.Monoid as Monoid
  18 import Data.Proxy (Proxy(..))
  19 import Prelude hiding ((<$>), Monoid(..))
  20
  21 import Language.Symantic.Type
  22 import Language.Symantic.Repr
  23 import Language.Symantic.Expr.Root
  24 import Language.Symantic.Expr.Error
  25 import Language.Symantic.Expr.From
  26 import Language.Symantic.Trans.Common
  27
  28 -- * Class 'Sym_Monoid'
  29 -- | Symantic.
  30 class Sym_Monoid repr where
  31         mempty  :: Monoid a => repr a
  32         mappend :: Monoid a => repr a -> repr a -> repr a
  33         default mempty  :: (Trans t repr, Monoid a) => t repr a
  34         default mappend :: (Trans t repr, Monoid a) => t repr a -> t repr a -> t repr a
  35         mempty  = trans_lift mempty
  36         mappend = trans_map2 mappend
  37 instance Sym_Monoid Repr_Host where
  38         mempty  = Repr_Host Monoid.mempty
  39         mappend = liftM2 Monoid.mappend
  40 instance Sym_Monoid Repr_Text where
  41         mempty  = repr_text_app0 "mempty"
  42         mappend = repr_text_app2 "mappend"
  43 instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (Repr_Dup r1 r2) where
  44         mempty  = repr_dup0 sym_Monoid mempty
  45         mappend = repr_dup2 sym_Monoid mappend
  46
  47 sym_Monoid :: Proxy Sym_Monoid
  48 sym_Monoid = Proxy
  49
  50 -- | 'mappend' alias.
  51 (<>) ::
  52  ( Sym_Monoid repr
  53  , Monoid a )
  54  => repr a -> repr a -> repr a
  55 (<>) = mappend
  56 infixr 6 <>
  57
  58 -- * Type 'Expr_Monoid'
  59 -- | Expression.
  60 data Expr_Monoid (root:: *)
  61 type instance Root_of_Expr      (Expr_Monoid root)      = root
  62 type instance Type_of_Expr      (Expr_Monoid root)      = No_Type
  63 type instance Sym_of_Expr       (Expr_Monoid root) repr = (Sym_Monoid repr)
  64 type instance Error_of_Expr ast (Expr_Monoid root)      = No_Error_Expr
  65
  66 -- | Parse 'mempty'.
  67 mempty_from
  68  :: forall root ty ast hs ret.
  69  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
  70  , Type0_From ast ty
  71  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  72                    (Error_of_Expr ast root)
  73  , Root_of_Expr root ~ root
  74  , Type0_Constraint Monoid ty
  75  ) => ast
  76  -> ExprFrom ast (Expr_Monoid root) hs ret
  77 mempty_from ast_a ex ast _ctx k =
  78  -- mempty :: Monoid a => a
  79         either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
  80         type0_from (Proxy::Proxy ty) ast_a $ \ty_a -> Right $
  81         check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_a $ \Dict ->
  82         k ty_a $ Forall_Repr_with_Context $
  83         const mempty
  84
  85 -- | Parse 'mappend'.
  86 mappend_from
  87  :: forall root ty ast hs ret.
  88  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
  89  , Type0_Eq ty
  90  , Expr_From ast root
  91  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  92                    (Error_of_Expr ast root)
  93  , Root_of_Expr root ~ root
  94  , Type0_Constraint Monoid ty
  95  ) => ast -> ast
  96  -> ExprFrom ast (Expr_Monoid root) hs ret
  97 mappend_from = class_op2_from mappend (Proxy::Proxy Monoid)
  98
  99 -- | Parse 'mappend', partially applied.
 100 mappend_from1
 101  :: forall root ty ast hs ret.
 102  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
 103  , Type0_Eq ty
 104  , Type0_Lift Type_Fun (Type_of_Expr root)
 105  , Expr_From ast root
 106  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 107                    (Error_of_Expr ast root)
 108  , Root_of_Expr root ~ root
 109  , Type0_Constraint Monoid ty
 110  ) => ast
 111  -> ExprFrom ast (Expr_Monoid root) hs ret
 112 mappend_from1 = class_op2_from1 mappend (Proxy::Proxy Monoid)