Ticket #3616: tmp.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, GeneralizedNewtypeDeriving, -XNoMonomorphismRestriction #-}

module MonadSupply 
    (SupplyT,
     MonadSupply,
     snext,
     snexts,
     Supply,
     runSupplyT,
     runSupply,
     useSupply)
    where

import Control.Arrow
import Control.Monad
import Control.Applicative
import Control.Monad.State
import Control.Monad.Identity
import Data.List

-- based on RWH's Supply monad in ch. 15: http://book.realworldhaskell.org/read/programming-with-monads.html#id646649
-- transformer in ch. 18: http://book.realworldhaskell.org/read/monad-transformers.html#monadtrans.maybet

-- advantages over previous version at http://www.haskell.org/haskellwiki/New_monads/MonadSupply
-- hides implementation, handles finite supplies

newtype SupplyT s m a = ST (StateT [s] m a) deriving (Functor, Monad, MonadTrans, MonadIO)
newtype Supply s a = S (SupplyT s Identity a) deriving (Monad, Functor, MonadSupply s)

class (Monad m, Functor m) => MonadSupply s m | m -> s where
    snext  :: m (Maybe s)
    snext  =  head <$> snexts 1
    snexts :: Integral a => a -> m [Maybe s]

instance (Monad m, Functor m) => MonadSupply s (SupplyT s m) where
    snexts n = ST $ do -- blackh @ #haskell's solution, cleaner than my Kleislis
        (these,rest) <- genericSplitAt n <$> get
        put rest
        return . genericTake n $ map Just these ++ repeat Nothing

runSupply :: Supply s a -> [s] -> (a, [s])
runSupply (S m) = runIdentity . runSupplyT m

runSupplyT :: SupplyT s m a -> [s] -> m (a, [s])
runSupplyT (ST s) = runStateT s

useSupply :: (Functor f) => Supply s a -> f [s] -> f a
useSupply = fmap . (fst `dot` runSupply)

-- from http://www.haskell.org/haskellwiki/Pointfree#Dot
dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d
dot = (.) . (.)

main :: IO ()
main = mapM_ s [1 .. 5]
    where s = putStrLn . show

--    mapM_ s $ useSupply main' [1 .. 5]
--    mapM_ s $ useSupply main' [replicate k ['a'..'z'] | k <- [1..]]

--main' :: MonadSupply a m => m [a]
main' = snext