{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif

-----------------------------------------------------------------------------

-- |

-- Module      :  Control.Lens.Internal.FieldTH

-- Copyright   :  (C) 2014-2016 Edward Kmett, (C) 2014 Eric Mertens

-- License     :  BSD-style (see the file LICENSE)

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  experimental

-- Portability :  non-portable

--

-----------------------------------------------------------------------------


module Control.Lens.Internal.FieldTH
  ( LensRules(..)
  , FieldNamer
  , DefName(..)
  , ClassyNamer
  , makeFieldOptics
  , makeFieldOpticsForDec
  , makeFieldOpticsForDec'
  , makeFieldOpticExp
  , HasFieldClasses
  ) where

import Prelude ()

import Control.Lens.At
import Control.Lens.Fold
import Control.Lens.Indexed
import Control.Lens.Internal.TH
import Control.Lens.Internal.Prelude
import Control.Lens.Lens
import Control.Lens.Plated
import Control.Lens.Prism
import Control.Lens.Setter
import Control.Lens.Getter
import Control.Lens.Tuple
import Control.Lens.Traversal
import Control.Monad
import Control.Monad.State
import Language.Haskell.TH.Lens
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
import Data.Maybe (fromMaybe,isJust,maybeToList)
import Data.List (nub)
import Data.Either (partitionEithers)
import Data.Semigroup (Any (..))
import Data.Set.Lens
import           Data.Map ( Map )
import           Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Traversable as T

------------------------------------------------------------------------

-- 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

makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec 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)
-> (Dec -> StateT (Set Name) Q [Dec]) -> Dec -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules

makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]
makeFieldOpticsForDec' :: LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules = LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> (Dec -> StateT (Set Name) Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo)
-> (Dec -> Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q DatatypeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Q DatatypeInfo
D.normalizeDec

-- | Build the field optic for a single record field as an /expression/, given

-- that field's selector name. This is the engine behind

-- 'Control.Lens.TH.makeLens'. It reuses the very same scaffold and clause

-- generator as 'makeFieldOptics'\/'makeLenses', so the optic it produces is the

-- one 'makeLenses' would declare for that field: an 'Control.Lens.Iso.Iso' for

-- a sole single-field constructor, a 'Control.Lens.Traversal.Traversal' for a

-- field absent from some constructors, and a 'Control.Lens.Lens' otherwise.

--

-- The generated clauses are bound in a @let@ so the result is an anonymous

-- optic expression rather than a top-level declaration. Its type is left to be

-- inferred at the splice site.

makeFieldOpticExp :: LensRules -> Name {- ^ record field selector -} -> ExpQ
makeFieldOpticExp :: LensRules -> Name -> ExpQ
makeFieldOpticExp LensRules
rules Name
fieldName =
  do DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
fieldName
     let s :: Type
s    = DatatypeInfo -> Type
datatypeTypeKinded DatatypeInfo
info
         cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons     DatatypeInfo
info
     [(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 (((Name, [(Maybe Name, Type)])
 -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
folded (((Name, [(Maybe Name, Type)])
  -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
 -> [(Name, [(Maybe Name, Type)])]
 -> Const (Endo [Name]) [(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
Lens
  (Name, [(Maybe Name, Type)])
  (Name, [(Maybe Name, Type)])
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
_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
. ((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> [(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(Maybe Name, Type)] (Maybe Name, Type)
folded (((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
 -> [(Maybe Name, Type)]
 -> Const (Endo [Name]) [(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
Lens
  (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_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 => IndexedFold Int (f a) a
IndexedFold Int (Maybe Name) Name
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
     Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
sameField [Name]
allFields) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
       String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"makeLens: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
fieldName
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a record field of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
     Name
funNm <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"optic"
     let defName :: DefName
defName = Name -> DefName
TopName Name
funNm
         assignDef :: Maybe Name -> [(DefName, Maybe Name)]
assignDef Maybe Name
mName | Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Name -> Bool
sameField Maybe Name
mName = [(DefName
defName, Maybe Name
mName)]
                         | Bool
otherwise                   = []
         defCons :: [(Name, [([(DefName, Maybe Name)], Type)])]
defCons = ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (Maybe Name)
  [(DefName, Maybe Name)]
-> (Maybe Name -> [(DefName, Maybe Name)])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([(DefName, Maybe Name)], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, [(Maybe Name, Type)])
 -> Identity (Name, [([(DefName, Maybe Name)], Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Identity [(Name, [([(DefName, Maybe Name)], Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Name, [(Maybe Name, Type)])
  -> Identity (Name, [([(DefName, Maybe Name)], Type)]))
 -> [(Name, [(Maybe Name, Type)])]
 -> Identity [(Name, [([(DefName, Maybe Name)], Type)])])
-> ((Maybe Name -> Identity [(DefName, Maybe Name)])
    -> (Name, [(Maybe Name, Type)])
    -> Identity (Name, [([(DefName, Maybe Name)], Type)]))
-> ASetter
     [(Name, [(Maybe Name, Type)])]
     [(Name, [([(DefName, Maybe Name)], Type)])]
     (Maybe Name)
     [(DefName, Maybe Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Maybe Name, Type)]
 -> Identity [([(DefName, Maybe Name)], Type)])
-> (Name, [(Maybe Name, Type)])
-> Identity (Name, [([(DefName, Maybe Name)], Type)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [(Maybe Name, Type)])
  (Name, [([(DefName, Maybe Name)], Type)])
  [(Maybe Name, Type)]
  [([(DefName, Maybe Name)], Type)]
_2 (([(Maybe Name, Type)]
  -> Identity [([(DefName, Maybe Name)], Type)])
 -> (Name, [(Maybe Name, Type)])
 -> Identity (Name, [([(DefName, Maybe Name)], Type)]))
-> ((Maybe Name -> Identity [(DefName, Maybe Name)])
    -> [(Maybe Name, Type)]
    -> Identity [([(DefName, Maybe Name)], Type)])
-> (Maybe Name -> Identity [(DefName, Maybe Name)])
-> (Name, [(Maybe Name, Type)])
-> Identity (Name, [([(DefName, Maybe Name)], Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Identity ([(DefName, Maybe Name)], Type))
-> [(Maybe Name, Type)]
-> Identity [([(DefName, Maybe Name)], Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Maybe Name, Type) -> Identity ([(DefName, Maybe Name)], Type))
 -> [(Maybe Name, Type)]
 -> Identity [([(DefName, Maybe Name)], Type)])
-> ((Maybe Name -> Identity [(DefName, Maybe Name)])
    -> (Maybe Name, Type) -> Identity ([(DefName, Maybe Name)], Type))
-> (Maybe Name -> Identity [(DefName, Maybe Name)])
-> [(Maybe Name, Type)]
-> Identity [([(DefName, Maybe Name)], Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Identity [(DefName, Maybe Name)])
-> (Maybe Name, Type) -> Identity ([(DefName, Maybe Name)], Type)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Maybe Name, Type)
  ([(DefName, Maybe Name)], Type)
  (Maybe Name)
  [(DefName, Maybe Name)]
_1) Maybe Name -> [(DefName, Maybe Name)]
assignDef [(Name, [(Maybe Name, Type)])]
fieldCons
     (OpticType
opticType, OpticStab
_stab, [(Name, Int, [(Maybe Name, Int)])]
scaffolds) <- LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
defCons DefName
defName
     [Q Dec] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
funNm (LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
scaffolds)] (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
funNm)
  where
  sameField :: Name -> Bool
sameField Name
n = Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
fieldName

-- | 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 Set String
keywords <- Q (Set String) -> StateT (Set Name) Q (Set String)
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q (Set String)
activeKeywords
     Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef <- Q (Map
     DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
     (Set Name)
     Q
     (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Map
      DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> StateT
      (Set Name)
      Q
      (Map
         DefName
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> Q (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
     (Set Name)
     Q
     (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 (((Name, [(Maybe Name, Type)])
 -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
folded (((Name, [(Maybe Name, Type)])
  -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
 -> [(Name, [(Maybe Name, Type)])]
 -> Const (Endo [Name]) [(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
Lens
  (Name, [(Maybe Name, Type)])
  (Name, [(Maybe Name, Type)])
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
_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
. ((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> [(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(Maybe Name, Type)] (Maybe Name, Type)
folded (((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
 -> [(Maybe Name, Type)]
 -> Const (Endo [Name]) [(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
Lens
  (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_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 => IndexedFold Int (f a) a
IndexedFold Int (Maybe Name) Name
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
       let defCons :: [(Name, [([(DefName, Maybe Name)], Type)])]
defCons    = ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (Maybe Name)
  [(DefName, Maybe Name)]
-> (Maybe Name -> [(DefName, Maybe Name)])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([(DefName, Maybe Name)], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (Maybe Name)
  [(DefName, Maybe Name)]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels ([Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
           allDefs :: Set DefName
allDefs    = Getting
  (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
-> [(Name, [([(DefName, Maybe Name)], Type)])] -> Set DefName
forall a s. Getting (Set a) s a -> s -> Set a
setOf (([(DefName, Maybe Name)]
 -> Const (Set DefName) [(DefName, Maybe Name)])
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels (([(DefName, Maybe Name)]
  -> Const (Set DefName) [(DefName, Maybe Name)])
 -> [(Name, [([(DefName, Maybe Name)], Type)])]
 -> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])])
-> ((DefName -> Const (Set DefName) DefName)
    -> [(DefName, Maybe Name)]
    -> Const (Set DefName) [(DefName, Maybe Name)])
-> Getting
     (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, Maybe Name)
 -> Const (Set DefName) (DefName, Maybe Name))
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(DefName, Maybe Name)] (DefName, Maybe Name)
folded (((DefName, Maybe Name)
  -> Const (Set DefName) (DefName, Maybe Name))
 -> [(DefName, Maybe Name)]
 -> Const (Set DefName) [(DefName, Maybe Name)])
-> ((DefName -> Const (Set DefName) DefName)
    -> (DefName, Maybe Name)
    -> Const (Set DefName) (DefName, Maybe Name))
-> (DefName -> Const (Set DefName) DefName)
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefName -> Const (Set DefName) DefName)
-> (DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (DefName, Maybe Name) (DefName, Maybe Name) DefName DefName
_1) [(Name, [([(DefName, Maybe Name)], Type)])]
defCons
       ((DefName, Maybe Name) -> Q ()) -> [(DefName, Maybe Name)] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Set String -> Name -> (DefName, Maybe Name) -> Q ()
checkDefName Set String
keywords Name
tyName) (Getting
  (Endo [(DefName, Maybe Name)])
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (DefName, Maybe Name)
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> [(DefName, Maybe Name)]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (([(DefName, Maybe Name)]
 -> Const (Endo [(DefName, Maybe Name)]) [(DefName, Maybe Name)])
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Const
     (Endo [(DefName, Maybe Name)])
     [(Name, [([(DefName, Maybe Name)], Type)])]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels (([(DefName, Maybe Name)]
  -> Const (Endo [(DefName, Maybe Name)]) [(DefName, Maybe Name)])
 -> [(Name, [([(DefName, Maybe Name)], Type)])]
 -> Const
      (Endo [(DefName, Maybe Name)])
      [(Name, [([(DefName, Maybe Name)], Type)])])
-> (((DefName, Maybe Name)
     -> Const (Endo [(DefName, Maybe Name)]) (DefName, Maybe Name))
    -> [(DefName, Maybe Name)]
    -> Const (Endo [(DefName, Maybe Name)]) [(DefName, Maybe Name)])
-> Getting
     (Endo [(DefName, Maybe Name)])
     [(Name, [([(DefName, Maybe Name)], Type)])]
     (DefName, Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, Maybe Name)
 -> Const (Endo [(DefName, Maybe Name)]) (DefName, Maybe Name))
-> [(DefName, Maybe Name)]
-> Const (Endo [(DefName, Maybe Name)]) [(DefName, Maybe Name)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(DefName, Maybe Name)] (DefName, Maybe Name)
folded) [(Name, [([(DefName, Maybe Name)], Type)])]
defCons)
       Map
  DefName
  (Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Q (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map DefName (f a) -> f (Map DefName a)
T.sequenceA ((DefName
 -> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Set DefName
-> Map
     DefName
     (Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
defCons) Set DefName
allDefs)

     let defs :: [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef
     case LensRules -> ClassyNamer
_classyLenses LensRules
rules Name
tyName of
       Just (Name
className, Name
methodName) ->
         do Q () -> StateT (Set Name) Q ()
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> StateT (Set Name) Q ()) -> Q () -> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ Set String -> Name -> Name -> Q ()
checkClassyName Set String
keywords Name
tyName Name
methodName
            LensRules
-> Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
       Maybe (Name, Name)
Nothing -> do [[Dec]]
decss <- ((DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
                     [Dec] -> StateT (Set Name) Q [Dec]
forall a. a -> StateT (Set Name) Q a
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 :: forall a b (f :: * -> *).
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
Lens
  (Name, [(a, Type)]) (Name, [(b, Type)]) [(a, Type)] [(b, Type)]
_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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
Lens (a, Type) (b, Type) a b
_1

  -- Map a (possibly missing) field's name to zero-to-many optic definitions

  expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
  expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields Maybe Name
mName = (\DefName
x -> (DefName
x, Maybe Name
mName)) (DefName -> (DefName, Maybe Name))
-> [DefName] -> [(DefName, Maybe Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
mName [Name] -> (Name -> [DefName]) -> [DefName]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LensRules -> FieldNamer
_fieldToDef LensRules
rules Name
tyName [Name]
allFields)

-- | Fail early, in 'Q', when a 'FieldNamer' generates a definition or method

-- name that is reserved in the splice's language. Without this check GHC

-- rejects the generated declarations with an "Illegal variable name" error that

-- names neither the field nor the data type responsible. See issue #762.

checkDefName :: Set String -> Name -> (DefName, Maybe Name) -> Q ()
checkDefName :: Set String -> Name -> (DefName, Maybe Name) -> Q ()
checkDefName Set String
keywords Name
tyName (DefName
defName, Maybe Name
field) =
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> String
nameBase Name
n String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
keywords) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"Cannot generate an optic named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' for the field"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
tyName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"':"
    , String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is a Haskell keyword or is reserved by an enabled extension."
    , String
"Possible fixes: rename the field, or use a 'lensField' naming rule that"
    , String
"avoids reserved names, e.g. by wrapping the namer with 'avoidKeywordsNamer'"
    , String
"or 'avoidNamesNamer (haskellKeywords <> ghcExtensionKeywords)'."
    ]
  where
  n :: Name
n = case DefName
defName of
        TopName Name
x      -> Name
x
        MethodName Name
_ Name
x -> Name
x
  fieldMsg :: String
fieldMsg = String -> (Name -> String) -> Maybe Name -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Name
f -> String
" '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") Maybe Name
field

-- | As 'checkDefName', but for the class method generated by a 'ClassyNamer'

-- (e.g. 'makeClassy' on a type named @Where@).

checkClassyName :: Set String -> Name -> Name -> Q ()
checkClassyName :: Set String -> Name -> Name -> Q ()
checkClassyName Set String
keywords Name
tyName Name
methodName =
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> String
nameBase Name
methodName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
keywords) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"Cannot generate a classy lens method named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
methodName
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
tyName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"':"
    , String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
methodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is a Haskell keyword or is reserved by an enabled extension."
    , String
"Possible fixes: rename the data type, or use a 'lensClass' naming rule"
    , String
"that avoids reserved names, e.g. by wrapping the namer with"
    , String
"'avoidKeywordsClassyNamer' or"
    , String
"'avoidNamesClassyNamer (haskellKeywords <> ghcExtensionKeywords)'."
    ]

-- | Normalized the Con type into a uniform positional representation,

-- eliminating the variance between records, infix constructors, and normal

-- constructors.

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 a. a -> Q a
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 {b} {a}. HasTypeVars b => Maybe a -> b -> (Maybe a, b)
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 a b. (a -> b) -> [a] -> [b]
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 -> b -> (Maybe a, b)
checkForExistentials Maybe a
_ b
fieldtype
      | (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ ()]
unallowable
      = (Maybe a
forall a. Maybe a
Nothing, b
fieldtype)
      where
        used :: Set Name
used        = Getting (Set Name) b Name -> b -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) b Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' b Name
typeVars b
fieldtype
        unallowable :: [TyVarBndr_ ()]
unallowable = ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
con
    checkForExistentials Maybe a
fieldname b
fieldtype = (Maybe a
fieldname, b
fieldtype)

data OpticType = GetterType | LensType | 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, Maybe Name)], Type)])] {- ^ normalized constructors          -} ->
  DefName                                     {- ^ target definition                -} ->
  Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
              {- ^ optic type, definition type, field count, target fields -}
buildScaffold :: LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], 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 (Maybe Name, Type)])]
consForDef [(Name, [Either Type (Maybe Name, Type)])]
-> ((Name, [Either Type (Maybe Name, Type)])
    -> (Name, [Either Type Type]))
-> [(Name, [Either Type Type])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [Either Type (Maybe Name, Type)])
  (Name, [Either Type Type])
  [Either Type (Maybe Name, Type)]
  [Either Type Type]
_2 (([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
 -> (Name, [Either Type (Maybe Name, Type)])
 -> Identity (Name, [Either Type Type]))
-> (((Maybe Name, Type) -> Identity Type)
    -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> ((Maybe Name, Type) -> Identity Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type]
Setter
  [Either Type (Maybe Name, Type)]
  [Either Type Type]
  (Either Type (Maybe Name, Type))
  (Either Type Type)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((Either Type (Maybe Name, Type) -> Identity (Either Type Type))
 -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (((Maybe Name, Type) -> Identity Type)
    -> Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> ((Maybe Name, Type) -> Identity Type)
-> [Either Type (Maybe Name, Type)]
-> Identity [Either Type Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Identity Type)
-> Either Type (Maybe Name, Type) -> Identity (Either Type Type)
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
_Right (((Maybe Name, Type) -> Identity Type)
 -> (Name, [Either Type (Maybe Name, Type)])
 -> Identity (Name, [Either Type Type]))
-> ((Maybe Name, Type) -> Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> (Name, [Either Type Type])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Maybe Name, Type) -> Type
forall a b. (a, b) -> b
snd))

     let defType :: OpticStab
defType
           | Just ([TyVarBndrSpec]
_,[Type]
cx,Type
a') <- Getting
  (First ([TyVarBndrSpec], [Type], Type))
  Type
  ([TyVarBndrSpec], [Type], Type)
-> Type -> Maybe ([TyVarBndrSpec], [Type], Type)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting
  (First ([TyVarBndrSpec], [Type], Type))
  Type
  ([TyVarBndrSpec], [Type], Type)
Prism' Type ([TyVarBndrSpec], [Type], Type)
_ForallT Type
a =
               let optic :: Name
optic | Bool
lensCase  = Name
getterTypeName
                         | Bool
otherwise = Name
foldTypeName
               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  = Name
getterTypeName
                         | Bool
otherwise = Name
foldTypeName
               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 | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
iso'TypeName
                         | Bool
lensCase                    = Name
lens'TypeName
                         | Bool
otherwise                   = Name
traversal'TypeName
               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 | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
isoTypeName
                         | Bool
lensCase                    = Name
lensTypeName
                         | Bool
otherwise                   = Name
traversalTypeName
               in Name -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Name
optic Type
s' Type
t Type
a Type
b

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

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

  scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
  scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
scaffolds = [ (Name
n, [Either Type (Maybe Name, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type (Maybe Name, Type)]
ts, (\(Int
a, Maybe Name
b) -> (Maybe Name
b, Int
a)) ((Int, Maybe Name) -> (Maybe Name, Int))
-> [(Int, Maybe Name)] -> [(Maybe Name, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type (Maybe Name, Type)]
ts [Either Type (Maybe Name, Type)]
-> IndexedGetting
     Int
     (Endo [(Int, Maybe Name)])
     [Either Type (Maybe Name, Type)]
     (Maybe Name)
-> [(Int, Maybe Name)]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. Indexed
  Int
  (Either Type (Maybe Name, Type))
  (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const
     (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int
  [Either Type (Maybe Name, Type)]
  (Either Type (Maybe Name, Type))
folded (Indexed
   Int
   (Either Type (Maybe Name, Type))
   (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
 -> [Either Type (Maybe Name, Type)]
 -> Const
      (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)])
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> Either Type (Maybe Name, Type)
    -> Const
         (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> IndexedGetting
     Int
     (Endo [(Int, Maybe Name)])
     [Either Type (Maybe Name, Type)]
     (Maybe Name)
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. ((Maybe Name, Type)
 -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const
     (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
_Right (((Maybe Name, Type)
  -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
 -> Either Type (Maybe Name, Type)
 -> Const
      (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> (Maybe Name, Type)
    -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> Either Type (Maybe Name, Type)
-> Const
     (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> (Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_1) | (Name
n,[Either Type (Maybe Name, Type)]
ts) <- [(Name, [Either Type (Maybe Name, Type)])]
consForDef ]

  -- Right: types for this definition

  -- Left : other types

  categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
  categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize ([(DefName, Maybe Name)]
defNames, Type
t) =
    case DefName -> [(DefName, Maybe Name)] -> Maybe (Maybe Name)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DefName
defName [(DefName, Maybe Name)]
defNames of
    Just Maybe Name
c -> (Maybe Name, Type) -> Either Type (Maybe Name, Type)
forall a b. b -> Either a b
Right (Maybe Name
c, Type
t)
    Maybe (Maybe Name)
Nothing -> Type -> Either Type (Maybe Name, Type)
forall a b. a -> Either a b
Left Type
t

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

  isoCase :: Bool
  isoCase :: Bool
isoCase = case [(Name, Int, [(Maybe Name, Int)])]
scaffolds of
              [(Name
_,Int
1,[(Maybe Name
_, Int
0)])] -> Bool
True
              [(Name, Int, [(Maybe Name, Int)])]
_                -> Bool
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)
forall (f :: * -> *) a.
Applicative f =>
Map Name (f a) -> f (Map Name a)
T.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
forall (m :: * -> *). Quote m => String -> m 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
Traversal (Type, Type) (Type, Type) Type Type
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r 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 a. a -> Q a
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 (Set Name) [Type] Name -> [Type] -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [Type] Name
typeVars [Type]
fixedFields
  unfixedTypeVars :: Set Name
unfixedTypeVars = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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 :: forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb = (Name -> (Name, Set Name))
-> (Name -> Type -> (Name, Set Name))
-> TyVarBndr_ flag
-> (Name, Set Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
D.elimTV (\Name
n   -> (Name
n, Set Name
forall a. Set a
Set.empty))
                           (\Name
n Type
k -> (Name
n, Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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_ () -> (Name, Set Name))
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> (Name, Set Name)
forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb ([TyVarBndr_ ()] -> [(Name, Set Name)])
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
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 b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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, [(Maybe Name, Int)])])) ->
  HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticType
opticType, OpticStab
defType, [(Name, Int, [(Maybe Name, Int)])]
cons)) = do
  Set Name
locals <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
  StateT (Set Name) Q ()
addName
  DecsQ -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
T.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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

  addName :: StateT (Set Name) Q ()
addName = case DefName
defName of
            MethodName Name
c Name
_ -> Name -> StateT (Set Name) Q ()
addFieldClassName Name
c
            DefName
_              -> () -> StateT (Set Name) Q ()
forall a. a -> StateT (Set Name) Q a
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 -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
          MethodName{} -> []

  fun :: Name -> [Q Dec]
fun Name
n = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [Q Clause]
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 :: [Q Clause]
clauses = LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons

------------------------------------------------------------------------

-- Classy class generator

------------------------------------------------------------------------



makeClassyDriver ::
  LensRules ->
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
  HasFieldClasses [Dec]
makeClassyDriver :: LensRules
-> Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, 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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
T.sequenceA ([StateT (Set Name) 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 (Set Name) Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [Q Dec -> StateT (Set Name) Q Dec
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> StateT (Set Name) Q Dec)
-> Q Dec -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs]
      | Bool
otherwise = []

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


makeClassyClass ::
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
  DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = do
  let ss :: [Type]
ss   = ((DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> Type)
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS (OpticStab -> Type)
-> ((DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> OpticStab)
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  OpticStab
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  OpticStab
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> OpticStab
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
 -> Const
      OpticStab
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Const
     OpticStab
     (DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
_2 (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  -> Const
       OpticStab
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> (DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> Const
      OpticStab
      (DefName,
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> ((OpticStab -> Const OpticStab OpticStab)
    -> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    -> Const
         OpticStab
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Getting
     OpticStab
     (DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     OpticStab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
     OpticStab
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  OpticStab
  OpticStab
_2)) [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, 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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
  let vars :: [TyVarBndr_ ()]
vars     = () -> [TyVarBndr_ ()] -> [TyVarBndr_ ()]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags ()
bndrReq ([TyVarBndr_ ()] -> [TyVarBndr_ ()])
-> [TyVarBndr_ ()] -> [TyVarBndr_ ()]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s']
      varNames :: [Name]
varNames = (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ ()]
vars
      fd :: [FunDep]
fd   | [TyVarBndr_ ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ ()]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]


  Q [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className (Name -> TyVarBndr_ ()
D.plainTV Name
cTyVarBndr_ () -> [TyVarBndr_ ()] -> [TyVarBndr_ ()]
forall a. a -> [a] -> [a]
:[TyVarBndr_ ()]
vars) [FunDep]
fd
    ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
lens'TypeName 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 -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
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, [(Maybe Name, Int)])]
_)) <- [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
      , let body :: ExpQ
body = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
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, [(Maybe Name, Int)])]))] ->
  HasFieldClasses Dec
makeClassyInstance :: LensRules
-> Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = do
  [[Dec]]
methodss <- ((DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs

  Q Dec -> StateT (Set Name) Q Dec
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> StateT (Set Name) Q Dec)
-> Q Dec -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) (Type -> Q Type
forall a. a -> Q a
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
$ Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodName) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName)) []
           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 a. a -> Q a
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_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvbToType [TyVarBndr_ ()]
vars)
  vars :: [TyVarBndr_ ()]
vars         = [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]
  rules' :: LensRules
rules'       = LensRules
rules { _generateSigs    = False
                       , _generateClasses = False
                       }

------------------------------------------------------------------------

-- Field class generation

------------------------------------------------------------------------


makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
className Name
methodName =
  Q [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
className [Name -> TyVarBndr_ ()
D.plainTV Name
s, Name -> TyVarBndr_ ()
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
         [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
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 a b. Q a -> (a -> Q b) -> Q b
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 -> Q Type) -> Type -> Q Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> Q Type
D.resolveTypeSynonyms
    where
    go :: Type -> Q Bool
    go :: Type -> Q Bool
go (ConT Name
nm) =
      -- Note that the call to `reify` can fail if `nm` is not yet defined.

      -- (This can actually happen if `nm` is declared in a Template Haskell

      -- quote.) If this fails, there is no way to tell if the type contains

      -- type families, so we recover and conservatively assume that is does not

      -- contain any.

      Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
recover
        (Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
        (Getting Any Info () -> Info -> Bool
forall s a. Getting Any s a -> s -> Bool
has (((Dec, [Dec]) -> Const Any (Dec, [Dec])) -> Info -> Const Any Info
Prism' Info (Dec, [Dec])
_FamilyI (((Dec, [Dec]) -> Const Any (Dec, [Dec]))
 -> Info -> Const Any Info)
-> ((() -> Const Any ()) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Getting Any Info ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec])
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Dec, [Dec]) (Dec, [Dec]) Dec Dec
_1 ((Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Getting Any Dec ()
-> (() -> Const Any ())
-> (Dec, [Dec])
-> Const Any (Dec, [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Any Dec ()
_TypeFamilyD) (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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Bool
go (Type
ty Type -> Getting (Endo [Type]) Type Type -> [Type]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Type]) Type Type
forall a. Plated a => Traversal' a a
Traversal' Type Type
plate)

    -- We want to catch type families, but not *data* families. See #799.

    _TypeFamilyD :: Getting Any Dec ()
    _TypeFamilyD :: Getting Any Dec ()
_TypeFamilyD = (TypeFamilyHead -> Const Any TypeFamilyHead)
-> Dec -> Const Any Dec
Prism' Dec TypeFamilyHead
_OpenTypeFamilyD((TypeFamilyHead -> Const Any TypeFamilyHead)
 -> Dec -> Const Any Dec)
-> ((() -> Const Any ())
    -> TypeFamilyHead -> Const Any TypeFamilyHead)
-> Getting Any Dec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ()) -> TypeFamilyHead -> Const Any TypeFamilyHead
forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
united Getting Any Dec () -> Getting Any Dec () -> Getting Any Dec ()
forall a. Semigroup a => a -> a -> a
<> ((TypeFamilyHead, [TySynEqn])
 -> Const Any (TypeFamilyHead, [TySynEqn]))
-> Dec -> Const Any Dec
Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD(((TypeFamilyHead, [TySynEqn])
  -> Const Any (TypeFamilyHead, [TySynEqn]))
 -> Dec -> Const Any Dec)
-> ((() -> Const Any ())
    -> (TypeFamilyHead, [TySynEqn])
    -> Const Any (TypeFamilyHead, [TySynEqn]))
-> Getting Any Dec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ())
-> (TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn])
forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
united

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

  mkInstanceDec :: [Q Type] -> [Type] -> Q Dec
mkInstanceDec [Q Type]
context [Type]
headTys =
    Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type]
context) (Type -> Q Type
forall a. a -> Q a
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, [(Maybe Name, Int)])] -> [ClauseQ]
makeFieldClauses :: LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons =
  case OpticType
opticType of

    OpticType
IsoType    -> [ Name -> Q Clause
makeIsoClause Name
conName | (Name
conName, Int
_, [(Maybe Name, Int)]
_) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]

    OpticType
GetterType -> [ Name -> Int -> [Int] -> Q Clause
makeGetterClause Name
conName Int
fieldCount ((Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fields)
                    | (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]

    OpticType
LensType   -> [ Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
makeFieldOpticClause Name
conName Int
fieldCount [(Maybe Name, Int)]
fields Bool
irref Bool
recSyn
                    | (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]
      where
      irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules
           Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      recSyn :: Bool
recSyn = LensRules -> Bool
_recordSyntax LensRules
rules Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, 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 -> Q Clause
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)

     [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)]
            (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName) ([ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
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
forall (m :: * -> *). Quote m => Name -> m Exp
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] -> Q Clause
makeGetterClause Name
conName Int
fieldCount []     = Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
  do Name
f  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
     NonEmpty Name
xs' <-
       case [Name]
xs of
         (Name
x:[Name]
xs') -> NonEmpty Name -> Q (NonEmpty Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
x Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| [Name]
xs')
         []      -> String -> Q (NonEmpty Name)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeGetterClause: Internal check failed"

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

         (ExpQ
fx :| [ExpQ]
fxs) = (Name -> ExpQ) -> NonEmpty Name -> NonEmpty ExpQ
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE) NonEmpty Name
xs'
         body :: ExpQ
body  = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a ExpQ
b -> [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, ExpQ
a, ExpQ
b])
                       (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
phantomValName) ExpQ
fx)
                       [ExpQ]
fxs

     -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn

     [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Int] -> [Name] -> [Q Pat]
forall {m :: * -> *}. Quote m => [Int] -> [Name] -> [m Pat]
pats [Int
0..Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
            (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
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 -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ Bool
_ =
  Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
_ Int
_ [(Just Name
fieldName, Int
_)] Bool
_ Bool
True =
  do Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     Name
r <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
     Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
     let body :: ExpQ
body = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ [| fmap |]
                      , [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (ExpQ -> [Q (Name, Exp)] -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) [(,) Name
fieldName (Exp -> (Name, Exp)) -> ExpQ -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x])
                      , Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r)
                      ]
     [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
body) []
makeFieldOpticClause Name
conName Int
fieldCount ((Maybe Name
_, Int
field):[(Maybe Name, Int)]
fieldsWithNames) Bool
irref Bool
_ =
  do Name
f  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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
+ [(Maybe Name, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Int)]
fieldsWithNames)

     let fields :: [Int]
fields = (Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fieldsWithNames
         xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
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 -> m Exp
mkFx Int
i = m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
xs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))

         body0 :: ExpQ
body0 = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fmapValName
                       , [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ys) ([ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
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
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs'))
                       , Int -> ExpQ
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
field
                       ]

         body :: ExpQ
body = (ExpQ -> Int -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a Int
b -> [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, ExpQ
a, Int -> ExpQ
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
b]) ExpQ
body0 [Int]
fields

     let wrap :: Q Pat -> Q Pat
wrap = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

     [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Q Pat -> Q Pat
wrap (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))]
            (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
body)
            []


-- | Build a clause that constructs an Iso

makeIsoClause :: Name -> ClauseQ
makeIsoClause :: Name -> Q Clause
makeIsoClause Name
conName = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isoValName, ExpQ
destruct, ExpQ
construct])) []
  where
  destruct :: ExpQ
destruct  = do Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                 Q Pat -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)

  construct :: ExpQ
construct = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName


------------------------------------------------------------------------

-- 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 a. String -> Q a
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 a. a -> Q a
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 a. a -> Q a
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 Any Type Name -> Name -> Type -> Bool
forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf Getting Any Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
      String -> Q (Map Name Type, Type)
forall a. String -> Q a
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 a. a -> Q a
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 [TyVarBndrSpec]
v1 [] Type
t1) (ForallT [TyVarBndrSpec]
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
     [TyVarBndrSpec]
v <- ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> Q [TyVarBndrSpec] -> Q [TyVarBndrSpec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. Eq a => [a] -> [a]
nub ((TyVarBndrSpec -> Q TyVarBndrSpec)
-> [TyVarBndrSpec] -> Q [TyVarBndrSpec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub1) ([TyVarBndrSpec]
v1[TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
v2))
     (Map Name Type, Type) -> Q (Map Name Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub1, [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
v [] Type
t)

unify1 Map Name Type
_ Type
x Type
y = String -> Q (Map Name Type, Type)
forall a. String -> Q a
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 -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub TyVarBndrSpec
tv
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndrSpec
tv) Map Name Type
sub =
       case Type
r of
         VarT Name
m -> Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub ((Name -> Name) -> TyVarBndrSpec -> TyVarBndrSpec
forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
D.mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
m) TyVarBndrSpec
tv)
         Type
_ -> String -> Q TyVarBndrSpec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
  | Bool
otherwise = TyVarBndrSpec -> Q TyVarBndrSpec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrSpec
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. Plated a => (a -> Maybe a) -> a -> a
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 to construct lenses for data fields.

data LensRules = LensRules
  { LensRules -> Bool
_simpleLenses    :: Bool
  , LensRules -> Bool
_generateSigs    :: Bool
  , LensRules -> Bool
_generateClasses :: Bool
  , LensRules -> Bool
_allowIsos       :: Bool
  , LensRules -> Bool
_allowUpdates    :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold)

  , LensRules -> Bool
_lazyPatterns    :: Bool
  , LensRules -> Bool
_recordSyntax    :: Bool
  , LensRules -> FieldNamer
_fieldToDef      :: FieldNamer
       -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names

  , LensRules -> ClassyNamer
_classyLenses    :: ClassyNamer
       -- type name to class name and top method

  }

-- | The rule to create function names of lenses for data fields.

--

-- Although it's sometimes useful, you won't need the first two

-- arguments most of the time.

type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.

                  -> [Name] -- ^ Names of all fields (including the field being named) in the data type.

                  -> Name -- ^ Name of the field being named.

                  -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.


-- | Name to give to generated field optics.

data DefName
  = TopName Name -- ^ Simple top-level definition 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
$cshowsPrec :: Int -> DefName -> String -> String
showsPrec :: Int -> DefName -> String -> String
$cshow :: DefName -> String
show :: DefName -> String
$cshowList :: [DefName] -> String -> String
showList :: [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
$c== :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
/= :: 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
$ccompare :: DefName -> DefName -> Ordering
compare :: DefName -> DefName -> Ordering
$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
>= :: DefName -> DefName -> Bool
$cmax :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
min :: DefName -> DefName -> DefName
Ord)

-- | The optional rule to create a class and method around a

-- monomorphic data type. If this naming convention is provided, it

-- generates a "classy" lens.

type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.

                   -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.


-- | Tracks the field class 'Name's that have been created so far. We consult

-- these so that we may avoid creating duplicate classes.


-- See #643 for more information.

type HasFieldClasses = StateT (Set Name) Q

addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> StateT (Set Name) Q ()
addFieldClassName Name
n = (Set Name -> Set Name) -> StateT (Set Name) Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set Name -> Set Name) -> StateT (Set Name) Q ())
-> (Set Name -> Set Name) -> StateT (Set Name) Q ()
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