{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
module Data.Parameterized.TraversableF
( FunctorF(..)
, FoldableF(..)
, foldlMF
, foldlMF'
, foldrMF
, foldrMF'
, TraversableF(..)
, traverseF_
, forF_
, forF
, fmapFDefault
, foldMapFDefault
, allF
, anyF
, lengthF
) where
import Control.Applicative
import Control.Monad.Identity
import Data.Coerce
import Data.Functor.Compose (Compose(..))
import Data.Monoid
import GHC.Exts (build)
import Data.Parameterized.TraversableFC
class FunctorF m where
fmapF :: (forall x . f x -> g x) -> m f -> m g
instance FunctorF (Const x) where
fmapF _ = coerce
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
(#.) _f = coerce
class FoldableF (t :: (k -> *) -> *) where
{-# MINIMAL foldMapF | foldrF #-}
foldMapF :: Monoid m => (forall s . e s -> m) -> t e -> m
foldMapF f = foldrF (mappend . f) mempty
foldrF :: (forall s . e s -> b -> b) -> b -> t e -> b
foldrF f z t = appEndo (foldMapF (Endo #. f) t) z
foldlF :: (forall s . b -> e s -> b) -> b -> t e -> b
foldlF f z t = appEndo (getDual (foldMapF (\e -> Dual (Endo (\r -> f r e))) t)) z
foldrF' :: (forall s . e s -> b -> b) -> b -> t e -> b
foldrF' f0 z0 xs = foldlF (f' f0) id xs z0
where f' f k x z = k $! f x z
foldlF' :: (forall s . b -> e s -> b) -> b -> t e -> b
foldlF' f0 z0 xs = foldrF (f' f0) id xs z0
where f' f x k z = k $! f z x
toListF :: (forall tp . f tp -> a) -> t f -> [a]
toListF f t = build (\c n -> foldrF (\e v -> c (f e) v) n t)
foldlMF :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b
foldlMF f z0 xs = foldrF f' return xs z0
where f' x k z = f z x >>= k
foldlMF' :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b
foldlMF' f z0 xs = seq z0 (foldrF f' return xs z0)
where f' x k z = f z x >>= \r -> seq r (k r)
foldrMF :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b
foldrMF f z0 xs = foldlF f' return xs z0
where f' k x z = f x z >>= k
foldrMF' :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b
foldrMF' f z0 xs = seq z0 $ foldlF f' return xs z0
where f' k x z = f x z >>= \r -> seq r (k r)
allF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool
allF p = getAll #. foldMapF (All #. p)
anyF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool
anyF p = getAny #. foldMapF (Any #. p)
lengthF :: FoldableF t => t f -> Int
lengthF = foldrF (const (+1)) 0
instance FoldableF (Const x) where
foldMapF _ _ = mempty
class (FunctorF t, FoldableF t) => TraversableF t where
traverseF :: Applicative m
=> (forall s . e s -> m (f s))
-> t e
-> m (t f)
instance TraversableF (Const x) where
traverseF _ (Const x) = pure (Const x)
forF :: (TraversableF t, Applicative m) => t e -> (forall s . e s -> m (f s)) -> m (t f)
forF f x = traverseF x f
{-# INLINE forF #-}
fmapFDefault :: TraversableF t => (forall s . e s -> f s) -> t e -> t f
fmapFDefault f = runIdentity #. traverseF (Identity #. f)
{-# INLINE fmapFDefault #-}
foldMapFDefault :: (TraversableF t, Monoid m) => (forall s . e s -> m) -> t e -> m
foldMapFDefault f = getConst #. traverseF (Const #. f)
traverseF_ :: (FoldableF t, Applicative f) => (forall s . e s -> f a) -> t e -> f ()
traverseF_ f = foldrF (\e r -> f e *> r) (pure ())
forF_ :: (FoldableF t, Applicative m) => t f -> (forall x. f x -> m a) -> m ()
forF_ v f = traverseF_ f v
{-# INLINE forF_ #-}
instance ( FunctorF (s :: (k -> *) -> *)
, FunctorFC (t :: (l -> *) -> (k -> *))
) =>
FunctorF (Compose s t) where
fmapF f (Compose v) = Compose $ fmapF (fmapFC f) v
instance ( TraversableF (s :: (k -> *) -> *)
, TraversableFC (t :: (l -> *) -> (k -> *))
) =>
FoldableF (Compose s t) where
foldMapF = foldMapFDefault
instance ( TraversableF (s :: (k -> *) -> *)
, TraversableFC (t :: (l -> *) -> (k -> *))
) =>
TraversableF (Compose s t) where
traverseF :: forall (f :: l -> *) (g :: l -> *) m. (Applicative m) =>
(forall (u :: l). f u -> m (g u))
-> Compose s t f -> m (Compose s t g)
traverseF f (Compose v) = Compose <$> traverseF (traverseFC f) v