{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, NoMonomorphismRestriction, NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__>=700
{-# LANGUAGE RebindableSyntax #-}
#endif

module Control.RMonad.Trans.List where

import Control.RMonad.Prelude

import Control.RMonad
import Control.RMonad.Trans

import Data.Suitable

import Control.Monad.Trans.List

data instance Constraints (ListT m) a = (Suitable m a, Suitable m [a]) => ListTConstraints

instance (Suitable m a, Suitable m [a]) => Suitable (ListT m) a where
   constraints = ListTConstraints

instance RMonad m => RMonad (ListT m) where
   return a = withResConstraints $ \ListTConstraints -> ListT $ return [a]
   m >>= f = withConstraintsOf m $ \ListTConstraints -> withResConstraints $ \ListTConstraints ->
             ListT $ do as <- runListT m
                        foldr (liftM2 (++)) (return []) $ map (runListT . f) as

instance RMonad m => RMonadPlus (ListT m) where
   mzero = withResConstraints $ \ListTConstraints -> ListT (return [])
   mplus (ListT m1) (ListT m2)
     = withResConstraints $ \ListTConstraints -> ListT $ liftM2 (++) m1 m2

instance RMonadTrans ListT where
  lift m = withResConstraints $ \ListTConstraints -> ListT . liftM (:[]) $ m

instance RMonadIO m => RMonadIO (ListT m) where
  liftIO m = withResConstraints $ \ListTConstraints -> lift $ liftIO m