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 $ \_p _v -> "mempty"
  42         mappend = repr_text_app2 "mappend"
  43
  44 -- | 'mappend' alias.
  45 (<>) ::
  46  ( Sym_Monoid repr
  47  , Monoid a )
  48  => repr a -> repr a -> repr a
  49 (<>) = mappend
  50 infixr 6 <>
  51
  52 -- * Type 'Expr_Monoid'
  53 -- | Expression.
  54 data Expr_Monoid (root:: *)
  55 type instance Root_of_Expr      (Expr_Monoid root)      = root
  56 type instance Type_of_Expr      (Expr_Monoid root)      = No_Type
  57 type instance Sym_of_Expr       (Expr_Monoid root) repr = (Sym_Monoid repr)
  58 type instance Error_of_Expr ast (Expr_Monoid root)      = No_Error_Expr
  59
  60 -- | Parse 'mempty'.
  61 mempty_from
  62  :: forall root ty ast hs ret.
  63  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
  64  , Type0_From ast ty
  65  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  66                    (Error_of_Expr ast root)
  67  , Root_of_Expr root ~ root
  68  , Type0_Constraint Monoid ty
  69  ) => ast
  70  -> ExprFrom ast (Expr_Monoid root) hs ret
  71 mempty_from ast_a ex ast _ctx k =
  72  -- mempty :: Monoid a => a
  73         either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
  74         type0_from (Proxy::Proxy ty) ast_a $ \ty_a -> Right $
  75         check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_a $ \Dict ->
  76         k ty_a $ Forall_Repr_with_Context $
  77         const mempty
  78
  79 -- | Parse 'mappend'.
  80 mappend_from
  81  :: forall root ty ast hs ret.
  82  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
  83  , Type0_Eq ty
  84  , Expr_From ast root
  85  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  86                    (Error_of_Expr ast root)
  87  , Root_of_Expr root ~ root
  88  , Type0_Constraint Monoid ty
  89  ) => ast -> ast
  90  -> ExprFrom ast (Expr_Monoid root) hs ret
  91 mappend_from = class_op2_from mappend (Proxy::Proxy Monoid)
  92
  93 -- | Parse 'mappend', partially applied.
  94 mappend_from1
  95  :: forall root ty ast hs ret.
  96  ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
  97  , Type0_Eq ty
  98  , Type0_Lift Type_Fun (Type_of_Expr root)
  99  , Expr_From ast root
 100  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 101                    (Error_of_Expr ast root)
 102  , Root_of_Expr root ~ root
 103  , Type0_Constraint Monoid ty
 104  ) => ast
 105  -> ExprFrom ast (Expr_Monoid root) hs ret
 106 mappend_from1 = class_op2_from1 mappend (Proxy::Proxy Monoid)