1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE Rank2Types #-}
7#if __GLASGOW_HASKELL__ >= 707
8{-# LANGUAGE DeriveDataTypeable #-}
9{-# LANGUAGE DeriveGeneric #-}
10#endif
11#include "free-common.h"
12
13--------------------------------------------------------------------------------
14-- |
15-- Given an applicative, the free monad transformer.
16--------------------------------------------------------------------------------
17
18module Control.Monad.Trans.Free.Ap
19  (
20  -- * The base functor
21    FreeF(..)
22  -- * The free monad transformer
23  , FreeT(..)
24  -- * The free monad
25  , Free, free, runFree
26  -- * Operations
27  , liftF
28  , iterT
29  , iterTM
30  , hoistFreeT
31  , transFreeT
32  , joinFreeT
33  , cutoff
34  , partialIterT
35  , intersperseT
36  , intercalateT
37  , retractT
38  -- * Operations of free monad
39  , retract
40  , iter
41  , iterM
42  -- * Free Monads With Class
43  , MonadFree(..)
44  ) where
45
46import Control.Applicative
47import Control.Monad (liftM, MonadPlus(..), join)
48import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
49import Control.Monad.Trans.Class
50import qualified Control.Monad.Fail as Fail
51import Control.Monad.Free.Class
52import Control.Monad.IO.Class
53import Control.Monad.Reader.Class
54import Control.Monad.Writer.Class
55import Control.Monad.State.Class
56import Control.Monad.Error.Class
57import Control.Monad.Cont.Class
58import Data.Functor.Bind hiding (join)
59import Data.Functor.Classes.Compat
60import Data.Functor.Identity
61import Data.Traversable
62import Data.Bifunctor
63import Data.Bifoldable
64import Data.Bitraversable
65import Data.Data
66#if __GLASGOW_HASKELL__ >= 707
67import GHC.Generics
68#endif
69
70#if !(MIN_VERSION_base(4,8,0))
71import Data.Foldable
72import Data.Monoid
73#endif
74
75-- | The base functor for a free monad.
76data FreeF f a b = Pure a | Free (f b)
77  deriving (Eq,Ord,Show,Read
78#if __GLASGOW_HASKELL__ >= 707
79           ,Typeable ,Generic, Generic1
80#endif
81           )
82
83#ifdef LIFTED_FUNCTOR_CLASSES
84instance Show1 f => Show2 (FreeF f) where
85  liftShowsPrec2 spa _sla _spb _slb d (Pure a) =
86    showsUnaryWith spa "Pure" d a
87  liftShowsPrec2 _spa _sla spb slb d (Free as) =
88    showsUnaryWith (liftShowsPrec spb slb) "Free" d as
89
90instance (Show1 f, Show a) => Show1 (FreeF f a) where
91  liftShowsPrec = liftShowsPrec2 showsPrec showList
92#else
93instance (Show1 f, Show a) => Show1 (FreeF f a) where
94  showsPrec1 d (Pure a)  = showParen (d > 10) $ showString "Pure " . showsPrec 11 a
95  showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as
96#endif
97
98#ifdef LIFTED_FUNCTOR_CLASSES
99instance Read1 f => Read2 (FreeF f) where
100  liftReadsPrec2 rpa _rla rpb rlb = readsData $
101    readsUnaryWith rpa "Pure" Pure `mappend`
102    readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free
103
104instance (Read1 f, Read a) => Read1 (FreeF f a) where
105  liftReadsPrec = liftReadsPrec2 readsPrec readList
106#else
107instance (Read1 f, Read a) => Read1 (FreeF f a) where
108  readsPrec1 d r = readParen (d > 10)
109      (\r' -> [ (Pure m, t)
110             | ("Pure", s) <- lex r'
111             , (m, t) <- readsPrec 11 s]) r
112    ++ readParen (d > 10)
113      (\r' -> [ (Free m, t)
114             | ("Free", s) <- lex r'
115             , (m, t) <- readsPrec1 11 s]) r
116#endif
117
118#ifdef LIFTED_FUNCTOR_CLASSES
119instance Eq1 f => Eq2 (FreeF f) where
120  liftEq2 eq _ (Pure a) (Pure b) = eq a b
121  liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs
122  liftEq2 _ _ _ _ = False
123
124instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where
125  liftEq = liftEq2 (==)
126#else
127instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where
128  Pure a  `eq1` Pure b = a == b
129  Free as `eq1` Free bs = as `eq1` bs
130  _       `eq1` _ = False
131#endif
132
133#ifdef LIFTED_FUNCTOR_CLASSES
134instance Ord1 f => Ord2 (FreeF f) where
135  liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b
136  liftCompare2 _ _ (Pure _) (Free _) = LT
137  liftCompare2 _ _ (Free _) (Pure _) = GT
138  liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb
139
140instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where
141  liftCompare = liftCompare2 compare
142#else
143instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where
144  Pure a `compare1` Pure b = a `compare` b
145  Pure _ `compare1` Free _ = LT
146  Free _ `compare1` Pure _ = GT
147  Free fa `compare1` Free fb = fa `compare1` fb
148#endif
149
150instance Functor f => Functor (FreeF f a) where
151  fmap _ (Pure a)  = Pure a
152  fmap f (Free as) = Free (fmap f as)
153  {-# INLINE fmap #-}
154
155instance Foldable f => Foldable (FreeF f a) where
156  foldMap f (Free as) = foldMap f as
157  foldMap _ _         = mempty
158  {-# INLINE foldMap #-}
159
160instance Traversable f => Traversable (FreeF f a) where
161  traverse _ (Pure a)  = pure (Pure a)
162  traverse f (Free as) = Free <$> traverse f as
163  {-# INLINE traverse #-}
164
165instance Functor f => Bifunctor (FreeF f) where
166  bimap f _ (Pure a)  = Pure (f a)
167  bimap _ g (Free as) = Free (fmap g as)
168  {-# INLINE bimap #-}
169
170instance Foldable f => Bifoldable (FreeF f) where
171  bifoldMap f _ (Pure a)  = f a
172  bifoldMap _ g (Free as) = foldMap g as
173  {-# INLINE bifoldMap #-}
174
175instance Traversable f => Bitraversable (FreeF f) where
176  bitraverse f _ (Pure a)  = Pure <$> f a
177  bitraverse _ g (Free as) = Free <$> traverse g as
178  {-# INLINE bitraverse #-}
179
180transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
181transFreeF _ (Pure a) = Pure a
182transFreeF t (Free as) = Free (t as)
183{-# INLINE transFreeF #-}
184
185-- | The \"free monad transformer\" for an applicative @f@
186newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) }
187
188-- | The \"free monad\" for an applicative @f@.
189type Free f = FreeT f Identity
190
191-- | Evaluates the first layer out of a free monad value.
192runFree :: Free f a -> FreeF f a (Free f a)
193runFree = runIdentity . runFreeT
194{-# INLINE runFree #-}
195
196-- | Pushes a layer into a free monad value.
197free :: FreeF f a (Free f a) -> Free f a
198free = FreeT . Identity
199{-# INLINE free #-}
200
201#ifdef LIFTED_FUNCTOR_CLASSES
202instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where
203#else
204instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where
205#endif
206    (==) = eq1
207
208#ifdef LIFTED_FUNCTOR_CLASSES
209instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where
210  liftEq eq = go
211    where
212      go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y
213#else
214instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where
215  eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)
216#endif
217
218#ifdef LIFTED_FUNCTOR_CLASSES
219instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where
220#else
221instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where
222#endif
223    compare = compare1
224
225#ifdef LIFTED_FUNCTOR_CLASSES
226instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where
227  liftCompare cmp = go
228    where
229      go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y
230#else
231instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where
232  compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)
233#endif
234
235#ifdef LIFTED_FUNCTOR_CLASSES
236instance (Show1 f, Show1 m) => Show1 (FreeT f m) where
237  liftShowsPrec sp sl = go
238    where
239      goList = liftShowList sp sl
240      go d (FreeT x) = showsUnaryWith
241        (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))
242        "FreeT" d x
243#else
244instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where
245  showsPrec1 d (FreeT m) = showParen (d > 10) $
246    showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)
247#endif
248
249#ifdef LIFTED_FUNCTOR_CLASSES
250instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where
251#else
252instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where
253#endif
254  showsPrec = showsPrec1
255
256#ifdef LIFTED_FUNCTOR_CLASSES
257instance (Read1 f, Read1 m) => Read1 (FreeT f m) where
258  liftReadsPrec rp rl = go
259    where
260      goList = liftReadList rp rl
261      go = readsData $ readsUnaryWith
262        (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))
263        "FreeT" FreeT
264#else
265instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where
266  readsPrec1 d =  readParen (d > 10) $ \r ->
267    [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]
268#endif
269
270#ifdef LIFTED_FUNCTOR_CLASSES
271instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where
272#else
273instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where
274#endif
275  readsPrec = readsPrec1
276
277instance (Functor f, Monad m) => Functor (FreeT f m) where
278  fmap f (FreeT m) = FreeT (liftM f' m) where
279    f' (Pure a)  = Pure (f a)
280    f' (Free as) = Free (fmap (fmap f) as)
281
282instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where
283  pure a = FreeT (return (Pure a))
284  {-# INLINE pure #-}
285  FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where
286    g (Pure f') (Pure a') = Pure (f' a')
287    g (Pure f') (Free as) = Free $ fmap f' <$> as
288    g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs
289    g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as
290  {-# INLINE (<*>) #-}
291
292instance (Apply f, Apply m, Monad m) => Apply (FreeT f m) where
293  FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where
294    g (Pure f') (Pure a') = Pure (f' a')
295    g (Pure f') (Free as) = Free $ fmap f' <$> as
296    g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs
297    g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as
298
299instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where
300  FreeT m >>- f = FreeT $ m >>= \v -> case v of
301    Pure a -> runFreeT (f a)
302    Free w -> return (Free (fmap (>>- f) w))
303
304instance (Applicative f, Applicative m, Monad m) => Monad (FreeT f m) where
305  return = pure
306  {-# INLINE return #-}
307  FreeT m >>= f = FreeT $ m >>= \v -> case v of
308    Pure a -> runFreeT (f a)
309    Free w -> return (Free (fmap (>>= f) w))
310#if !MIN_VERSION_base(4,13,0)
311  fail e = FreeT (fail e)
312#endif
313
314instance (Applicative f, Applicative m, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where
315  fail e = FreeT (Fail.fail e)
316
317instance MonadTrans (FreeT f) where
318  lift = FreeT . liftM Pure
319  {-# INLINE lift #-}
320
321instance (Applicative f, Applicative m, MonadIO m) => MonadIO (FreeT f m) where
322  liftIO = lift . liftIO
323  {-# INLINE liftIO #-}
324
325instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where
326  ask = lift ask
327  {-# INLINE ask #-}
328  local f = hoistFreeT (local f)
329  {-# INLINE local #-}
330
331instance (Applicative f, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where
332  tell = lift . tell
333  {-# INLINE tell #-}
334  listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)
335    where
336      concat' (Pure x, w) = Pure (x, w)
337      concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y
338  pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m
339    where
340      clean = pass . liftM (\x -> (x, const mempty))
341      pass' = join . liftM g
342      g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)
343      g (Free f)           = return . Free . fmap (FreeT . pass' . runFreeT) $ f
344#if MIN_VERSION_mtl(2,1,1)
345  writer w = lift (writer w)
346  {-# INLINE writer #-}
347#endif
348
349instance (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where
350  get = lift get
351  {-# INLINE get #-}
352  put = lift . put
353  {-# INLINE put #-}
354#if MIN_VERSION_mtl(2,1,1)
355  state f = lift (state f)
356  {-# INLINE state #-}
357#endif
358
359instance (Applicative f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where
360  throwError = lift . throwError
361  {-# INLINE throwError #-}
362  FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f)
363
364instance (Applicative f, Applicative m, MonadCont m) => MonadCont (FreeT f m) where
365  callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))
366
367instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where
368  empty = FreeT mzero
369  FreeT ma <|> FreeT mb = FreeT (mplus ma mb)
370  {-# INLINE (<|>) #-}
371
372instance (Applicative f, Applicative m, MonadPlus m) => MonadPlus (FreeT f m) where
373  mzero = FreeT mzero
374  {-# INLINE mzero #-}
375  mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)
376  {-# INLINE mplus #-}
377
378instance (Applicative f, Applicative m, Monad m) => MonadFree f (FreeT f m) where
379  wrap = FreeT . return . Free
380  {-# INLINE wrap #-}
381
382instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where
383  throwM = lift . throwM
384  {-# INLINE throwM #-}
385
386instance (Applicative f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where
387  FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m
388                                `Control.Monad.Catch.catch` (runFreeT . f)
389  {-# INLINE catch #-}
390
391-- | Given an applicative homomorphism from @f (m a)@ to @m a@,
392-- tear down a free monad transformer using iteration.
393iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
394iterT f (FreeT m) = do
395    val <- m
396    case fmap (iterT f) val of
397        Pure x -> return x
398        Free y -> f y
399
400-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@,
401-- tear down a free monad transformer using iteration over a transformer.
402iterTM :: (Applicative f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a
403iterTM f (FreeT m) = do
404    val <- lift m
405    case fmap (iterTM f) val of
406        Pure x -> return x
407        Free y -> f y
408
409instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
410  foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m
411
412instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where
413  traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m
414
415-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@
416--
417-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@
418hoistFreeT :: (Monad m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
419hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT
420
421-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@
422transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
423transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT
424
425-- | Pull out and join @m@ layers of @'FreeT' f m a@.
426joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)
427joinFreeT (FreeT m) = m >>= joinFreeF
428  where
429    joinFreeF (Pure x) = return (return x)
430    joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f
431
432-- |
433-- 'retract' is the left inverse of 'liftF'
434--
435-- @
436-- 'retract' . 'liftF' = 'id'
437-- @
438retract :: Monad f => Free f a -> f a
439retract m =
440  case runIdentity (runFreeT m) of
441    Pure a  -> return a
442    Free as -> as >>= retract
443
444-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.
445iter :: Applicative f => (f a -> a) -> Free f a -> a
446iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)
447
448-- | Like 'iter' for monadic values.
449iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a
450iterM phi = iterT phi . hoistFreeT (return . runIdentity)
451
452-- | Cuts off a tree of computations at a given depth.
453-- If the depth is @0@ or less, no computation nor
454-- monadic effects will take place.
455--
456-- Some examples (@n ≥ 0@):
457--
458-- @
459-- 'cutoff' 0     _        ≡ 'return' 'Nothing'
460-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just'
461-- 'cutoff' (n+1) '.' 'lift'   ≡ 'lift' '.' 'liftM' 'Just'
462-- 'cutoff' (n+1) '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('cutoff' n)
463-- @
464--
465-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the
466-- steps in the iteration is terminating.
467cutoff :: (Applicative f, Applicative m, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
468cutoff n _ | n <= 0 = return Nothing
469cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m
470
471-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.
472-- This is sort of the opposite for @'cutoff'@.
473--
474-- Some examples (@n ≥ 0@):
475--
476-- @
477-- 'partialIterT' 0 _ m              ≡ m
478-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return'
479-- 'partialIterT' (n+1) phi '.' 'lift'   ≡ 'lift'
480-- 'partialIterT' (n+1) phi '.' 'wrap'   ≡ 'join' . 'lift' . phi
481-- @
482partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
483partialIterT n phi m
484  | n <= 0 = m
485  | otherwise = FreeT $ do
486      val <- runFreeT m
487      case val of
488        Pure a -> return (Pure a)
489        Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi
490
491-- | @intersperseT f m@ inserts a layer @f@ between every two layers in
492-- @m@.
493--
494-- @
495-- 'intersperseT' f '.' 'return' ≡ 'return'
496-- 'intersperseT' f '.' 'lift'   ≡ 'lift'
497-- 'intersperseT' f '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))
498-- @
499intersperseT :: (Monad m, Applicative m, Applicative f) => f a -> FreeT f m b -> FreeT f m b
500intersperseT f (FreeT m) = FreeT $ do
501  val <- m
502  case val of
503    Pure x -> return $ Pure x
504    Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y
505
506-- | Tear down a free monad transformer using Monad instance for @t m@.
507retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a
508retractT (FreeT m) = do
509  val <- lift m
510  case val of
511    Pure x -> return x
512    Free y -> y >>= retractT
513
514-- | @intercalateT f m@ inserts a layer @f@ between every two layers in
515-- @m@ and then retracts the result.
516--
517-- @
518-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f
519-- @
520#if __GLASGOW_HASKELL__ < 710
521intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b
522#else
523intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b
524#endif
525intercalateT f (FreeT m) = do
526  val <- lift m
527  case val of
528    Pure x -> return x
529    Free y -> y >>= iterTM (\x -> f >> join x)
530
531#if __GLASGOW_HASKELL__ < 707
532instance Typeable1 f => Typeable2 (FreeF f) where
533  typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where
534    f :: FreeF f a b -> f a
535    f = undefined
536
537instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where
538  typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where
539    f :: FreeT f w a -> f a
540    f = undefined
541    w :: FreeT f w a -> w a
542    w = undefined
543
544freeFTyCon, freeTTyCon :: TyCon
545#if __GLASGOW_HASKELL__ < 704
546freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT"
547freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF"
548#else
549freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT"
550freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF"
551#endif
552{-# NOINLINE freeTTyCon #-}
553{-# NOINLINE freeFTyCon #-}
554
555instance
556  ( Typeable1 f, Typeable a, Typeable b
557  , Data a, Data (f b), Data b
558  ) => Data (FreeF f a b) where
559    gfoldl f z (Pure a) = z Pure `f` a
560    gfoldl f z (Free as) = z Free `f` as
561    toConstr Pure{} = pureConstr
562    toConstr Free{} = freeConstr
563    gunfold k z c = case constrIndex c of
564        1 -> k (z Pure)
565        2 -> k (z Free)
566        _ -> error "gunfold"
567    dataTypeOf _ = freeFDataType
568    dataCast1 f = gcast1 f
569
570instance
571  ( Typeable1 f, Typeable1 w, Typeable a
572  , Data (w (FreeF f a (FreeT f w a)))
573  , Data a
574  ) => Data (FreeT f w a) where
575    gfoldl f z (FreeT w) = z FreeT `f` w
576    toConstr _ = freeTConstr
577    gunfold k z c = case constrIndex c of
578        1 -> k (z FreeT)
579        _ -> error "gunfold"
580    dataTypeOf _ = freeTDataType
581    dataCast1 f = gcast1 f
582
583pureConstr, freeConstr, freeTConstr :: Constr
584pureConstr = mkConstr freeFDataType "Pure" [] Prefix
585freeConstr = mkConstr freeFDataType "Free" [] Prefix
586freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix
587{-# NOINLINE pureConstr #-}
588{-# NOINLINE freeConstr #-}
589{-# NOINLINE freeTConstr #-}
590
591freeFDataType, freeTDataType :: DataType
592freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr]
593freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr]
594{-# NOINLINE freeFDataType #-}
595{-# NOINLINE freeTDataType #-}
596#endif
597