fail.hs

{-# Language MultiParamTypeClasses, PolyKinds #-}
module Monads where

import Control.Monad.Reader
import Data.Binary.Get
import Data.Proxy
import qualified Data.ByteString.Lazy as BS

type ReadContext = String
type MyGetM m = ReaderT ReadContext m
type MyGetter t m = MyGetM m

data ProtoProxy t m = ProtoProxy
protofoo :: ProtoProxy ProtoFoo Get
protofoo = ProtoProxy

class Monad m => Proto t m where
    getTop :: ProtoProxy t m -> BS.ByteString -> String
    getBool :: MyGetter t m Bool
    getString :: MyGetter t m String

data ProtoFoo = ProtoFoo

type FooGetter = MyGetter ProtoFoo Get

instance Proto ProtoFoo Get where
    getTop _ s = runGet (runReaderT (getString :: FooGetter String) "foo") s
    getString = ask
    getBool = do
        v <- lift getWord8
        return (v /= 0)

runMe :: Proto t m => ProtoProxy t m -> String
runMe p = getTop p BS.empty

good.hs

{-# Language MultiParamTypeClasses, PolyKinds #-}
module Monads where

import Control.Monad.Reader
import Data.Binary.Get
import Data.Proxy
import qualified Data.ByteString.Lazy as BS

type ReadContext = String
type MyGetM m = ReaderT ReadContext m

data MyGetter t m a = MyGetter (MyGetM m a)

instance Functor m => Functor (MyGetter t m) where
    fmap f (MyGetter g) = MyGetter (fmap f g)
instance Applicative m => Applicative (MyGetter t m) where
    pure v = MyGetter (pure v)
    (MyGetter a) <*> (MyGetter b) = MyGetter (a <*> b)
instance Monad m => Monad (MyGetter t m) where
    (MyGetter a) >>= g = let unget (MyGetter a) = a
                          in MyGetter (a >>= (unget . g))

data ProtoProxy t m = ProtoProxy
protofoo :: ProtoProxy ProtoFoo Get
protofoo = ProtoProxy

class Monad m => Proto t m where
    getTop :: ProtoProxy t m -> BS.ByteString -> String
    getBool :: MyGetter t m Bool
    getString :: MyGetter t m String

data ProtoFoo = ProtoFoo

type FooGetter = MyGetter ProtoFoo Get

instance Proto ProtoFoo Get where
    getTop _ s = let MyGetter g = getString :: FooGetter String
                  in runGet (runReaderT g "foo") s
    getString = MyGetter ask
    getBool = do
        v <- MyGetter (lift getWord8)
        return (v /= 0)

runMe :: Proto t m => ProtoProxy t m -> String
runMe p = getTop p BS.empty