{-# LANGUAGE FlexibleInstances, RankNTypes #-}

module Main ( main, useAbstractMonad ) where

import Control.Monad
import Control.Monad.ST
import Control.Applicative

newtype ReaderT r m a = ReaderT {
        -- | The underlying computation, as a function of the environment.
        runReaderT :: r -> m a
    }

instance (Applicative m) => Applicative (ReaderT r m) where
    pure    = liftReaderT . pure
    f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r

instance (Functor m) => Functor (ReaderT r m) where
    fmap f  = mapReaderT (fmap f)

instance (Monad m) => Monad (ReaderT r m) where
    m >>= k  = ReaderT $ \ r -> do
        a <- runReaderT m r
        runReaderT (k a) r

instance MonadFail m => MonadFail (ReaderT r m) where
    fail msg = ReaderT (\_ -> fail msg)

mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT f m = ReaderT $ f . runReaderT m

liftReaderT :: m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)

ask :: (Monad m) => ReaderT r m r
ask = ReaderT return

class (Applicative m, Functor m , Monad m) => MonadAbstractIOST m where
    addstuff :: Int -> m Int

type ReaderST s = ReaderT (Int) (ST s)

instance MonadAbstractIOST (ReaderST s) where
    addstuff a = return . (a +) =<< ask

runAbstractST :: (forall s. ReaderST s a) -> a
runAbstractST f = runST $ runReaderT f 99

{-# SPECIALIZE useAbstractMonad :: Int -> ReaderST s Int #-}
-- Note the polymorphism
useAbstractMonad :: MonadAbstractIOST m => Int -> m Int
useAbstractMonad n = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]

-- useConcreteMonad :: Int -> ReaderST s Int
-- useConcreteMonad = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]

main :: IO ()
main = do
    let st = runAbstractST (useAbstractMonad 5000000)
    putStrLn . show $ st