{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances, CPP #-}

module Data.Random.Lift where

import Data.RVar
import qualified Data.Functor.Identity as T
import qualified Control.Monad.Trans.Class as T
import Data.Random.Source.Std

#ifndef MTL2
import qualified Control.Monad.Identity as MTL
#endif

-- | A class for \"liftable\" data structures. Conceptually
-- an extension of 'T.MonadTrans' to allow deep lifting,
-- but lifting need not be done between monads only. Eg lifting
-- between 'Applicative's is allowed.
--
-- For instances where 'm' and 'n' have 'return'/'pure' defined,
-- these instances must satisfy
-- @lift (return x) == return x@.
-- 
-- This form of 'lift' has an extremely general type and is used primarily to
-- support 'sample'.  Its excessive generality is the main reason it's not
-- exported from "Data.Random".  'RVarT' is, however, an instance of 
-- 'T.MonadTrans', which in most cases is the preferred way
-- to do the lifting.
class Lift m n where
    lift :: m a -> n a

instance (Monad m, T.MonadTrans t) => Lift m (t m) where
    lift = T.lift

instance Lift m m where
    lift = id

-- | This instance is incoherent with the others. However,
-- by the law @lift (return x) == return x@, the results
-- must always be the same.
instance Monad m => Lift T.Identity m where
    lift = return . T.runIdentity

instance Lift (RVarT T.Identity) (RVarT m) where
    lift x = runRVar x StdRandom

-- | This instance is again incoherent with the others, but provides a
-- more-specific instance to resolve the overlap between the
-- @Lift m (t m)@ and @Lift Identity m@ instances.
instance T.MonadTrans t => Lift T.Identity (t T.Identity) where
    lift = T.lift

#ifndef MTL2

-- | This instance is incoherent with the others. However,
-- by the law @lift (return x) == return x@, the results
-- must always be the same.
instance Monad m => Lift MTL.Identity m where
    lift = return . MTL.runIdentity

instance Lift (RVarT MTL.Identity) (RVarT m) where
    lift x = runRVarTWith (return . MTL.runIdentity) x StdRandom

-- | This instance is again incoherent with the others, but provides a
-- more-specific instance to resolve the overlap between the
-- @Lift m (t m)@ and @Lift Identity m@ instances.
instance T.MonadTrans t => Lift MTL.Identity (t MTL.Identity) where
    lift = T.lift

#endif