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