1{-# LANGUAGE CPP #-}
2{-# LANGUAGE PatternGuards #-}
3#ifdef TRUSTWORTHY
4# if MIN_VERSION_template_haskell(2,12,0)
5{-# LANGUAGE Safe #-}
6# else
7{-# LANGUAGE Trustworthy #-}
8# endif
9#endif
10
11-----------------------------------------------------------------------------
12-- |
13-- Module      :  Control.Lens.Internal.FieldTH
14-- Copyright   :  (C) 2014-2016 Edward Kmett, (C) 2014 Eric Mertens
15-- License     :  BSD-style (see the file LICENSE)
16-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
17-- Stability   :  experimental
18-- Portability :  non-portable
19--
20-----------------------------------------------------------------------------
21
22module Control.Lens.Internal.FieldTH
23  ( LensRules(..)
24  , FieldNamer
25  , DefName(..)
26  , ClassyNamer
27  , makeFieldOptics
28  , makeFieldOpticsForDec
29  , makeFieldOpticsForDec'
30  , HasFieldClasses
31  ) where
32
33import Prelude ()
34
35import Control.Lens.At
36import Control.Lens.Fold
37import Control.Lens.Internal.TH
38import Control.Lens.Internal.Prelude
39import Control.Lens.Lens
40import Control.Lens.Plated
41import Control.Lens.Prism
42import Control.Lens.Setter
43import Control.Lens.Getter
44import Control.Lens.Tuple
45import Control.Lens.Traversal
46import Control.Monad
47import Control.Monad.State
48import Language.Haskell.TH.Lens
49import Language.Haskell.TH
50import qualified Language.Haskell.TH.Datatype as D
51import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
52import Data.Maybe (fromMaybe,isJust,maybeToList)
53import Data.List (nub, findIndices)
54import Data.Either (partitionEithers)
55import Data.Semigroup (Any (..))
56import Data.Set.Lens
57import           Data.Map ( Map )
58import           Data.Set ( Set )
59import qualified Data.Set as Set
60import qualified Data.Map as Map
61import qualified Data.Traversable as T
62
63------------------------------------------------------------------------
64-- Field generation entry point
65------------------------------------------------------------------------
66
67
68-- | Compute the field optics for the type identified by the given type name.
69-- Lenses will be computed when possible, Traversals otherwise.
70makeFieldOptics :: LensRules -> Name -> DecsQ
71makeFieldOptics rules = (`evalStateT` Set.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype
72
73makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
74makeFieldOpticsForDec rules = (`evalStateT` Set.empty) . makeFieldOpticsForDec' rules
75
76makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]
77makeFieldOpticsForDec' rules = makeFieldOpticsForDatatype rules <=< lift . D.normalizeDec
78
79-- | Compute the field optics for a deconstructed datatype Dec
80-- When possible build an Iso otherwise build one optic per field.
81makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
82makeFieldOpticsForDatatype rules info =
83  do perDef <- lift $ do
84       fieldCons <- traverse normalizeConstructor cons
85       let allFields  = toListOf (folded . _2 . folded . _1 . folded) fieldCons
86       let defCons    = over normFieldLabels (expandName allFields) fieldCons
87           allDefs    = setOf (normFieldLabels . folded) defCons
88       T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs)
89
90     let defs = Map.toList perDef
91     case _classyLenses rules tyName of
92       Just (className, methodName) ->
93         makeClassyDriver rules className methodName s defs
94       Nothing -> do decss <- traverse (makeFieldOptic rules) defs
95                     return (concat decss)
96
97  where
98  tyName = D.datatypeName     info
99  s      = datatypeTypeKinded info
100  cons   = D.datatypeCons     info
101
102  -- Traverse the field labels of a normalized constructor
103  normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
104  normFieldLabels = traverse . _2 . traverse . _1
105
106  -- Map a (possibly missing) field's name to zero-to-many optic definitions
107  expandName :: [Name] -> Maybe Name -> [DefName]
108  expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList
109
110-- | Normalized the Con type into a uniform positional representation,
111-- eliminating the variance between records, infix constructors, and normal
112-- constructors.
113normalizeConstructor ::
114  D.ConstructorInfo ->
115  Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type
116
117normalizeConstructor con =
118  return (D.constructorName con,
119          zipWith checkForExistentials fieldNames (D.constructorFields con))
120  where
121    fieldNames =
122      case D.constructorVariant con of
123        D.RecordConstructor xs -> fmap Just xs
124        D.NormalConstructor    -> repeat Nothing
125        D.InfixConstructor     -> repeat Nothing
126
127    -- Fields mentioning existentially quantified types are not
128    -- elligible for TH generated optics.
129    checkForExistentials _ fieldtype
130      | any (\tv -> D.tvName tv `Set.member` used) unallowable
131      = (Nothing, fieldtype)
132      where
133        used        = setOf typeVars fieldtype
134        unallowable = D.constructorVars con
135    checkForExistentials fieldname fieldtype = (fieldname, fieldtype)
136
137data OpticType = GetterType | LensType | IsoType
138
139-- | Compute the positional location of the fields involved in
140-- each constructor for a given optic definition as well as the
141-- type of clauses to generate and the type to annotate the declaration
142-- with.
143buildScaffold ::
144  LensRules                                                                  ->
145  Type                              {- ^ outer type                       -} ->
146  [(Name, [([DefName], Type)])]     {- ^ normalized constructors          -} ->
147  DefName                           {- ^ target definition                -} ->
148  Q (OpticType, OpticStab, [(Name, Int, [Int])])
149              {- ^ optic type, definition type, field count, target fields -}
150buildScaffold rules s cons defName =
151
152  do (s',t,a,b) <- buildStab s (concatMap snd consForDef)
153
154     let defType
155           | Just (_,cx,a') <- preview _ForallT a =
156               let optic | lensCase  = getterTypeName
157                         | otherwise = foldTypeName
158               in OpticSa cx optic s' a'
159
160           -- Getter and Fold are always simple
161           | not (_allowUpdates rules) =
162               let optic | lensCase  = getterTypeName
163                         | otherwise = foldTypeName
164               in OpticSa [] optic s' a
165
166           -- Generate simple Lens and Traversal where possible
167           | _simpleLenses rules || s' == t && a == b =
168               let optic | isoCase && _allowIsos rules = iso'TypeName
169                         | lensCase                    = lens'TypeName
170                         | otherwise                   = traversal'TypeName
171               in OpticSa [] optic s' a
172
173           -- Generate type-changing Lens and Traversal otherwise
174           | otherwise =
175               let optic | isoCase && _allowIsos rules = isoTypeName
176                         | lensCase                    = lensTypeName
177                         | otherwise                   = traversalTypeName
178               in OpticStab optic s' t a b
179
180         opticType | has _ForallT a            = GetterType
181                   | not (_allowUpdates rules) = GetterType
182                   | isoCase                   = IsoType
183                   | otherwise                 = LensType
184
185     return (opticType, defType, scaffolds)
186  where
187  consForDef :: [(Name, [Either Type Type])]
188  consForDef = over (mapped . _2 . mapped) categorize cons
189
190  scaffolds :: [(Name, Int, [Int])]
191  scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ]
192
193  rightIndices :: [Either Type Type] -> [Int]
194  rightIndices = findIndices (has _Right)
195
196  -- Right: types for this definition
197  -- Left : other types
198  categorize :: ([DefName], Type) -> Either Type Type
199  categorize (defNames, t)
200    | defName `elem` defNames = Right t
201    | otherwise               = Left  t
202
203  lensCase :: Bool
204  lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef
205
206  isoCase :: Bool
207  isoCase = case scaffolds of
208              [(_,1,[0])] -> True
209              _           -> False
210
211
212data OpticStab = OpticStab     Name Type Type Type Type
213               | OpticSa   Cxt Name Type Type
214
215stabToType :: OpticStab -> Type
216stabToType (OpticStab  c s t a b) = quantifyType [] (c `conAppsT` [s,t,a,b])
217stabToType (OpticSa cx c s   a  ) = quantifyType cx (c `conAppsT` [s,a])
218
219stabToContext :: OpticStab -> Cxt
220stabToContext OpticStab{}        = []
221stabToContext (OpticSa cx _ _ _) = cx
222
223stabToOptic :: OpticStab -> Name
224stabToOptic (OpticStab c _ _ _ _) = c
225stabToOptic (OpticSa _ c _ _) = c
226
227stabToS :: OpticStab -> Type
228stabToS (OpticStab _ s _ _ _) = s
229stabToS (OpticSa _ _ s _) = s
230
231stabToA :: OpticStab -> Type
232stabToA (OpticStab _ _ _ a _) = a
233stabToA (OpticSa _ _ _ a) = a
234
235-- | Compute the s t a b types given the outer type 's' and the
236-- categorized field types. Left for fixed and Right for visited.
237-- These types are "raw" and will be packaged into an 'OpticStab'
238-- shortly after creation.
239buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)
240buildStab s categorizedFields =
241  do (subA,a) <- unifyTypes targetFields
242     let s' = applyTypeSubst subA s
243
244     -- compute possible type changes
245     sub <- T.sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars)
246     let (t,b) = over both (substTypeVars sub) (s',a)
247
248     return (s',t,a,b)
249
250  where
251  (fixedFields, targetFields) = partitionEithers categorizedFields
252
253  fixedTypeVars, unfixedTypeVars :: Set Name
254  fixedTypeVars   = closeOverKinds $ setOf typeVars fixedFields
255  unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars
256
257  -- Compute the kind variables that appear in the kind of a type variable
258  -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a
259  -- type variable binder lacks an explicit kind annotation, this
260  -- conservatively assumes that there are no kind variables. For example,
261  -- @kindVarsOfTvb (y) = (y, {})@.
262  kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
263  kindVarsOfTvb = D.elimTV (\n   -> (n, Set.empty))
264                           (\n k -> (n, setOf typeVars k))
265
266  -- For each type variable name that appears in @s@, map to the kind variables
267  -- that appear in that type variable's kind.
268  sKindVarMap :: Map Name (Set Name)
269  sKindVarMap = Map.fromList $ map kindVarsOfTvb $ D.freeVariablesWellScoped [s]
270
271  lookupSKindVars :: Name -> Set Name
272  lookupSKindVars n = fromMaybe Set.empty $ Map.lookup n sKindVarMap
273
274  -- Consider this example (adapted from #972):
275  --
276  --   data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int }
277  --   $(makeLenses ''Dart)
278  --
279  -- When generating a Lens for `direction`, the type variable `s` should be
280  -- fixed. But note that (s :: k), and as a result, the kind variable `k`
281  -- needs to be fixed as well. This is because a type like this would be
282  -- ill kinded:
283  --
284  --   direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction
285  --
286  -- However, only `s` is mentioned syntactically in the type of `_arc`, so we
287  -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this
288  -- with `closeOverKinds`, which does the following:
289  --
290  -- 1. Use freeVariablesWellScoped to compute the free type variables of
291  --    `Dart (s :: k)`, which gives us `(s :: k)`.
292  -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up
293  --    the kind variables in the type variable's kind. In the case of `s`,
294  --    the only kind variable is `k`.
295  -- 3. Add these kind variables to the set of fixed type variables.
296  closeOverKinds :: Set Name -> Set Name
297  closeOverKinds st = foldl' Set.union Set.empty (Set.map lookupSKindVars st) `Set.union` st
298
299-- | Build the signature and definition for a single field optic.
300-- In the case of a singleton constructor irrefutable matches are
301-- used to enable the resulting lenses to be used on a bottom value.
302makeFieldOptic ::
303  LensRules ->
304  (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->
305  HasFieldClasses [Dec]
306makeFieldOptic rules (defName, (opticType, defType, cons)) = do
307  locals <- get
308  addName
309  lift $ do cls <- mkCls locals
310            T.sequenceA (cls ++ sig ++ def)
311  where
312  mkCls locals = case defName of
313                 MethodName c n | _generateClasses rules ->
314                  do classExists <- isJust <$> lookupTypeName (show c)
315                     return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n])
316                 _ -> return []
317
318  addName = case defName of
319            MethodName c _ -> addFieldClassName c
320            _              -> return ()
321
322  sig = case defName of
323          _ | not (_generateSigs rules) -> []
324          TopName n -> [sigD n (return (stabToType defType))]
325          MethodName{} -> []
326
327  fun n = funD n clauses : inlinePragma n
328
329  def = case defName of
330          TopName n      -> fun n
331          MethodName c n -> [makeFieldInstance defType c (fun n)]
332
333  clauses = makeFieldClauses rules opticType cons
334
335------------------------------------------------------------------------
336-- Classy class generator
337------------------------------------------------------------------------
338
339
340makeClassyDriver ::
341  LensRules ->
342  Name ->
343  Name ->
344  Type {- ^ Outer 's' type -} ->
345  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
346  HasFieldClasses [Dec]
347makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst)
348
349  where
350  cls | _generateClasses rules = [lift $ makeClassyClass className methodName s defs]
351      | otherwise = []
352
353  inst = [makeClassyInstance rules className methodName s defs]
354
355
356makeClassyClass ::
357  Name ->
358  Name ->
359  Type {- ^ Outer 's' type -} ->
360  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
361  DecQ
362makeClassyClass className methodName s defs = do
363  let ss   = map (stabToS . view (_2 . _2)) defs
364  (sub,s') <- unifyTypes (s : ss)
365  c <- newName "c"
366  let vars     = D.freeVariablesWellScoped [s']
367      varNames = map D.tvName vars
368      fd   | null vars = []
369           | otherwise = [FunDep [c] varNames]
370
371
372  classD (cxt[]) className (D.plainTV c:vars) fd
373    $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s']))
374    : concat
375      [ [sigD defName (return ty)
376        ,valD (varP defName) (normalB body) []
377        ] ++
378        inlinePragma defName
379      | (TopName defName, (_, stab, _)) <- defs
380      , let body = appsE [varE composeValName, varE methodName, varE defName]
381      , let ty   = quantifyType' (Set.fromList (c:varNames))
382                                 (stabToContext stab)
383                 $ stabToOptic stab `conAppsT`
384                       [VarT c, applyTypeSubst sub (stabToA stab)]
385      ]
386
387
388makeClassyInstance ::
389  LensRules ->
390  Name ->
391  Name ->
392  Type {- ^ Outer 's' type -} ->
393  [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
394  HasFieldClasses Dec
395makeClassyInstance rules className methodName s defs = do
396  methodss <- traverse (makeFieldOptic rules') defs
397
398  lift $ instanceD (cxt[]) (return instanceHead)
399           $ valD (varP methodName) (normalB (varE idValName)) []
400           : map return (concat methodss)
401
402  where
403  instanceHead = className `conAppsT` (s : map tvbToType vars)
404  vars         = D.freeVariablesWellScoped [s]
405  rules'       = rules { _generateSigs    = False
406                       , _generateClasses = False
407                       }
408
409------------------------------------------------------------------------
410-- Field class generation
411------------------------------------------------------------------------
412
413makeFieldClass :: OpticStab -> Name -> Name -> DecQ
414makeFieldClass defType className methodName =
415  classD (cxt []) className [D.plainTV s, D.plainTV a] [FunDep [s] [a]]
416         [sigD methodName (return methodType)]
417  where
418  methodType = quantifyType' (Set.fromList [s,a])
419                             (stabToContext defType)
420             $ stabToOptic defType `conAppsT` [VarT s,VarT a]
421  s = mkName "s"
422  a = mkName "a"
423
424-- | Build an instance for a field. If the field’s type contains any type
425-- families, will produce an equality constraint to avoid a type family
426-- application in the instance head.
427makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
428makeFieldInstance defType className decs =
429  containsTypeFamilies a >>= pickInstanceDec
430  where
431  s = stabToS defType
432  a = stabToA defType
433
434  containsTypeFamilies = go <=< D.resolveTypeSynonyms
435    where
436    go (ConT nm) = has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm
437    go ty = or <$> traverse go (ty ^.. plate)
438
439    -- We want to catch type families, but not *data* families. See #799.
440    _TypeFamilyD :: Getting Any Dec ()
441    _TypeFamilyD = _OpenTypeFamilyD.united <> _ClosedTypeFamilyD.united
442      where
443#if !(MIN_VERSION_template_haskell(2,11,0))
444      _OpenTypeFamilyD = _FamilyD . _1 . _TypeFam
445#endif
446
447  pickInstanceDec hasFamilies
448    | hasFamilies = do
449        placeholder <- VarT <$> newName "a"
450        mkInstanceDec
451          [return (D.equalPred placeholder a)]
452          [s, placeholder]
453    | otherwise = mkInstanceDec [] [s, a]
454
455  mkInstanceDec context headTys =
456    instanceD (cxt context) (return (className `conAppsT` headTys)) decs
457
458------------------------------------------------------------------------
459-- Optic clause generators
460------------------------------------------------------------------------
461
462
463makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
464makeFieldClauses rules opticType cons =
465  case opticType of
466
467    IsoType    -> [ makeIsoClause conName | (conName, _, _) <- cons ]
468
469    GetterType -> [ makeGetterClause conName fieldCount fields
470                    | (conName, fieldCount, fields) <- cons ]
471
472    LensType   -> [ makeFieldOpticClause conName fieldCount fields irref
473                    | (conName, fieldCount, fields) <- cons ]
474      where
475      irref = _lazyPatterns rules
476           && length cons == 1
477
478
479
480-- | Construct an optic clause that returns an unmodified value
481-- given a constructor name and the number of fields on that
482-- constructor.
483makePureClause :: Name -> Int -> ClauseQ
484makePureClause conName fieldCount =
485  do xs <- newNames "x" fieldCount
486     -- clause: _ (Con x1..xn) = pure (Con x1..xn)
487     clause [wildP, conP conName (map varP xs)]
488            (normalB (appE (varE pureValName) (appsE (conE conName : map varE xs))))
489            []
490
491
492-- | Construct an optic clause suitable for a Getter or Fold
493-- by visited the fields identified by their 0 indexed positions
494makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
495makeGetterClause conName fieldCount []     = makePureClause conName fieldCount
496makeGetterClause conName fieldCount fields =
497  do f  <- newName "f"
498     xs <- newNames "x" (length fields)
499
500     let pats (i:is) (y:ys)
501           | i `elem` fields = varP y : pats is ys
502           | otherwise = wildP : pats is (y:ys)
503         pats is     _  = map (const wildP) is
504
505         fxs   = [ appE (varE f) (varE x) | x <- xs ]
506         body  = foldl (\a b -> appsE [varE apValName, a, b])
507                       (appE (varE phantomValName) (head fxs))
508                       (tail fxs)
509
510     -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn
511     clause [varP f, conP conName (pats [0..fieldCount - 1] xs)]
512            (normalB body)
513            []
514
515-- | Build a clause that updates the field at the given indexes
516-- When irref is 'True' the value with me matched with an irrefutable
517-- pattern. This is suitable for Lens and Traversal construction
518makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
519makeFieldOpticClause conName fieldCount [] _ =
520  makePureClause conName fieldCount
521makeFieldOpticClause conName fieldCount (field:fields) irref =
522  do f  <- newName "f"
523     xs <- newNames "x" fieldCount
524     ys <- newNames "y" (1 + length fields)
525
526     let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys)
527
528         mkFx i = appE (varE f) (varE (xs !! i))
529
530         body0 = appsE [ varE fmapValName
531                       , lamE (map varP ys) (appsE (conE conName : map varE xs'))
532                       , mkFx field
533                       ]
534
535         body = foldl (\a b -> appsE [varE apValName, a, mkFx b]) body0 fields
536
537     let wrap = if irref then tildeP else id
538
539     clause [varP f, wrap (conP conName (map varP xs))]
540            (normalB body)
541            []
542
543
544-- | Build a clause that constructs an Iso
545makeIsoClause :: Name -> ClauseQ
546makeIsoClause conName = clause [] (normalB (appsE [varE isoValName, destruct, construct])) []
547  where
548  destruct  = do x <- newName "x"
549                 lam1E (conP conName [varP x]) (varE x)
550
551  construct = conE conName
552
553
554------------------------------------------------------------------------
555-- Unification logic
556------------------------------------------------------------------------
557
558-- The field-oriented optic generation supports incorporating fields
559-- with distinct but unifiable types into a single definition.
560
561
562
563-- | Unify the given list of types, if possible, and return the
564-- substitution used to unify the types for unifying the outer
565-- type when building a definition's type signature.
566unifyTypes :: [Type] -> Q (Map Name Type, Type)
567unifyTypes (x:xs) = foldM (uncurry unify1) (Map.empty, x) xs
568unifyTypes []     = fail "unifyTypes: Bug: Unexpected empty list"
569
570
571-- | Attempt to unify two given types using a running substitution
572unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
573unify1 sub (VarT x) y
574  | Just r <- Map.lookup x sub = unify1 sub r y
575unify1 sub x (VarT y)
576  | Just r <- Map.lookup y sub = unify1 sub x r
577unify1 sub x y
578  | x == y = return (sub, x)
579unify1 sub (AppT f1 x1) (AppT f2 x2) =
580  do (sub1, f) <- unify1 sub  f1 f2
581     (sub2, x) <- unify1 sub1 x1 x2
582     return (sub2, AppT (applyTypeSubst sub2 f) x)
583unify1 sub x (VarT y)
584  | elemOf typeVars y (applyTypeSubst sub x) =
585      fail "Failed to unify types: occurs check"
586  | otherwise = return (Map.insert y x sub, x)
587unify1 sub (VarT x) y = unify1 sub y (VarT x)
588
589-- TODO: Unify contexts
590unify1 sub (ForallT v1 [] t1) (ForallT v2 [] t2) =
591     -- This approach works out because by the time this code runs
592     -- all of the type variables have been renamed. No risk of shadowing.
593  do (sub1,t) <- unify1 sub t1 t2
594     v <- fmap nub (traverse (limitedSubst sub1) (v1++v2))
595     return (sub1, ForallT v [] t)
596
597unify1 _ x y = fail ("Failed to unify types: " ++ show (x,y))
598
599
600-- | Perform a limited substitution on type variables. This is used
601-- when unifying rank-2 fields when trying to achieve a Getter or Fold.
602limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
603limitedSubst sub tv
604  | Just r <- Map.lookup (D.tvName tv) sub =
605       case r of
606         VarT m -> limitedSubst sub (D.mapTVName (const m) tv)
607         _ -> fail "Unable to unify exotic higher-rank type"
608  | otherwise = return tv
609
610
611-- | Apply a substitution to a type. This is used after unifying
612-- the types of the fields in unifyTypes.
613applyTypeSubst :: Map Name Type -> Type -> Type
614applyTypeSubst sub = rewrite aux
615  where
616  aux (VarT n) = Map.lookup n sub
617  aux _        = Nothing
618
619
620------------------------------------------------------------------------
621-- Field generation parameters
622------------------------------------------------------------------------
623
624-- | Rules to construct lenses for data fields.
625data LensRules = LensRules
626  { _simpleLenses    :: Bool
627  , _generateSigs    :: Bool
628  , _generateClasses :: Bool
629  , _allowIsos       :: Bool
630  , _allowUpdates    :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold)
631  , _lazyPatterns    :: Bool
632  , _fieldToDef      :: FieldNamer
633       -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names
634  , _classyLenses    :: ClassyNamer
635       -- type name to class name and top method
636  }
637
638-- | The rule to create function names of lenses for data fields.
639--
640-- Although it's sometimes useful, you won't need the first two
641-- arguments most of the time.
642type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.
643                  -> [Name] -- ^ Names of all fields (including the field being named) in the data type.
644                  -> Name -- ^ Name of the field being named.
645                  -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.
646
647-- | Name to give to generated field optics.
648data DefName
649  = TopName Name -- ^ Simple top-level definition name
650  | MethodName Name Name -- ^ makeFields-style class name and method name
651  deriving (Show, Eq, Ord)
652
653-- | The optional rule to create a class and method around a
654-- monomorphic data type. If this naming convention is provided, it
655-- generates a "classy" lens.
656type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.
657                   -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.
658
659-- | Tracks the field class 'Name's that have been created so far. We consult
660-- these so that we may avoid creating duplicate classes.
661
662-- See #643 for more information.
663type HasFieldClasses = StateT (Set Name) Q
664
665addFieldClassName :: Name -> HasFieldClasses ()
666addFieldClassName n = modify $ Set.insert n
667