{-# 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 = forall (h :: (* -> *) -> * -> *) m (a :: * -> *).
(HFoldable h, Monoid m) =>
(a :=> m) -> h a :=> m
hfoldMap forall a i. K a i -> a
unK

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

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

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


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

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

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


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