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 :: 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 :: [([Char], [Char])] -> Name -> DecsQ
makeFieldLabelsFor [([Char], [Char])]
fields = LensRules -> Name -> DecsQ
makeFieldLabelsWith ([([Char], [Char])] -> LensRules
fieldLabelsRulesFor [([Char], [Char])]
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 :: [([Char], [Char])] -> DecsQ -> DecsQ
declareFieldLabelsFor [([Char], [Char])]
fields
  = LensRules -> DecsQ -> DecsQ
declareFieldLabelsWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> LensRules
fieldLabelsRulesFor [([Char], [Char])]
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 a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
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' 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
fieldLabelsRules = 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 :: [([Char], [Char])] -> LensRules
fieldLabelsRulesFor [([Char], [Char])]
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
.~ [([Char], [Char])] -> FieldNamer
lookingupNamer [([Char], [Char])]
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 :: [([Char], [Char])] -> Name -> DecsQ
makeLensesFor [([Char], [Char])]
fields = LensRules -> Name -> DecsQ
makeFieldOptics ([([Char], [Char])] -> LensRules
lensRulesFor [([Char], [Char])]
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 :: [([Char], [Char])] -> DecsQ -> DecsQ
declareLensesFor [([Char], [Char])]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> LensRules
lensRulesFor [([Char], [Char])]
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 (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
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 a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
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
  { _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 :: [([Char], [Char])] -> LensRules
lensRulesFor [([Char], [Char])]
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
.~ [([Char], [Char])] -> FieldNamer
lookingupNamer [([Char], [Char])]
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 :: [Char] -> [Char] -> [([Char], [Char])] -> Name -> DecsQ
makeClassyFor [Char]
clsName [Char]
funName [([Char], [Char])]
fields = LensRules -> Name -> DecsQ
makeFieldOptics (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$
  ([Char] -> Maybe ([Char], [Char]))
-> [([Char], [Char])] -> LensRules
classyRulesFor (Maybe ([Char], [Char]) -> [Char] -> Maybe ([Char], [Char])
forall a b. a -> b -> a
const (([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
clsName, [Char]
funName))) [([Char], [Char])]
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 :: [([Char], ([Char], [Char]))]
-> [([Char], [Char])] -> DecsQ -> DecsQ
declareClassyFor [([Char], ([Char], [Char]))]
classes [([Char], [Char])]
fields
  = LensRules -> DecsQ -> DecsQ
declareLensesWith
  (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe ([Char], [Char]))
-> [([Char], [Char])] -> LensRules
classyRulesFor ([Char] -> [([Char], ([Char], [Char]))] -> Maybe ([Char], [Char])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup`[([Char], ([Char], [Char]))]
classes) [([Char], [Char])]
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
  { _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 -> [Char]
nameBase Name
n of
          Char
x:[Char]
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just ([Char] -> Name
mkName ([Char]
"Has" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs), [Char] -> Name
mkName (Char -> Char
toLower Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
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 ([Char] -> Name
mkName (Char
'_'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Name -> [Char]
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 :: ([Char] -> Maybe ([Char], [Char]))
-> [([Char], [Char])] -> LensRules
classyRulesFor [Char] -> Maybe ([Char], [Char])
classFun [([Char], [Char])]
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
  (WithIx Int)
  (Maybe ([Char], [Char]))
  (Maybe (Name, Name))
  [Char]
  Name
-> ([Char] -> Name) -> Maybe ([Char], [Char]) -> 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 ([Char], [Char]))
  (Maybe (Name, Name))
  ([Char], [Char])
  (Name, Name)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped Setter
  (Maybe ([Char], [Char]))
  (Maybe (Name, Name))
  ([Char], [Char])
  (Name, Name)
-> Optic
     A_Traversal (WithIx Int) ([Char], [Char]) (Name, Name) [Char] Name
-> Optic
     A_Setter
     (WithIx Int)
     (Maybe ([Char], [Char]))
     (Maybe (Name, Name))
     [Char]
     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 (WithIx Int) ([Char], [Char]) (Name, Name) [Char] Name
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each) [Char] -> Name
mkName (Maybe ([Char], [Char]) -> Maybe (Name, Name))
-> (Name -> Maybe ([Char], [Char])) -> ClassyNamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe ([Char], [Char])
classFun ([Char] -> Maybe ([Char], [Char]))
-> (Name -> [Char]) -> Name -> Maybe ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
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
.~ [([Char], [Char])] -> FieldNamer
lookingupNamer [([Char], [Char])]
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
  { _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 a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _simpleLenses = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateSigs = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _allowUpdates = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _lazyPatterns = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateClasses = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNamer
x -> LensRules
r { _fieldToDef = 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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ClassyNamer
x -> LensRules
r { _classyLenses = 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 = noPrefixNamer }

abbreviatedFieldLabels :: LensRules
abbreviatedFieldLabels :: LensRules
abbreviatedFieldLabels = LensRules
fieldLabelsRules { _fieldToDef = 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 = 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 -> [Char]
nameBase Name
n of
    Char
'_':Char
x:[Char]
xs -> [Name -> DefName
TopName ([Char] -> Name
mkName (Char -> Char
toLower Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs))]
    [Char]
_        -> []


-- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer :: [([Char], [Char])] -> FieldNamer
lookingupNamer [([Char], [Char])]
kvs Name
_ [Name]
_ Name
field =
  [ Name -> DefName
TopName ([Char] -> Name
mkName [Char]
v) | ([Char]
k,[Char]
v) <- [([Char], [Char])]
kvs, [Char]
k [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
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 :: ([Char] -> [[Char]]) -> FieldNamer
mappingNamer [Char] -> [[Char]]
mapper Name
_ [Name]
_ = ([Char] -> DefName) -> [[Char]] -> [DefName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DefName
TopName (Name -> DefName) -> ([Char] -> Name) -> [Char] -> DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName) ([[Char]] -> [DefName]) -> (Name -> [[Char]]) -> Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
mapper ([Char] -> [[Char]]) -> (Name -> [Char]) -> Name -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
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
  [Char]
_      <- [Char] -> Maybe [Char]
prefix [Char]
field'
  [Char]
method <- Maybe [Char]
niceLens
  [Char]
cls    <- Maybe [Char]
classNaming
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName ([Char] -> Name
mkName [Char]
cls) ([Char] -> Name
mkName [Char]
method))
  where
    field' :: [Char]
field' = Name -> [Char]
nameBase Name
field
    prefix :: [Char] -> Maybe [Char]
prefix (Char
'_':[Char]
xs) | Char
'_' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Char]
xs = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') [Char]
xs)
    prefix [Char]
_                          = Maybe [Char]
forall a. Maybe a
Nothing
    niceLens :: Maybe [Char]
niceLens    = [Char] -> Maybe [Char]
prefix [Char]
field' Maybe [Char] -> ([Char] -> [Char]) -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Char]
n -> Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) [Char]
field'
    classNaming :: Maybe [Char]
classNaming = Maybe [Char]
niceLens Maybe [Char] -> ([Char] -> [Char]) -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Char]
"Has_" [Char] -> [Char] -> [Char]
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

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

  where
  expectedPrefix :: [Char]
expectedPrefix = [Char]
optUnderscore [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Optic An_AffineTraversal NoIx [Char] [Char] Char Char
-> (Char -> Char) -> [Char] -> [Char]
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 NoIx [Char] [Char] Char Char
forall s a. Cons s s a a => AffineTraversal' s a
_head Char -> Char
toLower (Name -> [Char]
nameBase Name
tyName)

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

  computeMethod :: [Char] -> Maybe [Char]
computeMethod (Char
x:[Char]
xs) | Char -> Bool
isUpper Char
x = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs)
  computeMethod [Char]
_                  = Maybe [Char]
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
  [Char]
fieldUnprefixed <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix [Char]
"_" (Name -> [Char]
nameBase Name
field)
  let className :: [Char]
className  = [Char]
"Has" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Optic An_AffineTraversal NoIx [Char] [Char] Char Char
-> (Char -> Char) -> [Char] -> [Char]
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 NoIx [Char] [Char] Char Char
forall s a. Cons s s a a => AffineTraversal' s a
_head Char -> Char
toUpper [Char]
fieldUnprefixed
      methodName :: [Char]
methodName = [Char]
fieldUnprefixed
  DefName -> Maybe DefName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName ([Char] -> Name
mkName [Char]
className) ([Char] -> Name
mkName [Char]
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

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

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

  computeMethod :: [Char] -> Maybe [Char]
computeMethod (Char
x:[Char]
xs) | Char -> Bool
isUpper Char
x = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs)
  computeMethod [Char]
_                  = Maybe [Char]
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 :: forall a. Q a -> Declare a
liftDeclare = StateT (Set Name) Q a
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) Q a
 -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a)
-> (Q a -> StateT (Set Name) Q a)
-> Q a
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m 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 a. a -> Q a
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 :: forall (f :: * -> *).
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Dec -> f Dec
go [Dec]
body
      Dec
_ -> Dec -> f Dec
forall a. a -> f a
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 Specificity]
tyVars Cxt
ctx Con
con) = [TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
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)