{-# LANGUAGE NoImplicitPrelude #-}

{-|
Module      : Headroom.Data.Lens
Description : Custom functionality related to /lens/
Copyright   : (c) 2019-2021 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Provides customized versions of /lens/ functions.
-}

module Headroom.Data.Lens
  ( suffixLenses
  , suffixLensesFor
  )
where

import qualified Language.Haskell.TH.Lib            as TH
import qualified Language.Haskell.TH.Syntax         as TH
import           Lens.Micro.TH                       ( DefName(..)
                                                     , lensField
                                                     , lensRules
                                                     , lensRulesFor
                                                     , makeLensesWith
                                                     )
import           RIO


-- | A template haskell function to build lenses for a record type. This
-- function differs from the 'Control.Lens.makeLenses' function in that
-- it does not require the record fields to be prefixed with underscores
-- and it adds an "L" suffix to lens names to make it clear that they
-- are lenses.
suffixLenses :: TH.Name -> TH.DecsQ
suffixLenses :: Name -> DecsQ
suffixLenses = LensRules -> Name -> DecsQ
makeLensesWith (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
 -> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
  -> Identity (Name -> [Name] -> Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Name -> [Name] -> Name -> [DefName]
forall p p. p -> p -> Name -> [DefName]
withSuffix
  where withSuffix :: p -> p -> Name -> [DefName]
withSuffix p
_ p
_ Name
name = [Name -> DefName
TopName (Name -> DefName) -> (String -> Name) -> String -> DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
TH.mkName (String -> DefName) -> String -> DefName
forall a b. (a -> b) -> a -> b
$ (Name -> String
TH.nameBase Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"L")]


-- | Same as 'suffixLensesFor', but build lenses only for selected fields.
suffixLensesFor :: [String] -> TH.Name -> TH.DecsQ
suffixLensesFor :: [String] -> Name -> DecsQ
suffixLensesFor [String]
fields = LensRules -> Name -> DecsQ
makeLensesWith (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields'
  where fields' :: [(String, String)]
fields' = (String -> (String, String)) -> [String] -> [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
f -> (String
f, String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"L")) [String]
fields