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

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

-- | 'Syntactic' instance for 'Remon' for domains based on 'Typed' and
-- 'BindingT'

module Language.Syntactic.Sugar.MonadTyped where



import Control.Monad.Cont
import Data.Typeable

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



-- | One-layer sugaring of monadic actions
sugarMonad
    :: ( sym ~ Typed s
       , BindingT :<: s
       , MONAD m  :<: s
       , TYPEABLE m
       , Typeable a
       )
    => 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 (Typed sup) sig, sig ~ SmartSig fi,
 Typed sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup,
 Typeable (DenResult sig)) =>
sub sig -> f
sugarSymTyped 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
    ( sym ~ Typed s
    , Syntactic a, Domain a ~ sym
    , BindingT :<: s
    , MONAD m  :<: s
    , TYPEABLE m
    , Typeable (Internal a)
    ) =>
      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 :: * -> *) (s :: * -> *) (sym :: * -> *) a.
(MONAD m :<: s, sym ~ Typed s, Typeable a, Typeable m) =>
Remon sym m (ASTF sym a) -> ASTF sym (m a)
desugarMonadTyped (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 :: * -> *) (s :: * -> *) (m :: * -> *) a.
(sym ~ Typed s, BindingT :<: s, MONAD m :<: s, Typeable m,
 Typeable a) =>
ASTF sym (m a) -> Remon sym m (ASTF sym a)
sugarMonad