------------------------------------------------------------------------
-- |
-- Module           : Data.Parameterized.TraversableFC
-- Copyright        : (c) Galois, Inc 2014-2015
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Description      : Traversing structures having a single parametric type followed by a fixed kind.
--
-- This module declares classes for working with structures that accept
-- a parametric type parameter followed by some fixed kind.
------------------------------------------------------------------------
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
module Data.Parameterized.TraversableFC
  ( TestEqualityFC(..)
  , OrdFC(..)
  , ShowFC(..)
  , HashableFC(..)
  , FunctorFC(..)
  , FoldableFC(..)
  , foldlMFC
  , foldlMFC'
  , foldrMFC
  , foldrMFC'
  , TraversableFC(..)
  , traverseFC_
  , forMFC_
  , forFC_
  , forFC
  , fmapFCDefault
  , foldMapFCDefault
  , allFC
  , anyFC
  , lengthFC
  ) where

import Control.Applicative (Const(..) )
import Control.Monad.Identity ( Identity (..) )
import Data.Coerce
import Data.Kind
import Data.Monoid
import GHC.Exts (build)
import Data.Type.Equality

import Data.Parameterized.Classes

-- | A parameterized type that is a functor on all instances.
--
-- Laws:
--
-- [Identity]    @'fmapFC' 'id' == 'id'@
-- [Composition] @'fmapFC' (f . g) == 'fmapFC' f . 'fmapFC' g@
class FunctorFC (t :: (k -> Type) -> l -> Type) where
  fmapFC :: forall f g. (forall x. f x -> g x) ->
                        (forall x. t f x -> t g x)

-- | A parameterized class for types which can be shown, when given
--   functions to show parameterized subterms.
class ShowFC (t :: (k -> Type) -> l -> Type) where
  {-# MINIMAL showFC | showsPrecFC #-}

  showFC :: forall f. (forall x. f x -> String)
         -> (forall x. t f x -> String)
  showFC forall (x :: k). f x -> String
sh t f x
x = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *).
ShowFC t =>
(forall (x :: k). Int -> f x -> ShowS)
-> forall (x :: l). Int -> t f x -> ShowS
showsPrecFC (\Int
_prec f x
z String
rest -> forall (x :: k). f x -> String
sh f x
z forall a. [a] -> [a] -> [a]
++ String
rest) Int
0 t f x
x []

  showsPrecFC :: forall f. (forall x. Int -> f x -> ShowS) ->
                           (forall x. Int -> t f x -> ShowS)
  showsPrecFC forall (x :: k). Int -> f x -> ShowS
sh Int
_prec t f x
x String
rest = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *).
ShowFC t =>
(forall (x :: k). f x -> String)
-> forall (x :: l). t f x -> String
showFC (\f x
z -> forall (x :: k). Int -> f x -> ShowS
sh Int
0 f x
z []) t f x
x forall a. [a] -> [a] -> [a]
++ String
rest


-- | A parameterized class for types which can be hashed, when given
--   functions to hash parameterized subterms.
class HashableFC (t :: (k -> Type) -> l -> Type) where
  hashWithSaltFC :: forall f. (forall x. Int -> f x -> Int) ->
                              (forall x. Int -> t f x -> Int)

-- | A parameterized class for types which can be tested for parameterized equality,
--   when given an equality test for subterms.
class TestEqualityFC (t :: (k -> Type) -> l -> Type) where
  testEqualityFC :: forall f. (forall x y. f x -> f y -> (Maybe (x :~: y))) ->
                              (forall x y. t f x -> t f y -> (Maybe (x :~: y)))

-- | A parameterized class for types which can be tested for parameterized ordering,
--   when given an comparison test for subterms.
class TestEqualityFC t => OrdFC (t :: (k -> Type) -> l -> Type) where
  compareFC :: forall f. (forall x y. f x -> f y -> OrderingF x y) ->
                         (forall x y. t f x -> t f y -> OrderingF x y)

------------------------------------------------------------------------
-- FoldableF

-- | This is a coercion used to avoid overhead associated
-- with function composition.
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
#. :: forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
(#.) b -> c
_f = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | This is a generalization of the 'Foldable' class to
-- structures over parameterized terms.
class FoldableFC (t :: (k -> Type) -> l -> Type) where
  {-# MINIMAL foldMapFC | foldrFC #-}

  -- | Map each element of the structure to a monoid,
  -- and combine the results.
  foldMapFC :: forall f m. Monoid m => (forall x. f x -> m) -> (forall x. t f x -> m)
  foldMapFC forall (x :: k). f x -> m
f = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: k). f x -> m
f) forall a. Monoid a => a
mempty

  -- | Right-associative fold of a structure.
  foldrFC :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b)
  foldrFC forall (x :: k). f x -> b -> b
f b
z t f x
t = forall a. Endo a -> a -> a
appEndo (forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) m.
(FoldableFC t, Monoid m) =>
(forall (x :: k). f x -> m) -> forall (x :: l). t f x -> m
foldMapFC (forall a. (a -> a) -> Endo a
Endo forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (x :: k). f x -> b -> b
f) t f x
t) b
z

  -- | Left-associative fold of a structure.
  foldlFC :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b)
  foldlFC forall (x :: k). b -> f x -> b
f b
z t f x
t = forall a. Endo a -> a -> a
appEndo (forall a. Dual a -> a
getDual (forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) m.
(FoldableFC t, Monoid m) =>
(forall (x :: k). f x -> m) -> forall (x :: l). t f x -> m
foldMapFC (\f x
e -> forall a. a -> Dual a
Dual (forall a. (a -> a) -> Endo a
Endo (\b
r -> forall (x :: k). b -> f x -> b
f b
r f x
e))) t f x
t)) b
z

  -- | Right-associative fold of a structure,
  -- but with strict application of the operator.
  foldrFC' :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b)
  foldrFC' forall (x :: k). f x -> b -> b
f0 b
z0 t f x
xs = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). b -> f x -> b)
-> forall (x :: l). b -> t f x -> b
foldlFC (forall {t} {t} {a} {b}. (t -> t -> a) -> (a -> b) -> t -> t -> b
f' forall (x :: k). f x -> b -> b
f0) forall a. a -> a
id t f x
xs b
z0
    where f' :: (t -> t -> a) -> (a -> b) -> t -> t -> b
f' t -> t -> a
f a -> b
k t
x t
z = a -> b
k forall a b. (a -> b) -> a -> b
$! t -> t -> a
f t
x t
z

  -- | Left-associative fold of a parameterized structure
  -- with a strict accumulator.
  foldlFC' :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b)
  foldlFC' forall (x :: k). b -> f x -> b
f0 b
z0 t f x
xs = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (forall {t} {t} {a} {b}. (t -> t -> a) -> t -> (a -> b) -> t -> b
f' forall (x :: k). b -> f x -> b
f0) forall a. a -> a
id t f x
xs b
z0
    where f' :: (t -> t -> a) -> t -> (a -> b) -> t -> b
f' t -> t -> a
f t
x a -> b
k t
z = a -> b
k forall a b. (a -> b) -> a -> b
$! t -> t -> a
f t
z t
x

  -- | Convert structure to list.
  toListFC :: forall f a. (forall x. f x -> a) -> (forall x. t f x -> [a])
  toListFC forall (x :: k). f x -> a
f t f x
t = forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (\a -> b -> b
c b
n -> forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (\f x
e b
v -> a -> b -> b
c (forall (x :: k). f x -> a
f f x
e) b
v) b
n t f x
t)

-- | Monadic fold over the elements of a structure from left to right.
foldlMFC :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b
foldlMFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *) b
       (f :: k -> *) (c :: l).
(FoldableFC t, Monad m) =>
(forall (x :: k). b -> f x -> m b) -> b -> t f c -> m b
foldlMFC forall (x :: k). b -> f x -> m b
f b
z0 t f c
xs = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC forall {x :: k} {b}. f x -> (b -> m b) -> b -> m b
f' forall (m :: * -> *) a. Monad m => a -> m a
return t f c
xs b
z0
  where f' :: f x -> (b -> m b) -> b -> m b
f' f x
x b -> m b
k b
z = forall (x :: k). b -> f x -> m b
f b
z f x
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
k

-- | Monadic strict fold over the elements of a structure from left to right.
foldlMFC' :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b
foldlMFC' :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *) b
       (f :: k -> *) (c :: l).
(FoldableFC t, Monad m) =>
(forall (x :: k). b -> f x -> m b) -> b -> t f c -> m b
foldlMFC' forall (x :: k). b -> f x -> m b
f b
z0 t f c
xs = seq :: forall a b. a -> b -> b
seq b
z0 forall a b. (a -> b) -> a -> b
$ forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC forall {x :: k} {b}. f x -> (b -> m b) -> b -> m b
f' forall (m :: * -> *) a. Monad m => a -> m a
return t f c
xs b
z0
  where f' :: f x -> (b -> m b) -> b -> m b
f' f x
x b -> m b
k b
z = forall (x :: k). b -> f x -> m b
f b
z f x
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
r -> seq :: forall a b. a -> b -> b
seq b
r (b -> m b
k b
r)

-- | Monadic fold over the elements of a structure from right to left.
foldrMFC :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b
foldrMFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) b (c :: l).
(FoldableFC t, Monad m) =>
(forall (x :: k). f x -> b -> m b) -> b -> t f c -> m b
foldrMFC forall (x :: k). f x -> b -> m b
f b
z0 t f c
xs = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). b -> f x -> b)
-> forall (x :: l). b -> t f x -> b
foldlFC forall {b} {x :: k}. (b -> m b) -> f x -> b -> m b
f' forall (m :: * -> *) a. Monad m => a -> m a
return t f c
xs b
z0
  where f' :: (b -> m b) -> f x -> b -> m b
f' b -> m b
k f x
x b
z = forall (x :: k). f x -> b -> m b
f f x
x b
z forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
k

-- | Monadic strict fold over the elements of a structure from right to left.
foldrMFC' :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b
foldrMFC' :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) b (c :: l).
(FoldableFC t, Monad m) =>
(forall (x :: k). f x -> b -> m b) -> b -> t f c -> m b
foldrMFC' forall (x :: k). f x -> b -> m b
f b
z0 t f c
xs = seq :: forall a b. a -> b -> b
seq b
z0 (forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). b -> f x -> b)
-> forall (x :: l). b -> t f x -> b
foldlFC forall {b} {x :: k}. (b -> m b) -> f x -> b -> m b
f' forall (m :: * -> *) a. Monad m => a -> m a
return t f c
xs b
z0)
  where f' :: (b -> m b) -> f x -> b -> m b
f' b -> m b
k f x
x b
z = forall (x :: k). f x -> b -> m b
f f x
x b
z forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
r -> seq :: forall a b. a -> b -> b
seq b
r (b -> m b
k b
r)

-- | Return 'True' if all values satisfy predicate.
allFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool)
allFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (f :: k -> *).
FoldableFC t =>
(forall (x :: k). f x -> Bool) -> forall (x :: l). t f x -> Bool
allFC forall (x :: k). f x -> Bool
p = All -> Bool
getAll forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) m.
(FoldableFC t, Monoid m) =>
(forall (x :: k). f x -> m) -> forall (x :: l). t f x -> m
foldMapFC (Bool -> All
All forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (x :: k). f x -> Bool
p)

-- | Return 'True' if any values satisfy predicate.
anyFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool)
anyFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (f :: k -> *).
FoldableFC t =>
(forall (x :: k). f x -> Bool) -> forall (x :: l). t f x -> Bool
anyFC forall (x :: k). f x -> Bool
p = Any -> Bool
getAny forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) m.
(FoldableFC t, Monoid m) =>
(forall (x :: k). f x -> m) -> forall (x :: l). t f x -> m
foldMapFC (Bool -> Any
Any forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (x :: k). f x -> Bool
p)

-- | Return number of elements that we fold over.
lengthFC :: FoldableFC t => t f x -> Int
lengthFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (f :: k -> *) (x :: l).
FoldableFC t =>
t f x -> Int
lengthFC = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (forall a b. a -> b -> a
const (forall a. Num a => a -> a -> a
+Int
1)) Int
0

------------------------------------------------------------------------
-- TraversableF

class (FunctorFC t, FoldableFC t) => TraversableFC (t :: (k -> Type) -> l -> Type) where
  traverseFC :: forall f g m. Applicative m
             => (forall x. f x -> m (g x))
             -> (forall x. t f x -> m (t g x))

-- | This function may be used as a value for `fmapF` in a `FunctorF`
-- instance.
fmapFCDefault :: TraversableFC t => forall f g. (forall x. f x -> g x) -> (forall x. t f x -> t g x)
fmapFCDefault :: forall {k} {l} (t :: (k -> *) -> l -> *) (f :: k -> *)
       (g :: k -> *).
TraversableFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFCDefault = \forall (x :: k). f x -> g x
f -> forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (m :: * -> *).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: k). f x -> g x
f)
{-# INLINE fmapFCDefault #-}

-- | This function may be used as a value for `Data.Foldable.foldMap`
-- in a `Foldable` instance.
foldMapFCDefault :: (TraversableFC t, Monoid m) => (forall x. f x -> m) -> (forall x. t f x -> m)
foldMapFCDefault :: forall {k} {l} (t :: (k -> *) -> l -> *) m (f :: k -> *).
(TraversableFC t, Monoid m) =>
(forall (x :: k). f x -> m) -> forall (x :: l). t f x -> m
foldMapFCDefault = \forall (x :: k). f x -> m
f -> forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (m :: * -> *).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: k). f x -> m
f)
{-# INLINE foldMapFCDefault #-}

-- | Map each element of a structure to an action, evaluate
-- these actions from left to right, and ignore the results.
traverseFC_ :: (FoldableFC t, Applicative m) => (forall x. f x -> m a) -> (forall x. t f x -> m ())
traverseFC_ :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ forall (x :: k). f x -> m a
f = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (\f x
e m ()
r -> forall (x :: k). f x -> m a
f f x
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
r) (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINE traverseFC_ #-}

-- | Map each element of a structure to an action, evaluate
-- these actions from left to right, and ignore the results.
forMFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m ()
forMFC_ :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) (c :: l) a.
(FoldableFC t, Applicative m) =>
t f c -> (forall (x :: k). f x -> m a) -> m ()
forMFC_ t f c
v forall (x :: k). f x -> m a
f = forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ forall (x :: k). f x -> m a
f t f c
v
{-# INLINE forMFC_ #-}
{-# DEPRECATED forMFC_ "Use forFC_" #-}

-- | Map each element of a structure to an action, evaluate
-- these actions from left to right, and ignore the results.
forFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m ()
forFC_ :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) (c :: l) a.
(FoldableFC t, Applicative m) =>
t f c -> (forall (x :: k). f x -> m a) -> m ()
forFC_ t f c
v forall (x :: k). f x -> m a
f = forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ forall (x :: k). f x -> m a
f t f c
v
{-# INLINE forFC_ #-}

-- | Flipped 'traverseFC'
forFC ::
  (TraversableFC t, Applicative m) =>
  t f x -> (forall y. f y -> m (g y)) -> m (t g x)
forFC :: forall {k} {l} (t :: (k -> *) -> l -> *) (m :: * -> *)
       (f :: k -> *) (x :: l) (g :: k -> *).
(TraversableFC t, Applicative m) =>
t f x -> (forall (y :: k). f y -> m (g y)) -> m (t g x)
forFC t f x
v forall (y :: k). f y -> m (g y)
f = forall k l (t :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (m :: * -> *).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall (y :: k). f y -> m (g y)
f t f x
v
{-# INLINE forFC #-}