module Optics.TH
  (
  -- * Generation of field optics
  -- ** Labels
    makeFieldLabels
  , makeFieldLabelsNoPrefix
  , makeFieldLabelsFor
  , makeFieldLabelsWith
  , declareFieldLabels
  , declareFieldLabelsFor
  , declareFieldLabelsWith
  , fieldLabelsRules
  , fieldLabelsRulesFor
  -- ** Functions
  , makeLenses
  , makeLensesFor
  , makeLensesWith
  , declareLenses
  , declareLensesFor
  , declareLensesWith
  , lensRules
  , lensRulesFor
  -- ** Single class per data type
  -- $deprecatedClassy
  , makeClassy
  , makeClassy_
  , makeClassyFor
  , declareClassy
  , declareClassyFor
  , classyRules
  , classyRules_
  , classyRulesFor
  -- ** Multiple classes per data type
  -- $deprecatedFields
  , makeFields
  , makeFieldsNoPrefix
  , declareFields
  , defaultFieldRules
  -- * Generation of constructor optics
  -- ** Labels
  , makePrismLabels
  -- ** Functions
  , makePrisms
  , declarePrisms
  -- ** Single class per data type
  , makeClassyPrisms
  -- * Generation rules for field optics
  , LensRules
  , simpleLenses
  , generateSignatures
  , generateUpdateableOptics
  , generateLazyPatterns
  , createClass
  , lensField
  , lensClass
  -- * Common rules
  , noPrefixFieldLabels
  , abbreviatedFieldLabels
  , underscoreFields
  , camelCaseFields
  , classUnderscoreNoPrefixFields
  , abbreviatedFields
  -- * Field namers
  , FieldNamer
  , ClassyNamer
  , DefName(..)
  , noPrefixNamer
  , underscoreNoPrefixNamer
  , lookingupNamer
  , mappingNamer
  , underscoreNamer
  , camelCaseNamer
  , classUnderscoreNoPrefixNamer
  , abbreviatedNamer
  ) where

import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.Char (toLower, toUpper, isUpper)
import Data.List as List
import Data.Maybe (maybeToList)
import Data.Monoid
import Data.Set (Set)
import Language.Haskell.TH.Syntax hiding (lift)
import Language.Haskell.TH
import qualified Data.Set as Set

import Optics.Core hiding (cons)
import Optics.TH.Internal.Product
import Optics.TH.Internal.Sum

----------------------------------------
-- Labels

-- | Build field optics as instances of the 'LabelOptic' class for use with
-- overloaded labels.  See "Optics.Label" for how to use this pattern.
--
-- /e.g./
--
-- @
-- data Animal
--   = Cat { animalAge  :: Int
--         , animalName :: String
--         }
--   | Dog { animalAge    :: Int
--         , animalAbsurd :: forall a b. a -> b
--         }
-- makeFieldLabels ''Animal
-- @
--
-- will create
--
-- @
-- instance
--   (k ~ A_Lens, a ~ Int, b ~ Int
--   ) => LabelOptic "age" k Animal Animal a b where
--   labelOptic = lensVL $ \\f s -> case s of
--     Cat x1 x2 -> fmap (\\y -> Cat y x2) (f x1)
--     Dog x1 x2 -> fmap (\\y -> Dog y x2) (f x1)
--
-- instance
--   (k ~ An_AffineTraversal, a ~ String, b ~ String
--   ) => LabelOptic "name" k Animal Animal a b where
--   labelOptic = atraversalVL $ \\point f s -> case s of
--     Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2)
--     Dog x1 x2 -> point (Dog x1 x2)
--
-- instance
--   ( Dysfunctional "absurd" k Animal Animal a b
--   , k ~ An_AffineFold, a ~ (x -> y), b ~ (x -> y)
--   ) => LabelOptic "absurd" k Animal Animal a b where
--   labelOptic = afolding $ \\s -> case s of
--     Cat _ _  -> Nothing
--     Dog _ f  -> Just f
-- @
--
-- which can be used as @#age@, @#name@ and @#absurd@ with the
-- @OverloadedLabels@ language extension.
--
-- /Note:/ if you wonder about the structure of instances, see
-- "Optics.Label#structure".
--
-- @
-- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules'
-- @
makeFieldLabels :: Name -> DecsQ
makeFieldLabels :: Name -> DecsQ
makeFieldLabels = LensRules -> Name -> DecsQ
makeFieldLabelsWith LensRules
fieldLabelsRules

-- | An alias for @makeFieldLabels noPrefixFieldLabels@.
makeFieldLabelsNoPrefix :: Name -> DecsQ
makeFieldLabelsNoPrefix :: Name -> DecsQ
makeFieldLabelsNoPrefix = LensRules -> Name -> DecsQ
makeFieldLabelsWith LensRules
noPrefixFieldLabels

-- | Derive field optics as labels, specifying explicit pairings of @(fieldName,
-- labelName)@.
--
-- If you map multiple fields to the same label and it is present in the same
-- constructor, 'Traversal' (or 'Fold' for a read only version) will be
-- generated.
--
-- /e.g./
--
-- @
-- 'makeFieldLabelsFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
-- 'makeFieldLabelsFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
-- @
makeFieldLabelsFor :: [(String, String)] -> Name -> DecsQ
makeFieldLabelsFor :: [(String, String)] -> Name -> DecsQ
makeFieldLabelsFor [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldLabelsWith ([(String, String)] -> LensRules
fieldLabelsRulesFor [(String, String)]
fields)

-- | Make field optics as labels for all records in the given declaration
-- quote. All record syntax in the input will be stripped off.
--
-- /e.g./
--
-- @
-- declareLenses [d|
--   data Dog = Dog { name :: String, age :: Int }
--     deriving Show
--   |]
-- @
--
-- will create
--
-- @
-- data Dog = Dog String Int
--   deriving Show
-- instance (k ~ A_Lens, ...) => LabelOptic "name" k Dog Dog ...
-- instance (k ~ A_Lens, ...) => LabelOptic "age" k Dog Dog ...
-- @
declareFieldLabels :: DecsQ -> DecsQ
declareFieldLabels :: DecsQ -> DecsQ
declareFieldLabels
  = LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
fieldLabelsRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- | Similar to 'makeFieldLabelsFor', but takes a declaration quote.
declareFieldLabelsFor :: [(String, String)] -> DecsQ -> DecsQ
declareFieldLabelsFor :: [(String, String)] -> DecsQ -> DecsQ
declareFieldLabelsFor [(String, String)]
fields
  = LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
fieldLabelsRulesFor [(String, String)]
fields
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- Similar to 'makeFieldLabelsWith', but takes a declaration quote.
declareFieldLabelsWith :: LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith :: LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith LensRules
rules = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  [Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DecsQ -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall a. Q a -> Declare a
liftDeclare (LensRules -> Dec -> DecsQ
makeFieldLabelsForDec LensRules
rules Dec
dec)
  Dec -> Declare Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Declare Dec) -> Dec -> Declare Dec
forall a b. (a -> b) -> a -> b
$ Dec -> Dec
stripFields Dec
dec

-- | Rules for generation of 'LabelOptic' intances for use with
-- OverloadedLabels. Same as 'lensRules', but uses 'camelCaseNamer'.
--
-- /Note:/ if you don't want to prefix field names with the full name of the
-- data type, you can use 'abbreviatedNamer' instead.
fieldLabelsRules :: LensRules
fieldLabelsRules :: LensRules
fieldLabelsRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
False
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
False
  , _allowIsos :: Bool
_allowIsos       = Bool
True
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
camelCaseNamer
  }

-- | Construct a 'LensRules' value for generating 'LabelOptic' instances using
-- the given map from field names to definition names.
fieldLabelsRulesFor
  :: [(String, String)] {- ^ [(Field name, Label name)] -}
  -> LensRules
fieldLabelsRulesFor :: [(String, String)] -> LensRules
fieldLabelsRulesFor [(String, String)]
fields = LensRules
fieldLabelsRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields

----------------------------------------
-- Lenses

-- | Build field optics as top level functions with a sensible default
-- configuration.
--
-- /e.g./
--
-- @
-- data Animal
--   = Cat { _age  :: 'Int'
--         , _name :: 'String'
--         }
--   | Dog { _age    :: 'Int'
--         , _absurd :: forall a b. a -> b
--         }
-- 'makeLenses' ''Animal
-- @
--
-- will create
--
-- @
-- absurd :: forall a b. AffineFold Animal (a -> b)
-- absurd = afolding $ \\s -> case s of
--   Cat _ _ -> Nothing
--   Dog _ x -> Just x
--
-- age :: Lens' Animal Int
-- age = lensVL $ \\f s -> case s of
--   Cat x1 x2 -> fmap (\\y -> Cat y x2) (f x1)
--   Dog x1 x2 -> fmap (\\y -> Dog y x2) (f x1)
--
-- name :: AffineTraversal' Animal String
-- name = atraversalVL $ \\point f s -> case s of
--   Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2)
--   Dog x1 x2 -> point (Dog x1 x2)
-- @
--
-- @
-- 'makeLenses' = 'makeLensesWith' 'lensRules'
-- @
makeLenses :: Name -> DecsQ
makeLenses :: Name -> DecsQ
makeLenses = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
lensRules

-- | Derive field optics, specifying explicit pairings of @(fieldName,
-- opticName)@.
--
-- If you map multiple fields to the same optic and it is present in the same
-- constructor, 'Traversal' (or 'Fold' for a read only version) will be
-- generated.
--
-- /e.g./
--
-- @
-- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
-- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
-- @
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics ([(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields)

-- | Build field optics with a custom configuration.
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = LensRules -> Name -> DecsQ
makeFieldOptics

-- | Make field optics for all records in the given declaration quote. All
-- record syntax in the input will be stripped off.
--
-- /e.g./
--
-- @
-- declareLenses [d|
--   data Foo = Foo { fooX, fooY :: 'Int' }
--     deriving 'Show'
--   |]
-- @
--
-- will create
--
-- @
-- data Foo = Foo 'Int' 'Int' deriving 'Show'
-- fooX, fooY :: 'Lens'' Foo Int
-- @
declareLenses :: DecsQ -> DecsQ
declareLenses :: DecsQ -> DecsQ
declareLenses
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
lensRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- | Similar to 'makeLensesFor', but takes a declaration quote.
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor [(String, String)]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- | 'declareLenses' with custom 'LensRules'.
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
rules = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  [Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Set Name) Q [Dec]
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules Dec
dec)
  Dec -> Declare Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Declare Dec) -> Dec -> Declare Dec
forall a b. (a -> b) -> a -> b
$ Dec -> Dec
stripFields Dec
dec

-- | Rules for making read-write field optics as top-level functions. It uses
-- 'underscoreNoPrefixNamer'.
lensRules :: LensRules
lensRules :: LensRules
lensRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
False
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
False
  , _allowIsos :: Bool
_allowIsos       = Bool
True
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
underscoreNoPrefixNamer
  }

-- | Construct a 'LensRules' value for generating top-level functions using the
-- given map from field names to definition names.
lensRulesFor
  :: [(String, String)] {- ^ [(Field name, Optic name)] -}
  -> LensRules
lensRulesFor :: [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields = LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields

----------------------------------------
-- Classy

-- $deprecatedClassy
--
-- This method of optics generation should only be used when migrating an
-- existing codebase from the @lens@ library to @optics@ as it:
--
-- - Doesn't support prefixless fields.
--
-- - Doesn't support type changing updates.
--
-- See "Optics.Label" for our recommended pattern.

-- | Make lenses and traversals for a type, and create a class when the type has
-- no arguments.
--
-- /e.g./
--
-- @
-- data Foo = Foo { _fooX, _fooY :: 'Int' }
-- 'makeClassy' ''Foo
-- @
--
-- will create
--
-- @
-- class HasFoo c where
--   foo  :: Lens' c Foo
--   fooX :: Lens' c Int
--   fooY :: Lens' c Int
--   fooX = foo % fooX
--   fooY = foo % fooY
--
-- instance HasFoo Foo where
--   foo  = lensVL id
--   fooX = lensVL $ \\f s -> case s of
--     Foo x1 x2 -> fmap (\\y -> Foo y x2) (f x1)
--   fooY = lensVL $ \\f s -> case s of
--     Foo x1 x2 -> fmap (\\y -> Foo x1 y) (f x2)
-- @
--
-- @
-- 'makeClassy' = 'makeLensesWith' 'classyRules'
-- @
makeClassy :: Name -> DecsQ
makeClassy :: Name -> DecsQ
makeClassy = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules

-- | Make lenses and traversals for a type, and create a class when the type has
-- no arguments. Works the same as 'makeClassy' except that (a) it expects that
-- record field names do not begin with an underscore, (b) all record fields are
-- made into lenses, and (c) the resulting lens is prefixed with an underscore.
makeClassy_ :: Name -> DecsQ
makeClassy_ :: Name -> DecsQ
makeClassy_ = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules_

-- | Derive lenses and traversals, using a named wrapper class, and
-- specifying explicit pairings of @(fieldName, traversalName)@.
--
-- Example usage:
--
-- @
-- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo
-- @
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor String
clsName String
funName [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$
  (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (Maybe (String, String) -> String -> Maybe (String, String)
forall a b. a -> b -> a
const ((String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
clsName, String
funName))) [(String, String)]
fields

-- | For each record in the declaration quote, make lenses and traversals for
-- it, and create a class when the type has no arguments. All record syntax
-- in the input will be stripped off.
--
-- /e.g./
--
-- @
-- declareClassy [d|
--   data Foo = Foo { fooX, fooY :: 'Int' }
--     deriving 'Show'
--   |]
-- @
--
-- will create
--
-- @
-- data Foo = Foo 'Int' 'Int' deriving 'Show'
-- class HasFoo t where
--   foo :: 'Lens'' t Foo
-- instance HasFoo Foo where foo = 'id'
-- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'
-- @
declareClassy :: DecsQ -> DecsQ
declareClassy :: DecsQ -> DecsQ
declareClassy
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- | Similar to 'makeClassyFor', but takes a declaration quote.
declareClassyFor ::
  [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor :: [(String, (String, String))]
-> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor [(String, (String, String))]
classes [(String, String)]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (String -> [(String, (String, String))] -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup`[(String, (String, String))]
classes) [(String, String)]
fields
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
noPrefixNamer

-- | Rules for making lenses and traversals that precompose another 'Lens'.
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
True
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
True
  , _allowIsos :: Bool
_allowIsos       = Bool
False -- generating Isos would hinder "subtyping"
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = \Name
n ->
        case Name -> String
nameBase Name
n of
          Char
x:String
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (String -> Name
mkName (String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs), String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))
          []   -> Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
underscoreNoPrefixNamer
  }

-- | A 'LensRules' used by 'makeClassy_'.
classyRules_ :: LensRules
classyRules_ :: LensRules
classyRules_
  = LensRules
classyRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName (String -> Name
mkName (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
n))]

-- | Rules for making lenses and traversals that precompose another 'Lens' using
-- a custom function for naming the class, main class method, and a mapping from
-- field names to definition names.
classyRulesFor
  :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} ->
  [(String, String)] {- ^ [(Field Name, Method Name)] -} ->
  LensRules
classyRulesFor :: (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor String -> Maybe (String, String)
classFun [(String, String)]
fields = LensRules
classyRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules ClassyNamer
lensClass Lens' LensRules ClassyNamer
-> ClassyNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Optic
  A_Setter
  '[Int]
  (Maybe (String, String))
  (Maybe (Name, Name))
  String
  Name
-> (String -> Name) -> Maybe (String, String) -> Maybe (Name, Name)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over (Setter
  (Maybe (String, String))
  (Maybe (Name, Name))
  (String, String)
  (Name, Name)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped Setter
  (Maybe (String, String))
  (Maybe (Name, Name))
  (String, String)
  (Name, Name)
-> Optic
     A_Traversal '[Int] (String, String) (Name, Name) String Name
-> Optic
     A_Setter
     '[Int]
     (Maybe (String, String))
     (Maybe (Name, Name))
     String
     Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal '[Int] (String, String) (Name, Name) String Name
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each) String -> Name
mkName (Maybe (String, String) -> Maybe (Name, Name))
-> (Name -> Maybe (String, String)) -> ClassyNamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, String)
classFun (String -> Maybe (String, String))
-> (Name -> String) -> Name -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields

----------------------------------------
-- Fields

-- $deprecatedFields
--
-- This method of optics generation should only be used when migrating an
-- existing codebase from the @lens@ library to @optics@ as it:
--
-- - Doesn't support type changing updates.
--
-- - Introduces tight coupling between types in your application as either all
--   types need to be put in a single module (for @HasX@ class generation to
--   work properly) or there needs to be a single, written by hand module with
--   all the @HasX@ classes the application will use. Both approaches don't
--   scale.
--
-- - Can't be leveraged by libraries because of the above problem lifted to the
--   library level: there would have to exist a library with all possible @HasX@
--   classes written by hand that is imported by all the other
--   libraries. Otherwise for a given @field@ independent libraries would
--   provide multiple @HasField@ classes incompatible with each other.
--
-- See "Optics.Label" for our recommended pattern.

-- | Generate overloaded field accessors.
--
-- /e.g/
--
-- @
-- data Foo a = Foo { _fooX :: 'Int', _fooY :: a }
-- newtype Bar = Bar { _barX :: 'Char' }
-- makeFields ''Foo
-- makeFields ''Bar
-- @
--
-- will create
--
-- @
-- class HasX s a | s -> a where
--   x :: Lens' s a
--
-- instance HasX (Foo a) Int where
--   x = lensVL $ \\f s -> case s of
--     Foo x1 x2 -> fmap (\\y -> Foo y x2) (f x1)
--
-- class HasY s a | s -> a where
--   y :: Lens' s a
--
-- instance HasY (Foo a) a where
--   y = lensVL $ \\f s -> case s of
--     Foo x1 x2 -> fmap (\\y -> Foo x1 y) (f x2)
--
-- instance HasX Bar Char where
--   x = lensVL $ \\f s -> case s of
--     Bar x1 -> fmap (\\y -> Bar y) (f x1)
-- @
--
-- For details, see 'camelCaseFields'.
--
-- @
-- makeFields = 'makeLensesWith' 'defaultFieldRules'
-- @
makeFields :: Name -> DecsQ
makeFields :: Name -> DecsQ
makeFields = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
camelCaseFields

-- | Generate overloaded field accessors based on field names which
-- are only prefixed with an underscore (e.g. '_name'), not
-- additionally with the type name (e.g. '_fooName').
--
-- This might be the desired behaviour in case the
-- @DuplicateRecordFields@ language extension is used in order to get
-- rid of the necessity to prefix each field name with the type name.
--
-- As an example:
--
-- @
-- data Foo a  = Foo { _x :: 'Int', _y :: a }
-- newtype Bar = Bar { _x :: 'Char' }
-- makeFieldsNoPrefix ''Foo
-- makeFieldsNoPrefix ''Bar
-- @
--
-- will create classes
--
-- @
-- class HasX s a | s -> a where
--   x :: Lens' s a
-- class HasY s a | s -> a where
--   y :: Lens' s a
-- @
--
-- together with instances
--
-- @
-- instance HasX (Foo a) Int
-- instance HasY (Foo a) a where
-- instance HasX Bar Char where
-- @
--
-- For details, see 'classUnderscoreNoPrefixFields'.
--
-- @
-- makeFieldsNoPrefix = 'makeLensesWith' 'classUnderscoreNoPrefixFields'
-- @
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classUnderscoreNoPrefixFields

-- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @
declareFields :: DecsQ -> DecsQ
declareFields :: DecsQ -> DecsQ
declareFields = LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
defaultFieldRules

defaultFieldRules :: LensRules
defaultFieldRules :: LensRules
defaultFieldRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
True
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
True  -- classes will still be skipped if they already exist
  , _allowIsos :: Bool
_allowIsos       = Bool
False -- generating Isos would hinder field class reuse
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: ClassyNamer
_classyLenses    = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: FieldNamer
_fieldToDef      = FieldNamer
camelCaseNamer
  }

----------------------------------------
-- Prisms

-- | Generate a 'Control.Lens.Type.Prism' for each constructor of each data type.
--
-- /e.g./
--
-- @
-- declarePrisms [d|
--   data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }
--   |]
-- @
--
-- will create
--
-- @
-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }
-- _Lit :: 'Prism'' Exp Int
-- _Var :: 'Prism'' Exp String
-- _Lambda :: 'Prism'' Exp (String, Exp)
-- @
declarePrisms :: DecsQ -> DecsQ
declarePrisms :: DecsQ -> DecsQ
declarePrisms = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
  [Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DecsQ -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall a. Q a -> Declare a
liftDeclare (Bool -> Dec -> DecsQ
makeDecPrisms Bool
True Dec
dec)
  Dec -> Declare Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec

----------------------------------------
-- Customization of rules

-- | Generate "simple" optics even when type-changing optics are possible.
-- (e.g. 'Lens'' instead of 'Lens')
simpleLenses :: Lens' LensRules Bool
simpleLenses :: Lens' LensRules Bool
simpleLenses = LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool)
-> LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> f Bool
f LensRules
r ->
  (Bool -> LensRules) -> f Bool -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _simpleLenses :: Bool
_simpleLenses = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_simpleLenses LensRules
r))

-- | Indicate whether or not to supply the signatures for the generated lenses.
--
-- Disabling this can be useful if you want to provide a more restricted type
-- signature or if you want to supply hand-written haddocks.
generateSignatures :: Lens' LensRules Bool
generateSignatures :: Lens' LensRules Bool
generateSignatures = LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool)
-> LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> f Bool
f LensRules
r ->
  (Bool -> LensRules) -> f Bool -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateSigs :: Bool
_generateSigs = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_generateSigs LensRules
r))

-- | Generate "updateable" optics when 'True'. When 'False', (affine) folds will
-- be generated instead of (affine) traversals and getters will be generated
-- instead of lenses. This mode is intended to be used for types with invariants
-- which must be maintained by "smart" constructors.
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics = LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool)
-> LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> f Bool
f LensRules
r ->
  (Bool -> LensRules) -> f Bool -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _allowUpdates :: Bool
_allowUpdates = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_allowUpdates LensRules
r))

-- | Generate optics using lazy pattern matches. This can
-- allow fields of an undefined value to be initialized with lenses:
--
-- @
-- data Foo = Foo {_x :: Int, _y :: Bool}
--   deriving Show
--
-- 'makeLensesWith' ('lensRules' & 'generateLazyPatterns' .~ True) ''Foo
-- @
--
-- @
-- > undefined & x .~ 8 & y .~ True
-- Foo {_x = 8, _y = True}
-- @
--
-- The downside of this flag is that it can lead to space-leaks and
-- code-size/compile-time increases when generated for large records. By default
-- this flag is turned off, and strict optics are generated.
--
-- When using lazy optics the strict optic can be recovered by composing with
-- 'equality'':
--
-- @
-- strictOptic = equality' % lazyOptic
-- @
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns = LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool)
-> LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> f Bool
f LensRules
r ->
  (Bool -> LensRules) -> f Bool -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _lazyPatterns :: Bool
_lazyPatterns = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_lazyPatterns LensRules
r))

-- | Create the class if the constructor if generated lenses would be
-- type-preserving and the 'lensClass' rule matches.
createClass :: Lens' LensRules Bool
createClass :: Lens' LensRules Bool
createClass = LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool)
-> LensVL LensRules LensRules Bool Bool -> Lens' LensRules Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> f Bool
f LensRules
r ->
  (Bool -> LensRules) -> f Bool -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateClasses :: Bool
_generateClasses = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_generateClasses LensRules
r))

-- | 'Lens'' to access the convention for naming fields in our 'LensRules'.
lensField :: Lens' LensRules FieldNamer
lensField :: Lens' LensRules FieldNamer
lensField = LensVL LensRules LensRules FieldNamer FieldNamer
-> Lens' LensRules FieldNamer
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules FieldNamer FieldNamer
 -> Lens' LensRules FieldNamer)
-> LensVL LensRules LensRules FieldNamer FieldNamer
-> Lens' LensRules FieldNamer
forall a b. (a -> b) -> a -> b
$ \FieldNamer -> f FieldNamer
f LensRules
r ->
  (FieldNamer -> LensRules) -> f FieldNamer -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNamer
x -> LensRules
r { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
x}) (FieldNamer -> f FieldNamer
f (LensRules -> FieldNamer
_fieldToDef LensRules
r))

-- | 'Lens'' to access the option for naming "classy" lenses.
lensClass :: Lens' LensRules ClassyNamer
lensClass :: Lens' LensRules ClassyNamer
lensClass = LensVL LensRules LensRules ClassyNamer ClassyNamer
-> Lens' LensRules ClassyNamer
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LensRules LensRules ClassyNamer ClassyNamer
 -> Lens' LensRules ClassyNamer)
-> LensVL LensRules LensRules ClassyNamer ClassyNamer
-> Lens' LensRules ClassyNamer
forall a b. (a -> b) -> a -> b
$ \ClassyNamer -> f ClassyNamer
f LensRules
r ->
  (ClassyNamer -> LensRules) -> f ClassyNamer -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ClassyNamer
x -> LensRules
r { _classyLenses :: ClassyNamer
_classyLenses = ClassyNamer
x }) (ClassyNamer -> f ClassyNamer
f (LensRules -> ClassyNamer
_classyLenses LensRules
r))

----------------------------------------
-- Common sets of rules

-- | Field rules for fields without any prefix. Useful for generation of field
-- labels when paired with @DuplicateRecordFields@ language extension so that no
-- prefixes for field names are necessary.
--
-- @since 0.2
noPrefixFieldLabels :: LensRules
noPrefixFieldLabels :: LensRules
noPrefixFieldLabels = LensRules
fieldLabelsRules { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
noPrefixNamer }

abbreviatedFieldLabels :: LensRules
abbreviatedFieldLabels :: LensRules
abbreviatedFieldLabels = LensRules
fieldLabelsRules { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
abbreviatedNamer }

-- | Field rules for fields in the form @ _prefix_fieldname @
underscoreFields :: LensRules
underscoreFields :: LensRules
underscoreFields = LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
underscoreNamer

-- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @
--
-- If you want all fields to be lensed, then there is no reason to use an @_@
-- before the prefix.  If any of the record fields leads with an @_@ then it is
-- assume a field without an @_@ should not have a lens created.
--
-- __Note__: The @prefix@ must be the same as the typename (with the first
-- letter lowercased). This is a change from lens versions before lens 4.5. If
-- you want the old behaviour, use 'makeLensesWith' 'abbreviatedFields'
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules

-- | Field rules for fields in the form @ _fieldname @ (the leading
-- underscore is mandatory).
--
-- __Note__: The primary difference to 'camelCaseFields' is that for
-- @classUnderscoreNoPrefixFields@ the field names are not expected to
-- be prefixed with the type name. This might be the desired behaviour
-- when the @DuplicateRecordFields@ extension is enabled.
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields =
  LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField Lens' LensRules FieldNamer -> FieldNamer -> LensRules -> LensRules
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FieldNamer
classUnderscoreNoPrefixNamer

-- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @
-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.
-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.
--
-- Note that @prefix@ may be any string of characters that are not uppercase
-- letters. (In particular, it may be arbitrary string of lowercase letters
-- and numbers) This is the behavior that 'defaultFieldRules' had in lens
-- 4.4 and earlier.
abbreviatedFields :: LensRules
abbreviatedFields :: LensRules
abbreviatedFields = LensRules
defaultFieldRules { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
abbreviatedNamer }

----------------------------------------
-- Namers

-- | A 'FieldNamer' that leaves the field name as-is. Useful for generation of
-- field labels when paired with @DuplicateRecordFields@ language extension so
-- that no prefixes for field names are necessary.
--
-- @since 0.2
noPrefixNamer :: FieldNamer
noPrefixNamer :: FieldNamer
noPrefixNamer Name
_ [Name]
_ Name
n = [Name -> DefName
TopName Name
n]

-- | A 'FieldNamer' that strips the _ off of the field name, lowercases the
-- name, and skips the field if it doesn't start with an '_'.
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer Name
_ [Name]
_ Name
n =
  case Name -> String
nameBase Name
n of
    Char
'_':Char
x:String
xs -> [Name -> DefName
TopName (String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))]
    String
_        -> []


-- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer :: [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
kvs Name
_ [Name]
_ Name
field =
  [ Name -> DefName
TopName (String -> Name
mkName String
v) | (String
k,String
v) <- [(String, String)]
kvs, String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
field]

-- | Create a 'FieldNamer' from a mapping function. If the function returns
-- @[]@, it creates no lens for the field.
mappingNamer :: (String -> [String]) -- ^ A function that maps a @fieldName@ to
                                     -- @lensName@s.
             -> FieldNamer
mappingNamer :: (String -> [String]) -> FieldNamer
mappingNamer String -> [String]
mapper Name
_ [Name]
_ = (String -> DefName) -> [String] -> [DefName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DefName
TopName (Name -> DefName) -> (String -> Name) -> String -> DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [DefName]) -> (Name -> [String]) -> Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
mapper (String -> [String]) -> (Name -> String) -> Name -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | A 'FieldNamer' for 'underscoreFields'.
underscoreNamer :: FieldNamer
underscoreNamer :: FieldNamer
underscoreNamer Name
_ [Name]
_ Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
  String
_      <- String -> Maybe String
prefix String
field'
  String
method <- Maybe String
niceLens
  String
cls    <- Maybe String
classNaming
  DefName -> Maybe DefName
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))
  where
    field' :: String
field' = Name -> String
nameBase Name
field
    prefix :: String -> Maybe String
prefix (Char
'_':String
xs) | Char
'_' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` String
xs = String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
xs)
    prefix String
_                             = Maybe String
forall a. Maybe a
Nothing
    niceLens :: Maybe String
niceLens    = String -> Maybe String
prefix String
field' Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
n -> Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) String
field'
    classNaming :: Maybe String
classNaming = Maybe String
niceLens Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"Has_" String -> String -> String
forall a. [a] -> [a] -> [a]
++)

-- | A 'FieldNamer' for 'camelCaseFields'.
camelCaseNamer :: FieldNamer
camelCaseNamer :: FieldNamer
camelCaseNamer Name
tyName [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do

  String
fieldPart <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
expectedPrefix (Name -> String
nameBase Name
field)
  String
method    <- String -> Maybe String
computeMethod String
fieldPart
  let cls :: String
cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
  DefName -> Maybe DefName
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))

  where
  expectedPrefix :: String
expectedPrefix = String
optUnderscore String -> String -> String
forall a. [a] -> [a] -> [a]
++ Optic An_AffineTraversal '[] String String Char Char
-> (Char -> Char) -> String -> String
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic An_AffineTraversal '[] String String Char Char
forall s a. Cons s s a a => AffineTraversal' s a
_head Char -> Char
toLower (Name -> String
nameBase Name
tyName)

  optUnderscore :: String
optUnderscore  = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]

  computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
  computeMethod String
_                  = Maybe String
forall a. Maybe a
Nothing

-- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer Name
_ [Name]
_ Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
  String
fieldUnprefixed <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"_" (Name -> String
nameBase Name
field)
  let className :: String
className  = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Optic An_AffineTraversal '[] String String Char Char
-> (Char -> Char) -> String -> String
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic An_AffineTraversal '[] String String Char Char
forall s a. Cons s s a a => AffineTraversal' s a
_head Char -> Char
toUpper String
fieldUnprefixed
      methodName :: String
methodName = String
fieldUnprefixed
  DefName -> Maybe DefName
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
className) (String -> Name
mkName String
methodName))

-- | A 'FieldNamer' for 'abbreviatedFields'.
abbreviatedNamer :: FieldNamer
abbreviatedNamer :: FieldNamer
abbreviatedNamer Name
_ [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do

  String
fieldPart <- String -> Maybe String
stripMaxLc (Name -> String
nameBase Name
field)
  String
method    <- String -> Maybe String
computeMethod String
fieldPart
  let cls :: String
cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
  DefName -> Maybe DefName
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))

  where
  stripMaxLc :: String -> Maybe String
stripMaxLc String
f = do String
x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
optUnderscore String
f
                    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
x of
                      (String
p,String
s) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
p Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
s -> Maybe String
forall a. Maybe a
Nothing
                            | Bool
otherwise                  -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
  optUnderscore :: String
optUnderscore  = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]

  computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
  computeMethod String
_                  = Maybe String
forall a. Maybe a
Nothing

----------------------------------------
-- Internal TH Implementation

-- Declaration quote stuff

declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith Dec -> Declare Dec
fun = (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ)
-> ([Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec])
-> [Dec]
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Declare Dec)
-> [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> Declare Dec
fun ([Dec] -> DecsQ) -> DecsQ -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

-- | Monad for emitting top-level declarations as a side effect. We also track
-- the set of field class 'Name's that have been created and consult them to
-- avoid creating duplicate classes.

-- See #463 for more information.
type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)

liftDeclare :: Q a -> Declare a
liftDeclare :: Q a -> Declare a
liftDeclare = StateT (Set Name) Q a -> Declare a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) Q a -> Declare a)
-> (Q a -> StateT (Set Name) Q a) -> Q a -> Declare a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> StateT (Set Name) Q a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runDeclare :: Declare [Dec] -> DecsQ
runDeclare :: WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec = do
  ([Dec]
out, Endo [Dec]
endo) <- StateT (Set Name) Q ([Dec], Endo [Dec])
-> Set Name -> Q ([Dec], Endo [Dec])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
-> StateT (Set Name) Q ([Dec], Endo [Dec])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec) Set Name
forall a. Set a
Set.empty
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [Dec]
out [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Endo [Dec] -> [Dec] -> [Dec]
forall a. Endo a -> a -> a
appEndo Endo [Dec]
endo []

emit :: [Dec] -> Declare ()
emit :: [Dec] -> Declare ()
emit [Dec]
decs = Endo [Dec] -> Declare ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Endo [Dec] -> Declare ()) -> Endo [Dec] -> Declare ()
forall a b. (a -> b) -> a -> b
$ ([Dec] -> [Dec]) -> Endo [Dec]
forall a. (a -> a) -> Endo a
Endo ([Dec]
decs[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++)

-- | Traverse each data, newtype, data instance or newtype instance
-- declaration.
traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype :: (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> f Dec
f [Dec]
decs = (Dec -> f Dec) -> [Dec] -> f [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Dec -> f Dec
go [Dec]
decs
  where
    go :: Dec -> f Dec
go Dec
dec = case Dec
dec of
      DataD{} -> Dec -> f Dec
f Dec
dec
      NewtypeD{} -> Dec -> f Dec
f Dec
dec
      DataInstD{} -> Dec -> f Dec
f Dec
dec
      NewtypeInstD{} -> Dec -> f Dec
f Dec
dec

      -- Recurse into instance declarations because they main contain
      -- associated data family instances.
      InstanceD Maybe Overlap
moverlap Cxt
ctx Type
inst [Dec]
body -> Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
moverlap Cxt
ctx Type
inst ([Dec] -> Dec) -> f [Dec] -> f Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> f Dec) -> [Dec] -> f [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Dec -> f Dec
go [Dec]
body
      Dec
_ -> Dec -> f Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec

stripFields :: Dec -> Dec
stripFields :: Dec -> Dec
stripFields Dec
dec = case Dec
dec of
  DataD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
    Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Type
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
  NewtypeD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
    Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
  DataInstD Cxt
ctx Maybe [TyVarBndr]
tyName Type
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
    Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctx Maybe [TyVarBndr]
tyName Type
tyArgs Maybe Type
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
  NewtypeInstD Cxt
ctx Maybe [TyVarBndr]
tyName Type
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
    Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
ctx Maybe [TyVarBndr]
tyName Type
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
  Dec
_ -> Dec
dec

deRecord :: Con -> Con
deRecord :: Con -> Con
deRecord con :: Con
con@NormalC{} = Con
con
deRecord con :: Con
con@InfixC{} = Con
con
deRecord (ForallC [TyVarBndr]
tyVars Cxt
ctx Con
con) = [TyVarBndr] -> Cxt -> Con -> Con
ForallC [TyVarBndr]
tyVars Cxt
ctx (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Con -> Con
deRecord Con
con
deRecord (RecC Name
conName [VarBangType]
fields) = Name -> [BangType] -> Con
NormalC Name
conName ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields)
deRecord con :: Con
con@GadtC{} = Con
con
deRecord (RecGadtC [Name]
ns [VarBangType]
fields Type
retTy) = [Name] -> [BangType] -> Type -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields) Type
retTy

dropFieldName :: VarBangType -> BangType
dropFieldName :: VarBangType -> BangType
dropFieldName (Name
_, Bang
str, Type
typ) = (Bang
str, Type
typ)