How to test Monad instance for custom StateT? - haskell

I'm learning Monad Transformers, and one of the exercises asks to implement the Monad instance for StateT.
I want to test that my implementation admits to the Monad laws using the validity package, which is like the checkers package.
Problem is, my Arbitrary instance doesn't compile. I saw this question, but it doesn't quite do what I want because the test basically duplicates the implementation and doesn't check the laws.
There's also this question, but it's unanswered, and I've already figured out how to test Monad Transformers not involving functions (like MaybeT).
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE InstanceSigs #-}
module Ch11.MonadT (StT (..)) where
import Control.Monad.Trans.State (StateT (..))
newtype StT s m a = StT (s -> m (a, s))
deriving
(Functor, Applicative)
via StateT s m
instance (Monad m) => Monad (StT s m) where
return :: a -> StT s m a
return = pure
(>>=) :: StT s m a -> (a -> StT s m b) -> StT s m b
StT x >>= f = StT $ \s -> do
(k, s') <- x s
let StT y = f k
y s'
(>>) :: StT s m a -> StT s m b -> StT s m b
(>>) = (*>)
My test:
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Ch11.MonadTSpec (spec) where
import Ch11.MonadT (StT (..))
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Monad
spec :: Spec
spec = do
monadSpecOnArbitrary #(StTArbit Int [] Int)
-- create wrapper to avoid orphan instance error
newtype StTArbit s m a = StTArbit (StT s m a)
deriving
(Functor, Applicative, Monad)
instance (Arbitrary s, Function s, Arbitrary1 m, Arbitrary a) => Arbitrary (StTArbit s m a) where
arbitrary = do
f <- arbitrary :: Fun s (m (a, s))
StTArbit . StT <$> f
Error:
• Couldn't match type: (a0, s0)
with: s -> m (a, s)
Expected: Gen (s -> m (a, s))
Actual: Gen (a0, s0)
• In the second argument of ‘(<$>)’, namely ‘f’
In a stmt of a 'do' block: StTArbit . StT <$> f

OP here, this is what I ended up doing.
-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/explicit_forall.html
{-# LANGUAGE ExplicitForAll #-}
-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html
{-# LANGUAGE TypeApplications #-}
module Ch11.MonadTSpec (spec) where
import Ch11.MonadT (StT (..), runStT)
import Data.Function as F
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
spec :: Spec
spec = do
describe "Monad (StT Int [])" $ do
describe "satisfies Monad laws" $ do
-- the types are in the same order as in `forall`
prop "right identity law" (prop_monadRightId #Int #Int #[])
prop "left identity law" (prop_monadLeftId #Int #Int #Int #[])
prop "associative law" (prop_monadAssoc #Int #Int #Int #Int #[])
{- HLINT ignore -}
{-
the types in `forall` are specified in the order of dependency.
since `m` needs `a` and `s`, those appear before `m` in the list.
-}
-- (x >>= return) == x
prop_monadRightId ::
forall a s m.
(Monad m, Eq (m (a, s)), Show (m (a, s))) =>
s ->
Fun s (m (a, s)) ->
Property
prop_monadRightId s f = ((===) `F.on` go) (m >>= return) m
where
m = StT $ applyFun f
go st = runStT st s
-- (return x >>= f) == (f x)
prop_monadLeftId ::
forall a b s m.
(Monad m, Eq (m (b, s)), Show (m (b, s))) =>
a ->
s ->
Fun (a, s) (m (b, s)) ->
Property
prop_monadLeftId a s f = ((===) `F.on` go) (return a >>= h) m
where
g = applyFun2 f
m = StT $ g a
h = StT . g
go st = runStT st s
-- ((x >>= f) >>= g) == (x >>= (\x' -> f x' >>= g))
prop_monadAssoc ::
forall a b c s m.
(Monad m, Eq (m (b, s)), Show (m (b, s)), Eq (m (c, s)), Show (m (c, s))) =>
s ->
Fun s (m (a, s)) ->
Fun (a, s) (m (b, s)) ->
Fun (b, s) (m (c, s)) ->
Property
prop_monadAssoc s h f g =
((===) `F.on` go)
((m >>= f') >>= g')
(m >>= (\x -> f' x >>= g'))
where
m = StT $ applyFun h
f' = StT . applyFun2 f
g' = StT . applyFun2 g
go st = runStT st s

I think you want pure, not (<$>). (But I haven't checked with my local compiler, so I'm not sure.) You probably also have to turn your Fun into an actual function.
arbitrary = do
f <- arbitrary
pure (StTArbit . StT . applyFun $ f)
I'd also point out that there's not much point to making a newtype here. I guess it avoids an orphan instance warning? But you've defined the type you're writing an instance for yourself, presumably even in the same package, so it seems pretty benign; if it's part of a separate cabal component that people can't depend on, like a test suite, even more so.

Related

How can I use Template Haskell to build structures polymorphically?

I can write an instance
-- In Data.Sequence.Internal
instance Lift a => Lift (Seq a) where
...
letting users lift fully realized sequences into splices. But suppose I want something a bit different, to build functions for creating sequences?
sequenceCode :: Quote m => Seq (Code m a) -> Code m (Seq a)
sequenceCode = ???
The idea would be that I'd be able to write something like
triple :: a -> a -> a -> Seq a
triple a b c = $$(sequenceCode (fromList [[|| a ||], [|| b ||], [|| c ||]]))
and have that function build its sequence directly with the underlying sequence constructors, rather than having to build and convert a list at run-time.
It's not very hard to write something like sequenceCode directly for sequences, using their internals (look below the jump). But, as the name suggests, sequenceCode looks a lot like sequence. Is there a way to generalize it? A moment's reflection shows that Traversable is insufficient. Would it be possible to do something with the Generic1 class in staged generics? I made a few attempts, but I don't understand that package well enough to know the right place to start. Would it be possible even just using plain old GHC generics? I'm beginning to suspect so, but I haven't tried yet and it will surely be hairy.
Here's the code for a Data.Sequence version:
{-# language TemplateHaskellQuotes #-}
import Data.Sequence.Internal
import qualified Language.Haskell.TH.Syntax as TH
class Functor t => SequenceCode t where
traverseCode :: TH.Quote m => (a -> TH.Code m b) -> t a -> TH.Code m (t b)
traverseCode f = sequenceCode . fmap f
sequenceCode :: TH.Quote m => t (TH.Code m a) -> TH.Code m (t a)
sequenceCode = traverseCode id
instance SequenceCode Seq where
sequenceCode (Seq t) = [|| Seq $$(traverseCode sequenceCode t) ||]
instance SequenceCode Elem where
sequenceCode (Elem t) = [|| Elem $$t ||]
instance SequenceCode FingerTree where
sequenceCode (Deep s pr m sf) =
[|| Deep s $$(sequenceCode pr) $$(traverseCode sequenceCode m) $$(sequenceCode sf) ||]
sequenceCode (Single a) = [|| Single $$a ||]
sequenceCode EmptyT = [|| EmptyT ||]
instance SequenceCode Digit where
sequenceCode (One a) = [|| One $$a ||]
sequenceCode (Two a b) = [|| Two $$a $$b ||]
sequenceCode (Three a b c) = [|| Three $$a $$b $$c ||]
sequenceCode (Four a b c d) = [|| Four $$a $$b $$c $$d ||]
instance SequenceCode Node where
sequenceCode (Node2 s x y) = [|| Node2 s $$x $$y ||]
sequenceCode (Node3 s x y z) = [|| Node3 s $$x $$y $$z ||]
Then in another module, we can define triple as above:
triple :: a -> a -> a -> Seq a
triple a b c = $$(sequenceCode (fromList [[|| a ||], [|| b ||], [|| c ||]]))
When I compile this with -ddump-splices (or -ddump-ds), I can verify that the sequence is built directly rather than using fromList.
I've uploaded a package that does this.
It turns out that GHC.Generics is sufficient. However, I will actually use linear-generics instead, because it has a more general version of Generic1. The idea is that by examining the generic representation of a value, we can build up all the information we need to produce a Template Haskell code for it. It's all quite low-level! First, some throat-clearing:
{-# language TemplateHaskellQuotes #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language ScopedTypeVariables #-}
{-# language DataKinds #-}
{-# language TypeOperators #-}
{-# language EmptyCase #-}
{-# language DefaultSignatures #-}
module Language.Haskell.TH.TraverseCode
( TraverseCode (..)
, sequenceCode
, genericTraverseCode
, genericSequenceCode
) where
import Generics.Linear
import Language.Haskell.TH.Syntax
(Code, Lift (..), Exp (..), Quote, Name)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Lib (conE)
import Data.Kind (Type)
-- for instances
import qualified Data.Functor.Product as FProd
import qualified Data.Functor.Sum as FSum
import Data.Functor.Identity
import qualified Data.Sequence.Internal as Seq
import Data.Coerce
Now we'll get into the meat of things:
class TraverseCode t where
traverseCode :: Quote m => (a -> Code m b) -> t a -> Code m (t b)
default traverseCode
:: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
=> (a -> Code m b) -> t a -> Code m (t b)
traverseCode = genericTraverseCode
sequenceCode
:: (TraverseCode t, Quote m)
=> t (Code m a) -> Code m (t a)
sequenceCode = traverseCode id
genericSequenceCode
:: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
=> t (Code m a) -> Code m (t a)
genericSequenceCode = TH.unsafeCodeCoerce . gtraverseCode id . from1
genericTraverseCode
:: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
=> (a -> Code m b) -> t a -> Code m (t b)
genericTraverseCode f = TH.unsafeCodeCoerce . gtraverseCode f . from1
class GTraverseCode f where
gtraverseCode :: Quote m => (a -> Code m b) -> f a -> m Exp
Why do we use untyped Template Haskell here? Simple: it's pretty easy to build the expressions we need, but working out how to make types useful for the sub-expressions would be tricky. So then, of course, we need generic instances. We'll work our way down step by step, from the outside in, gathering info along the way.
First we look at the type stuff:
instance (Datatype c, GTraverseCodeCon f)
=> GTraverseCode (D1 c f) where
gtraverseCode f m#(M1 x) = gtraverseCodeCon pkg modl f x
where
pkg = packageName m
modl = moduleName m
This gets us the names GHC uses for the package and module.
Next we look at the constructor stuff:
class GTraverseCodeCon f where
gtraverseCodeCon :: Quote m => String -> String -> (a -> Code m b) -> f a -> m Exp
instance GTraverseCodeCon V1 where
gtraverseCodeCon _pkg _modl _f x = case x of
instance (GTraverseCodeCon f, GTraverseCodeCon g)
=> GTraverseCodeCon (f :+: g) where
gtraverseCodeCon pkg modl f (L1 x) = gtraverseCodeCon pkg modl f x
gtraverseCodeCon pkg modl f (R1 y) = gtraverseCodeCon pkg modl f y
instance (Constructor c, GTraverseCodeFields f)
=> GTraverseCodeCon (C1 c f) where
gtraverseCodeCon pkg modl f m#(M1 x) = gtraverseCodeFields (conE conN) f x
where
conBase = conName m
conN :: Name
conN = TH.mkNameG_d pkg modl conBase
The interesting case is when we reach an actual constructor (C1). Here we grab the (unqualified) name of the constructor from the Constructor instance, and combine it with the package and module names to get the Template Haskell Name of the constructor, from which we can build an expression referring to it. This expression gets passed on down to the lowest level, where we deal with fields. The rest is basically a left fold over those fields.
class GTraverseCodeFields f where
gtraverseCodeFields :: Quote m => m Exp -> (a -> Code m b) -> f a -> m Exp
instance GTraverseCodeFields f => GTraverseCodeFields (S1 c f) where
gtraverseCodeFields c f (M1 x) = gtraverseCodeFields c f x
instance (GTraverseCodeFields f, GTraverseCodeFields g)
=> GTraverseCodeFields (f :*: g) where
gtraverseCodeFields c f (x :*: y) =
gtraverseCodeFields (gtraverseCodeFields c f x) f y
instance Lift p => GTraverseCodeFields (K1 i p) where
gtraverseCodeFields c _f (K1 x) = [| $c x |]
instance GTraverseCodeFields Par1 where
gtraverseCodeFields cc f (Par1 ca) =
[| $cc $(TH.unTypeCode (f ca)) |]
instance GTraverseCodeFields U1 where
gtraverseCodeFields cc _f U1 = cc
-- Note: this instance is *different* from the one that we'd
-- write if we were using GHC.Generics, because composition works
-- differently in Generics.Linear.
instance (GTraverseCodeFields f, TraverseCode g) => GTraverseCodeFields (f :.: g) where
gtraverseCodeFields cc f (Comp1 x) =
gtraverseCodeFields cc (traverseCode f) x
Now we can write all sorts of instances:
instance TraverseCode Maybe
instance TraverseCode Identity
instance TraverseCode []
instance TH.Lift a => TraverseCode (Either a)
instance TH.Lift a => TraverseCode ((,) a)
instance (TraverseCode f, TraverseCode g)
=> TraverseCode (FProd.Product f g)
instance (TraverseCode f, TraverseCode g)
=> TraverseCode (FSum.Sum f g)
instance TraverseCode V1
-- The Elem instance isn't needed for the Seq instance
instance TraverseCode Seq.Elem
instance TraverseCode Seq.Digit
instance TraverseCode Seq.Node
instance TraverseCode Seq.FingerTree
For the Seq instance I was after, we need to write something by hand, because Seq isn't an instance of Generic1 (and we don't want it to be). Additionally, we don't really want the derived instance. Using a bit of coercion magic, and knowing a little something about how zipWith and replicate work on sequences, we can minimize the size of the splice and the number of types GHC has to deal with once it's compiled to Core.
instance TraverseCode Seq.Seq where
-- Stick a single coercion on the outside, instead of having a bunch
-- of `Elem` constructors on the inside.
traverseCode f s = [|| coerceFT $$(traverseCode f ft') ||]
where
-- Use zipWith to make the tree representing the sequence
-- nice and shallow.
ft' = coerceSeq (Seq.zipWith (flip const) (Seq.replicate (Seq.length s) ()) s)
coerceFT :: Seq.FingerTree a -> Seq.Seq a
coerceFT = coerce
coerceSeq :: Seq.Seq a -> Seq.FingerTree a
coerceSeq = coerce

Implementing an MFunctor instance for RVarT

Is it possible to implement an MFunctor instance for RVarT?
So far I've come up with the following:
{-# LANGUAGE RankNTypes #-}
import Data.RVar -- from rvar
import Control.Monad.Trans.Class (lift) -- from transformers
hoistRVarT :: Monad m => (forall t. n t -> m t) -> RVarT n a -> RVarT m a
hoistRVarT f rv = sampleRVarTWith (lift . f) rv
However this can not be used as a definition of hoist for MFunctor, due to the Monad constraint on m incurred by lift. The problem is, that I couldn't find another way to lift the the resulting monad into RVarT without lift. But I think conceptually it should be possible, since RVarT should be similar to StateT and there is an MFunctor instance for StateT. The problem is that I couldn't find anything in the API of rvar or random-fu which exposed such functionality.
RVarT m a is a newtype for PromptT Prim m a, where PromptT is defined in Control.Monad.Prompt. PromptT Prim m a is a newtype for Prompt (Lift Prim m) a. This, in turn, is a newtype for
forall b. (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b
You can unwrap the whole thing with unsafeCoerce:
fromRVarT :: RVarT m a -> (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b
fromRVarT = unsafeCoerce
toRVarT :: (forall b. (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b) -> RVarT m a
toRVarT = unsafeCoerce
Prim isn't exported, but since you shouldn't need to touch it in the first place, and you're assembling and disassembling the whole thing with unsafeCoerce, you can just define:
data Prim a
You can write an MFunctor instance for Lift:
instance MFunctor (Lift f) where
hoist _ (Effect p) = Effect p
hoist phi (Lift m) = Lift (phi m)
And then you can unwrap the RVarT, hoist all the Lifts passed to its prompting function, and wrap it again:
instance MFunctor RVarT where
hoist phi rv = toRVarT $ \done prm -> fromRVarT rv done (\l -> prm $ hoist phi l)
I found a trick that works for this and similar cases if you do not need to be able to actually use a value RVarT m without a monad instance for m. It works by deferring the application of the natural transformation until we actually need to get out a value. It would still be nice if there was a proper instance.
{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
import Data.RVar
import Control.Monad.Trans.Class (lift)
import Control.Monad.Morph
import Control.Monad (ap)
hoistRVarT :: Monad m => (forall t. n t -> m t) -> RVarT n a -> RVarT m a
hoistRVarT f = sampleRVarTWith (lift . f)
data RVarTFun m a = forall n. RVarTFun
{ transformation :: forall t. n t -> m t
, rvart :: RVarT n a }
-- You can only get a value out if you have a monad for m.
getRVarTFun :: Monad m => RVarTFun m a -> RVarT m a
getRVarTFun (RVarTFun t ma) = hoistRVarT t ma
wrapRVarTFun :: RVarT m a -> RVarTFun m a
wrapRVarTFun = RVarTFun id
-- Actually the result is slightly stronger than MFunctor because we don't need
-- a Monad on n.
hoistRVarTFun :: (forall t. n t -> m t) -> RVarTFun n a -> RVarTFun m a
hoistRVarTFun f (RVarTFun t nx) = RVarTFun (f . t) nx
instance MFunctor RVarTFun where
hoist = hoistRVarTFun
A more general implementation of this can be found here.

Testing monadic laws using QuickCheck

Is there a library or tools for testing the laws of a custom monad? My current hacked attempt goes something like this:
Define Arbitrary1, similar to Eq1, Show1 etc.
Define a helper type that wraps Arbitrary1 as Arbitrary.
Define a test (for example) for monadic laws.
Is any of this already implemented somewhere?
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
import Data.Functor.Classes
import Data.Proxy
import Test.QuickCheck
import Test.QuickCheck.Function
import Test.QuickCheck.Poly
Define Arbitrary1 for * -> * types:
class Arbitrary1 m where
arbitrary1 :: (Arbitrary a) => Gen (m a)
shrink1 :: (Arbitrary a) => m a -> [m a]
shrink1 _ = []
And a helper wrapper so that we can use functions that work with Arbitrary:
newtype Action m a = Action { getAction :: m a }
instance (Arbitrary a, Arbitrary1 m) => Arbitrary (Action m a) where
arbitrary = Action <$> arbitrary1
shrink = map Action . shrink1 . getAction
instance (Show a, Show1 m) => Show (Action m a) where
showsPrec p = showsPrec1 p . getAction
Now we can write a test like this:
-- (m >>= f) >>= g ≡ m >>= (\x -> f x >>= g)
testBindAssoc :: forall m . (Monad m, Arbitrary1 m, Show1 m, Eq1 m) => Proxy m -> Property
testBindAssoc _ =
forAllShrink (arbitrary :: Gen (Action m A)) shrink $ \m' ->
forAllShrink (arbitrary :: Gen (Fun A (Action m B))) shrink $ \f' ->
forAllShrink (arbitrary :: Gen (Fun B (Action m C))) shrink $ \g' ->
let m = getAction m'
f = getAction <$> apply f'
g = getAction <$> apply g'
k = (m >>= f) >>= g
l = m >>= (\x -> f x >>= g)
in counterexample (showsPrec1 0 k . showString " != " . showsPrec1 0 l $ "")
$ k `eq1` l
And let's write a broken Writer monad:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Writer
newtype MyMonad w a = MyMonad { runMyMonad :: Writer w a }
deriving (Functor, Applicative)
instance (Monoid w) => Monad (MyMonad w) where
return = pure
k >>= f = let (a, w) = runWriter . runMyMonad $ k
in MyMonad $ writer (a, w <> w) >>= (runMyMonad . f)
-- ^ broken here
getMyMonad :: MyMonad w a -> (a, w)
getMyMonad = runWriter . runMyMonad
instance (Eq w) => Eq1 (MyMonad w) where
eq1 k l = getMyMonad k == getMyMonad l
instance (Show w) => Show1 (MyMonad w) where
showsPrec1 p k = showsPrec p (getMyMonad k)
instance (Monoid w, Arbitrary w) => Arbitrary1 (MyMonad w) where
arbitrary1 = MyMonad . writer <$> arbitrary
shrink1 = map (MyMonad . writer) . shrink . getMyMonad
main :: IO ()
main = quickCheck (testBindAssoc (Proxy :: Proxy (MyMonad (Sum Int))))
Fails with:
*** Failed! Falsifiable (after 2 tests and 13 shrinks):
(1,Sum {getSum = 1})
{_->(1,Sum {getSum = 0})}
{_->(1,Sum {getSum = 0})}
(1,Sum {getSum = 4}) != (1,Sum {getSum = 2})
Any ideas for improvements?

Problems in defining an applicative instance

Suppose that I'm wanting to define a data-type indexed by two type level environments. Something like:
data Woo s a = Woo a | Waa s a
data Foo (s :: *) (env :: [(Symbol,*)]) (env' :: [(Symbol,*)]) (a :: *) =
Foo { runFoo :: s -> Sing env -> (Woo s a, Sing env') }
The idea is that env is the input environment and env' is the output one. So, type Foo acts like an indexed state monad. So far, so good. My problem is how could I show that Foo is an applicative functor. The obvious try is
instance Applicative (Foo s env env') where
pure x = Foo (\s env -> (Woo x, env))
-- definition of (<*>) omitted.
but GHC complains that pure is ill-typed since it infers the type
pure :: a -> Foo s env env a
instead of the expected type
pure :: a -> Foo s env env' a
what is completely reasonable. My point is, it is possible to define an Applicative instance for Foo allowing to change the environment type? I googled for indexed functors, but at first sight, they don't appear to solve my problem. Can someone suggest something to achieve this?
Your Foo type is an example of what Atkey originally called a parameterised monad, and everyone else (arguably incorrectly) now calls an indexed monad.
Indexed monads are monad-like things with two indices which describe a path through a directed graph of types. Sequencing indexed monadic computations requires that the indices of the two computations line up like dominos.
class IFunctor f where
imap :: (a -> b) -> f x y a -> f x y b
class IFunctor f => IApplicative f where
ipure :: a -> f x x a
(<**>) :: f x y (a -> b) -> f y z a -> f x z b
class IApplicative m => IMonad m where
(>>>=) :: m x y a -> (a -> m y z b) -> m x z b
If you have an indexed monad which describes a path from x to y, and a way to get from y to z, the indexed bind >>>= will give you a bigger computation which takes you from x to z.
Note also that ipure returns f x x a. The value returned by ipure doesn't take any steps through the directed graph of types. Like a type-level id.
A simple example of an indexed monad, to which you alluded in your question, is the indexed state monad newtype IState i o a = IState (i -> (o, a)), which transforms the type of its argument from i to o. You can only sequence stateful computations if the output type of the first matches the input type of the second.
newtype IState i o a = IState { runIState :: i -> (o, a) }
instance IFunctor IState where
imap f s = IState $ \i ->
let (o, x) = runIState s i
in (o, f x)
instance IApplicative IState where
ipure x = IState $ \s -> (s, x)
sf <**> sx = IState $ \i ->
let (s, f) = runIState sf i
(o, x) = runIState sx s
in (o, f x)
instance IMonad IState where
s >>>= f = IState $ \i ->
let (t, x) = runIState s i
in runIState (f x) t
Now, to your actual question. IMonad, with its domino-esque sequencing, is a good abstraction for computations which transform a type-level environment: you expect the first computation to leave the environment in a state which is palatable to the second. Let us write an instance of IMonad for Foo.
I'm going to start by noting that your Woo s a type is isomorphic to (a, Maybe s), which is an example of the Writer monad. I mention this because we'll need an instance for Monad (Woo s) later and I'm too lazy to write my own.
type Woo s a = Writer (First s) a
I've picked First as my preferred flavour of Maybe monoid but I don't know exactly how you intend to use Woo. You may prefer Last.
I'm also soon going to make use of the fact that Writer is an instance of Traversable. In fact, Writer is even more traversable than that: because it contains exactly one a, we won't need to smash any results together. This means we only need a Functor constraint for the effectful f.
-- cf. traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
traverseW :: Functor f => (a -> f b) -> Writer w a -> f (Writer w b)
traverseW f m = let (x, w) = runWriter m
in fmap (\x -> writer (x, w)) (f x)
Let's get down to business.
Foo s is an IFunctor. The instance makes use of Writer s's functor-ness: we go inside the stateful computation and fmap the function over the Writer monad inside.
newtype Foo (s :: *) (env :: [(Symbol,*)]) (env' :: [(Symbol,*)]) (a :: *) =
Foo { runFoo :: s -> Sing env -> (Woo s a, Sing env') }
instance IFunctor (Foo s) where
imap f foo = Foo $ \s env ->
let (woo, env') = runFoo foo s env
in (fmap f woo, env')
We'll also need to make Foo a regular Functor, to use it with traverseW later.
instance Functor (Foo s x y) where
fmap = imap
Foo s is an IApplicative. We have to use Writer s's Applicative instance to smash the Woos together. This is where the Monoid s constraint comes from.
instance IApplicative (Foo s) where
ipure x = Foo $ \s env -> (pure x, env)
foo <**> bar = Foo $ \s env ->
let (woof, env') = runFoo foo s env
(woox, env'') = runFoo bar s env'
in (woof <*> woox, env'')
Foo s is an IMonad. Surprise surprise, we end up delegating to Writer s's Monad instance. Note also the crafty use of traverseW to feed the intermediate a inside the writer to the Kleisli arrow f.
instance IMonad (Foo s) where
foo >>>= f = Foo $ \s env ->
let (woo, env') = runFoo foo s env
(woowoo, env'') = runFoo (traverseW f woo) s env'
in (join woowoo, env'')
Addendum: The thing that's missing from this picture is transformers. Instinct tells me that you should be able to express Foo as a monad transformer stack:
type Foo s env env' = ReaderT s (IStateT (Sing env) (Sing env') (WriterT (First s) Identity))
But indexed monads don't have a compelling story to tell about transformers. The type of >>>= would require all the indexed monads in the stack to manipulate their indices in the same way, which is probably not what you want. Indexed monads also don't compose nicely with regular monads.
All this is to say that indexed monad transformers play out a bit nicer with a McBride-style indexing scheme. McBride's IMonad looks like this:
type f ~> g = forall x. f x -> g x
class IMonad m where
ireturn :: a ~> m a
(=<?) :: (a ~> m b) -> (m a ~> m b)
Then monad transformers would look like this:
class IMonadTrans t where
ilift :: IMonad m => m a ~> t m a
Essentially, you're missing a constraint on Sing env' - namely that it needs to be a Monoid, because:
you need to be able to generate a value of type Sing env' from nothing (e.g. mempty)
you need to be able to combine two values of type Sing env' into one during <*> (e.g. mappend).
You'll also need to the ability combine s values in <*>, so, unless you want to import SemiGroup from somewhere, you'll probably want that to be a Monoid too.
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
module SO37860911 where
import GHC.TypeLits (Symbol)
import Data.Singletons (Sing)
data Woo s a = Woo a | Waa s a
deriving Functor
instance Monoid s => Applicative (Woo s) where
pure = Woo
Woo f <*> Woo a = Woo $ f a
Waa s f <*> Woo a = Waa s $ f a
Woo f <*> Waa s a = Waa s $ f a
Waa s f <*> Waa s' a = Waa (mappend s s') $ f a
data Foo (s :: *) (env :: [(Symbol,*)]) (env' :: [(Symbol,*)]) (a :: *) =
Foo { runFoo :: s -> Sing env -> (Woo s a, Sing env') }
deriving Functor
instance (Monoid s, Monoid (Sing env')) => Applicative (Foo s env env') where
pure a = Foo $ \_s _env -> (pure a, mempty)
Foo mf <*> Foo ma = Foo $ \s env -> case (mf s env, ma s env) of
((w,e), (w',e')) -> (w <*> w', e `mappend` e')

A MonadTransControl instance for FreeT

Is it possible to implement a MonadTransControl instance for FreeT? I started with the following, but got stuck:
instance (Functor f) => MonadTransControl (FreeT f) where
newtype StT (FreeT f) r = FreeTStT r
liftWith unlift = lift $ unlift $ error "Stuck here"
restoreT inner = do
FreeTStT r <- lift inner
return r
If it is unimplementable, than why and is it possible to extend a specific free functor implementation somehow to make it implementable?
Disclaimer: turns out you need Traversable f constraint for MonadTransControl instance.
Warning: the instance in this answer does not obey all the laws of MonadTransControl
Pragmas and imports
{-# LANGUAGE TypeFamilies #-}
import qualified Data.Traversable as T
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Trans.Free
import qualified Control.Monad.Free as F
Free monadic state
As I said in comments, the proper "monadic state" of FreeT f should be Free f (the one from Control.Monad.Free):
instance T.Traversable f => MonadTransControl (FreeT f) where
newtype StT (FreeT f) a = StTFreeT { getStTFreeT :: F.Free f a }
Now the implementation of restoreT changes a bit:
restoreT inner = do
StTFreeT m <- lift inner
F.toFreeT m
liftWith implementation
Before we look at the implementation let's see what should the type of liftWith be:
liftWith :: Monad m => (Run (FreeT f) -> m a) -> FreeT f m a
And Run (FreeT f) is actually
forall n b. Monad n => FreeT f n b -> n (StTFreeT f b)
So the implementation would be like that:
liftWith unlift = lift $ unlift (liftM StTFreeT . pushFreeT)
The rest is simple:
pushFreeT :: (T.Traversable f, Monad m) => FreeT f m a -> m (F.Free f a)
pushFreeT m = do
f <- runFreeT m
case f of
Pure x -> return (return x)
Free y -> liftM wrap $ T.mapM pushFreeT y
Why Traversable?
As you can see the problem is with pushFreeT function: it uses T.mapM (which is traverse but with Monad constraint). Why do we need it there? If you look at the definition of FreeT you may notice that (NB: this is rough, I forget about Pure here):
FreeT f m a ~ m (f (m (f ... )))
And as a result of pushFreeT we need m (Free f a):
m (Free f a) ~ m (f (f (f ... )))
So we need to "push" all fs to the end and join all ms in the head. Thus we need an operation that lets us push a single f through single m and this is exactly what T.mapM pushFreeT gives us:
mapM :: (Monad m, Traversable t) => (a -> m b) -> t a -> m (t b)
mapM pushFreeT :: Traversable t => t (FreeT t m a) -> m (t (Free t a))
The laws
Every class instance usually come with laws. MonadTransControl is not an exception, so let's check if they hold for this instance:
liftWith . const . return = return
liftWith (const (m >>= f)) = liftWith (const m) >>= liftWith . const . f
These two laws obviously follow from laws for MonadTrans and the definition of liftWith.
liftWith (\run -> run t) >>= restoreT . return = t
Apparently, this law does not hold. This is because monad layers in t are collapsed when we pushFreeT. So the implemented liftWith merges effects in all layers of FreeT f m leaving us with the equivalent of m (Free f).

Resources