{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.HFoldable
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- This module defines higher-order foldable functors.
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.HFoldable
    (
     HFoldable (..),
     kfoldr,
     kfoldl,
     htoList
     ) where

import Data.Comp.Multi.HFunctor
import Data.Maybe
import Data.Monoid

-- | Higher-order functors that can be folded.
--
-- Minimal complete definition: 'hfoldMap' or 'hfoldr'.
class HFunctor h => HFoldable h where
    hfold :: Monoid m => h (K m) :=> m
    hfold = (K m :=> m) -> h (K m) :=> m
forall (h :: (* -> *) -> * -> *) m (a :: * -> *).
(HFoldable h, Monoid m) =>
(a :=> m) -> h a :=> m
hfoldMap K m :=> m
forall a i. K a i -> a
unK

    hfoldMap :: Monoid m => (a :=> m) -> h a :=> m
    hfoldMap f :: a :=> m
f = (a :=> (m -> m)) -> m -> h a :=> m
forall (h :: (* -> *) -> * -> *) (a :: * -> *) b.
HFoldable h =>
(a :=> (b -> b)) -> b -> h a :=> b
hfoldr (m -> m -> m
forall a. Monoid a => a -> a -> a
mappend (m -> m -> m) -> (a i -> m) -> a i -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a i -> m
a :=> m
f) m
forall a. Monoid a => a
mempty

    hfoldr :: (a :=> (b->b) ) -> b -> h a :=> b
    hfoldr f :: a :=> (b -> b)
f z :: b
z t :: h a i
t = Endo b -> b -> b
forall a. Endo a -> a -> a
appEndo ((a :=> Endo b) -> h a i -> Endo b
forall (h :: (* -> *) -> * -> *) m (a :: * -> *).
(HFoldable h, Monoid m) =>
(a :=> m) -> h a :=> m
hfoldMap ((b -> b) -> Endo b
forall a. (a -> a) -> Endo a
Endo ((b -> b) -> Endo b) -> (a i -> b -> b) -> a i -> Endo b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a i -> b -> b
a :=> (b -> b)
f) h a i
t) b
z

    hfoldl :: (b -> a :=> b) -> b -> h a :=> b
    hfoldl f :: b -> a :=> b
f z :: b
z t :: h a i
t = Endo b -> b -> b
forall a. Endo a -> a -> a
appEndo (Dual (Endo b) -> Endo b
forall a. Dual a -> a
getDual ((a :=> Dual (Endo b)) -> h a i -> Dual (Endo b)
forall (h :: (* -> *) -> * -> *) m (a :: * -> *).
(HFoldable h, Monoid m) =>
(a :=> m) -> h a :=> m
hfoldMap (Endo b -> Dual (Endo b)
forall a. a -> Dual a
Dual (Endo b -> Dual (Endo b))
-> (a i -> Endo b) -> a i -> Dual (Endo b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b) -> Endo b
forall a. (a -> a) -> Endo a
Endo ((b -> b) -> Endo b) -> (a i -> b -> b) -> a i -> Endo b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a i -> b) -> a i -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a i -> b
b -> a :=> b
f) h a i
t)) b
z


    hfoldr1 :: forall a. (a -> a -> a) -> h (K a) :=> a
    hfoldr1 f :: a -> a -> a
f xs :: h (K a) i
xs = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> a
forall a. HasCallStack => [Char] -> a
error "hfoldr1: empty structure")
                   ((K a :=> (Maybe a -> Maybe a)) -> Maybe a -> h (K a) i -> Maybe a
forall (h :: (* -> *) -> * -> *) (a :: * -> *) b.
HFoldable h =>
(a :=> (b -> b)) -> b -> h a :=> b
hfoldr K a :=> (Maybe a -> Maybe a)
mf Maybe a
forall a. Maybe a
Nothing h (K a) i
xs)
          where mf :: K a :=> (Maybe a -> Maybe a)
                mf :: K a i -> Maybe a -> Maybe a
mf (K x :: a
x) Nothing = a -> Maybe a
forall a. a -> Maybe a
Just a
x
                mf (K x :: a
x) (Just y :: a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
f a
x a
y)

    hfoldl1 :: forall a . (a -> a -> a) -> h (K a) :=> a
    hfoldl1 f :: a -> a -> a
f xs :: h (K a) i
xs = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> a
forall a. HasCallStack => [Char] -> a
error "hfoldl1: empty structure")
                   ((Maybe a -> K a :=> Maybe a) -> Maybe a -> h (K a) i -> Maybe a
forall (h :: (* -> *) -> * -> *) b (a :: * -> *).
HFoldable h =>
(b -> a :=> b) -> b -> h a :=> b
hfoldl Maybe a -> K a :=> Maybe a
mf Maybe a
forall a. Maybe a
Nothing h (K a) i
xs)
          where mf :: Maybe a -> K a :=> Maybe a
                mf :: Maybe a -> K a :=> Maybe a
mf Nothing (K y :: a
y) = a -> Maybe a
forall a. a -> Maybe a
Just a
y
                mf (Just x :: a
x) (K y :: a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
f a
x a
y)

htoList :: (HFoldable f) => f a :=> [E a]
htoList :: f a :=> [E a]
htoList = (a :=> ([E a] -> [E a])) -> [E a] -> f a :=> [E a]
forall (h :: (* -> *) -> * -> *) (a :: * -> *) b.
HFoldable h =>
(a :=> (b -> b)) -> b -> h a :=> b
hfoldr (\ n :: a i
n l :: [E a]
l ->  a i -> E a
forall (f :: * -> *) i. f i -> E f
E a i
n E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
l) []

kfoldr :: (HFoldable f) => (a -> b -> b) -> b -> f (K a) :=> b
kfoldr :: (a -> b -> b) -> b -> f (K a) :=> b
kfoldr f :: a -> b -> b
f = (K a :=> (b -> b)) -> b -> f (K a) :=> b
forall (h :: (* -> *) -> * -> *) (a :: * -> *) b.
HFoldable h =>
(a :=> (b -> b)) -> b -> h a :=> b
hfoldr (\ (K x) y :: b
y -> a -> b -> b
f a
x b
y)


kfoldl :: (HFoldable f) => (b -> a -> b) -> b -> f (K a) :=> b
kfoldl :: (b -> a -> b) -> b -> f (K a) :=> b
kfoldl f :: b -> a -> b
f = (b -> K a :=> b) -> b -> f (K a) :=> b
forall (h :: (* -> *) -> * -> *) b (a :: * -> *).
HFoldable h =>
(b -> a :=> b) -> b -> h a :=> b
hfoldl (\ x :: b
x (K y) -> b -> a -> b
f b
x a
y)