1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Applicative as A
import Data.Monoid as Mon
-- from Some package
import qualified Data.Some.Church as C
import qualified Data.Some.GADT as G
import qualified Data.Some.Newtype as N
class FFoldable t where
ffoldMap :: Monoid m => (forall a. f a -> m) -> t f -> m
-- one derived operation, is ftraverse_, which we can implement using ffoldMap
gadt_ftraverse_ :: (FFoldable t, A.Applicative m) => (forall a. f a -> m b) -> t f -> m ()
gadt_ftraverse_ k tf = case ffoldMap (G.Some . k) tf of
G.Some mx -> () <$ mx
newtype_ftraverse_ :: (FFoldable t, Applicative m) => (forall a. f a -> m b) -> t f -> m ()
newtype_ftraverse_ k tf = case ffoldMap (N.Some . k) tf of
N.Some mx -> () <$ mx
church_ftraverse_ :: (FFoldable t, Applicative m) => (forall a. f a -> m b) -> t f -> m ()
church_ftraverse_ k tf = C.withSome (ffoldMap (C.mkSome . k) tf) $
\mx -> () <$ mx
-- ghc -c -fforce-recomp -O -ddump-simpl -dsuppress-all HKD.hs
data Ex f where
Nil :: Ex f
Cons :: f a -> Ex f -> Ex f
instance FFoldable Ex where
ffoldMap f = go where
go Nil = Mon.mempty
go (Cons x xs) = mappend (f x) (go xs)
gadt_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m ()
gadt_ftraverse_Ex = gadt_ftraverse_
newtype_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m ()
newtype_ftraverse_Ex = newtype_ftraverse_
church_ftraverse_Ex :: Applicative m => (forall a. f a -> m b) -> Ex f -> m ()
church_ftraverse_Ex = church_ftraverse_
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
main :: IO ()
main = return ()
|
