1{-# LANGUAGE CPP #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE Trustworthy #-} 6 7#ifndef MIN_VERSION_template_haskell 8#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) 9#endif 10 11#ifndef MIN_VERSION_containers 12#define MIN_VERSION_containers(x,y,z) 1 13#endif 14 15#if __GLASGOW_HASKELL__ >= 800 16{-# LANGUAGE TemplateHaskellQuotes #-} 17#else 18{-# LANGUAGE TemplateHaskell #-} 19#endif 20 21 22{- | 23Module : Lens.Micro.TH 24Copyright : (C) 2013-2016 Eric Mertens, Edward Kmett, Artyom Kazak; 2018 Monadfix 25License : BSD-style (see the file LICENSE) 26-} 27module Lens.Micro.TH 28( 29 -- * Dealing with “not in scope” errors 30 -- $errors-note 31 32 -- * Using this module in GHCi 33 -- $ghci-note 34 35 -- * 'SimpleGetter' and 'SimpleFold' 36 -- $getter-fold-note 37 38 -- * Generating lenses 39 makeLenses, 40 makeLensesFor, 41 makeLensesWith, 42 makeFields, 43 makeClassy, 44 45 -- * Default lens rules 46 LensRules, 47 DefName(..), 48 lensRules, 49 lensRulesFor, 50 classyRules, 51 camelCaseFields, 52 abbreviatedFields, 53 54 -- * Configuring lens rules 55 lensField, 56 lensClass, 57 createClass, 58 simpleLenses, 59 generateSignatures, 60 generateUpdateableOptics, 61 generateLazyPatterns, 62) 63where 64 65 66import Control.Monad 67import Control.Monad.Trans.State 68import Data.Char 69import Data.Data 70import Data.Either 71import qualified Data.Map as Map 72import Data.Map (Map) 73import qualified Data.Set as Set 74import Data.Set (Set) 75import Data.List (nub, findIndices, stripPrefix, isPrefixOf) 76import Data.Maybe 77import Lens.Micro 78import Lens.Micro.Internal (phantom) 79import Lens.Micro.TH.Internal 80import Language.Haskell.TH 81import qualified Language.Haskell.TH.Datatype as D 82import qualified Language.Haskell.TH.Datatype.TyVarBndr as D 83 84#if __GLASGOW_HASKELL__ < 710 85import Control.Applicative 86import Data.Traversable (traverse, sequenceA) 87#endif 88 89 90{- $errors-note 91 92When you use Template Haskell, the order of declarations suddenly starts to matter. For instance, if you try to use 'makeLenses', 'makeFields', etc before the type is defined, you'll get a “not in scope” error: 93 94@ 95'makeLenses' ''Foo 96 97data Foo = Foo {_foo :: Int} 98@ 99 100@ 101Not in scope: type constructor or class ‘Foo’ … 102 In the Template Haskell quotation ''Foo 103@ 104 105You can't refer to generated lenses before you call 'makeLenses', either: 106 107@ 108data Foo = Foo {_foo :: Int} 109 110bar :: Lens' Foo Int 111bar = foo 112 113'makeLenses' ''Foo 114@ 115 116@ 117Not in scope: ‘foo’ … 118 Perhaps you meant one of these: 119 data constructor ‘Foo’ (line 1), ‘_foo’ (line 1) 120@ 121-} 122 123{- $ghci-note 124 125You can use 'makeLenses' and friends to define lenses right from GHCi, but it's slightly tricky. 126 127First, enable Template Haskell: 128 129>>> :set -XTemplateHaskell 130 131Then define a bogus type (you can use any name in place of @M@, and you can use the same name many times), and follow the definition by the actual Template Haskell command you want to use: 132 133>>> data M; makeLenses ''Foo 134 135This will generate lenses for @Foo@ and you'll be able to use them from GHCi. 136 137If you want, you can define the type and lenses for it simultaneously with @:{@ and @:}@: 138 139@ 140>>> :{ 141data Foobar = Foobar { 142 _foo :: Int, 143 _bar :: Bool } 144 deriving (Eq, Show) 145 146makeLenses ''Foobar 147:} 148@ 149-} 150 151{- $getter-fold-note 152 153When updates are forbidden (by using 'generateUpdateableOptics'), or when a field simply can't be updated (for instance, in the presence of @forall@), instead of 'Lens' and 'Traversal' we generate 'SimpleGetter' and 'SimpleFold'. These aren't true @Getter@ and @Fold@ from lens, so beware. (Still, they're compatible, it's just that you can't do some things with them that you can do with original ones – for instance, @backwards@ and @takingWhile@ don't work on 'SimpleFold'.) 154 155If you want to export true folds, it's recommended that you depend on <http://hackage.haskell.org/package/microlens-contra microlens-contra>, use 'makeLensesFor' to generate 'SimpleFold's with prefixes, and then export versions of those folds with @<http://hackage.haskell.org/package/microlens-contra/docs/Lens-Micro-Contra.html#v:fromSimpleFold fromSimpleFold>@ applied. 156-} 157 158-- Utilities 159 160-- like 'rewrite' from uniplate 161rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b 162rewrite f mbA = case cast mbA of 163 Nothing -> gmapT (rewrite f) mbA 164 Just a -> let a' = gmapT (rewrite f) a 165 in fromJust . cast $ fromMaybe a' (f a') 166 167-- like 'children' from uniplate 168children :: Data a => a -> [a] 169children = catMaybes . gmapQ cast 170 171-- Control.Lens.TH 172 173{- | 174Generate lenses for a data type or a newtype. 175 176To use it, you have to enable Template Haskell first: 177 178@ 179\{\-\# LANGUAGE TemplateHaskell \#\-\} 180@ 181 182Then, after declaring the datatype (let's say @Foo@), add @makeLenses ''Foo@ on a separate line (if you do it before the type is declared, you'll get a “not in scope” error – see the section at the top of this page): 183 184@ 185data Foo = Foo { 186 _x :: Int, 187 _y :: Bool } 188 189'makeLenses' ''Foo 190@ 191 192This would generate the following lenses, which can be used to access the fields of @Foo@: 193 194@ 195x :: 'Lens'' Foo Int 196x f foo = (\\x' -> foo {_x = x'}) '<$>' f (_x foo) 197 198y :: 'Lens'' Foo Bool 199y f foo = (\\y' -> foo {_y = y'}) '<$>' f (_y foo) 200@ 201 202(If you don't want a lens to be generated for some field, don't prefix it with “_”.) 203 204If you want to create lenses for many types, you can do it all in one place like this (of course, instead you just can use 'makeLenses' several times if you feel it would be more readable): 205 206@ 207data Foo = ... 208data Bar = ... 209data Quux = ... 210 211'concat' '<$>' 'mapM' 'makeLenses' [''Foo, ''Bar, ''Quux] 212@ 213 214When the data type has type parameters, it's possible for a lens to do a polymorphic update – i.e. change the type of the thing along with changing the type of the field. For instance, with this type 215 216@ 217data Foo a = Foo { 218 _x :: a, 219 _y :: Bool } 220@ 221 222the following lenses would be generated: 223 224@ 225x :: 'Lens' (Foo a) (Foo b) a b 226y :: 'Lens'' (Foo a) Bool 227@ 228 229However, when there are several fields using the same type parameter, type-changing updates are no longer possible: 230 231@ 232data Foo a = Foo { 233 _x :: a, 234 _y :: a } 235@ 236 237generates 238 239@ 240x :: 'Lens'' (Foo a) a 241y :: 'Lens'' (Foo a) a 242@ 243 244Finally, when the type has several constructors, some of fields may not be /always/ present – for those, a 'Traversal' is generated instead. For instance, in this example @y@ can be present or absent: 245 246@ 247data FooBar 248 = Foo { _x :: Int, _y :: Bool } 249 | Bar { _x :: Int } 250@ 251 252and the following accessors would be generated: 253 254@ 255x :: 'Lens'' FooBar Int 256y :: 'Traversal'' FooBar Bool 257@ 258 259So, to get @_y@, you'd have to either use ('^?') if you're not sure it's there, or ('^?!') if you're absolutely sure (and if you're wrong, you'll get an exception). Setting and updating @_y@ can be done as usual. 260-} 261makeLenses :: Name -> DecsQ 262makeLenses = makeFieldOptics lensRules 263 264{- | 265Like 'makeLenses', but lets you choose your own names for lenses: 266 267@ 268data Foo = Foo {foo :: Int, bar :: Bool} 269 270'makeLensesFor' [(\"foo\", \"fooLens\"), (\"bar\", \"_bar\")] ''Foo 271@ 272 273would create lenses called @fooLens@ and @_bar@. This is useful, for instance, when you don't want to prefix your fields with underscores and want to prefix /lenses/ with underscores instead. 274 275If you give the same name to different fields, it will generate a 'Traversal' instead: 276 277@ 278data Foo = Foo {slot1, slot2, slot3 :: Int} 279 280'makeLensesFor' [(\"slot1\", \"slots\"), 281 (\"slot2\", \"slots\"), 282 (\"slot3\", \"slots\")] ''Foo 283@ 284 285would generate 286 287@ 288slots :: 'Traversal'' Foo Int 289slots f foo = Foo '<$>' f (slot1 foo) 290 '<*>' f (slot2 foo) 291 '<*>' f (slot3 foo) 292@ 293-} 294makeLensesFor :: [(String, String)] -> Name -> DecsQ 295makeLensesFor fields = makeFieldOptics (lensRulesFor fields) 296 297{- | 298Generate lenses with custom parameters. 299 300To see what exactly you can customise, look at the “Configuring lens rules” section. Usually you would build upon the 'lensRules' configuration, which is used by 'makeLenses': 301 302@ 303'makeLenses' = 'makeLensesWith' 'lensRules' 304@ 305 306Here's an example of generating lenses that would use lazy patterns: 307 308@ 309data Foo = Foo {_x, _y :: Int} 310 311'makeLensesWith' ('lensRules' '&' 'generateLazyPatterns' '.~' True) ''Foo 312@ 313 314When there are several modifications to the rules, the code looks nicer when you use 'flip': 315 316@ 317'flip' 'makeLensesWith' ''Foo $ 318 'lensRules' 319 '&' 'generateLazyPatterns' '.~' True 320 '&' 'generateSignatures' '.~' False 321@ 322-} 323makeLensesWith :: LensRules -> Name -> DecsQ 324makeLensesWith = makeFieldOptics 325 326{- | 327Generate overloaded lenses. 328 329This lets you deal with several data types having same fields. For instance, let's say you have @Foo@ and @Bar@, and both have a field named @x@. To avoid those fields clashing, you would have to use prefixes: 330 331@ 332data Foo a = Foo { 333 fooX :: Int, 334 fooY :: a } 335 336data Bar = Bar { 337 barX :: Char } 338@ 339 340However, if you use 'makeFields' on both @Foo@ and @Bar@ now, it would generate lenses called @x@ and @y@ – and @x@ would be able to access both @fooX@ and @barX@! This is done by generating a separate class for each field, and making relevant types instances of that class: 341 342@ 343class HasX s a | s -> a where 344 x :: 'Lens'' s a 345 346instance HasX (Foo a) Int where 347 x :: 'Lens'' (Foo a) Int 348 x = ... 349 350instance HasX Bar Char where 351 x :: 'Lens'' Bar Char 352 x = ... 353 354 355class HasY s a | s -> a where 356 y :: 'Lens'' s a 357 358instance HasY (Foo a) a where 359 y :: 'Lens'' (Foo a) a 360 y = ... 361@ 362 363(There's a minor drawback, though: you can't perform type-changing updates with these lenses.) 364 365If you only want to make lenses for some fields, you can prefix them with underscores – the rest would be untouched. If no fields are prefixed with underscores, lenses would be created for all fields. 366 367The prefix must be the same as the name of the name of the data type (/not/ the constructor). If you don't like this behavior, use @'makeLensesWith' 'abbreviatedFields'@ – it allows any prefix (and even different prefixes). 368 369If you want to use 'makeFields' on types declared in different modules, you can do it, but then you would have to export the @Has*@ classes from one of the modules – 'makeFields' creates a class if it's not in scope yet, so the class must be in scope or else there would be duplicate classes and you would get an “Ambiguous occurrence” error. 370 371Finally, 'makeFields' is implemented as @'makeLensesWith' 'camelCaseFields'@, so you can build on 'camelCaseFields' if you want to customise behavior of 'makeFields'. 372-} 373makeFields :: Name -> DecsQ 374makeFields = makeFieldOptics camelCaseFields 375 376{- | 377Generate overloaded lenses without ad-hoc classes; useful when there's a collection of fields that you want to make common for several types. 378 379Like 'makeFields', each lens is a member of a class. However, the classes are per-type and not per-field. Let's take the following type: 380 381@ 382data Person = Person { 383 _name :: String, 384 _age :: Double } 385@ 386 387'makeClassy' would generate a single class with 3 methods: 388 389@ 390class HasPerson c where 391 person :: Lens' c Person 392 393 age :: Lens' c Double 394 age = person.age 395 396 name :: Lens' c String 397 name = person.name 398@ 399 400And an instance: 401 402@ 403instance HasPerson Person where 404 person = id 405 406 name = ... 407 age = ... 408@ 409 410So, you can use @name@ and @age@ to refer to the @_name@ and @_age@ fields, as usual. However, the extra lens – @person@ – allows you to do a kind of subtyping. Let's say that there's a type called @Worker@ and every worker has the same fields that a person has, but also a @job@. If you were using 'makeFields', you'd do the following: 411 412@ 413data Worker = Worker { 414 _workerName :: String, 415 _workerAge :: Double, 416 _workerJob :: String } 417@ 418 419However, with 'makeClassy' you can say “every worker is a person” in a more principled way: 420 421@ 422data Worker = Worker { 423 _workerPerson :: Person, 424 _job :: String } 425 426makeClassy ''Worker 427 428instance HasPerson Worker where person = workerPerson 429@ 430 431Now you can use @age@ and @name@ to access name\/age of a @Worker@, but you also can use @person@ to “downgrade” a @Worker@ to a @Person@ (and e.g. apply some @Person@-specific function to it). 432 433Unlike 'makeFields', 'makeClassy' doesn't make use of prefixes. @_workerPerson@ could've just as well been named @_foobar@. 434 435'makeClassy' is implemented as @'makeLensesWith' 'classyRules'@, so you can build on 'classyRules' if you want to customise behavior of 'makeClassy'. 436-} 437makeClassy :: Name -> DecsQ 438makeClassy = makeFieldOptics classyRules 439 440{- | 441Generate simple (monomorphic) lenses even when type-changing lenses are possible – i.e. 'Lens'' instead of 'Lens' and 'Traversal'' instead of 'Traversal'. Just in case, here's an example of a situation when type-changing lenses would be normally generated: 442 443@ 444data Foo a = Foo { _foo :: a } 445@ 446 447Generated lens: 448 449@ 450foo :: 'Lens' (Foo a) (Foo b) a b 451@ 452 453Generated lens with 'simpleLenses' turned on: 454 455@ 456foo :: 'Lens'' (Foo a) a 457@ 458 459This option is disabled by default. 460-} 461simpleLenses :: Lens' LensRules Bool 462simpleLenses f r = fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r)) 463 464{- | 465Supply type signatures for the generated lenses. 466 467This option is enabled by default. Disable it if you want to write the signature by yourself – for instance, if the signature should be more restricted, or if you want to write haddocks for the lens (as haddocks are attached to the signature and not to the definition). 468-} 469generateSignatures :: Lens' LensRules Bool 470generateSignatures f r = 471 fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r)) 472 473{- | 474Generate “updateable” optics. When turned off, 'SimpleFold's will be generated instead of 'Traversal's and 'SimpleGetter's will be generated instead of 'Lens'es. 475 476This option is enabled by default. Disabling it can be useful for types with invariants (also known as “types with smart constructors”) – if you generate updateable optics, anyone would be able to use them to break your invariants. 477-} 478generateUpdateableOptics :: Lens' LensRules Bool 479generateUpdateableOptics f r = 480 fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates r)) 481 482{- | 483Generate lenses using lazy pattern matches. This can allow fields of an undefined value to be initialized with lenses: 484 485@ 486data Foo = Foo {_x :: Int, _y :: Bool} 487 deriving Show 488 489'makeLensesWith' ('lensRules' '&' 'generateLazyPatterns' '.~' True) ''Foo 490@ 491 492@ 493>>> 'undefined' '&' x '.~' 8 '&' y '.~' True 494Foo {_x = 8, _y = True} 495@ 496 497(Without 'generateLazyPatterns', the result would be just 'undefined'.) 498 499This option is disabled by default. The downside of enabling it is that it can lead to space-leaks and code-size\/compile-time increases when lenses are generated for large records. 500 501When you have a lazy lens, you can get a strict lens from it by composing with ('$!'): 502 503@ 504strictLens = ('$!') . lazyLens 505@ 506-} 507generateLazyPatterns :: Lens' LensRules Bool 508generateLazyPatterns f r = 509 fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r)) 510 511{- | 512This lets you choose which fields would have lenses generated for them and how would those lenses be called. To do that, you provide a function that would take a field name and output a list (possibly empty) of lenses that should be generated for that field. 513 514Here's the full type of the function you have to provide: 515 516@ 517'Name' -> -- The datatype lenses are being generated for 518['Name'] -> -- A list of all fields of the datatype 519'Name' -> -- The current field 520['DefName'] -- A list of lens names 521@ 522 523Most of the time you won't need the first 2 parameters, but sometimes they are useful – for instance, the list of all fields would be useful if you wanted to implement a slightly more complicated rule like “if some fields are prefixed with underscores, generate lenses for them, but if no fields are prefixed with underscores, generate lenses for /all/ fields”. 524 525As an example, here's a function used by default. It strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_”: 526 527@ 528\\_ _ n -> 529 case 'nameBase' n of 530 \'_\':x:xs -> ['TopName' ('mkName' ('toLower' x : xs))] 531 _ -> [] 532@ 533 534You can also generate classes (i.e. what 'makeFields' does) by using @'MethodName' className lensName@ instead of @'TopName' lensName@. 535-} 536lensField :: Lens' LensRules (Name -> [Name] -> Name -> [DefName]) 537lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r)) 538 539{- | 540This lets you choose whether a class would be generated for the type itself (like 'makeClassy' does). If so, you can choose the name of the class and the name of the type-specific lens. 541 542For 'makeLenses' and 'makeFields' this is just @const Nothing@. For 'makeClassy' this function is defined like this: 543 544@ 545\\n -> 546 case 'nameBase' n of 547 x:xs -> Just ('mkName' ("Has" ++ x:xs), 'mkName' ('toLower' x : xs)) 548 [] -> Nothing 549@ 550-} 551lensClass :: Lens' LensRules (Name -> Maybe (Name, Name)) 552lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r)) 553 554{- | 555Decide whether generation of classes is allowed at all. 556 557If this is disabled, neither 'makeFields' nor 'makeClassy' would work, regardless of values of 'lensField' or 'lensClass'. On the other hand, if 'lensField' and 'lensClass' don't generate any classes, enabling this won't have any effect. 558-} 559createClass :: Lens' LensRules Bool 560createClass f r = 561 fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r)) 562 563{- | 564Lens rules used by default (i.e. in 'makeLenses'): 565 566* 'generateSignatures' is turned on 567* 'generateUpdateableOptics' is turned on 568* 'generateLazyPatterns' is turned off 569* 'simpleLenses' is turned off 570* 'lensField' strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_” (you can see how it's implemented in the docs for 'lensField') 571* 'lensClass' isn't used (i.e. defined as @const Nothing@) 572-} 573lensRules :: LensRules 574lensRules = LensRules 575 { _simpleLenses = False 576 , _generateSigs = True 577 , _generateClasses = False 578 -- , _allowIsos = True 579 , _allowUpdates = True 580 , _lazyPatterns = False 581 , _classyLenses = const Nothing 582 , _fieldToDef = \_ _ n -> 583 case nameBase n of 584 '_':x:xs -> [TopName (mkName (toLower x:xs))] 585 _ -> [] 586 } 587 588{- | 589A modification of 'lensRules' used by 'makeLensesFor' (the only difference is that a simple lookup function is used for 'lensField'). 590-} 591lensRulesFor 592 :: [(String, String)] -- ^ @[(fieldName, lensName)]@ 593 -> LensRules 594lensRulesFor fields = lensRules & lensField .~ mkNameLookup fields 595 596mkNameLookup :: [(String,String)] -> Name -> [Name] -> Name -> [DefName] 597mkNameLookup kvs _ _ field = 598 [ TopName (mkName v) | (k,v) <- kvs, k == nameBase field] 599 600{- | 601Lens rules used by 'makeFields': 602 603* 'generateSignatures' is turned on 604* 'generateUpdateableOptics' is turned on 605* 'generateLazyPatterns' is turned off 606* 'simpleLenses' is turned on (unlike in 'lensRules') 607* 'lensField' is more complicated – it takes fields which are prefixed with the name of the type they belong to (e.g. “fooFieldName” for “Foo”), strips that prefix, and generates a class called “HasFieldName” with a single method called “fieldName”. If some fields are prefixed with underscores, underscores would be stripped too, but then fields without underscores won't have any lenses generated for them. Also note that e.g. “foolish” won't have a lens called “lish” generated for it – the prefix must be followed by a capital letter (or else it wouldn't be camel case). 608* 'lensClass' isn't used (i.e. defined as @const Nothing@) 609-} 610camelCaseFields :: LensRules 611camelCaseFields = defaultFieldRules 612 613camelCaseNamer :: Name -> [Name] -> Name -> [DefName] 614camelCaseNamer tyName fields field = maybeToList $ do 615 616 fieldPart <- stripPrefix expectedPrefix (nameBase field) 617 method <- computeMethod fieldPart 618 let cls = "Has" ++ fieldPart 619 return (MethodName (mkName cls) (mkName method)) 620 621 where 622 expectedPrefix = optUnderscore ++ over _head toLower (nameBase tyName) 623 624 optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ] 625 626 computeMethod (x:xs) | isUpper x = Just (toLower x : xs) 627 computeMethod _ = Nothing 628 629{- | 630Like standard rules used by 'makeFields', but doesn't put any restrictions on the prefix. I.e. if you have fields called 631 632* @_fooBarBaz@ 633* @_someX@ 634* @someY@ 635 636then the generated lenses would be called @barBaz@ and @x@. 637-} 638abbreviatedFields :: LensRules 639abbreviatedFields = defaultFieldRules { _fieldToDef = abbreviatedNamer } 640 641abbreviatedNamer :: Name -> [Name] -> Name -> [DefName] 642abbreviatedNamer _ fields field = maybeToList $ do 643 644 fieldPart <- stripMaxLc (nameBase field) 645 method <- computeMethod fieldPart 646 let cls = "Has" ++ fieldPart 647 return (MethodName (mkName cls) (mkName method)) 648 649 where 650 stripMaxLc f = do x <- stripPrefix optUnderscore f 651 case break isUpper x of 652 (p,s) | null p || null s -> Nothing 653 | otherwise -> Just s 654 optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ] 655 656 computeMethod (x:xs) | isUpper x = Just (toLower x : xs) 657 computeMethod _ = Nothing 658 659defaultFieldRules :: LensRules 660defaultFieldRules = LensRules 661 { _simpleLenses = True 662 , _generateSigs = True 663 , _generateClasses = True -- classes will still be skipped if they already exist 664 -- , _allowIsos = False -- generating Isos would hinder field class reuse 665 , _allowUpdates = True 666 , _lazyPatterns = False 667 , _classyLenses = const Nothing 668 , _fieldToDef = camelCaseNamer 669 } 670 671underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName] 672underscoreNoPrefixNamer _ _ n = 673 case nameBase n of 674 '_':x:xs -> [TopName (mkName (toLower x:xs))] 675 _ -> [] 676 677{- | 678Lens rules used by 'makeClassy': 679 680* 'generateSignatures' is turned on 681* 'generateUpdateableOptics' is turned on 682* 'generateLazyPatterns' is turned off 683* 'simpleLenses' is turned on (unlike in 'lensRules') 684* 'lensField' is the same as in 'lensRules' 685* 'lensClass' just adds “Has” to the name of the type (so for “Person” the generated class would be called “HasPerson” and the type-specific lens in that class would be called “person”) 686-} 687classyRules :: LensRules 688classyRules = LensRules 689 { _simpleLenses = True 690 , _generateSigs = True 691 , _generateClasses = True 692 -- , _allowIsos = False -- generating Isos would hinder "subtyping" 693 , _allowUpdates = True 694 , _lazyPatterns = False 695 , _classyLenses = \n -> 696 case nameBase n of 697 x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs)) 698 [] -> Nothing 699 , _fieldToDef = underscoreNoPrefixNamer 700 } 701 702-- FieldTH.hs 703 704------------------------------------------------------------------------ 705-- Field generation entry point 706------------------------------------------------------------------------ 707 708 709-- Compute the field optics for the type identified by the given type name. 710-- Lenses will be computed when possible, Traversals otherwise. 711makeFieldOptics :: LensRules -> Name -> DecsQ 712makeFieldOptics rules = (`evalStateT` Set.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype 713 714type HasFieldClasses = StateT (Set Name) Q 715 716addFieldClassName :: Name -> HasFieldClasses () 717addFieldClassName n = modify $ Set.insert n 718 719-- | Compute the field optics for a deconstructed datatype Dec 720-- When possible build an Iso otherwise build one optic per field. 721makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec] 722makeFieldOpticsForDatatype rules info = 723 do perDef <- liftState $ do 724 fieldCons <- traverse normalizeConstructor cons 725 let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons 726 let defCons = over normFieldLabels (expandName allFields) fieldCons 727 allDefs = setOf (normFieldLabels . folded) defCons 728 sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) 729 730 let defs = Map.toList perDef 731 case _classyLenses rules tyName of 732 Just (className, methodName) -> 733 makeClassyDriver rules className methodName s defs 734 Nothing -> do decss <- traverse (makeFieldOptic rules) defs 735 return (concat decss) 736 737 where 738 tyName = D.datatypeName info 739 s = datatypeTypeKinded info 740 cons = D.datatypeCons info 741 742 -- Traverse the field labels of a normalized constructor 743 normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b 744 normFieldLabels = traverse . _2 . traverse . _1 745 746 -- Map a (possibly missing) field's name to zero-to-many optic definitions 747 expandName :: [Name] -> Maybe Name -> [DefName] 748 expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList 749 750normalizeConstructor :: 751 D.ConstructorInfo -> 752 Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type 753 754normalizeConstructor con = 755 return (D.constructorName con, 756 zipWith checkForExistentials fieldNames (D.constructorFields con)) 757 where 758 fieldNames = 759 case D.constructorVariant con of 760 D.RecordConstructor xs -> fmap Just xs 761 D.NormalConstructor -> repeat Nothing 762 D.InfixConstructor -> repeat Nothing 763 764 -- Fields mentioning existentially quantified types are not 765 -- elligible for TH generated optics. 766 checkForExistentials _ fieldtype 767 | any (\tv -> D.tvName tv `Set.member` used) unallowable 768 = (Nothing, fieldtype) 769 where 770 used = setOf typeVars fieldtype 771 unallowable = D.constructorVars con 772 checkForExistentials fieldname fieldtype = (fieldname, fieldtype) 773 774makeClassyDriver :: 775 LensRules -> 776 Name -> 777 Name -> 778 Type {- ^ Outer 's' type -} -> 779 [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> 780 HasFieldClasses [Dec] 781makeClassyDriver rules className methodName s defs = sequenceA (cls ++ inst) 782 783 where 784 cls | _generateClasses rules = [liftState $ makeClassyClass className methodName s defs] 785 | otherwise = [] 786 787 inst = [makeClassyInstance rules className methodName s defs] 788 789makeClassyClass :: 790 Name -> 791 Name -> 792 Type {- ^ Outer 's' type -} -> 793 [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> 794 DecQ 795makeClassyClass className methodName s defs = do 796 let ss = map (stabToS . (^. _2._2)) defs 797 (sub,s') <- unifyTypes (s : ss) 798 c <- newName "c" 799 let vars = D.freeVariablesWellScoped [s'] 800 varNames = map D.tvName vars 801 fd | null vars = [] 802 | otherwise = [FunDep [c] varNames] 803 804 805 classD (cxt[]) className (D.plainTV c:vars) fd 806 $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s'])) 807 : concat 808 [ [sigD defName (return ty) 809 ,valD (varP defName) (normalB body) [] 810 ] ++ 811 inlinePragma defName 812 | (TopName defName, (_, stab, _)) <- defs 813 , let body = appsE [varE '(.), varE methodName, varE defName] 814 , let ty = quantifyType' (Set.fromList (c:varNames)) 815 (stabToContext stab) 816 $ stabToOptic stab `conAppsT` 817 [VarT c, applyTypeSubst sub (stabToA stab)] 818 ] 819 820makeClassyInstance :: 821 LensRules -> 822 Name -> 823 Name -> 824 Type {- ^ Outer 's' type -} -> 825 [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> 826 HasFieldClasses Dec 827makeClassyInstance rules className methodName s defs = do 828 methodss <- traverse (makeFieldOptic rules') defs 829 830 liftState $ instanceD (cxt[]) (return instanceHead) 831 $ valD (varP methodName) (normalB (varE 'id)) [] 832 : map return (concat methodss) 833 834 where 835 instanceHead = className `conAppsT` (s : map tvbToType vars) 836 vars = D.freeVariablesWellScoped [s] 837 rules' = rules { _generateSigs = False 838 , _generateClasses = False 839 } 840 841data OpticType = GetterType | LensType -- or IsoType 842 843 844-- Compute the positional location of the fields involved in 845-- each constructor for a given optic definition as well as the 846-- type of clauses to generate and the type to annotate the declaration 847-- with. 848buildScaffold :: 849 LensRules -> 850 Type {- outer type -} -> 851 [(Name, [([DefName], Type)])] {- normalized constructors -} -> 852 DefName {- target definition -} -> 853 Q (OpticType, OpticStab, [(Name, Int, [Int])]) 854 {- ^ optic type, definition type, field count, target fields -} 855buildScaffold rules s cons defName = 856 857 do (s',t,a,b) <- buildStab s (concatMap snd consForDef) 858 859 let defType 860 | Just (_,cx,a') <- a ^? _ForallT = 861 let optic | lensCase = ''SimpleGetter 862 | otherwise = ''SimpleFold 863 in OpticSa cx optic s' a' 864 865 -- Getter and Fold are always simple 866 | not (_allowUpdates rules) = 867 let optic | lensCase = ''SimpleGetter 868 | otherwise = ''SimpleFold 869 in OpticSa [] optic s' a 870 871 -- Generate simple Lens and Traversal where possible 872 | _simpleLenses rules || s' == t && a == b = 873 let optic -- isoCase && _allowIsos rules = ''Iso' 874 | lensCase = ''Lens' 875 | otherwise = ''Traversal' 876 in OpticSa [] optic s' a 877 878 -- Generate type-changing Lens and Traversal otherwise 879 | otherwise = 880 let optic -- isoCase && _allowIsos rules = ''Iso 881 | lensCase = ''Lens 882 | otherwise = ''Traversal 883 in OpticStab optic s' t a b 884 885 opticType | has _ForallT a = GetterType 886 | not (_allowUpdates rules) = GetterType 887 -- isoCase = IsoType 888 | otherwise = LensType 889 890 return (opticType, defType, scaffolds) 891 where 892 consForDef :: [(Name, [Either Type Type])] 893 consForDef = over (mapped . _2 . mapped) categorize cons 894 895 scaffolds :: [(Name, Int, [Int])] 896 scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ] 897 898 rightIndices :: [Either Type Type] -> [Int] 899 rightIndices = findIndices (has _Right) 900 901 -- Right: types for this definition 902 -- Left : other types 903 categorize :: ([DefName], Type) -> Either Type Type 904 categorize (defNames, t) 905 | defName `elem` defNames = Right t 906 | otherwise = Left t 907 908 lensCase :: Bool 909 lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef 910 911 -- isoCase :: Bool 912 -- isoCase = case scaffolds of 913 -- [(_,1,[0])] -> True 914 -- _ -> False 915 916data OpticStab = OpticStab Name Type Type Type Type 917 | OpticSa Cxt Name Type Type 918 919 920stabToType :: OpticStab -> Type 921stabToType (OpticStab c s t a b) = quantifyType [] (c `conAppsT` [s,t,a,b]) 922stabToType (OpticSa cx c s a ) = quantifyType cx (c `conAppsT` [s,a]) 923 924stabToContext :: OpticStab -> Cxt 925stabToContext OpticStab{} = [] 926stabToContext (OpticSa cx _ _ _) = cx 927 928stabToOptic :: OpticStab -> Name 929stabToOptic (OpticStab c _ _ _ _) = c 930stabToOptic (OpticSa _ c _ _) = c 931 932stabToS :: OpticStab -> Type 933stabToS (OpticStab _ s _ _ _) = s 934stabToS (OpticSa _ _ s _) = s 935 936stabToA :: OpticStab -> Type 937stabToA (OpticStab _ _ _ a _) = a 938stabToA (OpticSa _ _ _ a) = a 939 940-- Compute the s t a b types given the outer type 's' and the 941-- categorized field types. Left for fixed and Right for visited. 942-- These types are "raw" and will be packaged into an 'OpticStab' 943-- shortly after creation. 944buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type) 945buildStab s categorizedFields = 946 do (subA,a) <- unifyTypes targetFields 947 let s' = applyTypeSubst subA s 948 949 -- compute possible type changes 950 sub <- sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars) 951 let (t,b) = over both (substTypeVars sub) (s',a) 952 953 return (s',t,a,b) 954 955 where 956 (fixedFields, targetFields) = partitionEithers categorizedFields 957 958 fixedTypeVars, unfixedTypeVars :: Set Name 959 fixedTypeVars = closeOverKinds $ setOf typeVars fixedFields 960 unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars 961 962 -- Compute the kind variables that appear in the kind of a type variable 963 -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a 964 -- type variable binder lacks an explicit kind annotation, this 965 -- conservatively assumes that there are no kind variables. For example, 966 -- @kindVarsOfTvb (y) = (y, {})@. 967 kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name) 968 kindVarsOfTvb = D.elimTV (\n -> (n, Set.empty)) 969 (\n k -> (n, setOf typeVars k)) 970 971 -- For each type variable name that appears in @s@, map to the kind variables 972 -- that appear in that type variable's kind. 973 sKindVarMap :: Map Name (Set Name) 974 sKindVarMap = Map.fromList $ map kindVarsOfTvb $ D.freeVariablesWellScoped [s] 975 976 lookupSKindVars :: Name -> Set Name 977 lookupSKindVars n = fromMaybe Set.empty $ Map.lookup n sKindVarMap 978 979 -- Consider this example (adapted from #972): 980 -- 981 -- data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int } 982 -- $(makeLenses ''Dart) 983 -- 984 -- When generating a Lens for `direction`, the type variable `s` should be 985 -- fixed. But note that (s :: k), and as a result, the kind variable `k` 986 -- needs to be fixed as well. This is because a type like this would be 987 -- ill kinded: 988 -- 989 -- direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction 990 -- 991 -- However, only `s` is mentioned syntactically in the type of `_arc`, so we 992 -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this 993 -- with `closeOverKinds`, which does the following: 994 -- 995 -- 1. Use freeVariablesWellScoped to compute the free type variables of 996 -- `Dart (s :: k)`, which gives us `(s :: k)`. 997 -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up 998 -- the kind variables in the type variable's kind. In the case of `s`, 999 -- the only kind variable is `k`. 1000 -- 3. Add these kind variables to the set of fixed type variables. 1001 closeOverKinds :: Set Name -> Set Name 1002 closeOverKinds st = Set.foldl' Set.union Set.empty (Set.map lookupSKindVars st) `Set.union` st 1003 1004-- Build the signature and definition for a single field optic. 1005-- In the case of a singleton constructor irrefutable matches are 1006-- used to enable the resulting lenses to be used on a bottom value. 1007makeFieldOptic :: 1008 LensRules -> 1009 (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) -> 1010 HasFieldClasses [Dec] 1011makeFieldOptic rules (defName, (opticType, defType, cons)) = do 1012 locals <- get 1013 addName 1014 liftState $ do 1015 cls <- mkCls locals 1016 sequenceA (cls ++ sig ++ def) 1017 where 1018 mkCls locals = case defName of 1019 MethodName c n | _generateClasses rules -> 1020 do classExists <- isJust <$> lookupTypeName (show c) 1021 return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n]) 1022 _ -> return [] 1023 1024 addName = case defName of 1025 MethodName c _ -> addFieldClassName c 1026 _ -> return () 1027 1028 sig = case defName of 1029 _ | not (_generateSigs rules) -> [] 1030 TopName n -> [sigD n (return (stabToType defType))] 1031 MethodName{} -> [] 1032 1033 fun n = funD n clauses : inlinePragma n 1034 1035 def = case defName of 1036 TopName n -> fun n 1037 MethodName c n -> [makeFieldInstance defType c (fun n)] 1038 1039 clauses = makeFieldClauses rules opticType cons 1040 1041------------------------------------------------------------------------ 1042-- Field class generation 1043------------------------------------------------------------------------ 1044 1045makeFieldClass :: OpticStab -> Name -> Name -> DecQ 1046makeFieldClass defType className methodName = 1047 classD (cxt []) className [D.plainTV s, D.plainTV a] [FunDep [s] [a]] 1048 [sigD methodName (return methodType)] 1049 where 1050 methodType = quantifyType' (Set.fromList [s,a]) 1051 (stabToContext defType) 1052 $ stabToOptic defType `conAppsT` [VarT s,VarT a] 1053 s = mkName "s" 1054 a = mkName "a" 1055 1056-- | Build an instance for a field. If the field’s type contains any type 1057-- families, will produce an equality constraint to avoid a type family 1058-- application in the instance head. 1059makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ 1060makeFieldInstance defType className decs = 1061 containsTypeFamilies a >>= pickInstanceDec 1062 where 1063 s = stabToS defType 1064 a = stabToA defType 1065 1066 containsTypeFamilies = go <=< D.resolveTypeSynonyms 1067 where 1068 go (ConT nm) = (\i -> case i of FamilyI d _ -> isTypeFamily d; _ -> False) 1069 <$> reify nm 1070 go ty = or <$> traverse go (children ty) 1071 1072#if MIN_VERSION_template_haskell(2,11,0) 1073 isTypeFamily OpenTypeFamilyD{} = True 1074 isTypeFamily ClosedTypeFamilyD{} = True 1075#elif MIN_VERSION_template_haskell(2,9,0) 1076 isTypeFamily (FamilyD TypeFam _ _ _) = True 1077 isTypeFamily ClosedTypeFamilyD{} = True 1078#else 1079 isTypeFamily (FamilyD TypeFam _ _ _) = True 1080#endif 1081 isTypeFamily _ = False 1082 1083 pickInstanceDec hasFamilies 1084 | hasFamilies = do 1085 placeholder <- VarT <$> newName "a" 1086 mkInstanceDec 1087 [return (D.equalPred placeholder a)] 1088 [s, placeholder] 1089 | otherwise = mkInstanceDec [] [s, a] 1090 1091 mkInstanceDec context headTys = 1092 instanceD (cxt context) (return (className `conAppsT` headTys)) decs 1093 1094------------------------------------------------------------------------ 1095-- Optic clause generators 1096------------------------------------------------------------------------ 1097 1098makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ] 1099makeFieldClauses rules opticType cons = 1100 case opticType of 1101 1102 -- IsoType -> [ makeIsoClause conName | (conName, _, _) <- cons ] 1103 1104 GetterType -> [ makeGetterClause conName fieldCount fields 1105 | (conName, fieldCount, fields) <- cons ] 1106 1107 LensType -> [ makeFieldOpticClause conName fieldCount fields irref 1108 | (conName, fieldCount, fields) <- cons ] 1109 where 1110 irref = _lazyPatterns rules 1111 && length cons == 1 1112 1113-- Construct an optic clause that returns an unmodified value 1114-- given a constructor name and the number of fields on that 1115-- constructor. 1116makePureClause :: Name -> Int -> ClauseQ 1117makePureClause conName fieldCount = 1118 do xs <- newNames "x" fieldCount 1119 -- clause: _ (Con x1..xn) = pure (Con x1..xn) 1120 clause [wildP, conP conName (map varP xs)] 1121 (normalB (appE (varE 'pure) (appsE (conE conName : map varE xs)))) 1122 [] 1123 1124-- Construct an optic clause suitable for a Getter or Fold 1125-- by visited the fields identified by their 0 indexed positions 1126makeGetterClause :: Name -> Int -> [Int] -> ClauseQ 1127makeGetterClause conName fieldCount [] = makePureClause conName fieldCount 1128makeGetterClause conName fieldCount fields = 1129 do f <- newName "f" 1130 xs <- newNames "x" (length fields) 1131 1132 let pats (i:is) (y:ys) 1133 | i `elem` fields = varP y : pats is ys 1134 | otherwise = wildP : pats is (y:ys) 1135 pats is _ = map (const wildP) is 1136 1137 fxs = [ appE (varE f) (varE x) | x <- xs ] 1138 body = foldl (\a b -> appsE [varE '(<*>), a, b]) 1139 (appE (varE 'phantom) (head fxs)) 1140 (tail fxs) 1141 1142 -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn 1143 clause [varP f, conP conName (pats [0..fieldCount - 1] xs)] 1144 (normalB body) 1145 [] 1146 1147-- Build a clause that updates the field at the given indexes 1148-- When irref is 'True' the value with me matched with an irrefutable 1149-- pattern. This is suitable for Lens and Traversal construction 1150makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ 1151makeFieldOpticClause conName fieldCount [] _ = 1152 makePureClause conName fieldCount 1153makeFieldOpticClause conName fieldCount (field:fields) irref = 1154 do f <- newName "f" 1155 xs <- newNames "x" fieldCount 1156 ys <- newNames "y" (1 + length fields) 1157 1158 let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) 1159 1160 mkFx i = appE (varE f) (varE (xs !! i)) 1161 1162 body0 = appsE [ varE 'fmap 1163 , lamE (map varP ys) (appsE (conE conName : map varE xs')) 1164 , mkFx field 1165 ] 1166 1167 body = foldl (\a b -> appsE [varE '(<*>), a, mkFx b]) body0 fields 1168 1169 let wrap = if irref then tildeP else id 1170 1171 clause [varP f, wrap (conP conName (map varP xs))] 1172 (normalB body) 1173 [] 1174 1175------------------------------------------------------------------------ 1176-- Unification logic 1177------------------------------------------------------------------------ 1178 1179-- The field-oriented optic generation supports incorporating fields 1180-- with distinct but unifiable types into a single definition. 1181 1182-- Unify the given list of types, if possible, and return the 1183-- substitution used to unify the types for unifying the outer 1184-- type when building a definition's type signature. 1185unifyTypes :: [Type] -> Q (Map Name Type, Type) 1186unifyTypes (x:xs) = foldM (uncurry unify1) (Map.empty, x) xs 1187unifyTypes [] = fail "unifyTypes: Bug: Unexpected empty list" 1188 1189 1190-- Attempt to unify two given types using a running substitution 1191unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type) 1192unify1 sub (VarT x) y 1193 | Just r <- Map.lookup x sub = unify1 sub r y 1194unify1 sub x (VarT y) 1195 | Just r <- Map.lookup y sub = unify1 sub x r 1196unify1 sub x y 1197 | x == y = return (sub, x) 1198unify1 sub (AppT f1 x1) (AppT f2 x2) = 1199 do (sub1, f) <- unify1 sub f1 f2 1200 (sub2, x) <- unify1 sub1 x1 x2 1201 return (sub2, AppT (applyTypeSubst sub2 f) x) 1202unify1 sub x (VarT y) 1203 | elemOf typeVars y (applyTypeSubst sub x) = 1204 fail "Failed to unify types: occurs check" 1205 | otherwise = return (Map.insert y x sub, x) 1206unify1 sub (VarT x) y = unify1 sub y (VarT x) 1207 1208-- TODO: Unify contexts 1209unify1 sub (ForallT v1 [] t1) (ForallT v2 [] t2) = 1210 -- This approach works out because by the time this code runs 1211 -- all of the type variables have been renamed. No risk of shadowing. 1212 do (sub1,t) <- unify1 sub t1 t2 1213 v <- fmap nub (traverse (limitedSubst sub1) (v1++v2)) 1214 return (sub1, ForallT v [] t) 1215 1216unify1 _ x y = fail ("Failed to unify types: " ++ show (x,y)) 1217 1218-- Perform a limited substitution on type variables. This is used 1219-- when unifying rank-2 fields when trying to achieve a Getter or Fold. 1220limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec 1221limitedSubst sub tv 1222 | Just r <- Map.lookup (D.tvName tv) sub = 1223 case r of 1224 VarT m -> limitedSubst sub (D.mapTVName (const m) tv) 1225 _ -> fail "Unable to unify exotic higher-rank type" 1226 | otherwise = return tv 1227 1228-- Apply a substitution to a type. This is used after unifying 1229-- the types of the fields in unifyTypes. 1230applyTypeSubst :: Map Name Type -> Type -> Type 1231applyTypeSubst sub = rewrite aux 1232 where 1233 aux (VarT n) = Map.lookup n sub 1234 aux _ = Nothing 1235 1236------------------------------------------------------------------------ 1237-- Field generation parameters 1238------------------------------------------------------------------------ 1239 1240{- | 1241Rules used to generate lenses. The fields are intentionally not exported; to create your own rules, see lenses in the “Configuring lens rules” section. You'd have to customise one of the existing rulesets; for an example of doing that, see 'makeLensesWith'. 1242-} 1243data LensRules = LensRules 1244 { _simpleLenses :: Bool 1245 , _generateSigs :: Bool 1246 , _generateClasses :: Bool 1247 -- , _allowIsos :: Bool 1248 , _allowUpdates :: Bool -- Allow Lens/Traversal (otherwise Getter/Fold) 1249 , _lazyPatterns :: Bool 1250 -- Type Name -> Field Names -> Target Field Name -> Definition Names 1251 , _fieldToDef :: Name -> [Name] -> Name -> [DefName] 1252 -- Type Name -> (Class Name, Top Method) 1253 , _classyLenses :: Name -> Maybe (Name, Name) 1254 } 1255 1256{- | 1257Name to give to a generated lens (used in 'lensField'). 1258-} 1259data DefName 1260 = TopName Name -- ^ Simple top-level definiton name 1261 | MethodName Name Name -- ^ 'makeFields'-style class name and method name 1262 deriving (Show, Eq, Ord) 1263 1264 1265------------------------------------------------------------------------ 1266-- Miscellaneous utility functions 1267------------------------------------------------------------------------ 1268 1269liftState :: Monad m => m a -> StateT s m a 1270liftState act = StateT (\s -> liftM (flip (,) s) act) 1271