{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Extensible.Product
-- Copyright : (c) Fumiaki Kinoshita 2018
-- License : BSD3
--
-- Maintainer : Fumiaki Kinoshita
--
------------------------------------------------------------------------
module Data.Extensible.Product (
-- * Basic operations
(:&)
, nil
, (<:)
, ( xs :& h -> (x ': xs) :& h
(<:) x = fromHList . HList.HCons x . toHList
{-# INLINE (<:) #-}
infixr 0 <:
(=<:) :: Wrapper h => Repr h x -> xs :& h -> (x ': xs) :& h
(=<:) = (<:) . review _Wrapper
{-# INLINE (=<:) #-}
infixr 0 =<:
-- | Strict version of ('<:').
( xs :& h -> (x ': xs) :& h
( xs :& h
fromHList xs = hfrozen (newFromHList xs)
{-# INLINE fromHList #-}
-- | Flipped 'hlookup'
hindex :: xs :& h -> Membership xs x -> h x
hindex = flip hlookup
{-# INLINE hindex #-}
-- | Map a function to every element of a product.
hmapWithIndex :: (forall x. Membership xs x -> g x -> h x) -> xs :& g -> xs :& h
hmapWithIndex t p = hfrozen (newFrom p t)
{-# INLINE hmapWithIndex #-}
-- | Map a function to every element of a product.
hmapWithIndexFor :: Forall c xs
=> proxy c
-> (forall x. c x => Membership xs x -> g x -> h x)
-> xs :& g -> xs :& h
hmapWithIndexFor c t p = hfrozen $ newFor c $ \i -> t i $ hlookup i p
{-# INLINE hmapWithIndexFor #-}
hmapWithIndexWith :: forall c xs g h. Forall c xs
=> (forall x. c x => Membership xs x -> g x -> h x)
-> xs :& g -> xs :& h
hmapWithIndexWith = hmapWithIndexFor (Proxy @ c)
-- | Transform every element in a product, preserving the order.
--
-- @
-- 'hmap' 'id' ≡ 'id'
-- 'hmap' (f . g) ≡ 'hmap' f . 'hmap' g
-- @
hmap :: (forall x. g x -> h x) -> xs :& g -> xs :& h
hmap f = hmapWithIndex (const f)
{-# INLINE hmap #-}
-- | 'zipWith' for heterogeneous product
hzipWith :: (forall x. f x -> g x -> h x) -> xs :& f -> xs :& g -> xs :& h
hzipWith t xs = hmapWithIndex (\i -> t (hlookup i xs))
{-# INLINE hzipWith #-}
-- | 'zipWith3' for heterogeneous product
hzipWith3 :: (forall x. f x -> g x -> h x -> i x) -> xs :& f -> xs :& g -> xs :& h -> xs :& i
hzipWith3 t xs ys = hmapWithIndex (\i -> t (hlookup i xs) (hlookup i ys))
{-# INLINE hzipWith3 #-}
-- | Map elements to a monoid and combine the results.
--
-- @'hfoldMap' f . 'hmap' g ≡ 'hfoldMap' (f . g)@
hfoldMap :: Monoid a => (forall x. h x -> a) -> xs :& h -> a
hfoldMap f = hfoldMapWithIndex (const f)
{-# INLINE hfoldMap #-}
-- | 'hfoldMap' with the membership of elements.
hfoldMapWithIndex :: Monoid a
=> (forall x. Membership xs x -> g x -> a) -> xs :& g -> a
hfoldMapWithIndex f = hfoldrWithIndex (\i -> mappend . f i) mempty
{-# INLINE hfoldMapWithIndex #-}
-- | Perform a strict left fold over the elements.
hfoldlWithIndex :: (forall x. Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r
hfoldlWithIndex f r xs = hfoldrWithIndex (\i x c a -> c $! f i a x) id xs r
{-# INLINE hfoldlWithIndex #-}
-- | 'hfoldrWithIndex' with a constraint for each element.
hfoldrWithIndexFor :: forall c xs h r proxy. (Forall c xs) => proxy c
-> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> xs :& h -> r
hfoldrWithIndexFor p f r xs = henumerateFor p (Proxy :: Proxy xs) (\i -> f i (hlookup i xs)) r
{-# INLINE hfoldrWithIndexFor #-}
hfoldrWithIndexWith :: forall c xs h r. (Forall c xs)
=> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> xs :& h -> r
hfoldrWithIndexWith f r xs = henumerateFor (Proxy @ c) (Proxy @ xs) (\i -> f i (hlookup i xs)) r
{-# INLINE hfoldrWithIndexWith #-}
-- | Constrained 'hfoldlWithIndex'
hfoldlWithIndexFor :: (Forall c xs) => proxy c
-> (forall x. c x => Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r
hfoldlWithIndexFor p f r xs = hfoldrWithIndexFor p (\i x c a -> c $! f i a x) id xs r
{-# INLINE hfoldlWithIndexFor #-}
-- | Constrained 'hfoldlWithIndex'
hfoldlWithIndexWith :: forall c xs h r. (Forall c xs)
=> (forall x. c x => Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r
hfoldlWithIndexWith f r xs = hfoldrWithIndexWith @c (\i x c a -> c $! f i a x) id xs r
{-# INLINE hfoldlWithIndexWith #-}
-- | 'hfoldMapWithIndex' with a constraint for each element.
hfoldMapWithIndexFor :: (Forall c xs, Monoid a) => proxy c
-> (forall x. c x => Membership xs x -> h x -> a) -> xs :& h -> a
hfoldMapWithIndexFor p f = hfoldrWithIndexFor p (\i -> mappend . f i) mempty
{-# INLINE hfoldMapWithIndexFor #-}
-- | 'hfoldMapWithIndex' with a constraint for each element.
hfoldMapWithIndexWith :: forall c xs h a. (Forall c xs, Monoid a)
=> (forall x. c x => Membership xs x -> h x -> a) -> xs :& h -> a
hfoldMapWithIndexWith f = hfoldrWithIndexWith @c (\i -> mappend . f i) mempty
{-# INLINE hfoldMapWithIndexWith #-}
-- | Constrained 'hfoldMap'
hfoldMapFor :: (Forall c xs, Monoid a) => proxy c
-> (forall x. c x => h x -> a) -> xs :& h -> a
hfoldMapFor p f = hfoldMapWithIndexFor p (const f)
{-# INLINE hfoldMapFor #-}
-- | Constrained 'hfoldMap'
hfoldMapWith :: forall c xs h a. (Forall c xs, Monoid a)
=> (forall x. c x => h x -> a) -> xs :& h -> a
hfoldMapWith f = hfoldMapWithIndexFor (Proxy @ c) (const f)
{-# INLINE hfoldMapWith #-}
-- | Traverse all elements and combine the result sequentially.
-- @
-- htraverse (fmap f . g) ≡ fmap (hmap f) . htraverse g
-- htraverse pure ≡ pure
-- htraverse (Comp . fmap g . f) ≡ Comp . fmap (htraverse g) . htraverse f
-- @
htraverse :: Applicative f => (forall x. g x -> f (h x)) -> xs :& g -> f (xs :& h)
htraverse f = fmap fromHList . HList.htraverse f . toHList
{-# INLINE htraverse #-}
-- | 'sequence' analog for extensible products
hsequence :: Applicative f => xs :& Comp f h -> f (xs :& h)
hsequence = htraverse getComp
{-# INLINE hsequence #-}
-- | The dual of 'htraverse'
hcollect :: (Functor f, Generate xs) => (a -> xs :& h) -> f a -> xs :& Comp f h
hcollect f m = htabulate $ \i -> Comp $ fmap (hlookup i . f) m
{-# INLINABLE hcollect #-}
-- | The dual of 'hsequence'
hdistribute :: (Functor f, Generate xs) => f (xs :& h) -> xs :& Comp f h
hdistribute = hcollect id
{-# INLINE hdistribute #-}
-- | 'htraverse' with 'Membership's.
htraverseWithIndex :: Applicative f
=> (forall x. Membership xs x -> g x -> f (h x)) -> xs :& g -> f (xs :& h)
htraverseWithIndex f = fmap fromHList . HList.htraverseWithIndex f . toHList
{-# INLINE htraverseWithIndex #-}
-- | A product filled with the specified value.
hrepeat :: Generate xs => (forall x. h x) -> xs :& h
hrepeat x = hfrozen $ newRepeat x
{-# INLINE hrepeat #-}
-- | Construct a product using a function which takes a 'Membership'.
--
-- @
-- 'hmap' f ('htabulate' g) ≡ 'htabulate' (f . g)
-- 'htabulate' ('hindex' m) ≡ m
-- 'hindex' ('htabulate' k) ≡ k
-- @
htabulate :: Generate xs => (forall x. Membership xs x -> h x) -> xs :& h
htabulate f = hfrozen $ new f
{-# INLINE htabulate #-}
-- | 'Applicative' version of 'htabulate'.
hgenerate :: (Generate xs, Applicative f)
=> (forall x. Membership xs x -> f (h x)) -> f (xs :& h)
hgenerate f = fmap fromHList $ hgenerateList f
{-# INLINE hgenerate #-}
-- | Pure version of 'hgenerateFor'.
htabulateFor :: Forall c xs => proxy c -> (forall x. c x => Membership xs x -> h x) -> xs :& h
htabulateFor p f = hfrozen $ newFor p f
{-# INLINE htabulateFor #-}
-- | Pure version of 'hgenerateFor'.
htabulateWith :: forall c xs h. Forall c xs => (forall x. c x => Membership xs x -> h x) -> xs :& h
htabulateWith f = hfrozen $ newFor (Proxy @ c) f
{-# INLINE htabulateWith #-}
-- | A product filled with the specified value.
hrepeatFor :: Forall c xs => proxy c -> (forall x. c x => h x) -> xs :& h
hrepeatFor p f = htabulateFor p (const f)
{-# INLINE hrepeatFor #-}
-- | A product filled with the specified value.
hrepeatWith :: forall c xs h. Forall c xs => (forall x. c x => h x) -> xs :& h
hrepeatWith f = htabulateFor (Proxy @ c) (const f)
{-# INLINE hrepeatWith #-}
-- | 'Applicative' version of 'htabulateFor'.
hgenerateFor :: (Forall c xs, Applicative f)
=> proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (xs :& h)
hgenerateFor p f = fmap fromHList $ hgenerateListFor p f
{-# INLINE hgenerateFor #-}
-- | 'Applicative' version of 'htabulateFor'.
hgenerateWith :: forall c xs f h. (Forall c xs, Applicative f)
=> (forall x. c x => Membership xs x -> f (h x)) -> f (xs :& h)
hgenerateWith f = fmap fromHList $ hgenerateListFor (Proxy @ c) f
{-# INLINE hgenerateWith #-}
-- | Accumulate sums on a product.
haccumMap :: Foldable f
=> (a -> xs :/ g)
-> (forall x. Membership xs x -> g x -> h x -> h x)
-> xs :& h -> f a -> xs :& h
haccumMap f g p0 xs = hmodify
(\s -> mapM_ (\x -> case f x of EmbedAt i v -> get s i >>= set s i . g i v) xs)
p0
{-# INLINE haccumMap #-}
-- | @haccum = 'haccumMap' 'id'@
haccum :: Foldable f
=> (forall x. Membership xs x -> g x -> h x -> h x)
-> xs :& h -> f (xs :/ g) -> xs :& h
haccum = haccumMap id
{-# INLINE haccum #-}
-- | Group sums by type.
hpartition :: (Foldable f, Generate xs) => (a -> xs :/ h) -> f a -> xs :& Comp [] h
hpartition f = haccumMap f (\_ x (Comp xs) -> Comp (x:xs)) $ hrepeat $ Comp []
{-# INLINE hpartition #-}
-- | Evaluate every element in a product.
hforce :: xs :& h -> xs :& h
hforce p = hfoldrWithIndex (const seq) p p
{-# INLINE hforce #-}