Language/Symantic/Lib/Monad.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Monad'.
   4 module Language.Symantic.Lib.Monad where
   5
   6 import Control.Monad (Monad)
   7 import qualified Control.Monad as Monad
   8 import Data.Proxy
   9 import Data.Type.Equality ((:~:)(Refl))
  10 import Prelude hiding (Monad(..))
  11
  12 import Language.Symantic.Parsing
  13 import Language.Symantic.Typing
  14 import Language.Symantic.Compiling
  15 import Language.Symantic.Interpreting
  16 import Language.Symantic.Transforming
  17 import Language.Symantic.Lib.Applicative (Sym_Applicative)
  18
  19 -- * Class 'Sym_Monad'
  20 class Sym_Applicative term => Sym_Monad term where
  21         return :: Monad m => term a -> term (m a)
  22         (>>=)  :: Monad m => term (m a) -> term (a -> m b) -> term (m b)
  23         join   :: Monad m => term (m (m a)) -> term (m a)
  24         when   :: Applicative f => term Bool -> term (f ()) -> term (f ())
  25
  26         default return :: (Trans t term, Monad m)
  27          => t term a -> t term (m a)
  28         default (>>=) :: (Trans t term, Monad m)
  29          => t term (m a) -> t term (a -> m b) -> t term (m b)
  30         default join :: (Trans t term, Monad m)
  31          => t term (m (m a)) -> t term (m a)
  32         default when :: (Trans t term, Applicative f)
  33          => t term Bool -> t term (f ()) -> t term (f ())
  34
  35         return = trans_map1 return
  36         (>>=)  = trans_map2 (>>=)
  37         join   = trans_map1 join
  38         when   = trans_map2 when
  39
  40 infixl 1 >>=
  41
  42 type instance Sym_of_Iface (Proxy Monad) = Sym_Monad
  43 type instance Consts_of_Iface (Proxy Monad) = Proxy Monad ': Consts_imported_by Monad
  44 type instance Consts_imported_by Monad =
  45  [ Proxy ()
  46  , Proxy Applicative
  47  , Proxy Bool
  48  ]
  49
  50 instance Sym_Monad HostI where
  51         return = Monad.liftM  Monad.return
  52         (>>=)  = Monad.liftM2 (Monad.>>=)
  53         join   = Monad.liftM  Monad.join
  54         when   = Monad.liftM2 Monad.when
  55 instance Sym_Monad TextI where
  56         return = textI1 "return"
  57         (>>=)  = textI_infix ">>=" (infixL 1)
  58         join   = textI1 "join"
  59         when   = textI2 "when"
  60 instance (Sym_Monad r1, Sym_Monad r2) => Sym_Monad (DupI r1 r2) where
  61         return = dupI1 (Proxy @Sym_Monad) return
  62         (>>=)  = dupI2 (Proxy @Sym_Monad) (>>=)
  63         join   = dupI1 (Proxy @Sym_Monad) join
  64         when   = dupI2 (Proxy @Sym_Monad) when
  65
  66 instance
  67  ( Read_TypeNameR Type_Name cs rs
  68  , Inj_Const cs Monad
  69  ) => Read_TypeNameR Type_Name cs (Proxy Monad ': rs) where
  70         read_typenameR _cs (Type_Name "Monad") k = k (ty @Monad)
  71         read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
  72 instance Show_Const cs => Show_Const (Proxy Monad ': cs) where
  73         show_const ConstZ{} = "Monad"
  74         show_const (ConstS c) = show_const c
  75
  76 instance Proj_ConC cs (Proxy Monad)
  77 data instance TokenT meta (ts::[*]) (Proxy Monad)
  78  = Token_Term_Monad_return (EToken meta '[Proxy Token_Type]) (EToken meta ts)
  79  | Token_Term_Monad_bind   (EToken meta ts) (EToken meta ts)
  80  | Token_Term_Monad_join   (EToken meta ts)
  81  | Token_Term_Monad_when   (EToken meta ts) (EToken meta ts)
  82 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Monad))
  83 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Monad))
  84 instance -- CompileI
  85  ( Read_TypeName Type_Name (Consts_of_Ifaces is)
  86  , Inj_Const (Consts_of_Ifaces is) Monad
  87  , Inj_Const (Consts_of_Ifaces is) (->)
  88  , Inj_Const (Consts_of_Ifaces is) ()
  89  , Inj_Const (Consts_of_Ifaces is) Applicative
  90  , Inj_Const (Consts_of_Ifaces is) Bool
  91  , Proj_Con  (Consts_of_Ifaces is)
  92  , Compile is
  93  ) => CompileI is (Proxy Monad) where
  94         compileI tok ctx k =
  95                 case tok of
  96                  Token_Term_Monad_return tok_ty_m tok_a ->
  97                         -- return :: Monad m => a -> m a
  98                         compile_type tok_ty_m $ \(ty_m::Type (Consts_of_Ifaces is) m) ->
  99                         check_kind
 100                          (At Nothing (SKiType `SKiArrow` SKiType))
 101                          (At (Just tok_ty_m) $ kind_of ty_m) $ \Refl ->
 102                         check_con (At (Just tok_ty_m) (ty @Monad :$ ty_m)) $ \Con ->
 103                         compileO tok_a ctx $ \ty_a (TermO a) ->
 104                         k (ty_m :$ ty_a) $ TermO $
 105                          \c -> return (a c)
 106                  Token_Term_Monad_bind tok_ma tok_a2mb ->
 107                         -- (>>=) :: Monad m => m a -> (a -> m b) -> m b
 108                         compileO tok_ma   ctx $ \ty_ma   (TermO ma) ->
 109                         compileO tok_a2mb ctx $ \ty_a2mb (TermO a2mb) ->
 110                         check_con1 (ty @Monad) (At (Just tok_ma) ty_ma) $ \Refl Con ty_ma_m ty_ma_a ->
 111                         check_type2 (ty @(->)) (At (Just tok_a2mb) ty_a2mb) $ \Refl ty_a2mb_a ty_a2mb_mb ->
 112                         check_type1 ty_ma_m (At (Just tok_a2mb) ty_a2mb_mb) $ \Refl _ty_a2mb_mb_b ->
 113                         check_type
 114                          (At (Just tok_a2mb) ty_a2mb_a)
 115                          (At (Just tok_ma) ty_ma_a) $ \Refl ->
 116                         k ty_a2mb_mb $ TermO $
 117                          \c -> (>>=) (ma c) (a2mb c)
 118                  Token_Term_Monad_join tok_mma ->
 119                         -- join :: Monad m => m (m a) -> m a
 120                         compileO tok_mma ctx $ \ty_mma (TermO mma) ->
 121                         check_con1 (ty @Monad) (At (Just tok_mma) ty_mma) $ \Refl Con ty_mma_m ty_mma_ma ->
 122                         check_type1 ty_mma_m (At (Just tok_mma) ty_mma_ma) $ \Refl _ty_mma_ma_a ->
 123                         k ty_mma_ma $ TermO $
 124                          \c -> join (mma c)
 125                  Token_Term_Monad_when tok_cond tok_ok ->
 126                         -- when :: Applicative f => Bool -> f () -> f ()
 127                         compileO tok_cond ctx $ \ty_cond (TermO cond) ->
 128                         compileO tok_ok   ctx $ \ty_ok   (TermO ok) ->
 129                         check_con1 (ty @Applicative) (At (Just tok_ok) ty_ok) $ \Refl Con _ty_ok_f ty_ok_u ->
 130                         check_type
 131                          (At Nothing (ty @Bool))
 132                          (At (Just tok_cond) ty_cond) $ \Refl ->
 133                         check_type
 134                          (At Nothing (ty @()))
 135                          (At (Just tok_ok) ty_ok_u) $ \Refl ->
 136                         k ty_ok $ TermO $
 137                          \c -> when (cond c) (ok c)
 138 instance -- TokenizeT
 139  Inj_Token meta ts Monad =>
 140  TokenizeT meta ts (Proxy Monad) where
 141         tokenizeT _t = mempty
 142          { tokenizers_infix = tokenizeTMod []
 143                  [ (Term_Name "Nothing",) Term_ProTok
 144                          { term_protok = \meta -> ProTokPi $ \m -> ProTokLam $ \a ->
 145                                 ProTok $ inj_etoken meta $ Token_Term_Monad_return m a
 146                          , term_fixity = infixN5
 147                          }
 148                  , tokenize2 ">>="  (infixL 1) Token_Term_Monad_bind
 149                  , tokenize1 "join" infixN5    Token_Term_Monad_join
 150                  , tokenize2 "when" infixN5    Token_Term_Monad_when
 151                  ]
 152          }
 153 instance Gram_Term_AtomsT meta ts (Proxy Monad) g