diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.4.0.0 + +* Added `makeClassy` (and `createClass`). + # 0.3.0.2 * Added forgotten copyright/authorship information. @@ -20,7 +24,7 @@ # 0.2.1.2 -* Bumped microlens version to be able to use phantom. +* Bumped microlens version to be able to use `phantom`. # 0.2.1.1 diff --git a/microlens-th.cabal b/microlens-th.cabal --- a/microlens-th.cabal +++ b/microlens-th.cabal @@ -1,5 +1,5 @@ name: microlens-th -version: 0.3.0.2 +version: 0.4.0.0 synopsis: Automatic generation of record lenses for microlens description: This package lets you automatically generate lenses for data types; code was extracted from the lens package, and therefore generated lenses are fully compatible with ones generated by lens (and can be used both from lens and microlens). diff --git a/src/Lens/Micro/TH.hs b/src/Lens/Micro/TH.hs --- a/src/Lens/Micro/TH.hs +++ b/src/Lens/Micro/TH.hs @@ -14,13 +14,11 @@ #endif ------------------------------------------------------------------------------ --- | --- Module : Lens.Micro.TH --- Copyright : (C) 2013-2016 Eric Mertens, Edward Kmett, Artyom --- License : BSD-style (see the file LICENSE) --- ----------------------------------------------------------------------------- +{- | +Module : Lens.Micro.TH +Copyright : (C) 2013-2016 Eric Mertens, Edward Kmett, Artyom +License : BSD-style (see the file LICENSE) +-} module Lens.Micro.TH ( -- * Dealing with “not in scope” errors @@ -37,16 +35,20 @@ makeLensesFor, makeLensesWith, makeFields, + makeClassy, -- * Default lens rules LensRules, DefName(..), lensRules, lensRulesFor, + classyRules, camelCaseFields, -- * Configuring lens rules lensField, + lensClass, + createClass, simpleLenses, generateSignatures, generateUpdateableOptics, @@ -162,13 +164,6 @@ -- Utilities --- Modify element at some index in a list. -setIx :: Int -> a -> [a] -> [a] -setIx i x s - | i < 0 || i >= length s = s - | otherwise = let (l, _:r) = splitAt i s - in l ++ [x] ++ r - -- This is like @rewrite@ from uniplate. rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b rewrite f mbA = case cast mbA of @@ -185,10 +180,6 @@ fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] #endif -overHead :: (a -> a) -> [a] -> [a] -overHead _ [] = [] -overHead f (x:xs) = f x : xs - -- Control.Lens.TH {- | @@ -222,7 +213,7 @@ (If you don't want a lens to be generated for some field, don't prefix it with “_”.) -If you want to creat 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): +If you want to create lenses for many types, you can do it all in one place like this (of course, instead you just can use 'makeLenses' several times if you feel it would be more readable): @ data Foo = ... @@ -389,12 +380,76 @@ If you want to use 'makeFields' on types declared in different modules, you can do it, but then you would have to export the @Has*@ classes from one of the modules – 'makeFields' creates a class if it's not in scope yet, so the class must be in scope or else there would be duplicate classes and you would get an “Ambiguous occurrence” error. -Finally, 'makeFields' is implemented as @'makeLenses' 'camelCaseFields'@, so you can build on 'camelCaseFields' if you want to customise behavior of 'makeFields'. +Finally, 'makeFields' is implemented as @'makeLensesWith' 'camelCaseFields'@, so you can build on 'camelCaseFields' if you want to customise behavior of 'makeFields'. -} makeFields :: Name -> DecsQ makeFields = makeFieldOptics camelCaseFields {- | +Generate overloaded lenses without ad-hoc classes; useful when there's a collection of fields that you want to make common for several types. + +Like 'makeFields', each lens is a member of a class. However, the classes are per-type and not per-field. Let's take the following type: + +@ +data Person = Person { + _name :: String, + _age :: Double } +@ + +'makeClassy' would generate a single class with 3 methods: + +@ +class HasPerson c where + person :: Lens' c Person + + age :: Lens' c Double + age = person.age + + name :: Lens' c String + name = person.name +@ + +And an instance: + +@ +instance HasPerson Person where + person = id + + name = ... + age = ... +@ + +So, you can use @name@ and @age@ to refer to the @_name@ and @_age@ fields, as usual. However, the extra lens – @person@ – allows you to do a kind of subtyping. Let's say that there's a type called @Worker@ and every worker has the same fields that a person has, but also a @job@. If you were using 'makeFields', you'd do the following: + +@ +data Worker = Worker { + _workerName :: String, + _workerAge :: Double, + _workerJob :: String } +@ + +However, with 'makeClassy' you can say “every worker is a person” in a more principled way: + +@ +data Worker = Worker { + _workerPerson :: Person, + _job :: String } + +makeClassy ''Worker + +instance HasPerson Worker where person = workerPerson +@ + +Now you can use @age@ and @name@ to access name\/age of a @Worker@, but you also can use @person@ to “downgrade” a @Worker@ to a @Person@ (and e.g. apply some @Person@-specific function to it). + +Unlike 'makeFields', 'makeClassy' doesn't make use of prefixes. @_workerPerson@ could've just as well been named @_foobar@. + +'makeClassy' is implemented as @'makeLensesWith' 'classyRules'@, so you can build on 'classyRules' if you want to customise behavior of 'makeClassy'. +-} +makeClassy :: Name -> DecsQ +makeClassy = makeFieldOptics classyRules + +{- | Generate simple (monomorphic) lenses even when type-changing lenses are possible – i.e. 'Lens'' instead of 'Lens' and 'Traversal'' instead of 'Traversal'. Just in case, here's an example of a situation when type-changing lenses would be normally generated: @ @@ -494,13 +549,38 @@ lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r)) {- | +This lets you choose whether a class would be generated for the type itself (like 'makeClassy' does). If so, you can choose the name of the class and the name of the type-specific lens. + +For 'makeLenses' and 'makeFields' this is just @const Nothing@. For 'makeClassy' this function is defined like this: + +@ +\\n -> + case 'nameBase' n of + x:xs -> Just ('mkName' ("Has" ++ x:xs), 'mkName' ('toLower' x : xs)) + [] -> Nothing +@ +-} +lensClass :: Lens' LensRules (Name -> Maybe (Name, Name)) +lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r)) + +{- | +Decide whether generation of classes is allowed at all. + +If this is disabled, neither 'makeFields' nor 'makeClassy' would work, regardless of values of 'lensField' or 'lensClass'. On the other hand, if 'lensField' and 'lensClass' don't generate any classes, enabling this won't have any effect. +-} +createClass :: Lens' LensRules Bool +createClass f r = + fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r)) + +{- | Lens rules used by default (i.e. in 'makeLenses'): * 'generateSignatures' is turned on * 'generateUpdateableOptics' is turned on * 'generateLazyPatterns' is turned off * 'simpleLenses' is turned off -* 'lensField' strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_” (you can see how it's implemented in the docs for 'lensField'). +* 'lensField' strips “_” off the field name, lowercases the next character after “_”, and skips the field entirely if it doesn't start with “_” (you can see how it's implemented in the docs for 'lensField') +* 'lensClass' isn't used (i.e. defined as @const Nothing@) -} lensRules :: LensRules lensRules = LensRules @@ -510,7 +590,7 @@ -- , _allowIsos = True , _allowUpdates = True , _lazyPatterns = False - -- , _classyLenses = const Nothing + , _classyLenses = const Nothing , _fieldToDef = \_ _ n -> case nameBase n of '_':x:xs -> [TopName (mkName (toLower x:xs))] @@ -537,6 +617,7 @@ * 'generateLazyPatterns' is turned off * 'simpleLenses' is turned on (unlike in 'lensRules') * 'lensField' is more complicated – it takes fields which are prefixed with the name of the type they belong to (e.g. “fooFieldName” for “Foo”), strips that prefix, and generates a class called “HasFieldName” with a single method called “fieldName”. If some fields are prefixed with underscores, underscores would be stripped too, but then fields without underscores won't have any lenses generated for them. Also note that e.g. “foolish” won't have a lens called “lish” generated for it – the prefix must be followed by a capital letter (or else it wouldn't be camel case). +* 'lensClass' isn't used (i.e. defined as @const Nothing@) -} camelCaseFields :: LensRules camelCaseFields = defaultFieldRules @@ -550,7 +631,7 @@ return (MethodName (mkName cls) (mkName method)) where - expectedPrefix = optUnderscore ++ overHead toLower (nameBase tyName) + expectedPrefix = optUnderscore ++ over _head toLower (nameBase tyName) optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ] @@ -565,10 +646,41 @@ -- , _allowIsos = False -- generating Isos would hinder field class reuse , _allowUpdates = True , _lazyPatterns = False - -- , _classyLenses = const Nothing + , _classyLenses = const Nothing , _fieldToDef = camelCaseNamer } +underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName] +underscoreNoPrefixNamer _ _ n = + case nameBase n of + '_':x:xs -> [TopName (mkName (toLower x:xs))] + _ -> [] + +{- | +Lens rules used by 'makeClassy': + +* 'generateSignatures' is turned on +* 'generateUpdateableOptics' is turned on +* 'generateLazyPatterns' is turned off +* 'simpleLenses' is turned on (unlike in 'lensRules') +* 'lensField' is the same as in 'lensRules' +* 'lensClass' just adds “Has” to the name of the type (so for “Person” the generated class would be called “HasPerson” and the type-specific lens in that class would be called “person”) +-} +classyRules :: LensRules +classyRules = LensRules + { _simpleLenses = True + , _generateSigs = True + , _generateClasses = True + -- , _allowIsos = False -- generating Isos would hinder "subtyping" + , _allowUpdates = True + , _lazyPatterns = False + , _classyLenses = \n -> + case nameBase n of + x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs)) + [] -> Nothing + , _fieldToDef = underscoreNoPrefixNamer + } + -- Language.Haskell.TH.Lens -- Has a 'Name' @@ -716,15 +828,11 @@ perDef <- sequenceA (fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef --- case _classyLenses rules tyName of --- Just (className, methodName) -> --- makeClassyDriver rules className methodName s defs --- Nothing -> do decss <- traverse (makeFieldOptic rules) defs --- return (concat decss) - - -- just don't make anything classy - decss <- traverse (makeFieldOptic rules) defs - return (concat decss) + case _classyLenses rules tyName of + Just (className, methodName) -> + makeClassyDriver rules className methodName s defs + Nothing -> do decss <- traverse (makeFieldOptic rules) defs + return (concat decss) where @@ -737,7 +845,72 @@ expandName allFields (Just n) = _fieldToDef rules tyName allFields n expandName _ _ = [] +makeClassyDriver :: + LensRules -> + Name -> + Name -> + Type {- ^ Outer 's' type -} -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + DecsQ +makeClassyDriver rules className methodName s defs = sequenceA (cls ++ inst) + where + cls | _generateClasses rules = [makeClassyClass className methodName s defs] + | otherwise = [] + + inst = [makeClassyInstance rules className methodName s defs] + +makeClassyClass :: + Name -> + Name -> + Type {- ^ Outer 's' type -} -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + DecQ +makeClassyClass className methodName s defs = do + let ss = map (stabToS . (^. _2._2)) defs + (sub,s') <- unifyTypes (s : ss) + c <- newName "c" + let vars = toListOf typeVars s' + fd | null vars = [] + | otherwise = [FunDep [c] vars] + + + classD (cxt[]) className (map PlainTV (c:vars)) fd + $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s'])) + : concat + [ [sigD defName (return ty) + ,valD (varP defName) (normalB body) [] + ] ++ + inlinePragma defName + | (TopName defName, (_, stab, _)) <- defs + , let body = appsE [varE '(.), varE methodName, varE defName] + , let ty = quantifyType' (Set.fromList (c:vars)) + (stabToContext stab) + $ stabToOptic stab `conAppsT` + [VarT c, applyTypeSubst sub (stabToA stab)] + ] + +makeClassyInstance :: + LensRules -> + Name -> + Name -> + Type {- ^ Outer 's' type -} -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + DecQ +makeClassyInstance rules className methodName s defs = do + methodss <- traverse (makeFieldOptic rules') defs + + instanceD (cxt[]) (return instanceHead) + $ valD (varP methodName) (normalB (varE 'id)) [] + : map return (concat methodss) + + where + instanceHead = className `conAppsT` (s : map VarT vars) + vars = toListOf typeVars s + rules' = rules { _generateSigs = False + , _generateClasses = False + } + -- Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal -- constructors. @@ -1001,7 +1174,7 @@ xs <- replicateM fieldCount (newName "x") ys <- replicateM (1 + length fields) (newName "y") - let xs' = foldr (\(i,x) -> setIx i x) xs (zip (field:fields) ys) + let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) mkFx i = appE (varE f) (varE (xs !! i)) @@ -1102,8 +1275,8 @@ , _lazyPatterns :: Bool -- Type Name -> Field Names -> Target Field Name -> Definition Names , _fieldToDef :: Name -> [Name] -> Name -> [DefName] - -- , _classyLenses :: Name -> Maybe (Name,Name) - -- type name to class name and top method + -- Type Name -> (Class Name, Top Method) + , _classyLenses :: Name -> Maybe (Name,Name) } {- |