gistfile1.hs

{-# LANGUAGE MagicHash, RankNTypes, UnboxedTuples #-}

import GHC.Base

newtype Counter s a = Counter (CRep s a)
type CRep s a = (# State# s, Int# #) -> (# State# s, Int#, a #)

instance Functor (Counter s) where
    fmap f (Counter m) = Counter $ \ s ->
      case (m s) of { (# new_s, n, r #) ->
      (# new_s, n, f r #) }

instance Monad (Counter s) where
    {-# INLINE return #-}
    {-# INLINE (>>)   #-}
    {-# INLINE (>>=)  #-}
    return x = Counter (\ (# s, n #) -> (# s, n, x #))
    m >> k   = m >>= \ _ -> k

    (Counter m) >>= k
      = Counter (\ (# s, n #) ->
        case (m (# s, n #)) of { (# new_s, n2, r #) ->
        case (k r) of { Counter k2 ->
        (k2 (# new_s, n2 #)) }})

runCounter :: (forall s. Counter s a) -> IO Int
runCounter (Counter rep) = IO (
    \state -> case (rep (# state, 0# #)) of
        (# state', n#, _ #) -> (# state', I# n# #) ) -- -> runSTRep (case st of { Counter st_rep -> st_rep })

one :: Counter s ()
one = Counter $ \(# s#, n# #) ->
    case n# +# 1# of var -> (# s#, var, () #)

ten :: Counter s ()
ten = Counter $ \(# s#, n# #) ->
    case n# +# 10# of var -> (# s#, var, () #)

main :: IO ()
main = do
    value <- runCounter $ do
        one
        ten
        one
    putStrLn "run"
    putStrLn $ show value
    putStrLn "stop"