Product.hs

{-# 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 <fumiexcel@gmail.com>
--
------------------------------------------------------------------------
module Data.Extensible.Product (
  -- * Basic operations
  (:&)
  , (:*)
  , nil
  , (<:)
  , (<!)
  , (=<:)
  , hlength
  , type (++)
  , happend
  , hmap
  , hmapWithIndex
  , hzipWith
  , hzipWith3
  , hfoldMap
  , hfoldMapWithIndex
  , hfoldrWithIndex
  , hfoldlWithIndex
  , htraverse
  , htraverseWithIndex
  , hsequence
  -- * Constrained fold
  , hmapWithIndexFor
  , hfoldMapFor
  , hfoldMapWithIndexFor
  , hfoldrWithIndexFor
  , hfoldlWithIndexFor
  -- * Constraind fold without proxies
  , hfoldMapWith
  , hfoldMapWithIndexWith
  , hfoldrWithIndexWith
  , hfoldlWithIndexWith
  , hmapWithIndexWith
  -- * Evaluating
  , hforce
  -- * Update
  , haccumMap
  , haccum
  , hpartition
  -- * Lookup
  , hlookup
  , hindex
  -- * Generation
  , Generate(..)
  , hgenerate
  , htabulate
  , hrepeat
  , hcollect
  , hdistribute
  , fromHList
  , toHList
  , Forall(..)
  , hgenerateFor
  , htabulateFor
  , hrepeatFor
  , hgenerateWith
  , htabulateWith
  , hrepeatWith) where

import Data.Extensible.Internal.Rig (review)
import Data.Extensible.Struct
import Data.Extensible.Sum
import Data.Extensible.Class
import Data.Extensible.Wrapper
import Data.Proxy
import qualified Type.Membership.HList as HList

-- | O(n) Prepend an element onto a product.
-- Expressions like @a <: b <: c <: nil@ are transformed to a single 'fromHList'.
(<:) :: h x -> 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 ('<:').
(<!) :: h x -> xs :& h -> (x ': xs) :& h
(<!) x = fromHList . (HList.HCons $! x) . toHList
{-# INLINE (<!) #-}
infixr 0 <!

-- | An empty product.
nil :: '[] :& h
nil = hfrozen $ new $ error "Impossible"
{-# NOINLINE nil #-}
{-# RULES "toHList/nil" toHList nil = HList.HNil #-}

-- | Convert 'HList.HList' into a product.
fromHList :: HList.HList h xs -> 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 #-}