Ticket #3616: tmp.hs

File tmp.hs, 2.0 KB (added by eflister, 5 years ago)
Line 
1{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, GeneralizedNewtypeDeriving, -XNoMonomorphismRestriction #-}
2
3module MonadSupply 
4    (SupplyT,
5     MonadSupply,
6     snext,
7     snexts,
8     Supply,
9     runSupplyT,
10     runSupply,
11     useSupply)
12    where
13
14import Control.Arrow
15import Control.Monad
16import Control.Applicative
17import Control.Monad.State
18import Control.Monad.Identity
19import Data.List
20
21-- based on RWH's Supply monad in ch. 15: http://book.realworldhaskell.org/read/programming-with-monads.html#id646649
22-- transformer in ch. 18: http://book.realworldhaskell.org/read/monad-transformers.html#monadtrans.maybet
23
24-- advantages over previous version at http://www.haskell.org/haskellwiki/New_monads/MonadSupply
25-- hides implementation, handles finite supplies
26
27newtype SupplyT s m a = ST (StateT [s] m a) deriving (Functor, Monad, MonadTrans, MonadIO)
28newtype Supply s a = S (SupplyT s Identity a) deriving (Monad, Functor, MonadSupply s)
29
30class (Monad m, Functor m) => MonadSupply s m | m -> s where
31    snext  :: m (Maybe s)
32    snext  =  head <$> snexts 1
33    snexts :: Integral a => a -> m [Maybe s]
34
35instance (Monad m, Functor m) => MonadSupply s (SupplyT s m) where
36    snexts n = ST $ do -- blackh @ #haskell's solution, cleaner than my Kleislis
37        (these,rest) <- genericSplitAt n <$> get
38        put rest
39        return . genericTake n $ map Just these ++ repeat Nothing
40
41runSupply :: Supply s a -> [s] -> (a, [s])
42runSupply (S m) = runIdentity . runSupplyT m
43
44runSupplyT :: SupplyT s m a -> [s] -> m (a, [s])
45runSupplyT (ST s) = runStateT s
46
47useSupply :: (Functor f) => Supply s a -> f [s] -> f a
48useSupply = fmap . (fst `dot` runSupply)
49
50-- from http://www.haskell.org/haskellwiki/Pointfree#Dot
51dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d
52dot = (.) . (.)
53
54main :: IO ()
55main = mapM_ s [1 .. 5]
56    where s = putStrLn . show
57
58--    mapM_ s $ useSupply main' [1 .. 5]
59--    mapM_ s $ useSupply main' [replicate k ['a'..'z'] | k <- [1..]]
60
61--main' :: MonadSupply a m => m [a]
62main' = snext