-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Lens generation utilities.
module Swarm.Util.Lens (
  makeLensesNoSigs,
  makeLensesExcluding,
  inherit,
  concatFold,
) where

import Control.Lens (
  Fold,
  Lens',
  folding,
  generateSignatures,
  lensField,
  lensRules,
  makeLensesWith,
  mapped,
  (%~),
  (&),
  (.~),
  (^.),
  (^..),
 )
import Language.Haskell.TH (DecsQ)
import Language.Haskell.TH.Syntax (Name)

-- | Generate lenses but with no type signatures, so we can explicitly
--   give type signatures and attach custom Haddock documentation to
--   them.
makeLensesNoSigs :: Name -> DecsQ
makeLensesNoSigs :: Name -> DecsQ
makeLensesNoSigs = LensRules -> Name -> DecsQ
makeLensesWith (LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> LensRules -> Identity LensRules
Lens' LensRules Bool
generateSignatures ((Bool -> Identity Bool) -> LensRules -> Identity LensRules)
-> Bool -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False)

-- | Generate lenses for the fields of a record type (with no type
--   signatures), except for a given list of excluded fields.
--
--   Especially useful in conjunction with the design pattern
--   described in
--   https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/
makeLensesExcluding :: [Name] -> Name -> DecsQ
makeLensesExcluding :: [Name] -> Name -> DecsQ
makeLensesExcluding [Name]
exclude =
  LensRules -> Name -> DecsQ
makeLensesWith
    ( LensRules
lensRules
        LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> LensRules -> Identity LensRules
Lens' LensRules Bool
generateSignatures ((Bool -> Identity Bool) -> LensRules -> Identity LensRules)
-> Bool -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
        LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> (((Name -> [DefName]) -> Identity (Name -> [DefName]))
    -> FieldNamer -> Identity FieldNamer)
-> ((Name -> [DefName]) -> Identity (Name -> [DefName]))
-> LensRules
-> Identity LensRules
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Name] -> Name -> [DefName])
 -> Identity ([Name] -> Name -> [DefName]))
-> FieldNamer -> Identity FieldNamer
Setter
  FieldNamer
  FieldNamer
  ([Name] -> Name -> [DefName])
  ([Name] -> Name -> [DefName])
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((([Name] -> Name -> [DefName])
  -> Identity ([Name] -> Name -> [DefName]))
 -> FieldNamer -> Identity FieldNamer)
-> (((Name -> [DefName]) -> Identity (Name -> [DefName]))
    -> ([Name] -> Name -> [DefName])
    -> Identity ([Name] -> Name -> [DefName]))
-> ((Name -> [DefName]) -> Identity (Name -> [DefName]))
-> FieldNamer
-> Identity FieldNamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> [DefName]) -> Identity (Name -> [DefName]))
-> ([Name] -> Name -> [DefName])
-> Identity ([Name] -> Name -> [DefName])
Setter
  ([Name] -> Name -> [DefName])
  ([Name] -> Name -> [DefName])
  (Name -> [DefName])
  (Name -> [DefName])
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name -> [DefName]) -> Identity (Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> ((Name -> [DefName]) -> Name -> [DefName])
-> LensRules
-> LensRules
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Name -> [DefName]
fn Name
n ->
          if Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
exclude then [] else Name -> [DefName]
fn Name
n
    )

-- | Copy a given field from one record to another.
inherit :: Lens' s a -> s -> (s -> s)
inherit :: forall s a. Lens' s a -> s -> s -> s
inherit Lens' s a
field s
parent s
child = s
child s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> s -> Identity s
Lens' s a
field ((a -> Identity a) -> s -> Identity s) -> a -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (s
parent s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
Lens' s a
field)

-- | Concatenate two folds into a single fold which encompasses all
--   elements from both.
concatFold :: Fold s a -> Fold s a -> Fold s a
concatFold :: forall s a. Fold s a -> Fold s a -> Fold s a
concatFold Fold s a
f1 Fold s a
f2 = (s -> [a]) -> Fold s a
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding (\s
s -> (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
Fold s a
f1) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
Fold s a
f2))