{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2009-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Data.Fold
  (
  -- * Scaners and Foldings
    Scan(..)
  , Folding(..)
  -- * Combinators
  , beneath
  -- * Scans
  -- ** Left Scans
  , L1(..)  -- lazy Mealy machine
  , L1'(..) -- strict Mealy machine
  -- ** Semigroup Scans
  , M1(..) -- semigroup reducer
  -- ** Right Scans
  , R1(..) -- reversed lazy Mealy machine
  -- * Foldings
  -- ** Left Foldings
  , L(..) -- lazy Moore machine
  , L'(..) -- strict Moore machine
  -- ** Monoidal Foldings
  , M(..) -- monoidal reducer
  -- ** Right Foldings
  , R(..) -- reversed lazy Moore machine
  -- * Homomorphisms
  -- ** Scan Homomorphisms
  -- $scanhom
  , AsRM1(..)
  , AsL1'(..)

  -- ** Folding Homomorphisms
  -- $foldinghom
  , AsRM(..)
  , AsL'(..)
  ) where

import Data.Fold.Class
import Data.Fold.Internal
import Data.Fold.L
import Data.Fold.L'
import Data.Fold.L1
import Data.Fold.L1'
import Data.Fold.M
import Data.Fold.M1
import Data.Fold.R
import Data.Fold.R1
import Control.Category ((>>>))

-- * Scan Homomorphisms

-- $scanhom
--
-- We define @f@ to be a scan homomorphism between @p@ and @q@ when:
--
-- @
-- f :: forall a b. p a b -> q a b
-- @
--
-- @
-- 'run1' xs (f φ)        ≡ 'run1' xs φ
-- 'prefix1' xs (f φ)     ≡ f ('prefix1' xs φ)
-- 'postfix1' (f φ) xs    ≡ f ('postfix1' φ xs)
-- 'dimap' l r (f φ)      ≡ f ('dimap' l r φ)
-- 'pure' a               ≡ f ('pure' a)
-- f φ '<*>' f ψ          ≡ f (φ '<*>' ψ)
-- 'return' a             ≡ f ('return' a)
-- f φ '>>=' f . k        ≡ f (φ '>>=' k)
-- 'interspersing' a (f φ) ≡ f ('interspersing' a φ)
-- @
--
-- Furthermore,
--
-- @'left'' (f φ)@ and @f ('left'' φ)@ should agree whenever either answer is 'Right'
--
-- @'right'' (f φ)@ and @f ('right'' φ)@ should agree whenever either answer is 'Left'
--

-- * Folding Homomorphisms

-- $foldinghom
--
-- We define @f@ to be a folding homomorphism between @p@ and @q@ when
-- @f@ is a scan homomorphism and additionally we can satisfy:
--
-- @
-- 'run' xs (f φ)         ≡ 'run' xs φ
-- 'runOf' l xs (f φ)     ≡ 'runOf' l xs φ
-- 'prefix' xs (f φ)      ≡ f ('prefix' xs φ)
-- 'prefixOf' l xs (f φ)  ≡ f ('prefixOf' l xs φ)
-- 'postfix' (f φ) xs     ≡ f ('postfix' φ xs)
-- 'postfixOf' l (f φ) xs ≡ f ('postfixOf' l φ xs)
-- 'extract' (f φ)        ≡ 'extract' φ
-- 'filtering' p (f φ)     ≡ f ('filtering' p φ)
-- @
--
-- Note: A law including 'extend' is explicitly excluded. To work consistenly
-- across foldings, use 'prefix' and 'postfix' instead.

class AsRM1 p where
  -- | 'asM1' is a scan homomorphism to a semigroup reducer
  asM1 :: p a b -> M1 a b
  asM1 = R1 a b -> M1 a b
forall (p :: * -> * -> *) a b. AsRM1 p => p a b -> M1 a b
asM1(R1 a b -> M1 a b) -> (p a b -> R1 a b) -> p a b -> M1 a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.p a b -> R1 a b
forall (p :: * -> * -> *) a b. AsRM1 p => p a b -> R1 a b
asR1

  -- | 'asM1' is a scan homomorphism to a right scan
  asR1 :: p a b -> R1 a b
  asR1 = M1 a b -> R1 a b
forall (p :: * -> * -> *) a b. AsRM1 p => p a b -> R1 a b
asR1(M1 a b -> R1 a b) -> (p a b -> M1 a b) -> p a b -> R1 a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.p a b -> M1 a b
forall (p :: * -> * -> *) a b. AsRM1 p => p a b -> M1 a b
asM1

instance AsRM1 L where
  asM1 :: L a b -> M1 a b
asM1 (L r -> b
k r -> a -> r
h r
z) = ((r -> r) -> b)
-> (a -> r -> r) -> ((r -> r) -> (r -> r) -> r -> r) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\r -> r
f -> r -> b
k (r -> r
f r
z)) ((r -> a -> r) -> a -> r -> r
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> a -> r
h) (r -> r) -> (r -> r) -> r -> r
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>)

instance AsRM1 L' where
  asR1 :: L' a b -> R1 a b
asR1 (L' r -> b
k r -> a -> r
h r
z) = ((r -> r) -> b)
-> (a -> (r -> r) -> r -> r) -> (a -> r -> r) -> R1 a b
forall a b c. (c -> b) -> (a -> c -> c) -> (a -> c) -> R1 a b
R1 (\r -> r
f -> r -> b
k (r -> r
f r
z)) (\a
b r -> r
g r
x -> r -> r
g (r -> r) -> r -> r
forall a b. (a -> b) -> a -> b
$! r -> a -> r
h r
x a
b) (\a
a r
x -> r -> a -> r
h r
x a
a)

instance AsRM1 L1 where
  asM1 :: L1 a b -> M1 a b
asM1 (L1 c -> b
k c -> a -> c
h a -> c
z) = (Pair' (c -> c) c -> b)
-> (a -> Pair' (c -> c) c)
-> (Pair' (c -> c) c -> Pair' (c -> c) c -> Pair' (c -> c) c)
-> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\(Pair' c -> c
_ c
r) -> c -> b
k c
r) (\a
a -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (c -> a -> c
`h` a
a) (a -> c
z a
a)) (\(Pair' c -> c
r2r' c
r') (Pair' c -> c
r2r c
_) -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (c -> c
r2r(c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.c -> c
r2r') (c -> c
r2r c
r'))

instance AsRM1 L1' where
  asM1 :: L1' a b -> M1 a b
asM1 (L1' c -> b
k c -> a -> c
h a -> c
z) = (Pair' (c -> c) c -> b)
-> (a -> Pair' (c -> c) c)
-> (Pair' (c -> c) c -> Pair' (c -> c) c -> Pair' (c -> c) c)
-> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\(Pair' c -> c
_ c
r) -> c -> b
k c
r) (\a
a -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (c -> a -> c
`h` a
a) (a -> c
z a
a)) (\(Pair' c -> c
r2r' c
r') (Pair' c -> c
r2r c
_) -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (\c
r -> c -> c
r2r (c -> c) -> c -> c
forall a b. (a -> b) -> a -> b
$! c -> c
r2r' c
r) (c -> c
r2r c
r'))

instance AsRM1 M where
  asM1 :: M a b -> M1 a b
asM1 (M m -> b
k a -> m
h m -> m -> m
m m
_) = (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 m -> b
k a -> m
h m -> m -> m
m
  asR1 :: M a b -> R1 a b
asR1 (M m -> b
k a -> m
h m -> m -> m
m m
_) = (m -> b) -> (a -> m -> m) -> (a -> m) -> R1 a b
forall a b c. (c -> b) -> (a -> c -> c) -> (a -> c) -> R1 a b
R1 m -> b
k (m -> m -> m
m(m -> m -> m) -> (a -> m) -> a -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> m
h) a -> m
h

instance AsRM1 M1 where
  asM1 :: M1 a b -> M1 a b
asM1 = M1 a b -> M1 a b
forall a. a -> a
id
  asR1 :: M1 a b -> R1 a b
asR1 (M1 m -> b
k a -> m
h m -> m -> m
m) = (m -> b) -> (a -> m -> m) -> (a -> m) -> R1 a b
forall a b c. (c -> b) -> (a -> c -> c) -> (a -> c) -> R1 a b
R1 m -> b
k (m -> m -> m
m(m -> m -> m) -> (a -> m) -> a -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> m
h) a -> m
h

instance AsRM1 R where
  asM1 :: R a b -> M1 a b
asM1 (R r -> b
k a -> r -> r
h r
z) = ((r -> r) -> b)
-> (a -> r -> r) -> ((r -> r) -> (r -> r) -> r -> r) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\r -> r
f -> r -> b
k (r -> r
f r
z)) a -> r -> r
h (r -> r) -> (r -> r) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
  asR1 :: R a b -> R1 a b
asR1 (R r -> b
k a -> r -> r
h r
z) = (r -> b) -> (a -> r -> r) -> (a -> r) -> R1 a b
forall a b c. (c -> b) -> (a -> c -> c) -> (a -> c) -> R1 a b
R1 r -> b
k a -> r -> r
h (\a
a -> a -> r -> r
h a
a r
z)

instance AsRM1 R1 where
  asM1 :: R1 a b -> M1 a b
asM1 (R1 c -> b
k a -> c -> c
h a -> c
z) = (Pair' (c -> c) c -> b)
-> (a -> Pair' (c -> c) c)
-> (Pair' (c -> c) c -> Pair' (c -> c) c -> Pair' (c -> c) c)
-> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\(Pair' c -> c
_ c
r) -> c -> b
k c
r) (\a
a -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (a -> c -> c
h a
a) (a -> c
z a
a)) (\(Pair' c -> c
r2r c
_) (Pair' c -> c
r2r' c
r') -> (c -> c) -> c -> Pair' (c -> c) c
forall a b. a -> b -> Pair' a b
Pair' (c -> c
r2r(c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.c -> c
r2r') (c -> c
r2r c
r'))
  asR1 :: R1 a b -> R1 a b
asR1 = R1 a b -> R1 a b
forall a. a -> a
id

class AsRM1 p => AsRM p where
  -- | 'asM' is a folding homomorphism to a monoidal folding
  --
  -- @
  -- 'run' xs ('asM' φ)         ≡ 'run' xs φ
  -- 'prefix' xs ('asM' φ)      ≡ 'asM' ('prefix' xs φ)
  -- 'prefixOf' l xs ('asM' φ)  ≡ 'asM' ('prefixOf' l xs φ)
  -- 'postfix' ('asM' φ) xs     ≡ 'asM' ('postfix' φ xs)
  -- 'postfixOf' l ('asM' φ) xs ≡ 'asM' ('postfixOf' l φ xs)
  -- 'left'' ('asM' φ)          ≡ 'asM' ('left'' φ)
  -- 'right'' ('asM' φ)         ≡ 'asM' ('right'' φ)
  -- 'dimap' l r ('asM' φ)      ≡ 'asM' ('dimap' l r φ)
  -- 'extract' ('asM' φ)        ≡ 'extract' φ
  -- 'pure' a                  ≡ 'asM' ('pure' a)
  -- 'asM' φ '<*>' 'asM' ψ        ≡ 'asM' (φ '<*>' ψ)
  -- 'return' a                ≡ 'asM' ('return' a)
  -- 'asM' φ '>>=' 'asM' . k      ≡ 'asM' (φ '>>=' k)
  -- 'filtering' p ('asM' φ)     ≡ 'asM' ('filtering' p φ)
  -- 'interspersing' a ('asM' φ) ≡ 'asM' ('interspersing' a φ)
  -- @
  asM :: p a b -> M a b
  asM = R a b -> M a b
forall (p :: * -> * -> *) a b. AsRM p => p a b -> M a b
asM (R a b -> M a b) -> (p a b -> R a b) -> p a b -> M a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> R a b
forall (p :: * -> * -> *) a b. AsRM p => p a b -> R a b
asR

  -- | 'asR' is a folding homomorphism to a right folding
  --
  -- @
  -- 'run' xs ('asR' φ)         ≡ 'run' xs φ
  -- 'prefix' xs ('asR' φ)      ≡ 'asR' ('prefix' xs φ)
  -- 'prefixOf' l xs ('asR' φ)  ≡ 'asR' ('prefixOf' l xs φ)
  -- 'postfix' ('asR' φ) xs     ≡ 'asR' ('postfix' φ xs)
  -- 'postfixOf' l ('asR' φ) xs ≡ 'asR' ('postfixOf' l φ xs)
  -- 'left'' ('asR' φ)          ≡ 'asR' ('left'' φ)
  -- 'right'' ('asR' φ)         ≡ 'asR' ('right'' φ)
  -- 'dimap' l r ('asR' φ)      ≡ 'asR' ('dimap' l r φ)
  -- 'extract' ('asR' φ)        ≡ 'extract' φ
  -- 'pure' a                  ≡ 'asR' ('pure' a)
  -- 'asR' φ '<*>' 'asR' ψ        ≡ 'asR' (φ '<*>' ψ)
  -- 'return' a                ≡ 'asR' ('return' a)
  -- 'asR' φ '>>=' 'asR' . k      ≡ 'asR' (φ '>>=' k)
  -- 'filtering' p ('asR' φ)     ≡ 'asR' ('filtering' p φ)
  -- 'interspersing' a ('asR' φ) ≡ 'asR' ('interspersing' a φ)
  -- @
  asR :: p a b -> R a b
  asR = M a b -> R a b
forall (p :: * -> * -> *) a b. AsRM p => p a b -> R a b
asR (M a b -> R a b) -> (p a b -> M a b) -> p a b -> R a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> M a b
forall (p :: * -> * -> *) a b. AsRM p => p a b -> M a b
asM

-- | We can convert from a lazy right fold to a monoidal fold
instance AsRM R where
  asM :: R a b -> M a b
asM (R r -> b
k a -> r -> r
h r
z) = ((r -> r) -> b)
-> (a -> r -> r)
-> ((r -> r) -> (r -> r) -> r -> r)
-> (r -> r)
-> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\r -> r
f -> r -> b
k (r -> r
f r
z)) a -> r -> r
h (r -> r) -> (r -> r) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) r -> r
forall a. a -> a
id
  asR :: R a b -> R a b
asR = R a b -> R a b
forall a. a -> a
id

-- | We can convert from a monoidal fold to a lazy right fold
instance AsRM M where
  asR :: M a b -> R a b
asR (M m -> b
k a -> m
h m -> m -> m
m m
z) = (m -> b) -> (a -> m -> m) -> m -> R a b
forall a b r. (r -> b) -> (a -> r -> r) -> r -> R a b
R m -> b
k (m -> m -> m
m(m -> m -> m) -> (a -> m) -> a -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> m
h) m
z
  asM :: M a b -> M a b
asM = M a b -> M a b
forall a. a -> a
id

-- | We can convert from a lazy left folding to a right or monoidal fold
instance AsRM L where
  asM :: L a b -> M a b
asM (L r -> b
k r -> a -> r
h r
z) = ((r -> r) -> b)
-> (a -> r -> r)
-> ((r -> r) -> (r -> r) -> r -> r)
-> (r -> r)
-> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\r -> r
f -> r -> b
k (r -> r
f r
z)) ((r -> a -> r) -> a -> r -> r
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> a -> r
h) (r -> r) -> (r -> r) -> r -> r
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) r -> r
forall a. a -> a
id
  asR :: L a b -> R a b
asR (L r -> b
k r -> a -> r
h r
z) = ((r -> r) -> b) -> (a -> (r -> r) -> r -> r) -> (r -> r) -> R a b
forall a b r. (r -> b) -> (a -> r -> r) -> r -> R a b
R (\r -> r
f -> r -> b
k (r -> r
f r
z)) (\a
b r -> r
g r
x -> r -> r
g (r -> a -> r
h r
x a
b)) r -> r
forall a. a -> a
id

-- | We can convert from a strict left folding to a right or monoidal fold
instance AsRM L' where
  asR :: L' a b -> R a b
asR (L' r -> b
k r -> a -> r
h r
z) = ((r -> r) -> b) -> (a -> (r -> r) -> r -> r) -> (r -> r) -> R a b
forall a b r. (r -> b) -> (a -> r -> r) -> r -> R a b
R (\r -> r
f -> r -> b
k (r -> r
f r
z)) (\a
b r -> r
g r
x -> r -> r
g (r -> r) -> r -> r
forall a b. (a -> b) -> a -> b
$! r -> a -> r
h r
x a
b) r -> r
forall a. a -> a
id

class AsRM1 p => AsL1' p where
  -- | Scan homomorphism to a strict Mealy machine
  asL1' :: p a b -> L1' a b
  default asL1' :: AsL' p => p a b -> L1' a b
  asL1' = L' a b -> L1' a b
forall (p :: * -> * -> *) a b. AsL1' p => p a b -> L1' a b
asL1'(L' a b -> L1' a b) -> (p a b -> L' a b) -> p a b -> L1' a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.p a b -> L' a b
forall (p :: * -> * -> *) a b. AsL' p => p a b -> L' a b
asL'

instance AsL1' L1' where
  asL1' :: L1' a b -> L1' a b
asL1' = L1' a b -> L1' a b
forall a. a -> a
id

instance AsL1' L1 where
  asL1' :: L1 a b -> L1' a b
asL1' (L1 c -> b
k c -> a -> c
h a -> c
z) = (Box c -> b) -> (Box c -> a -> Box c) -> (a -> Box c) -> L1' a b
forall a b c. (c -> b) -> (c -> a -> c) -> (a -> c) -> L1' a b
L1' (\(Box c
r) -> c -> b
k c
r) (\(Box c
r) a
a -> c -> Box c
forall a. a -> Box a
Box (c -> a -> c
h c
r a
a)) (\a
a -> c -> Box c
forall a. a -> Box a
Box (a -> c
z a
a))

instance AsL1' L where
  asL1' :: L a b -> L1' a b
asL1' (L r -> b
k r -> a -> r
h r
z) = (Box r -> b) -> (Box r -> a -> Box r) -> (a -> Box r) -> L1' a b
forall a b c. (c -> b) -> (c -> a -> c) -> (a -> c) -> L1' a b
L1' (\(Box r
r) -> r -> b
k r
r) (\(Box r
r) a
a -> r -> Box r
forall a. a -> Box a
Box (r -> a -> r
h r
r a
a)) (\a
a -> r -> Box r
forall a. a -> Box a
Box (r -> a -> r
h r
z a
a))

instance AsL1' L' where
  asL1' :: L' a b -> L1' a b
asL1' (L' r -> b
k r -> a -> r
h r
z) = (r -> b) -> (r -> a -> r) -> (a -> r) -> L1' a b
forall a b c. (c -> b) -> (c -> a -> c) -> (a -> c) -> L1' a b
L1' r -> b
k r -> a -> r
h (r -> a -> r
h r
z)

class (AsRM p, AsL1' p) => AsL' p where
  -- | 'asL'' is a folding homomorphism to a strict left folding
  --
  -- @
  -- 'run' xs ('asL'' φ)         ≡ 'run' xs φ
  -- 'prefix' xs ('asL'' φ)      ≡ 'asL'' ('prefix' xs φ)
  -- 'prefixOf' l xs ('asL'' φ)  ≡ 'asL'' ('prefixOf' l xs φ)
  -- 'postfix' ('asL'' φ) xs     ≡ 'asL'' ('postfix' φ xs)
  -- 'postfixOf' l ('asL'' φ) xs ≡ 'asL'' ('postfixOf' l φ xs)
  -- 'left'' ('asL'' φ)          ≡ 'asL'' ('left'' φ)
  -- 'right'' ('asL'' φ)         ≡ 'asL'' ('right'' φ)
  -- 'dimap' l r ('asL'' φ)      ≡ 'asL'' ('dimap' l r φ)
  -- 'extract' ('asL'' φ)        ≡ 'extract' φ
  -- 'pure' a                   ≡ 'asL'' ('pure' a)
  -- 'asL'' φ '<*>' 'asL'' ψ       ≡ 'asL'' (φ '<*>' ψ)
  -- 'return' a                 ≡ 'asL'' ('return' a)
  -- 'asL'' φ '>>=' 'asL'' . k     ≡ 'asL'' (φ '>>=' k)
  -- 'filtering' p ('asL'' φ)     ≡ 'asL'' ('filtering' p φ)
  -- 'interspersing' a ('asL'' φ) ≡ 'asL'' ('interspersing' a φ)
  -- @
  asL' :: p a b -> L' a b

-- | We can convert a lazy fold to itself
instance AsL' L' where
  asL' :: L' a b -> L' a b
asL' = L' a b -> L' a b
forall a. a -> a
id

-- | We can convert from a lazy left folding to a strict left folding.
instance AsL' L where
  asL' :: L a b -> L' a b
asL' (L r -> b
k r -> a -> r
h r
z) = (Box r -> b) -> (Box r -> a -> Box r) -> Box r -> L' a b
forall a b r. (r -> b) -> (r -> a -> r) -> r -> L' a b
L' (\(Box r
r) -> r -> b
k r
r) (\(Box r
r) a
a -> r -> Box r
forall a. a -> Box a
Box (r -> a -> r
h r
r a
a)) (r -> Box r
forall a. a -> Box a
Box r
z)