Language/Symantic/Expr/MonoFunctor.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE FlexibleInstances #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# LANGUAGE UndecidableInstances #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 -- | Expression for 'MonoFunctor'.
  14 module Language.Symantic.Expr.MonoFunctor where
  15
  16 import Control.Monad (liftM2)
  17 import Data.Proxy (Proxy(..))
  18 import Data.Type.Equality ((:~:)(Refl))
  19 import Prelude hiding (fmap)
  20 -- import qualified Data.Function as Fun
  21 import qualified Data.MonoTraversable as MT
  22 import Data.MonoTraversable (MonoFunctor)
  23
  24 import Language.Symantic.Type
  25 import Language.Symantic.Repr
  26 import Language.Symantic.Expr.Root
  27 import Language.Symantic.Expr.Error
  28 import Language.Symantic.Expr.From
  29 import Language.Symantic.Expr.Lambda
  30 import Language.Symantic.Trans.Common
  31 import Data.Text
  32
  33 -- * Class 'Sym_MonoFunctor'
  34 -- | Symantic.
  35 class Sym_Lambda repr => Sym_MonoFunctor repr where
  36         omap :: MonoFunctor m => repr (MT.Element m -> MT.Element m) -> repr m -> repr m
  37         default omap :: (Trans t repr, MonoFunctor m)
  38          => t repr (MT.Element m -> MT.Element m) -> t repr m -> t repr m
  39         omap = trans_map2 omap
  40 instance Sym_MonoFunctor Repr_Host where
  41         omap = liftM2 MT.omap
  42 instance Sym_MonoFunctor Repr_Text where
  43         omap = repr_text_app2 "omap"
  44 instance
  45  ( Sym_MonoFunctor r1
  46  , Sym_MonoFunctor r2
  47  ) => Sym_MonoFunctor (Dup r1 r2) where
  48         omap (f1 `Dup` f2) (m1 `Dup` m2) =
  49                 omap f1 m1 `Dup` omap f2 m2
  50
  51 -- * Type 'Expr_MonoFunctor'
  52 -- | Expression.
  53 data Expr_MonoFunctor (root:: *)
  54 type instance Root_of_Expr      (Expr_MonoFunctor root)      = root
  55 type instance Type_of_Expr      (Expr_MonoFunctor root)      = No_Type
  56 type instance Sym_of_Expr       (Expr_MonoFunctor root) repr = (Sym_MonoFunctor repr)
  57 type instance Error_of_Expr ast (Expr_MonoFunctor root)      = No_Error_Expr
  58
  59 -- * Type 'TypeFamily_MonoElement'
  60 -- | Proxy type for 'MT.Element'.
  61 data TypeFamily_MonoElement
  62 type instance Host_of_TypeFamily TypeFamily_MonoElement h = MT.Element h
  63
  64 instance TypeFamily TypeFamily_MonoElement (Type_Bool root)
  65 instance TypeFamily TypeFamily_MonoElement (Type_Char root)
  66 instance TypeFamily TypeFamily_MonoElement (Type_Int root)
  67 instance TypeFamily TypeFamily_MonoElement (Type_Integer root)
  68 instance TypeFamily TypeFamily_MonoElement (Type_Ordering root)
  69 instance Lift_Type_Root (Type_Type0 (Proxy (MT.Element Text))) root =>
  70          TypeFamily TypeFamily_MonoElement (Type_Text root) where
  71         typeFamily _at Type_Type0{} = Just type_type0
  72 instance TypeFamily TypeFamily_MonoElement (Type_Unit root)
  73 instance TypeFamily TypeFamily_MonoElement (Type_Var0 root)
  74 instance TypeFamily TypeFamily_MonoElement (Type_Var1 root)
  75
  76 instance TypeFamily TypeFamily_MonoElement (Type_IO root) where
  77         typeFamily _at (Type_Type1 _px a) = Just a
  78 instance TypeFamily TypeFamily_MonoElement (Type_List root) where
  79         typeFamily _at (Type_Type1 _px a) = Just a
  80 instance TypeFamily TypeFamily_MonoElement (Type_Maybe root) where
  81         typeFamily _at (Type_Type1 _px a) = Just a
  82 instance TypeFamily TypeFamily_MonoElement (Type_Either root) where
  83         typeFamily _at (Type_Type2 _px _l r) = Just r
  84 instance TypeFamily TypeFamily_MonoElement (Type_Fun root) where
  85         typeFamily _at (Type_Type2 _px _r a) = Just a
  86 instance TypeFamily TypeFamily_MonoElement (Type_Map root) where
  87         typeFamily _at (Type_Type2 _px _k a) = Just a
  88 instance TypeFamily TypeFamily_MonoElement (Type_Tuple2 root) where
  89         typeFamily _at (Type_Type2 _px _a b) = Just b
  90
  91 -- | Parse 'omap'.
  92 omap_from
  93  :: forall root ty ast hs ret.
  94  ( ty ~ Type_Root_of_Expr (Expr_MonoFunctor root)
  95  , Eq_Type ty
  96  , Expr_from ast root
  97  , Lift_Type   Type_Fun (Type_of_Expr root)
  98  , Unlift_Type Type_Fun (Type_of_Expr root)
  99  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 100                    (Error_of_Expr ast root)
 101  , Root_of_Expr root ~ root
 102  , Constraint_Type MonoFunctor ty
 103  , TypeFamily TypeFamily_MonoElement ty
 104  ) => ast -> ast
 105  -> Expr_From ast (Expr_MonoFunctor root) hs ret
 106 omap_from ast_f ast_m ex ast ctx k =
 107  -- NOTE: omap :: (TypeFamily_MonoElement mono -> TypeFamily_MonoElement mono) -> mono -> mono
 108         expr_from (Proxy::Proxy root) ast_f ctx $
 109          \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
 110         expr_from (Proxy::Proxy root) ast_m ctx $
 111          \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
 112         check_type_fun ex ast ty_f $ \(Type_Type2 Proxy ty_f_a ty_f_b
 113          :: Type_Fun ty h_f) ->
 114         check_constraint_type ex (Proxy::Proxy MonoFunctor) ast ty_m $ \Dict ->
 115         check_eq_type ex ast ty_f_a ty_f_b $ \Refl ->
 116         check_TypeFamily (Proxy::Proxy TypeFamily_MonoElement) ex ast ty_m $ \ty_m_ele ->
 117         check_eq_type ex ast ty_f_a ty_m_ele $ \Refl ->
 118         k ty_m $ Forall_Repr_with_Context $
 119          \c -> omap (f c) (m c)