-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | UStore templates generic traversals.
--
-- Normally you work with functionality of this module as follows:
-- 1. Pick the function fitting most for your traversal, one of
--    'traverseUStore', 'foldUStore' e.t.c.
-- 2. Create a custom datatype value of which will be put to that function.
-- 3. Implement a respective 'UStoreTemplateTraversable' instance for this
--    datatype.
module Lorentz.UStore.Traversal
  ( UStoreTraversalWay (..)
  , UStoreTraversalFieldHandler (..)
  , UStoreTraversalSubmapHandler (..)
  , UStoreTraversable
  , traverseUStore
  , modifyUStore
  , foldUStore
  , genUStore
  ) where

import qualified Data.Kind as Kind
import GHC.Generics ((:*:)(..), (:+:))
import qualified GHC.Generics as G

import Lorentz.UStore.Types
import Util.Label
import Util.TypeLits

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- | Defines general parameters of UStore template traversal.
-- You need a separate @way@ datatype with an instance of this typeclass for each
-- type of traversal.
class ( Applicative (UStoreTraversalArgumentWrapper way)
      , Applicative (UStoreTraversalMonad way)
      ) =>
      UStoreTraversalWay (way :: Kind.Type) where

  -- | Wrapper which will accompany the existing value of traversed template,
  -- aka argument.
  -- This is usually @'Identity'@ or @'Const' a@.
  type UStoreTraversalArgumentWrapper way :: Kind.Type -> Kind.Type

  -- | Additional constraints on monadic action used in traversal.
  -- Common ones include 'Identity', @'Const'@, @(,) a@
  type UStoreTraversalMonad way :: Kind.Type -> Kind.Type

-- | Declares a handler for UStore fields when given traversal way is applied.
class (UStoreTraversalWay way) =>
      UStoreTraversalFieldHandler
        (way :: Kind.Type) (marker :: UStoreMarkerType) (v :: Kind.Type) where
  -- | How to process each of UStore fields.
  ustoreTraversalFieldHandler
    :: (KnownUStoreMarker marker)
    => way
    -> Label name
    -> UStoreTraversalArgumentWrapper way v
    -> UStoreTraversalMonad way v

-- | Declares a handler for UStore submaps when given traversal way is applied.
class (UStoreTraversalWay way) =>
      UStoreTraversalSubmapHandler
        (way :: Kind.Type) (k :: Kind.Type) (v :: Kind.Type) where
  -- | How to process each of UStore submaps.
  ustoreTraversalSubmapHandler
    :: way
    -> Label name
    -> UStoreTraversalArgumentWrapper way (Map k v)
    -> UStoreTraversalMonad way (Map k v)

-- | Constraint for UStore traversal.
type UStoreTraversable way a =
  (Generic a, GUStoreTraversable way (G.Rep a), UStoreTraversalWay way)

-- | Perform UStore traversal. The most general way to perform a traversal.
traverseUStore
  :: forall way template.
     (UStoreTraversable way template)
  => way
  -> UStoreTraversalArgumentWrapper way template
  -> UStoreTraversalMonad way template
traverseUStore :: way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
traverseUStore way :: way
way =
  (Rep template Any -> template)
-> UStoreTraversalMonad way (Rep template Any)
-> UStoreTraversalMonad way template
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep template Any -> template
forall a x. Generic a => Rep a x -> a
G.to (UStoreTraversalMonad way (Rep template Any)
 -> UStoreTraversalMonad way template)
-> (UStoreTraversalArgumentWrapper way template
    -> UStoreTraversalMonad way (Rep template Any))
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. way
-> UStoreTraversalArgumentWrapper way (Rep template Any)
-> UStoreTraversalMonad way (Rep template Any)
forall way (x :: * -> *) p.
(GUStoreTraversable way x, UStoreTraversalWay way) =>
way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
gTraverseUStore way
way (UStoreTraversalArgumentWrapper way (Rep template Any)
 -> UStoreTraversalMonad way (Rep template Any))
-> (UStoreTraversalArgumentWrapper way template
    -> UStoreTraversalArgumentWrapper way (Rep template Any))
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way (Rep template Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (template -> Rep template Any)
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalArgumentWrapper way (Rep template Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap template -> Rep template Any
forall a x. Generic a => a -> Rep a x
G.from

-- | Modify each UStore entry.
modifyUStore
  :: ( UStoreTraversable way template
     , UStoreTraversalArgumentWrapper way ~ Identity
     , UStoreTraversalMonad way ~ Identity
     )
  => way
  -> template
  -> template
modifyUStore :: way -> template -> template
modifyUStore way :: way
way a :: template
a =
  Identity template -> template
forall a. Identity a -> a
runIdentity (Identity template -> template) -> Identity template -> template
forall a b. (a -> b) -> a -> b
$ way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
forall way template.
UStoreTraversable way template =>
way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
traverseUStore way
way (template -> Identity template
forall a. a -> Identity a
Identity template
a)

-- | Collect information about UStore entries into monoid.
foldUStore
  :: ( UStoreTraversable way template
     , UStoreTraversalArgumentWrapper way ~ Identity
     , UStoreTraversalMonad way ~ Const res
     )
  => way
  -> template
  -> res
foldUStore :: way -> template -> res
foldUStore way :: way
way a :: template
a =
  Const res template -> res
forall a k (b :: k). Const a b -> a
getConst (Const res template -> res) -> Const res template -> res
forall a b. (a -> b) -> a -> b
$ way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
forall way template.
UStoreTraversable way template =>
way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
traverseUStore way
way (template -> Identity template
forall a. a -> Identity a
Identity template
a)

-- | Fill UStore template with entries.
genUStore
  :: ( UStoreTraversable way template
     , UStoreTraversalArgumentWrapper way ~ Const ()
     )
  => way -> UStoreTraversalMonad way template
genUStore :: way -> UStoreTraversalMonad way template
genUStore way :: way
way =
  way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
forall way template.
UStoreTraversable way template =>
way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
traverseUStore way
way (() -> Const () template
forall k a (b :: k). a -> Const a b
Const ())

-- Implementation
----------------------------------------------------------------------------

-- | Generic traversal of UStore template.
class GUStoreTraversable (way :: Kind.Type) (x :: Kind.Type -> Kind.Type) where
  gTraverseUStore
    :: (UStoreTraversalWay way)
    => way
    -> UStoreTraversalArgumentWrapper way (x p)
    -> UStoreTraversalMonad way (x p)

instance GUStoreTraversable way x =>
         GUStoreTraversable way (G.D1 i x) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way (D1 i x p)
-> UStoreTraversalMonad way (D1 i x p)
gTraverseUStore way :: way
way x :: UStoreTraversalArgumentWrapper way (D1 i x p)
x =
    x p -> D1 i x p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (x p -> D1 i x p)
-> UStoreTraversalMonad way (x p)
-> UStoreTraversalMonad way (D1 i x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
forall way (x :: * -> *) p.
(GUStoreTraversable way x, UStoreTraversalWay way) =>
way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
gTraverseUStore way
way (D1 i x p -> x p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1 (D1 i x p -> x p)
-> UStoreTraversalArgumentWrapper way (D1 i x p)
-> UStoreTraversalArgumentWrapper way (x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UStoreTraversalArgumentWrapper way (D1 i x p)
x)

instance GUStoreTraversable way x =>
         GUStoreTraversable way (G.C1 i x) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way (C1 i x p)
-> UStoreTraversalMonad way (C1 i x p)
gTraverseUStore way :: way
way x :: UStoreTraversalArgumentWrapper way (C1 i x p)
x =
    x p -> C1 i x p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (x p -> C1 i x p)
-> UStoreTraversalMonad way (x p)
-> UStoreTraversalMonad way (C1 i x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
forall way (x :: * -> *) p.
(GUStoreTraversable way x, UStoreTraversalWay way) =>
way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
gTraverseUStore way
way (C1 i x p -> x p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1 (C1 i x p -> x p)
-> UStoreTraversalArgumentWrapper way (C1 i x p)
-> UStoreTraversalArgumentWrapper way (x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UStoreTraversalArgumentWrapper way (C1 i x p)
x)

instance TypeError ('Text "Unexpected sum type in UStore template") =>
         GUStoreTraversable way (x :+: y) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way ((:+:) x y p)
-> UStoreTraversalMonad way ((:+:) x y p)
gTraverseUStore _ = Text
-> UStoreTraversalArgumentWrapper way ((:+:) x y p)
-> UStoreTraversalMonad way ((:+:) x y p)
forall a. HasCallStack => Text -> a
error "imposible"

instance TypeError ('Text "Unexpected void-like type in UStore template") =>
         GUStoreTraversable way G.V1 where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way (V1 p)
-> UStoreTraversalMonad way (V1 p)
gTraverseUStore _ = Text
-> UStoreTraversalArgumentWrapper way (V1 p)
-> UStoreTraversalMonad way (V1 p)
forall a. HasCallStack => Text -> a
error "impossible"

instance ( GUStoreTraversable way x
         , GUStoreTraversable way y
         ) =>
         GUStoreTraversable way (x :*: y) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way ((:*:) x y p)
-> UStoreTraversalMonad way ((:*:) x y p)
gTraverseUStore way :: way
way a :: UStoreTraversalArgumentWrapper way ((:*:) x y p)
a =
    x p -> y p -> (:*:) x y p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (x p -> y p -> (:*:) x y p)
-> UStoreTraversalMonad way (x p)
-> UStoreTraversalMonad way (y p -> (:*:) x y p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
forall way (x :: * -> *) p.
(GUStoreTraversable way x, UStoreTraversalWay way) =>
way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
gTraverseUStore way
way (UStoreTraversalArgumentWrapper way ((:*:) x y p)
a UStoreTraversalArgumentWrapper way ((:*:) x y p)
-> ((:*:) x y p -> x p) -> UStoreTraversalArgumentWrapper way (x p)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(x :: x p
x :*: _) -> x p
x)
          UStoreTraversalMonad way (y p -> (:*:) x y p)
-> UStoreTraversalMonad way (y p)
-> UStoreTraversalMonad way ((:*:) x y p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> way
-> UStoreTraversalArgumentWrapper way (y p)
-> UStoreTraversalMonad way (y p)
forall way (x :: * -> *) p.
(GUStoreTraversable way x, UStoreTraversalWay way) =>
way
-> UStoreTraversalArgumentWrapper way (x p)
-> UStoreTraversalMonad way (x p)
gTraverseUStore way
way (UStoreTraversalArgumentWrapper way ((:*:) x y p)
a UStoreTraversalArgumentWrapper way ((:*:) x y p)
-> ((:*:) x y p -> y p) -> UStoreTraversalArgumentWrapper way (y p)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(_ :*: y :: y p
y) -> y p
y)

instance GUStoreTraversable way G.U1 where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way (U1 p)
-> UStoreTraversalMonad way (U1 p)
gTraverseUStore _ _ = U1 p -> UStoreTraversalMonad way (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
G.U1

instance {-# OVERLAPPABLE #-}
         UStoreTraversable way template =>
         GUStoreTraversable way (G.S1 i (G.Rec0 template)) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper way (S1 i (Rec0 template) p)
-> UStoreTraversalMonad way (S1 i (Rec0 template) p)
gTraverseUStore way :: way
way sub :: UStoreTraversalArgumentWrapper way (S1 i (Rec0 template) p)
sub =
    K1 R template p -> S1 i (Rec0 template) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 R template p -> S1 i (Rec0 template) p)
-> (template -> K1 R template p)
-> template
-> S1 i (Rec0 template) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. template -> K1 R template p
forall k i c (p :: k). c -> K1 i c p
G.K1 (template -> S1 i (Rec0 template) p)
-> UStoreTraversalMonad way template
-> UStoreTraversalMonad way (S1 i (Rec0 template) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
forall way template.
UStoreTraversable way template =>
way
-> UStoreTraversalArgumentWrapper way template
-> UStoreTraversalMonad way template
traverseUStore way
way (K1 R template p -> template
forall i c k (p :: k). K1 i c p -> c
G.unK1 (K1 R template p -> template)
-> (S1 i (Rec0 template) p -> K1 R template p)
-> S1 i (Rec0 template) p
-> template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 i (Rec0 template) p -> K1 R template p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1 (S1 i (Rec0 template) p -> template)
-> UStoreTraversalArgumentWrapper way (S1 i (Rec0 template) p)
-> UStoreTraversalArgumentWrapper way template
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UStoreTraversalArgumentWrapper way (S1 i (Rec0 template) p)
sub)

instance ( UStoreTraversalFieldHandler way marker v, KnownUStoreMarker marker
         , KnownSymbol ctor
         ) =>
         GUStoreTraversable
           way
           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (UStoreFieldExt marker v))) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper
     way
     (S1
        ('MetaSel ('Just ctor) _1 _2 _3)
        (Rec0 (UStoreFieldExt marker v))
        p)
-> UStoreTraversalMonad
     way
     (S1
        ('MetaSel ('Just ctor) _1 _2 _3)
        (Rec0 (UStoreFieldExt marker v))
        p)
gTraverseUStore way :: way
way entry :: UStoreTraversalArgumentWrapper
  way
  (S1
     ('MetaSel ('Just ctor) _1 _2 _3)
     (Rec0 (UStoreFieldExt marker v))
     p)
entry =
    K1 R (UStoreFieldExt marker v) p
-> S1
     ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (UStoreFieldExt marker v)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 R (UStoreFieldExt marker v) p
 -> S1
      ('MetaSel ('Just ctor) _1 _2 _3)
      (Rec0 (UStoreFieldExt marker v))
      p)
-> (v -> K1 R (UStoreFieldExt marker v) p)
-> v
-> S1
     ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (UStoreFieldExt marker v)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreFieldExt marker v -> K1 R (UStoreFieldExt marker v) p
forall k i c (p :: k). c -> K1 i c p
G.K1 (UStoreFieldExt marker v -> K1 R (UStoreFieldExt marker v) p)
-> (v -> UStoreFieldExt marker v)
-> v
-> K1 R (UStoreFieldExt marker v) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> UStoreFieldExt marker v
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField (v
 -> S1
      ('MetaSel ('Just ctor) _1 _2 _3)
      (Rec0 (UStoreFieldExt marker v))
      p)
-> UStoreTraversalMonad way v
-> UStoreTraversalMonad
     way
     (S1
        ('MetaSel ('Just ctor) _1 _2 _3)
        (Rec0 (UStoreFieldExt marker v))
        p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      way
-> Label ctor
-> UStoreTraversalArgumentWrapper way v
-> UStoreTraversalMonad way v
forall way (marker :: UStoreMarkerType) v (name :: Symbol).
(UStoreTraversalFieldHandler way marker v,
 KnownUStoreMarker marker) =>
way
-> Label name
-> UStoreTraversalArgumentWrapper way v
-> UStoreTraversalMonad way v
ustoreTraversalFieldHandler
        @_
        @marker
        way
way
        (KnownSymbol ctor => Label ctor
forall (name :: Symbol). KnownSymbol name => Label name
Label @ctor)
        (UStoreTraversalArgumentWrapper
  way
  (S1
     ('MetaSel ('Just ctor) _1 _2 _3)
     (Rec0 (UStoreFieldExt marker v))
     p)
entry UStoreTraversalArgumentWrapper
  way
  (S1
     ('MetaSel ('Just ctor) _1 _2 _3)
     (Rec0 (UStoreFieldExt marker v))
     p)
-> (S1
      ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (UStoreFieldExt marker v)) p
    -> v)
-> UStoreTraversalArgumentWrapper way v
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(G.M1 (G.K1 (UStoreField v :: v
v))) -> v
v)

instance (UStoreTraversalSubmapHandler way k v, KnownSymbol ctor) =>
         GUStoreTraversable
           way
           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (k |~> v))) where
  gTraverseUStore :: way
-> UStoreTraversalArgumentWrapper
     way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
-> UStoreTraversalMonad
     way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
gTraverseUStore way :: way
way entry :: UStoreTraversalArgumentWrapper
  way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
entry =
    K1 R (k |~> v) p
-> S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 R (k |~> v) p
 -> S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
-> (Map k v -> K1 R (k |~> v) p)
-> Map k v
-> S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k |~> v) -> K1 R (k |~> v) p
forall k i c (p :: k). c -> K1 i c p
G.K1 ((k |~> v) -> K1 R (k |~> v) p)
-> (Map k v -> k |~> v) -> Map k v -> K1 R (k |~> v) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> k |~> v
forall k v. Map k v -> k |~> v
UStoreSubMap (Map k v -> S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
-> UStoreTraversalMonad way (Map k v)
-> UStoreTraversalMonad
     way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      way
-> Label ctor
-> UStoreTraversalArgumentWrapper way (Map k v)
-> UStoreTraversalMonad way (Map k v)
forall way k v (name :: Symbol).
UStoreTraversalSubmapHandler way k v =>
way
-> Label name
-> UStoreTraversalArgumentWrapper way (Map k v)
-> UStoreTraversalMonad way (Map k v)
ustoreTraversalSubmapHandler
        way
way
        (KnownSymbol ctor => Label ctor
forall (name :: Symbol). KnownSymbol name => Label name
Label @ctor)
        (UStoreTraversalArgumentWrapper
  way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
entry UStoreTraversalArgumentWrapper
  way (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p)
-> (S1 ('MetaSel ('Just ctor) _1 _2 _3) (Rec0 (k |~> v)) p
    -> Map k v)
-> UStoreTraversalArgumentWrapper way (Map k v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(G.M1 (G.K1 (UStoreSubMap m :: Map k v
m))) -> Map k v
m)