TH.hs

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.Maybe (maybeToList)
import Data.Monoid
import Data.Set (Set)
import Language.Haskell.TH.Syntax hiding (lift)
import Language.Haskell.TH
import qualified Data.List as L
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 = makeFieldLabelsWith fieldLabelsRules

-- | An alias for @makeFieldLabels noPrefixFieldLabels@.
makeFieldLabelsNoPrefix :: Name -> DecsQ
makeFieldLabelsNoPrefix = makeFieldLabelsWith 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 fields = makeFieldLabelsWith (fieldLabelsRulesFor 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
  = declareFieldLabelsWith
  $ fieldLabelsRules
  & lensField .~ noPrefixNamer

-- | Similar to 'makeFieldLabelsFor', but takes a declaration quote.
declareFieldLabelsFor :: [(String, String)] -> DecsQ -> DecsQ
declareFieldLabelsFor fields
  = declareFieldLabelsWith
  $ fieldLabelsRulesFor fields
  & lensField .~ noPrefixNamer

-- Similar to 'makeFieldLabelsWith', but takes a declaration quote.
declareFieldLabelsWith :: LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith rules = declareWith $ \dec -> do
  emit =<< liftDeclare (makeFieldLabelsForDec rules dec)
  return $ stripFields dec

-- | Rules for generation of 'LabelOptic' instances 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
  { _simpleLenses    = False
  , _generateSigs    = True
  , _generateClasses = False
  , _allowIsos       = True
  , _allowUpdates    = True
  , _lazyPatterns    = False
  , _classyLenses    = const Nothing
  , _fieldToDef      = 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 fields = fieldLabelsRules & lensField .~ lookingupNamer 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 = makeFieldOptics 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 fields = makeFieldOptics (lensRulesFor fields)

-- | Build field optics with a custom configuration.
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = 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
  = declareLensesWith
  $ lensRules
  & lensField .~ noPrefixNamer

-- | Similar to 'makeLensesFor', but takes a declaration quote.
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor fields
  = declareLensesWith
  $ lensRulesFor fields
  & lensField .~ noPrefixNamer

-- | 'declareLenses' with custom 'LensRules'.
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith rules = declareWith $ \dec -> do
  emit =<< lift (makeFieldOpticsForDec' rules dec)
  return $ stripFields dec

-- | Rules for making read-write field optics as top-level functions. It uses
-- 'underscoreNoPrefixNamer'.
lensRules :: LensRules
lensRules = LensRules
  { _simpleLenses    = False
  , _generateSigs    = True
  , _generateClasses = False
  , _allowIsos       = True
  , _allowUpdates    = True
  , _lazyPatterns    = False
  , _classyLenses    = const Nothing
  , _fieldToDef      = 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 fields = lensRules & lensField .~ lookingupNamer 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 = makeFieldOptics 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_ = makeFieldOptics 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 clsName funName fields = makeFieldOptics $
  classyRulesFor (const (Just (clsName, funName))) 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
  = declareLensesWith
  $ classyRules
  & lensField .~ noPrefixNamer

-- | Similar to 'makeClassyFor', but takes a declaration quote.
declareClassyFor ::
  [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor classes fields
  = declareLensesWith
  $ classyRulesFor (`Prelude.lookup`classes) fields
  & lensField .~ noPrefixNamer

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

-- | A 'LensRules' used by 'makeClassy_'.
classyRules_ :: LensRules
classyRules_
  = classyRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase 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 classFun fields = classyRules
  & lensClass .~ (over (mapped % each) mkName . classFun . nameBase)
  & lensField .~ lookingupNamer 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 = makeFieldOptics 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 = makeFieldOptics classUnderscoreNoPrefixFields

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

defaultFieldRules :: LensRules
defaultFieldRules = LensRules
  { _simpleLenses    = True
  , _generateSigs    = True
  , _generateClasses = True  -- classes will still be skipped if they already exist
  , _allowIsos       = False -- generating Isos would hinder field class reuse
  , _allowUpdates    = True
  , _lazyPatterns    = False
  , _classyLenses    = const Nothing
  , _fieldToDef      = 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 = declareWith $ \dec -> do
  emit =<< liftDeclare (makeDecPrisms True dec)
  return 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 = lensVL $ \f r ->
  fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses 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 = lensVL $ \f r ->
  fmap (\x -> r { _generateSigs = x}) (f (_generateSigs 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 = lensVL $ \f r ->
  fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates 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 = lensVL $ \f r ->
  fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r))

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

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

-- | 'Lens'' to access the option for naming "classy" lenses.
lensClass :: Lens' LensRules ClassyNamer
lensClass = lensVL $ \f r ->
  fmap (\x -> r { _classyLenses = x }) (f (_classyLenses 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 = fieldLabelsRules { _fieldToDef = noPrefixNamer }

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

-- | Field rules for fields in the form @ _prefix_fieldname @
underscoreFields :: LensRules
underscoreFields = defaultFieldRules & lensField .~ 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 = 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 =
  defaultFieldRules & lensField .~ 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 = defaultFieldRules { _fieldToDef = 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 _ _ n = [TopName 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 _ _ n =
  case nameBase n of
    '_':x:xs -> [TopName (mkName (toLower x:xs))]
    _        -> []


-- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer kvs _ _ field =
  [ TopName (mkName v) | (k,v) <- kvs, k == nameBase 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 mapper _ _ = fmap (TopName . mkName) . mapper . nameBase

-- | A 'FieldNamer' for 'underscoreFields'.
underscoreNamer :: FieldNamer
underscoreNamer _ _ field = maybeToList $ do
  _      <- prefix field'
  method <- niceLens
  cls    <- classNaming
  return (MethodName (mkName cls) (mkName method))
  where
    field' = nameBase field
    prefix ('_':xs) | '_' `L.elem` xs = Just (takeWhile (/= '_') xs)
    prefix _                          = Nothing
    niceLens    = prefix field' <&> \n -> drop (length n + 2) field'
    classNaming = niceLens <&> ("Has_" ++)

-- | A 'FieldNamer' for 'camelCaseFields'.
camelCaseNamer :: FieldNamer
camelCaseNamer tyName fields field = maybeToList $ do

  fieldPart <- L.stripPrefix expectedPrefix (nameBase field)
  method    <- computeMethod fieldPart
  let cls = "Has" ++ fieldPart
  return (MethodName (mkName cls) (mkName method))

  where
  expectedPrefix = optUnderscore ++ over _head toLower (nameBase tyName)

  optUnderscore  = ['_' | any (L.isPrefixOf "_" . nameBase) fields ]

  computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
  computeMethod _                  = Nothing

-- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer _ _ field = maybeToList $ do
  fieldUnprefixed <- L.stripPrefix "_" (nameBase field)
  let className  = "Has" ++ over _head toUpper fieldUnprefixed
      methodName = fieldUnprefixed
  return (MethodName (mkName className) (mkName methodName))

-- | A 'FieldNamer' for 'abbreviatedFields'.
abbreviatedNamer :: FieldNamer
abbreviatedNamer _ fields field = maybeToList $ do

  fieldPart <- stripMaxLc (nameBase field)
  method    <- computeMethod fieldPart
  let cls = "Has" ++ fieldPart
  return (MethodName (mkName cls) (mkName method))

  where
  stripMaxLc f = do x <- L.stripPrefix optUnderscore f
                    case break isUpper x of
                      (p,s) | L.null p || L.null s -> Nothing
                            | otherwise            -> Just s
  optUnderscore  = ['_' | any (L.isPrefixOf "_" . nameBase) fields ]

  computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
  computeMethod _                  = Nothing

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

-- Declaration quote stuff

declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)

-- | 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 = lift . lift

runDeclare :: Declare [Dec] -> DecsQ
runDeclare dec = do
  (out, endo) <- evalStateT (runWriterT dec) Set.empty
  return $ out ++ appEndo endo []

emit :: [Dec] -> Declare ()
emit decs = tell $ Endo (decs++)

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

      -- Recurse into instance declarations because they main contain
      -- associated data family instances.
      InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body
      _ -> pure dec

stripFields :: Dec -> Dec
stripFields dec = case dec of
  DataD ctx tyName tyArgs kind cons derivings ->
    DataD ctx tyName tyArgs kind (map deRecord cons) derivings
  NewtypeD ctx tyName tyArgs kind con derivings ->
    NewtypeD ctx tyName tyArgs kind (deRecord con) derivings
  DataInstD ctx tyName tyArgs kind cons derivings ->
    DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings
  NewtypeInstD ctx tyName tyArgs kind con derivings ->
    NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings
  _ -> dec

deRecord :: Con -> Con
deRecord con@NormalC{} = con
deRecord con@InfixC{} = con
deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con
deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields)
deRecord con@GadtC{} = con
deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy

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