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