{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ < 708
#define TYPEABLE Typeable1
#else
#define TYPEABLE Typeable
#endif

-- | 'Syntactic' instance for 'Remon' for domains based on 'Binding'

module Language.Syntactic.Sugar.Monad where



import Control.Monad.Cont
import Data.Typeable

import Language.Syntactic
import Language.Syntactic.Functional
import Language.Syntactic.Sugar.Binding ()



-- | One-layer sugaring of monadic actions
sugarMonad :: (Binding :<: sym, MONAD m :<: sym) =>
    ASTF sym (m a) -> Remon sym m (ASTF sym a)
sugarMonad :: ASTF sym (m a) -> Remon sym m (ASTF sym a)
sugarMonad ASTF sym (m a)
ma = (forall r. Typeable r => Cont (ASTF sym (m r)) (ASTF sym a))
-> Remon sym m (ASTF sym a)
forall (sym :: * -> *) (m :: * -> *) a.
(forall r. Typeable r => Cont (ASTF sym (m r)) a) -> Remon sym m a
Remon ((forall r. Typeable r => Cont (ASTF sym (m r)) (ASTF sym a))
 -> Remon sym m (ASTF sym a))
-> (forall r. Typeable r => Cont (ASTF sym (m r)) (ASTF sym a))
-> Remon sym m (ASTF sym a)
forall a b. (a -> b) -> a -> b
$ ((ASTF sym a -> ASTF sym (m r)) -> ASTF sym (m r))
-> Cont (ASTF sym (m r)) (ASTF sym a)
forall a r. ((a -> r) -> r) -> Cont r a
cont (((ASTF sym a -> ASTF sym (m r)) -> ASTF sym (m r))
 -> Cont (ASTF sym (m r)) (ASTF sym a))
-> ((ASTF sym a -> ASTF sym (m r)) -> ASTF sym (m r))
-> Cont (ASTF sym (m r)) (ASTF sym a)
forall a b. (a -> b) -> a -> b
$ MONAD m (m a :-> ((a -> m r) :-> Full (m r)))
-> ASTF sym (m a)
-> (ASTF sym a -> ASTF sym (m r))
-> ASTF sym (m r)
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym MONAD m (m a :-> ((a -> m r) :-> Full (m r)))
forall (m :: * -> *) a b.
MONAD m (m a :-> ((a -> m b) :-> Full (m b)))
Bind ASTF sym (m a)
ma

instance
    ( Syntactic a
    , Domain a ~ sym
    , Binding :<: sym
    , MONAD m :<: sym
    , TYPEABLE m
    , Typeable (Internal a)
        -- The `Typeable` constraints are only needed due to the `Typeable`
        -- constraint in `Remon`. That constraint, in turn, is only needed by
        -- the module "Language.Syntactic.Sugar.MonadT".
    ) =>
      Syntactic (Remon sym m a)
  where
    type Domain (Remon sym m a)   = sym
    type Internal (Remon sym m a) = m (Internal a)
    desugar :: Remon sym m a
-> ASTF (Domain (Remon sym m a)) (Internal (Remon sym m a))
desugar = Remon sym m (ASTF sym (Internal a)) -> ASTF sym (m (Internal a))
forall (m :: * -> *) (sym :: * -> *) a.
(MONAD m :<: sym, Typeable a, Typeable m) =>
Remon sym m (ASTF sym a) -> ASTF sym (m a)
desugarMonad (Remon sym m (ASTF sym (Internal a)) -> ASTF sym (m (Internal a)))
-> (Remon sym m a -> Remon sym m (ASTF sym (Internal a)))
-> Remon sym m a
-> ASTF sym (m (Internal a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ASTF sym (Internal a))
-> Remon sym m a -> Remon sym m (ASTF sym (Internal a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ASTF sym (Internal a)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar
    sugar :: ASTF (Domain (Remon sym m a)) (Internal (Remon sym m a))
-> Remon sym m a
sugar   = (ASTF sym (Internal a) -> a)
-> Remon sym m (ASTF sym (Internal a)) -> Remon sym m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ASTF sym (Internal a) -> a
forall a. Syntactic a => ASTF (Domain a) (Internal a) -> a
sugar   (Remon sym m (ASTF sym (Internal a)) -> Remon sym m a)
-> (ASTF sym (m (Internal a))
    -> Remon sym m (ASTF sym (Internal a)))
-> ASTF sym (m (Internal a))
-> Remon sym m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF sym (m (Internal a)) -> Remon sym m (ASTF sym (Internal a))
forall (sym :: * -> *) (m :: * -> *) a.
(Binding :<: sym, MONAD m :<: sym) =>
ASTF sym (m a) -> Remon sym m (ASTF sym a)
sugarMonad