{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}

#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)
#endif

#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(x,y,z) 1
#endif

#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif


{- |
Module      :  Lens.Micro.TH
Copyright   :  (C) 2013-2016 Eric Mertens, Edward Kmett, Artyom Kazak; 2018 Monadfix
License     :  BSD-style (see the file LICENSE)
-}
module Lens.Micro.TH
(
  -- * Dealing with “not in scope” errors
  -- $errors-note

  -- * Using this module in GHCi
  -- $ghci-note

  -- * 'SimpleGetter' and 'SimpleFold'
  -- $getter-fold-note

  -- * Generating lenses
  makeLenses,
  makeLensesFor,
  makeLensesWith,
  makeFields,
  makeClassy,

  -- * Default lens rules
  LensRules,
  DefName(..),
  lensRules,
  lensRulesFor,
  classyRules,
  camelCaseFields,
  abbreviatedFields,

  -- * Configuring lens rules
  lensField,
  lensClass,
  createClass,
  simpleLenses,
  generateSignatures,
  generateUpdateableOptics,
  generateLazyPatterns,
)
where


import           Control.Monad
import           Control.Monad.Trans.State
import           Data.Char
import           Data.Data
import           Data.Either
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Data.Set as Set
import           Data.Set (Set)
import           Data.List (nub, findIndices, stripPrefix, isPrefixOf)
import           Data.Maybe
import           Lens.Micro
import           Lens.Micro.Internal (phantom)
import           Lens.Micro.TH.Internal
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
import           Data.Traversable (traverse, sequenceA)
#endif


{- $errors-note

When you use Template Haskell, the order of declarations suddenly starts to matter. For instance, if you try to use 'makeLenses', 'makeFields', etc before the type is defined, you'll get a “not in scope” error:

@
'makeLenses' ''Foo

data Foo = Foo {_foo :: Int}
@

@
Not in scope: type constructor or class ‘Foo’ …
    In the Template Haskell quotation ''Foo
@

You can't refer to generated lenses before you call 'makeLenses', either:

@
data Foo = Foo {_foo :: Int}

bar :: Lens' Foo Int
bar = foo

'makeLenses' ''Foo
@

@
Not in scope: ‘foo’ …
    Perhaps you meant one of these:
      data constructor ‘Foo’ (line 1), ‘_foo’ (line 1)
@
-}

{- $ghci-note

You can use 'makeLenses' and friends to define lenses right from GHCi, but it's slightly tricky.

First, enable Template Haskell:

>>> :set -XTemplateHaskell

Then define a bogus type (you can use any name in place of @M@, and you can use the same name many times), and follow the definition by the actual Template Haskell command you want to use:

>>> data M; makeLenses ''Foo

This will generate lenses for @Foo@ and you'll be able to use them from GHCi.

If you want, you can define the type and lenses for it simultaneously with @:{@ and @:}@:

@
>>> :{
data Foobar = Foobar {
  _foo :: Int,
  _bar :: Bool }
  deriving (Eq, Show)

makeLenses ''Foobar
:}
@
-}

{- $getter-fold-note

When updates are forbidden (by using 'generateUpdateableOptics'), or when a field simply can't be updated (for instance, in the presence of @forall@), instead of 'Lens' and 'Traversal' we generate 'SimpleGetter' and 'SimpleFold'. These aren't true @Getter@ and @Fold@ from lens, so beware. (Still, they're compatible, it's just that you can't do some things with them that you can do with original ones – for instance, @backwards@ and @takingWhile@ don't work on 'SimpleFold'.)

If you want to export true folds, it's recommended that you depend on <http://hackage.haskell.org/package/microlens-contra microlens-contra>, use 'makeLensesFor' to generate 'SimpleFold's with prefixes, and then export versions of those folds with @<http://hackage.haskell.org/package/microlens-contra/docs/Lens-Micro-Contra.html#v:fromSimpleFold fromSimpleFold>@ applied.
-}

-- Utilities

-- like 'rewrite' from uniplate
rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite :: (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f b
mbA = case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
mbA of
  Maybe a
Nothing -> (forall b. Data b => b -> b) -> b -> b
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((a -> Maybe a) -> b -> b
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f) b
mbA
  Just a
a  -> let a' :: a
a' = (forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((a -> Maybe a) -> b -> b
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f) a
a
             in  Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (a -> Maybe b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a' (a -> Maybe a
f a
a')

-- like 'children' from uniplate
children :: Data a => a -> [a]
children :: a -> [a]
children = [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> (a -> [Maybe a]) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> Maybe a) -> a -> [Maybe a]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast

-- Control.Lens.TH

{- |
Generate lenses for a data type or a newtype.

To use it, you have to enable Template Haskell first:

@
\{\-\# LANGUAGE TemplateHaskell \#\-\}
@

Then, after declaring the datatype (let's say @Foo@), add @makeLenses ''Foo@ on a separate line (if you do it before the type is declared, you'll get a “not in scope” error – see the section at the top of this page):

@
data Foo = Foo {
  _x :: Int,
  _y :: Bool }

'makeLenses' ''Foo
@

This would generate the following lenses, which can be used to access the fields of @Foo@:

@
x :: 'Lens'' Foo Int
x f foo = (\\x' -> foo {_x = x'}) '<$>' f (_x foo)

y :: 'Lens'' Foo Bool
y f foo = (\\y' -> foo {_y = y'}) '<$>' f (_y foo)
@

(If you don't want a lens to be generated for some field, don't prefix it with “_”.)

If you want to create lenses for many types, you can do it all in one place like this (of course, instead you just can use 'makeLenses' several times if you feel it would be more readable):

@
data Foo = ...
data Bar = ...
data Quux = ...

'concat' '<$>' 'mapM' 'makeLenses' [''Foo, ''Bar, ''Quux]
@

When the data type has type parameters, it's possible for a lens to do a polymorphic update – i.e. change the type of the thing along with changing the type of the field. For instance, with this type

@
data Foo a = Foo {
  _x :: a,
  _y :: Bool }
@

the following lenses would be generated:

@
x :: 'Lens' (Foo a) (Foo b) a b
y :: 'Lens'' (Foo a) Bool
@

However, when there are several fields using the same type parameter, type-changing updates are no longer possible:

@
data Foo a = Foo {
  _x :: a,
  _y :: a }
@

generates

@
x :: 'Lens'' (Foo a) a
y :: 'Lens'' (Foo a) a
@

Finally, when the type has several constructors, some of fields may not be /always/ present – for those, a 'Traversal' is generated instead. For instance, in this example @y@ can be present or absent:

@
data FooBar
  = Foo { _x :: Int, _y :: Bool }
  | Bar { _x :: Int }
@

and the following accessors would be generated:

@
x :: 'Lens'' FooBar Int
y :: 'Traversal'' FooBar Bool
@

So, to get @_y@, you'd have to either use ('^?') if you're not sure it's there, or ('^?!') if you're absolutely sure (and if you're wrong, you'll get an exception). Setting and updating @_y@ can be done as usual.
-}
makeLenses :: Name -> DecsQ
makeLenses :: Name -> DecsQ
makeLenses = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
lensRules

{- |
Like 'makeLenses', but lets you choose your own names for lenses:

@
data Foo = Foo {foo :: Int, bar :: Bool}

'makeLensesFor' [(\"foo\", \"fooLens\"), (\"bar\", \"_bar\")] ''Foo
@

would create lenses called @fooLens@ and @_bar@. This is useful, for instance, when you don't want to prefix your fields with underscores and want to prefix /lenses/ with underscores instead.

If you give the same name to different fields, it will generate a 'Traversal' instead:

@
data Foo = Foo {slot1, slot2, slot3 :: Int}

'makeLensesFor' [(\"slot1\", \"slots\"),
               (\"slot2\", \"slots\"),
               (\"slot3\", \"slots\")] ''Foo
@

would generate

@
slots :: 'Traversal'' Foo Int
slots f foo = Foo '<$>' f (slot1 foo)
                  '<*>' f (slot2 foo)
                  '<*>' f (slot3 foo)
@
-}
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)

{- |
Generate lenses with custom parameters.

To see what exactly you can customise, look at the “Configuring lens rules” section. Usually you would build upon the 'lensRules' configuration, which is used by 'makeLenses':

@
'makeLenses' = 'makeLensesWith' 'lensRules'
@

Here's an example of generating lenses that would use lazy patterns:

@
data Foo = Foo {_x, _y :: Int}

'makeLensesWith' ('lensRules' '&' 'generateLazyPatterns' '.~' True) ''Foo
@

When there are several modifications to the rules, the code looks nicer when you use 'flip':

@
'flip' 'makeLensesWith' ''Foo $
  'lensRules'
    '&' 'generateLazyPatterns' '.~' True
    '&' 'generateSignatures'   '.~' False
@
-}
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = LensRules -> Name -> DecsQ
makeFieldOptics

{- |
Generate overloaded lenses.

This lets you deal with several data types having same fields. For instance, let's say you have @Foo@ and @Bar@, and both have a field named @x@. To avoid those fields clashing, you would have to use prefixes:

@
data Foo a = Foo {
  fooX :: Int,
  fooY :: a }

data Bar = Bar {
  barX :: Char }
@

However, if you use 'makeFields' on both @Foo@ and @Bar@ now, it would generate lenses called @x@ and @y@ – and @x@ would be able to access both @fooX@ and @barX@! This is done by generating a separate class for each field, and making relevant types instances of that class:

@
class HasX s a | s -> a where
  x :: 'Lens'' s a

instance HasX (Foo a) Int where
  x :: 'Lens'' (Foo a) Int
  x = ...

instance HasX Bar Char where
  x :: 'Lens'' Bar Char
  x = ...


class HasY s a | s -> a where
  y :: 'Lens'' s a

instance HasY (Foo a) a where
  y :: 'Lens'' (Foo a) a
  y = ...
@

(There's a minor drawback, though: you can't perform type-changing updates with these lenses.)

If you only want to make lenses for some fields, you can prefix them with underscores – the rest would be untouched. If no fields are prefixed with underscores, lenses would be created for all fields.

The prefix must be the same as the name of the name of the data type (/not/ the constructor). If you don't like this behavior, use @'makeLensesWith' 'abbreviatedFields'@ – it allows any prefix (and even different prefixes).

If you want to use 'makeFields' on types declared in different modules, you can do it, but then you would have to export the @Has*@ classes from one of the modules – 'makeFields' creates a class if it's not in scope yet, so the class must be in scope or else there would be duplicate classes and you would get an “Ambiguous occurrence” error.

Finally, 'makeFields' is implemented as @'makeLensesWith' 'camelCaseFields'@, so you can build on 'camelCaseFields' if you want to customise behavior of 'makeFields'.
-}
makeFields :: Name -> DecsQ
makeFields :: Name -> DecsQ
makeFields = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
camelCaseFields

{- |
Generate overloaded lenses without ad-hoc classes; useful when there's a collection of fields that you want to make common for several types.

Like 'makeFields', each lens is a member of a class. However, the classes are per-type and not per-field. Let's take the following type:

@
data Person = Person {
  _name :: String,
  _age :: Double }
@

'makeClassy' would generate a single class with 3 methods:

@
class HasPerson c where
  person :: Lens' c Person

  age :: Lens' c Double
  age = person.age

  name :: Lens' c String
  name = person.name
@

And an instance:

@
instance HasPerson Person where
  person = id

  name = ...
  age = ...
@

So, you can use @name@ and @age@ to refer to the @_name@ and @_age@ fields, as usual. However, the extra lens – @person@ – allows you to do a kind of subtyping. Let's say that there's a type called @Worker@ and every worker has the same fields that a person has, but also a @job@. If you were using 'makeFields', you'd do the following:

@
data Worker = Worker {
  _workerName :: String,
  _workerAge :: Double,
  _workerJob :: String }
@

However, with 'makeClassy' you can say “every worker is a person” in a more principled way:

@
data Worker = Worker {
  _workerPerson :: Person,
  _job :: String }

makeClassy ''Worker

instance HasPerson Worker where person = workerPerson
@

Now you can use @age@ and @name@ to access name\/age of a @Worker@, but you also can use @person@ to “downgrade” a @Worker@ to a @Person@ (and e.g. apply some @Person@-specific function to it).

Unlike 'makeFields', 'makeClassy' doesn't make use of prefixes. @_workerPerson@ could've just as well been named @_foobar@.

'makeClassy' is implemented as @'makeLensesWith' 'classyRules'@, so you can build on 'classyRules' if you want to customise behavior of 'makeClassy'.
-}
makeClassy :: Name -> DecsQ
makeClassy :: Name -> DecsQ
makeClassy = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules

{- |
Generate simple (monomorphic) lenses even when type-changing lenses are possible – i.e. 'Lens'' instead of 'Lens' and 'Traversal'' instead of 'Traversal'. Just in case, here's an example of a situation when type-changing lenses would be normally generated:

@
data Foo a = Foo { _foo :: a }
@

Generated lens:

@
foo :: 'Lens' (Foo a) (Foo b) a b
@

Generated lens with 'simpleLenses' turned on:

@
foo :: 'Lens'' (Foo a) a
@

This option is disabled by default.
-}
simpleLenses :: Lens' LensRules Bool
simpleLenses :: (Bool -> f Bool) -> LensRules -> f LensRules
simpleLenses 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))

{- |
Supply type signatures for the generated lenses.

This option is enabled by default. Disable it if you want to write the signature by yourself – for instance, if the signature should be more restricted, or if you want to write haddocks for the lens (as haddocks are attached to the signature and not to the definition).
-}
generateSignatures :: Lens' LensRules Bool
generateSignatures :: (Bool -> f Bool) -> LensRules -> f LensRules
generateSignatures 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 turned off, 'SimpleFold's will be generated instead of 'Traversal's and 'SimpleGetter's will be generated instead of 'Lens'es.

This option is enabled by default. Disabling it can be useful for types with invariants (also known as “types with smart constructors”) – if you generate updateable optics, anyone would be able to use them to break your invariants.
-}
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics :: (Bool -> f Bool) -> LensRules -> f LensRules
generateUpdateableOptics 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 lenses 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}
@

(Without 'generateLazyPatterns', the result would be just 'undefined'.)

This option is disabled by default. The downside of enabling it is that it can lead to space-leaks and code-size\/compile-time increases when lenses are generated for large records.

When you have a lazy lens, you can get a strict lens from it by composing with ('$!'):

@
strictLens = ('$!') . lazyLens
@
-}
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns :: (Bool -> f Bool) -> LensRules -> f LensRules
generateLazyPatterns 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))

{- |
This lets you choose which fields would have lenses generated for them and how would those lenses be called. To do that, you provide a function that would take a field name and output a list (possibly empty) of lenses that should be generated for that field.

Here's the full type of the function you have to provide:

@
'Name' ->     -- The datatype lenses are being generated for
['Name'] ->   -- A list of all fields of the datatype
'Name' ->     -- The current field
['DefName']   -- A list of lens names
@

Most of the time you won't need the first 2 parameters, but sometimes they are useful – for instance, the list of all fields would be useful if you wanted to implement a slightly more complicated rule like “if some fields are prefixed with underscores, generate lenses for them, but if no fields are prefixed with underscores, generate lenses for /all/ fields”.

As an example, here's a function used by default. It strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_”:

@
\\_ _ n ->
  case 'nameBase' n of
    \'_\':x:xs -> ['TopName' ('mkName' ('toLower' x : xs))]
    _        -> []
@

You can also generate classes (i.e. what 'makeFields' does) by using @'MethodName' className lensName@ instead of @'TopName' lensName@.
-}
lensField :: Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField :: ((Name -> [Name] -> Name -> [DefName])
 -> f (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> f LensRules
lensField (Name -> [Name] -> Name -> [DefName])
-> f (Name -> [Name] -> Name -> [DefName])
f LensRules
r = ((Name -> [Name] -> Name -> [DefName]) -> LensRules)
-> f (Name -> [Name] -> Name -> [DefName]) -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name -> [Name] -> Name -> [DefName]
x -> LensRules
r { _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef = Name -> [Name] -> Name -> [DefName]
x}) ((Name -> [Name] -> Name -> [DefName])
-> f (Name -> [Name] -> Name -> [DefName])
f (LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef LensRules
r))

{- |
This lets you choose whether a class would be generated for the type itself (like 'makeClassy' does). If so, you can choose the name of the class and the name of the type-specific lens.

For 'makeLenses' and 'makeFields' this is just @const Nothing@. For 'makeClassy' this function is defined like this:

@
\\n ->
  case 'nameBase' n of
    x:xs -> Just ('mkName' ("Has" ++ x:xs), 'mkName' ('toLower' x : xs))
    []   -> Nothing
@
-}
lensClass :: Lens' LensRules (Name -> Maybe (Name, Name))
lensClass :: ((Name -> Maybe (Name, Name)) -> f (Name -> Maybe (Name, Name)))
-> LensRules -> f LensRules
lensClass (Name -> Maybe (Name, Name)) -> f (Name -> Maybe (Name, Name))
f LensRules
r = ((Name -> Maybe (Name, Name)) -> LensRules)
-> f (Name -> Maybe (Name, Name)) -> f LensRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name -> Maybe (Name, Name)
x -> LensRules
r { _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses = Name -> Maybe (Name, Name)
x }) ((Name -> Maybe (Name, Name)) -> f (Name -> Maybe (Name, Name))
f (LensRules -> Name -> Maybe (Name, Name)
_classyLenses LensRules
r))

{- |
Decide whether generation of classes is allowed at all.

If this is disabled, neither 'makeFields' nor 'makeClassy' would work, regardless of values of 'lensField' or 'lensClass'. On the other hand, if 'lensField' and 'lensClass' don't generate any classes, enabling this won't have any effect.
-}
createClass :: Lens' LensRules Bool
createClass :: (Bool -> f Bool) -> LensRules -> f LensRules
createClass 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 rules used by default (i.e. in 'makeLenses'):

* 'generateSignatures' is turned on
* 'generateUpdateableOptics' is turned on
* 'generateLazyPatterns' is turned off
* 'simpleLenses' is turned off
* 'lensField' strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_” (you can see how it's implemented in the docs for 'lensField')
* 'lensClass' isn't used (i.e. defined as @const Nothing@)
-}
lensRules :: LensRules
lensRules :: LensRules
lensRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> (Name -> [Name] -> Name -> [DefName])
-> (Name -> Maybe (Name, Name))
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
False
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
False
  -- , _allowIsos       = True
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses    = Maybe (Name, Name) -> Name -> Maybe (Name, Name)
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef      = \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
_        -> []
  }

{- |
A modification of 'lensRules' used by 'makeLensesFor' (the only difference is that a simple lookup function is used for 'lensField').
-}
lensRulesFor
  :: [(String, String)] -- ^ @[(fieldName, lensName)]@
  -> LensRules
lensRulesFor :: [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields = LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
 -> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
  -> Identity (Name -> [Name] -> Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup [(String, String)]
fields

mkNameLookup :: [(String,String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup :: [(String, String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup [(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]

{- |
Lens rules used by 'makeFields':

* 'generateSignatures' is turned on
* 'generateUpdateableOptics' is turned on
* 'generateLazyPatterns' is turned off
* 'simpleLenses' is turned on (unlike in 'lensRules')
* 'lensField' is more complicated – it takes fields which are prefixed with the name of the type they belong to (e.g. “fooFieldName” for “Foo”), strips that prefix, and generates a class called “HasFieldName” with a single method called “fieldName”. If some fields are prefixed with underscores, underscores would be stripped too, but then fields without underscores won't have any lenses generated for them. Also note that e.g. “foolish” won't have a lens called “lish” generated for it – the prefix must be followed by a capital letter (or else it wouldn't be camel case).
* 'lensClass' isn't used (i.e. defined as @const Nothing@)
-}
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules

camelCaseNamer :: Name -> [Name] -> Name -> [DefName]
camelCaseNamer :: Name -> [Name] -> Name -> [DefName]
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]
++ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' 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

{- |
Like standard rules used by 'makeFields', but doesn't put any restrictions on the prefix. I.e. if you have fields called

* @_fooBarBaz@
* @_someX@
* @someY@

then the generated lenses would be called @barBaz@ and @x@.
-}
abbreviatedFields :: LensRules
abbreviatedFields :: LensRules
abbreviatedFields = LensRules
defaultFieldRules { _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef = Name -> [Name] -> Name -> [DefName]
abbreviatedNamer }

abbreviatedNamer :: Name -> [Name] -> Name -> [DefName]
abbreviatedNamer :: Name -> [Name] -> Name -> [DefName]
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
null String
p Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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

defaultFieldRules :: LensRules
defaultFieldRules :: LensRules
defaultFieldRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> (Name -> [Name] -> Name -> [DefName])
-> (Name -> Maybe (Name, Name))
-> 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       = False -- generating Isos would hinder field class reuse
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses    = Maybe (Name, Name) -> Name -> Maybe (Name, Name)
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
  , _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef      = Name -> [Name] -> Name -> [DefName]
camelCaseNamer
  }

underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName]
underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName]
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
_        -> []

{- |
Lens rules used by 'makeClassy':

* 'generateSignatures' is turned on
* 'generateUpdateableOptics' is turned on
* 'generateLazyPatterns' is turned off
* 'simpleLenses' is turned on (unlike in 'lensRules')
* 'lensField' is the same as in 'lensRules'
* 'lensClass' just adds “Has” to the name of the type (so for “Person” the generated class would be called “HasPerson” and the type-specific lens in that class would be called “person”)
-}
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> (Name -> [Name] -> Name -> [DefName])
-> (Name -> Maybe (Name, Name))
-> LensRules
LensRules
  { _simpleLenses :: Bool
_simpleLenses    = Bool
True
  , _generateSigs :: Bool
_generateSigs    = Bool
True
  , _generateClasses :: Bool
_generateClasses = Bool
True
  -- , _allowIsos       = False -- generating Isos would hinder "subtyping"
  , _allowUpdates :: Bool
_allowUpdates    = Bool
True
  , _lazyPatterns :: Bool
_lazyPatterns    = Bool
False
  , _classyLenses :: Name -> Maybe (Name, Name)
_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 :: Name -> [Name] -> Name -> [DefName]
_fieldToDef      = Name -> [Name] -> Name -> [DefName]
underscoreNoPrefixNamer
  }

-- FieldTH.hs

------------------------------------------------------------------------
-- Field generation entry point
------------------------------------------------------------------------


-- Compute the field optics for the type identified by the given type name.
-- Lenses will be computed when possible, Traversals otherwise.
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics LensRules
rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set Name
forall a. Set a
Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> DatatypeInfo
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> DecsQ)
-> (Name -> Q DatatypeInfo) -> Name -> DecsQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
D.reifyDatatype

type HasFieldClasses = StateT (Set Name) Q

addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName Name
n = (Set Name -> Set Name) -> HasFieldClasses ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Set Name -> Set Name) -> HasFieldClasses ())
-> (Set Name -> Set Name) -> HasFieldClasses ()
forall a b. (a -> b) -> a -> b
$ Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
n

-- | Compute the field optics for a deconstructed datatype Dec
-- When possible build an Iso otherwise build one optic per field.
makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules DatatypeInfo
info =
  do Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
perDef <- Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT
     (Set Name)
     Q
     (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
 -> StateT
      (Set Name)
      Q
      (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])))
-> Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT
     (Set Name)
     Q
     (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
forall a b. (a -> b) -> a -> b
$ do
       [(Name, [(Maybe Name, Type)])]
fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
-> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor [ConstructorInfo]
cons
       let allFields :: [Name]
allFields  = Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
-> [(Name, [(Maybe Name, Type)])] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (Getting
  (Endo [Name])
  [(Name, [(Maybe Name, Type)])]
  (Name, [(Maybe Name, Type)])
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting
  (Endo [Name])
  [(Name, [(Maybe Name, Type)])]
  (Name, [(Maybe Name, Type)])
-> ((Name -> Const (Endo [Name]) Name)
    -> (Name, [(Maybe Name, Type)])
    -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
 -> (Name, [(Maybe Name, Type)])
 -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> ((Name -> Const (Endo [Name]) Name)
    -> [(Maybe Name, Type)]
    -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name -> Const (Endo [Name]) Name)
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Name]) [(Maybe Name, Type)] (Maybe Name, Type)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting (Endo [Name]) [(Maybe Name, Type)] (Maybe Name, Type)
-> ((Name -> Const (Endo [Name]) Name)
    -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> (Name -> Const (Endo [Name]) Name)
-> [(Maybe Name, Type)]
-> Const (Endo [Name]) [(Maybe Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Maybe Name -> Const (Endo [Name]) (Maybe Name))
 -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> ((Name -> Const (Endo [Name]) Name)
    -> Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Name -> Const (Endo [Name]) Name)
-> (Maybe Name, Type)
-> Const (Endo [Name]) (Maybe Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> Maybe Name -> Const (Endo [Name]) (Maybe Name)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
       let defCons :: [(Name, [([DefName], Type)])]
defCons    = ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
-> (Maybe Name -> [DefName])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([DefName], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels ([Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
           allDefs :: Set DefName
allDefs    = Getting (Endo [DefName]) [(Name, [([DefName], Type)])] DefName
-> [(Name, [([DefName], Type)])] -> Set DefName
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf (([DefName] -> Const (Endo [DefName]) [DefName])
-> [(Name, [([DefName], Type)])]
-> Const (Endo [DefName]) [(Name, [([DefName], Type)])]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels (([DefName] -> Const (Endo [DefName]) [DefName])
 -> [(Name, [([DefName], Type)])]
 -> Const (Endo [DefName]) [(Name, [([DefName], Type)])])
-> ((DefName -> Const (Endo [DefName]) DefName)
    -> [DefName] -> Const (Endo [DefName]) [DefName])
-> Getting (Endo [DefName]) [(Name, [([DefName], Type)])] DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefName -> Const (Endo [DefName]) DefName)
-> [DefName] -> Const (Endo [DefName]) [DefName]
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded) [(Name, [([DefName], Type)])]
defCons
       Map DefName (Q (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((DefName -> Q (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Set DefName
-> Map DefName (Q (OpticType, OpticStab, [(Name, Int, [Int])]))
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [Int])])
buildScaffold LensRules
rules Type
s [(Name, [([DefName], Type)])]
defCons) Set DefName
allDefs)

     let defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
perDef
     case LensRules -> Name -> Maybe (Name, Name)
_classyLenses LensRules
rules Name
tyName of
       Just (Name
className, Name
methodName) ->
         LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
       Maybe (Name, Name)
Nothing -> do [[Dec]]
decss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
                     [Dec] -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)

  where
  tyName :: Name
tyName = DatatypeInfo -> Name
D.datatypeName     DatatypeInfo
info
  s :: Type
s      = DatatypeInfo -> Type
datatypeTypeKinded DatatypeInfo
info
  cons :: [ConstructorInfo]
cons   = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons     DatatypeInfo
info

  -- Traverse the field labels of a normalized constructor
  normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
  normFieldLabels :: (a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels = ((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
 -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])])
-> ((a -> f b) -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> (a -> f b)
-> [(Name, [(a, Type)])]
-> f [(Name, [(b, Type)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, Type)] -> f [(b, Type)])
-> (Name, [(a, Type)]) -> f (Name, [(b, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([(a, Type)] -> f [(b, Type)])
 -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> ((a -> f b) -> [(a, Type)] -> f [(b, Type)])
-> (a -> f b)
-> (Name, [(a, Type)])
-> f (Name, [(b, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)])
-> ((a -> f b) -> (a, Type) -> f (b, Type))
-> (a -> f b)
-> [(a, Type)]
-> f [(b, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> (a, Type) -> f (b, Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1

  -- Map a (possibly missing) field's name to zero-to-many optic definitions
  expandName :: [Name] -> Maybe Name -> [DefName]
  expandName :: [Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields = (Name -> [DefName]) -> [Name] -> [DefName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef LensRules
rules Name
tyName [Name]
allFields) ([Name] -> [DefName])
-> (Maybe Name -> [Name]) -> Maybe Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList

normalizeConstructor ::
  D.ConstructorInfo ->
  Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type

normalizeConstructor :: ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor ConstructorInfo
con =
  (Name, [(Maybe Name, Type)]) -> Q (Name, [(Maybe Name, Type)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
          (Maybe Name -> Type -> (Maybe Name, Type))
-> [Maybe Name] -> [Type] -> [(Maybe Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Name -> Type -> (Maybe Name, Type)
forall s a. HasTypeVars s => Maybe a -> s -> (Maybe a, s)
checkForExistentials [Maybe Name]
fieldNames (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
con))
  where
    fieldNames :: [Maybe Name]
fieldNames =
      case ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
con of
        D.RecordConstructor [Name]
xs -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
xs
        ConstructorVariant
D.NormalConstructor    -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing
        ConstructorVariant
D.InfixConstructor     -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing

    -- Fields mentioning existentially quantified types are not
    -- elligible for TH generated optics.
    checkForExistentials :: Maybe a -> s -> (Maybe a, s)
checkForExistentials Maybe a
_ s
fieldtype
      | (TyVarBndr_ Any -> Bool) -> [TyVarBndr_ Any] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ Any
tv -> TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName TyVarBndr_ Any
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ Any]
unallowable
      = (Maybe a
forall a. Maybe a
Nothing, s
fieldtype)
      where
        used :: Set Name
used        = Getting (Endo [Name]) s Name -> s -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) s Name
forall t. HasTypeVars t => Traversal' t Name
typeVars s
fieldtype
        unallowable :: [TyVarBndr_ Any]
unallowable = ConstructorInfo -> [TyVarBndr_ Any]
D.constructorVars ConstructorInfo
con
    checkForExistentials Maybe a
fieldname s
fieldtype = (Maybe a
fieldname, s
fieldtype)

makeClassyDriver ::
  LensRules ->
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
  HasFieldClasses [Dec]
makeClassyDriver :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = [StateT (Set Name) Q Dec] -> StateT (Set Name) Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([StateT (Set Name) Q Dec]
forall s. [StateT s Q Dec]
cls [StateT (Set Name) Q Dec]
-> [StateT (Set Name) Q Dec] -> [StateT (Set Name) Q Dec]
forall a. [a] -> [a] -> [a]
++ [StateT (Set Name) Q Dec]
inst)

  where
  cls :: [StateT s Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [Q Dec -> StateT s Q Dec
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (Q Dec -> StateT s Q Dec) -> Q Dec -> StateT s Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs]
      | Bool
otherwise = []

  inst :: [StateT (Set Name) Q Dec]
inst = [LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs]

makeClassyClass ::
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
  DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = do
  let ss :: [Type]
ss   = ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) -> Type)
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS (OpticStab -> Type)
-> ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> OpticStab)
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Getting
     OpticStab
     (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
     OpticStab
-> OpticStab
forall s a. s -> Getting a s a -> a
^. ((OpticType, OpticStab, [(Name, Int, [Int])])
 -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Const
     OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
forall s t a b. Field2 s t a b => Lens s t a b
_2(((OpticType, OpticStab, [(Name, Int, [Int])])
  -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
 -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
 -> Const
      OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])))
-> ((OpticStab -> Const OpticStab OpticStab)
    -> (OpticType, OpticStab, [(Name, Int, [Int])])
    -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Getting
     OpticStab
     (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
     OpticStab
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [Int])])
-> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])])
forall s t a b. Field2 s t a b => Lens s t a b
_2)) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
  (Map Name Type
sub,Type
s') <- [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ss)
  Name
c <- String -> Q Name
newName String
"c"
  let vars :: [TyVarBndr_ Any]
vars     = [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s']
      varNames :: [Name]
varNames = (TyVarBndr_ Any -> Name) -> [TyVarBndr_ Any] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName [TyVarBndr_ Any]
vars
      fd :: [FunDep]
fd   | [TyVarBndr_ Any] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ Any]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]


  CxtQ -> Name -> [TyVarBndr_ Any] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([PredQ] -> CxtQ
cxt[]) Name
className (Name -> TyVarBndr_ Any
D.plainTV Name
cTyVarBndr_ Any -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. a -> [a] -> [a]
:[TyVarBndr_ Any]
vars) [FunDep]
fd
    ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> PredQ -> Q Dec
sigD Name
methodName (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return (''Lens' Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s']))
    Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [[Q Dec]] -> [Q Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Name -> PredQ -> Q Dec
sigD Name
defName (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
body) []
        ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
        Name -> [Q Dec]
inlinePragma Name
defName
      | (TopName Name
defName, (OpticType
_, OpticStab
stab, [(Name, Int, [Int])]
_)) <- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
      , let body :: ExpQ
body = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE '(.), Name -> ExpQ
varE Name
methodName, Name -> ExpQ
varE Name
defName]
      , let ty :: Type
ty   = Set Name -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Name
cName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
varNames))
                                 (OpticStab -> [Type]
stabToContext OpticStab
stab)
                 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
stab Name -> [Type] -> Type
`conAppsT`
                       [Name -> Type
VarT Name
c, Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub (OpticStab -> Type
stabToA OpticStab
stab)]
      ]

makeClassyInstance ::
  LensRules ->
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
  HasFieldClasses Dec
makeClassyInstance :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = do
  [[Dec]]
methodss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs

  Q Dec -> StateT (Set Name) Q Dec
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (Q Dec -> StateT (Set Name) Q Dec)
-> Q Dec -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt[]) (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHead)
    ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
methodName) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'id)) []
    Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)

  where
  instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndr_ Any -> Type) -> [TyVarBndr_ Any] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> Type
forall flag. TyVarBndr_ Any -> Type
tvbToType [TyVarBndr_ Any]
vars)
  vars :: [TyVarBndr_ Any]
vars         = [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s]
  rules' :: LensRules
rules'       = LensRules
rules { _generateSigs :: Bool
_generateSigs    = Bool
False
                       , _generateClasses :: Bool
_generateClasses = Bool
False
                       }

data OpticType = GetterType | LensType -- or IsoType


-- Compute the positional location of the fields involved in
-- each constructor for a given optic definition as well as the
-- type of clauses to generate and the type to annotate the declaration
-- with.
buildScaffold ::
  LensRules                                                                ->
  Type                              {- outer type                       -} ->
  [(Name, [([DefName], Type)])]     {- normalized constructors          -} ->
  DefName                           {- target definition                -} ->
  Q (OpticType, OpticStab, [(Name, Int, [Int])])
              {- ^ optic type, definition type, field count, target fields -}
buildScaffold :: LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [Int])])
buildScaffold LensRules
rules Type
s [(Name, [([DefName], Type)])]
cons DefName
defName =

  do (Type
s',Type
t,Type
a,Type
b) <- Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s (((Name, [Either Type Type]) -> [Either Type Type])
-> [(Name, [Either Type Type])] -> [Either Type Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Either Type Type]) -> [Either Type Type]
forall a b. (a, b) -> b
snd [(Name, [Either Type Type])]
consForDef)

     let defType :: OpticStab
defType
           | Just ([TyVarBndr_ Any]
_,[Type]
cx,Type
a') <- Type
a Type
-> Getting
     (First ([TyVarBndr_ Any], [Type], Type))
     Type
     ([TyVarBndr_ Any], [Type], Type)
-> Maybe ([TyVarBndr_ Any], [Type], Type)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First ([TyVarBndr_ Any], [Type], Type))
  Type
  ([TyVarBndr_ Any], [Type], Type)
Traversal' Type ([TyVarBndr_ Any], [Type], Type)
_ForallT =
               let optic :: Name
optic | Bool
lensCase  = ''SimpleGetter
                         | Bool
otherwise = ''SimpleFold
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [Type]
cx Name
optic Type
s' Type
a'

           -- Getter and Fold are always simple
           | Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) =
               let optic :: Name
optic | Bool
lensCase  = ''SimpleGetter
                         | Bool
otherwise = ''SimpleFold
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a

           -- Generate simple Lens and Traversal where possible
           | LensRules -> Bool
_simpleLenses LensRules
rules Bool -> Bool -> Bool
|| Type
s' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b =
               let optic :: Name
optic -- isoCase && _allowIsos rules = ''Iso'
                         | Bool
lensCase                    = ''Lens'
                         | Bool
otherwise                   = ''Traversal'
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a

           -- Generate type-changing Lens and Traversal otherwise
           | Bool
otherwise =
               let optic :: Name
optic -- isoCase && _allowIsos rules = ''Iso
                         | Bool
lensCase                    = ''Lens
                         | Bool
otherwise                   = ''Traversal
               in Name -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Name
optic Type
s' Type
t Type
a Type
b

         opticType :: OpticType
opticType | Getting Any Type ([TyVarBndr_ Any], [Type], Type) -> Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any Type ([TyVarBndr_ Any], [Type], Type)
Traversal' Type ([TyVarBndr_ Any], [Type], Type)
_ForallT Type
a            = OpticType
GetterType
                   | Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) = OpticType
GetterType
                   -- isoCase                   = IsoType
                   | Bool
otherwise                 = OpticType
LensType

     (OpticType, OpticStab, [(Name, Int, [Int])])
-> Q (OpticType, OpticStab, [(Name, Int, [Int])])
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticType
opticType, OpticStab
defType, [(Name, Int, [Int])]
scaffolds)
  where
  consForDef :: [(Name, [Either Type Type])]
  consForDef :: [(Name, [Either Type Type])]
consForDef = ASetter
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  ([DefName], Type)
  (Either Type Type)
-> (([DefName], Type) -> Either Type Type)
-> [(Name, [([DefName], Type)])]
-> [(Name, [Either Type Type])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (ASetter
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  (Name, [([DefName], Type)])
  (Name, [Either Type Type])
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ASetter
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  (Name, [([DefName], Type)])
  (Name, [Either Type Type])
-> ((([DefName], Type) -> Identity (Either Type Type))
    -> (Name, [([DefName], Type)])
    -> Identity (Name, [Either Type Type]))
-> ASetter
     [(Name, [([DefName], Type)])]
     [(Name, [Either Type Type])]
     ([DefName], Type)
     (Either Type Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([DefName], Type)] -> Identity [Either Type Type])
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([([DefName], Type)] -> Identity [Either Type Type])
 -> (Name, [([DefName], Type)])
 -> Identity (Name, [Either Type Type]))
-> ((([DefName], Type) -> Identity (Either Type Type))
    -> [([DefName], Type)] -> Identity [Either Type Type])
-> (([DefName], Type) -> Identity (Either Type Type))
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([DefName], Type) -> Identity (Either Type Type))
-> [([DefName], Type)] -> Identity [Either Type Type]
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped) ([DefName], Type) -> Either Type Type
categorize [(Name, [([DefName], Type)])]
cons

  scaffolds :: [(Name, Int, [Int])]
  scaffolds :: [(Name, Int, [Int])]
scaffolds = [ (Name
n, [Either Type Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type Type]
ts, [Either Type Type] -> [Int]
rightIndices [Either Type Type]
ts) | (Name
n,[Either Type Type]
ts) <- [(Name, [Either Type Type])]
consForDef ]

  rightIndices :: [Either Type Type] -> [Int]
  rightIndices :: [Either Type Type] -> [Int]
rightIndices = (Either Type Type -> Bool) -> [Either Type Type] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Getting Any (Either Type Type) Type -> Either Type Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any (Either Type Type) Type
forall a b b'. Traversal (Either a b) (Either a b') b b'
_Right)

  -- Right: types for this definition
  -- Left : other types
  categorize :: ([DefName], Type) -> Either Type Type
  categorize :: ([DefName], Type) -> Either Type Type
categorize ([DefName]
defNames, Type
t)
    | DefName
defName DefName -> [DefName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DefName]
defNames = Type -> Either Type Type
forall a b. b -> Either a b
Right Type
t
    | Bool
otherwise               = Type -> Either Type Type
forall a b. a -> Either a b
Left  Type
t

  lensCase :: Bool
  lensCase :: Bool
lensCase = ((Name, [Either Type Type]) -> Bool)
-> [(Name, [Either Type Type])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type Type])
x -> Getting (Endo [Type]) (Name, [Either Type Type]) Type
-> (Name, [Either Type Type]) -> Int
forall a s. Getting (Endo [a]) s a -> s -> Int
lengthOf (([Either Type Type] -> Const (Endo [Type]) [Either Type Type])
-> (Name, [Either Type Type])
-> Const (Endo [Type]) (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Either Type Type] -> Const (Endo [Type]) [Either Type Type])
 -> (Name, [Either Type Type])
 -> Const (Endo [Type]) (Name, [Either Type Type]))
-> ((Type -> Const (Endo [Type]) Type)
    -> [Either Type Type] -> Const (Endo [Type]) [Either Type Type])
-> Getting (Endo [Type]) (Name, [Either Type Type]) Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Type]) [Either Type Type] (Either Type Type)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting (Endo [Type]) [Either Type Type] (Either Type Type)
-> ((Type -> Const (Endo [Type]) Type)
    -> Either Type Type -> Const (Endo [Type]) (Either Type Type))
-> (Type -> Const (Endo [Type]) Type)
-> [Either Type Type]
-> Const (Endo [Type]) [Either Type Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Const (Endo [Type]) Type)
-> Either Type Type -> Const (Endo [Type]) (Either Type Type)
forall a b b'. Traversal (Either a b) (Either a b') b b'
_Right) (Name, [Either Type Type])
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [(Name, [Either Type Type])]
consForDef

  -- isoCase :: Bool
  -- isoCase = case scaffolds of
  --             [(_,1,[0])] -> True
  --             _           -> False

data OpticStab = OpticStab     Name Type Type Type Type
               | OpticSa   Cxt Name Type Type


stabToType :: OpticStab -> Type
stabToType :: OpticStab -> Type
stabToType (OpticStab  Name
c Type
s Type
t Type
a Type
b) = [Type] -> Type -> Type
quantifyType [] (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b])
stabToType (OpticSa [Type]
cx Name
c Type
s   Type
a  ) = [Type] -> Type -> Type
quantifyType [Type]
cx (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a])

stabToContext :: OpticStab -> Cxt
stabToContext :: OpticStab -> [Type]
stabToContext OpticStab{}        = []
stabToContext (OpticSa [Type]
cx Name
_ Type
_ Type
_) = [Type]
cx

stabToOptic :: OpticStab -> Name
stabToOptic :: OpticStab -> Name
stabToOptic (OpticStab Name
c Type
_ Type
_ Type
_ Type
_) = Name
c
stabToOptic (OpticSa [Type]
_ Name
c Type
_ Type
_) = Name
c

stabToS :: OpticStab -> Type
stabToS :: OpticStab -> Type
stabToS (OpticStab Name
_ Type
s Type
_ Type
_ Type
_) = Type
s
stabToS (OpticSa [Type]
_ Name
_ Type
s Type
_) = Type
s

stabToA :: OpticStab -> Type
stabToA :: OpticStab -> Type
stabToA (OpticStab Name
_ Type
_ Type
_ Type
a Type
_) = Type
a
stabToA (OpticSa [Type]
_ Name
_ Type
_ Type
a) = Type
a

-- Compute the s t a b types given the outer type 's' and the
-- categorized field types. Left for fixed and Right for visited.
-- These types are "raw" and will be packaged into an 'OpticStab'
-- shortly after creation.
buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)
buildStab :: Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s [Either Type Type]
categorizedFields =
  do (Map Name Type
subA,Type
a) <- [Type] -> Q (Map Name Type, Type)
unifyTypes [Type]
targetFields
     let s' :: Type
s' = Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
subA Type
s

     -- compute possible type changes
     Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars)
     let (Type
t,Type
b) = ASetter (Type, Type) (Type, Type) Type Type
-> (Type -> Type) -> (Type, Type) -> (Type, Type)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Type, Type) (Type, Type) Type Type
forall a b. Traversal (a, a) (b, b) a b
both (Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub) (Type
s',Type
a)

     (Type, Type, Type, Type) -> Q (Type, Type, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
s',Type
t,Type
a,Type
b)

  where
  ([Type]
fixedFields, [Type]
targetFields) = [Either Type Type] -> ([Type], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Type Type]
categorizedFields

  fixedTypeVars, unfixedTypeVars :: Set Name
  fixedTypeVars :: Set Name
fixedTypeVars   = Set Name -> Set Name
closeOverKinds (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Getting (Endo [Name]) [Type] Name -> [Type] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
fixedFields
  unfixedTypeVars :: Set Name
unfixedTypeVars = Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Name
fixedTypeVars

  -- Compute the kind variables that appear in the kind of a type variable
  -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a
  -- type variable binder lacks an explicit kind annotation, this
  -- conservatively assumes that there are no kind variables. For example,
  -- @kindVarsOfTvb (y) = (y, {})@.
  kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
  kindVarsOfTvb :: TyVarBndr_ Any -> (Name, Set Name)
kindVarsOfTvb = (Name -> (Name, Set Name))
-> (Name -> Type -> (Name, Set Name))
-> TyVarBndr_ Any
-> (Name, Set Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ Any -> r
D.elimTV (\Name
n   -> (Name
n, Set Name
forall a. Set a
Set.empty))
                           (\Name
n Type
k -> (Name
n, Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
k))

  -- For each type variable name that appears in @s@, map to the kind variables
  -- that appear in that type variable's kind.
  sKindVarMap :: Map Name (Set Name)
  sKindVarMap :: Map Name (Set Name)
sKindVarMap = [(Name, Set Name)] -> Map Name (Set Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Set Name)] -> Map Name (Set Name))
-> [(Name, Set Name)] -> Map Name (Set Name)
forall a b. (a -> b) -> a -> b
$ (TyVarBndr_ Any -> (Name, Set Name))
-> [TyVarBndr_ Any] -> [(Name, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> (Name, Set Name)
forall flag. TyVarBndr_ Any -> (Name, Set Name)
kindVarsOfTvb ([TyVarBndr_ Any] -> [(Name, Set Name)])
-> [TyVarBndr_ Any] -> [(Name, Set Name)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s]

  lookupSKindVars :: Name -> Set Name
  lookupSKindVars :: Name -> Set Name
lookupSKindVars Name
n = Set Name -> Maybe (Set Name) -> Set Name
forall a. a -> Maybe a -> a
fromMaybe Set Name
forall a. Set a
Set.empty (Maybe (Set Name) -> Set Name) -> Maybe (Set Name) -> Set Name
forall a b. (a -> b) -> a -> b
$ Name -> Map Name (Set Name) -> Maybe (Set Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Set Name)
sKindVarMap

  -- Consider this example (adapted from #972):
  --
  --   data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int }
  --   $(makeLenses ''Dart)
  --
  -- When generating a Lens for `direction`, the type variable `s` should be
  -- fixed. But note that (s :: k), and as a result, the kind variable `k`
  -- needs to be fixed as well. This is because a type like this would be
  -- ill kinded:
  --
  --   direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction
  --
  -- However, only `s` is mentioned syntactically in the type of `_arc`, so we
  -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this
  -- with `closeOverKinds`, which does the following:
  --
  -- 1. Use freeVariablesWellScoped to compute the free type variables of
  --    `Dart (s :: k)`, which gives us `(s :: k)`.
  -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up
  --    the kind variables in the type variable's kind. In the case of `s`,
  --    the only kind variable is `k`.
  -- 3. Add these kind variables to the set of fixed type variables.
  closeOverKinds :: Set Name -> Set Name
  closeOverKinds :: Set Name -> Set Name
closeOverKinds Set Name
st = (Set Name -> Set Name -> Set Name)
-> Set Name -> Set (Set Name) -> Set Name
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
forall a. Set a
Set.empty ((Name -> Set Name) -> Set Name -> Set (Set Name)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> Set Name
lookupSKindVars Set Name
st) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
st

-- Build the signature and definition for a single field optic.
-- In the case of a singleton constructor irrefutable matches are
-- used to enable the resulting lenses to be used on a bottom value.
makeFieldOptic ::
  LensRules ->
  (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->
  HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticType
opticType, OpticStab
defType, [(Name, Int, [Int])]
cons)) = do
  Set Name
locals <- StateT (Set Name) Q (Set Name)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  HasFieldClasses ()
addName
  DecsQ -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (DecsQ -> StateT (Set Name) Q [Dec])
-> DecsQ -> StateT (Set Name) Q [Dec]
forall a b. (a -> b) -> a -> b
$ do
    [Q Dec]
cls <- Set Name -> Q [Q Dec]
mkCls Set Name
locals
    [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Q Dec]
cls [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
sig [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
def)
  where
  mkCls :: Set Name -> Q [Q Dec]
mkCls Set Name
locals = case DefName
defName of
                 MethodName Name
c Name
n | LensRules -> Bool
_generateClasses LensRules
rules ->
                  do Bool
classExists <- Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (Name -> String
forall a. Show a => a -> String
show Name
c)
                     [Q Dec] -> Q [Q Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> Bool
|| Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
c Set Name
locals then [] else [OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
c Name
n])
                 DefName
_ -> [Q Dec] -> Q [Q Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  addName :: HasFieldClasses ()
addName = case DefName
defName of
            MethodName Name
c Name
_ -> Name -> HasFieldClasses ()
addFieldClassName Name
c
            DefName
_              -> () -> HasFieldClasses ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  sig :: [Q Dec]
sig = case DefName
defName of
          DefName
_ | Bool -> Bool
not (LensRules -> Bool
_generateSigs LensRules
rules) -> []
          TopName Name
n -> [Name -> PredQ -> Q Dec
sigD Name
n (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
          MethodName{} -> []

  fun :: Name -> [Q Dec]
fun Name
n = Name -> [ClauseQ] -> Q Dec
funD Name
n [ClauseQ]
clauses Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n

  def :: [Q Dec]
def = case DefName
defName of
          TopName Name
n      -> Name -> [Q Dec]
fun Name
n
          MethodName Name
c Name
n -> [OpticStab -> Name -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
c (Name -> [Q Dec]
fun Name
n)]

  clauses :: [ClauseQ]
clauses = LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons

------------------------------------------------------------------------
-- Field class generation
------------------------------------------------------------------------

makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
className Name
methodName =
  CxtQ -> Name -> [TyVarBndr_ Any] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([PredQ] -> CxtQ
cxt []) Name
className [Name -> TyVarBndr_ Any
D.plainTV Name
s, Name -> TyVarBndr_ Any
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
         [Name -> PredQ -> Q Dec
sigD Name
methodName (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
  where
  methodType :: Type
methodType = Set Name -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
s,Name
a])
                             (OpticStab -> [Type]
stabToContext OpticStab
defType)
             (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
defType Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
s,Name -> Type
VarT Name
a]
  s :: Name
s = String -> Name
mkName String
"s"
  a :: Name
a = String -> Name
mkName String
"a"

-- | Build an instance for a field. If the field’s type contains any type
-- families, will produce an equality constraint to avoid a type family
-- application in the instance head.
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance :: OpticStab -> Name -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
className [Q Dec]
decs =
  Type -> Q Bool
containsTypeFamilies Type
a Q Bool -> (Bool -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Q Dec
pickInstanceDec
  where
  s :: Type
s = OpticStab -> Type
stabToS OpticStab
defType
  a :: Type
a = OpticStab -> Type
stabToA OpticStab
defType

  containsTypeFamilies :: Type -> Q Bool
containsTypeFamilies = Type -> Q Bool
go (Type -> Q Bool) -> (Type -> PredQ) -> Type -> Q Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> PredQ
D.resolveTypeSynonyms
    where
    go :: Type -> Q Bool
go (ConT Name
nm) = (\Info
i -> case Info
i of FamilyI Dec
d [Dec]
_ -> Dec -> Bool
isTypeFamily Dec
d; Info
_ -> Bool
False)
                   (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm
    go Type
ty = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type -> [Type]
forall a. Data a => a -> [a]
children Type
ty)

#if MIN_VERSION_template_haskell(2,11,0)
  isTypeFamily :: Dec -> Bool
isTypeFamily OpenTypeFamilyD{}       = Bool
True
  isTypeFamily ClosedTypeFamilyD{}     = Bool
True
#elif MIN_VERSION_template_haskell(2,9,0)
  isTypeFamily (FamilyD TypeFam _ _ _) = True
  isTypeFamily ClosedTypeFamilyD{}     = True
#else
  isTypeFamily (FamilyD TypeFam _ _ _) = True
#endif
  isTypeFamily Dec
_ = Bool
False

  pickInstanceDec :: Bool -> Q Dec
pickInstanceDec Bool
hasFamilies
    | Bool
hasFamilies = do
        Type
placeholder <- Name -> Type
VarT (Name -> Type) -> Q Name -> PredQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"a"
        [PredQ] -> [Type] -> Q Dec
mkInstanceDec
          [Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
D.equalPred Type
placeholder Type
a)]
          [Type
s, Type
placeholder]
    | Bool
otherwise = [PredQ] -> [Type] -> Q Dec
mkInstanceDec [] [Type
s, Type
a]

  mkInstanceDec :: [PredQ] -> [Type] -> Q Dec
mkInstanceDec [PredQ]
context [Type]
headTys =
    CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt [PredQ]
context) (Type -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
className Name -> [Type] -> Type
`conAppsT` [Type]
headTys)) [Q Dec]
decs

------------------------------------------------------------------------
-- Optic clause generators
------------------------------------------------------------------------

makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons =
  case OpticType
opticType of

    -- IsoType    -> [ makeIsoClause conName | (conName, _, _) <- cons ]

    OpticType
GetterType -> [ Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount [Int]
fields
                    | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons ]

    OpticType
LensType   -> [ Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [Int]
fields Bool
irref
                    | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons ]
      where
      irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules
           Bool -> Bool -> Bool
&& [(Name, Int, [Int])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [Int])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

-- Construct an optic clause that returns an unmodified value
-- given a constructor name and the number of fields on that
-- constructor.
makePureClause :: Name -> Int -> ClauseQ
makePureClause :: Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
     -- clause: _ (Con x1..xn) = pure (Con x1..xn)
     [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)]
            (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'pure) ([ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))))
            []

-- Construct an optic clause suitable for a Getter or Fold
-- by visited the fields identified by their 0 indexed positions
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount []     = Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
  do Name
f  <- String -> Q Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)

     let pats :: [Int] -> [Name] -> [PatQ]
pats (Int
i:[Int]
is) (Name
y:[Name]
ys)
           | Int
i Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = Name -> PatQ
varP Name
y PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [PatQ]
pats [Int]
is [Name]
ys
           | Bool
otherwise = PatQ
wildP PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [PatQ]
pats [Int]
is (Name
yName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ys)
         pats [Int]
is     [Name]
_  = (Int -> PatQ) -> [Int] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ -> Int -> PatQ
forall a b. a -> b -> a
const PatQ
wildP) [Int]
is

         fxs :: [ExpQ]
fxs   = [ ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (Name -> ExpQ
varE Name
x) | Name
x <- [Name]
xs ]
         body :: ExpQ
body  = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a ExpQ
b -> [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE '(<*>), ExpQ
a, ExpQ
b])
                       (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'phantom) ([ExpQ] -> ExpQ
forall a. [a] -> a
head [ExpQ]
fxs))
                       ([ExpQ] -> [ExpQ]
forall a. [a] -> [a]
tail [ExpQ]
fxs)

     -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn
     [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name -> [PatQ] -> PatQ
conP Name
conName ([Int] -> [Name] -> [PatQ]
pats [Int
0..Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
            (ExpQ -> BodyQ
normalB ExpQ
body)
            []

-- Build a clause that updates the field at the given indexes
-- When irref is 'True' the value with me matched with an irrefutable
-- pattern. This is suitable for Lens and Traversal construction
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ =
  Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
conName Int
fieldCount (Int
field:[Int]
fields) Bool
irref =
  do Name
f  <- String -> Q Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
     [Name]
ys <- String -> Int -> Q [Name]
newNames String
"y" (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)

     let xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Name
x) -> ASetter [Name] [Name] Name Name -> Name -> [Name] -> [Name]
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index [Name] -> Traversal' [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index [Name]
i) Name
x) [Name]
xs ([Int] -> [Name] -> [(Int, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int
fieldInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
fields) [Name]
ys)

         mkFx :: Int -> ExpQ
mkFx Int
i = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (Name -> ExpQ
varE ([Name]
xs [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i))

         body0 :: ExpQ
body0 = [ExpQ] -> ExpQ
appsE [ Name -> ExpQ
varE 'fmap
                       , [PatQ] -> ExpQ -> ExpQ
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ys) ([ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs'))
                       , Int -> ExpQ
mkFx Int
field
                       ]

         body :: ExpQ
body = (ExpQ -> Int -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a Int
b -> [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE '(<*>), ExpQ
a, Int -> ExpQ
mkFx Int
b]) ExpQ
body0 [Int]
fields

     let wrap :: PatQ -> PatQ
wrap = if Bool
irref then PatQ -> PatQ
tildeP else PatQ -> PatQ
forall a. a -> a
id

     [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, PatQ -> PatQ
wrap (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))]
            (ExpQ -> BodyQ
normalB ExpQ
body)
            []

------------------------------------------------------------------------
-- Unification logic
------------------------------------------------------------------------

-- The field-oriented optic generation supports incorporating fields
-- with distinct but unifiable types into a single definition.

-- Unify the given list of types, if possible, and return the
-- substitution used to unify the types for unifying the outer
-- type when building a definition's type signature.
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
x:[Type]
xs) = ((Map Name Type, Type) -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> [Type] -> Q (Map Name Type, Type)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Map Name Type -> Type -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> Type -> Q (Map Name Type, Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1) (Map Name Type
forall k a. Map k a
Map.empty, Type
x) [Type]
xs
unifyTypes []     = String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unifyTypes: Bug: Unexpected empty list"


-- Attempt to unify two given types using a running substitution
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub (VarT Name
x) Type
y
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
r Type
y
unify1 Map Name Type
sub Type
x (VarT Name
y)
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
y Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
x Type
r
unify1 Map Name Type
sub Type
x Type
y
  | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
y = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (AppT Type
f1 Type
x1) (AppT Type
f2 Type
x2) =
  do (Map Name Type
sub1, Type
f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub  Type
f1 Type
f2
     (Map Name Type
sub2, Type
x) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub1 Type
x1 Type
x2
     (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub2, Type -> Type -> Type
AppT (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub2 Type
f) Type
x)
unify1 Map Name Type
sub Type
x (VarT Name
y)
  | Getting (Endo [Name]) Type Name -> Name -> Type -> Bool
forall a s. Eq a => Getting (Endo [a]) s a -> a -> s -> Bool
elemOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
      String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to unify types: occurs check"
  | Bool
otherwise = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
y Type
x Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (VarT Name
x) Type
y = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
y (Name -> Type
VarT Name
x)

-- TODO: Unify contexts
unify1 Map Name Type
sub (ForallT [TyVarBndr_ Any]
v1 [] Type
t1) (ForallT [TyVarBndr_ Any]
v2 [] Type
t2) =
     -- This approach works out because by the time this code runs
     -- all of the type variables have been renamed. No risk of shadowing.
  do (Map Name Type
sub1,Type
t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
t1 Type
t2
     [TyVarBndr_ Any]
v <- ([TyVarBndr_ Any] -> [TyVarBndr_ Any])
-> Q [TyVarBndr_ Any] -> Q [TyVarBndr_ Any]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. Eq a => [a] -> [a]
nub ((TyVarBndr_ Any -> Q (TyVarBndr_ Any))
-> [TyVarBndr_ Any] -> Q [TyVarBndr_ Any]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub1) ([TyVarBndr_ Any]
v1[TyVarBndr_ Any] -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. [a] -> [a] -> [a]
++[TyVarBndr_ Any]
v2))
     (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub1, [TyVarBndr_ Any] -> [Type] -> Type -> Type
ForallT [TyVarBndr_ Any]
v [] Type
t)

unify1 Map Name Type
_ Type
x Type
y = String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to unify types: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Type, Type) -> String
forall a. Show a => a -> String
show (Type
x,Type
y))

-- Perform a limited substitution on type variables. This is used
-- when unifying rank-2 fields when trying to achieve a Getter or Fold.
limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
limitedSubst :: Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub TyVarBndr_ Any
tv
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName TyVarBndr_ Any
tv) Map Name Type
sub =
       case Type
r of
         VarT Name
m -> Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub ((Name -> Name) -> TyVarBndr_ Any -> TyVarBndr_ Any
forall flag. (Name -> Name) -> TyVarBndr_ Any -> TyVarBndr_ Any
D.mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
m) TyVarBndr_ Any
tv)
         Type
_ -> String -> Q (TyVarBndr_ Any)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
  | Bool
otherwise = TyVarBndr_ Any -> Q (TyVarBndr_ Any)
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndr_ Any
tv

-- Apply a substitution to a type. This is used after unifying
-- the types of the fields in unifyTypes.
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub = (Type -> Maybe Type) -> Type -> Type
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite Type -> Maybe Type
aux
  where
  aux :: Type -> Maybe Type
aux (VarT Name
n) = Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
sub
  aux Type
_        = Maybe Type
forall a. Maybe a
Nothing

------------------------------------------------------------------------
-- Field generation parameters
------------------------------------------------------------------------

{- |
Rules used to generate lenses. The fields are intentionally not exported; to create your own rules, see lenses in the “Configuring lens rules” section. You'd have to customise one of the existing rulesets; for an example of doing that, see 'makeLensesWith'.
-}
data LensRules = LensRules
  { LensRules -> Bool
_simpleLenses    :: Bool
  , LensRules -> Bool
_generateSigs    :: Bool
  , LensRules -> Bool
_generateClasses :: Bool
  -- , _allowIsos       :: Bool
  , LensRules -> Bool
_allowUpdates    :: Bool -- Allow Lens/Traversal (otherwise Getter/Fold)
  , LensRules -> Bool
_lazyPatterns    :: Bool
  -- Type Name -> Field Names -> Target Field Name -> Definition Names
  , LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef      :: Name -> [Name] -> Name -> [DefName]
  -- Type Name -> (Class Name, Top Method)
  , LensRules -> Name -> Maybe (Name, Name)
_classyLenses    :: Name -> Maybe (Name, Name)
  }

{- |
Name to give to a generated lens (used in 'lensField').
-}
data DefName
  = TopName Name          -- ^ Simple top-level definiton name
  | MethodName Name Name  -- ^ 'makeFields'-style class name and method name
  deriving (Int -> DefName -> String -> String
[DefName] -> String -> String
DefName -> String
(Int -> DefName -> String -> String)
-> (DefName -> String)
-> ([DefName] -> String -> String)
-> Show DefName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DefName] -> String -> String
$cshowList :: [DefName] -> String -> String
show :: DefName -> String
$cshow :: DefName -> String
showsPrec :: Int -> DefName -> String -> String
$cshowsPrec :: Int -> DefName -> String -> String
Show, DefName -> DefName -> Bool
(DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool) -> Eq DefName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c== :: DefName -> DefName -> Bool
Eq, Eq DefName
Eq DefName
-> (DefName -> DefName -> Ordering)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> DefName)
-> (DefName -> DefName -> DefName)
-> Ord DefName
DefName -> DefName -> Bool
DefName -> DefName -> Ordering
DefName -> DefName -> DefName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmax :: DefName -> DefName -> DefName
>= :: DefName -> DefName -> Bool
$c>= :: DefName -> DefName -> Bool
> :: DefName -> DefName -> Bool
$c> :: DefName -> DefName -> Bool
<= :: DefName -> DefName -> Bool
$c<= :: DefName -> DefName -> Bool
< :: DefName -> DefName -> Bool
$c< :: DefName -> DefName -> Bool
compare :: DefName -> DefName -> Ordering
$ccompare :: DefName -> DefName -> Ordering
$cp1Ord :: Eq DefName
Ord)


------------------------------------------------------------------------
-- Miscellaneous utility functions
------------------------------------------------------------------------

liftState :: Monad m => m a -> StateT s m a
liftState :: m a -> StateT s m a
liftState m a
act = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\s
s -> (a -> (a, s)) -> m a -> m (a, s)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> s -> (a, s)) -> s -> a -> (a, s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) s
s) m a
act)