optics-th 0.3 → 0.3.0.1
raw patch · 6 files changed
+137/−23 lines, 6 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- optics-th.cabal +3/−2
- src/Optics/TH.hs +39/−5
- src/Optics/TH/Internal/Product.hs +36/−13
- tests/Optics/TH/Tests.hs +8/−3
- tests/Optics/TH/Tests/DuplicateRecordFields.hs +46/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+# optics-th-0.3.0.1 (2020-08-05)+* Fix handling of nullary type families+* Fix `declareFieldLabels` and `declareLenses` with DuplicateRecordFields+* Improve documentation of `Optics.TH`+ # optics-th-0.3 (2020-04-15) * `optics-core-0.3` compatible release * GHC-8.10 support
optics-th.cabal view
@@ -1,5 +1,5 @@ name: optics-th-version: 0.3+version: 0.3.0.1 license: BSD3 license-file: LICENSE build-type: Simple@@ -59,4 +59,5 @@ type: exitcode-stdio-1.0 main-is: Optics/TH/Tests.hs - other-modules: Optics.TH.Tests.T799+ other-modules: Optics.TH.Tests.DuplicateRecordFields+ Optics.TH.Tests.T799
src/Optics/TH.hs view
@@ -20,6 +20,7 @@ , lensRules , lensRulesFor -- ** Single class per data type+ -- $deprecatedClassy , makeClassy , makeClassy_ , makeClassyFor@@ -29,6 +30,7 @@ , classyRules_ , classyRulesFor -- ** Multiple classes per data type+ -- $deprecatedFields , makeFields , makeFieldsNoPrefix , declareFields@@ -90,8 +92,8 @@ ---------------------------------------- -- Labels --- | Build field optics as instances of 'LabelOptic' class for use as overloaded--- labels.+-- | Build field optics as instances of the 'LabelOptic' class for use with+-- overloaded labels. See "Optics.Label" for how to use this pattern. -- -- /e.g./ --@@ -124,11 +126,11 @@ -- Dog x1 x2 -> point (Dog x1 x2) -- @ ----- which can be used as @#age@ and @#name@ with language extension--- OverloadedLabels.+-- which can be used as @#age@ and @#name@ with the @OverloadedLabels@ language+-- extension. -- -- /Note:/ if you wonder about the form of instances or why there is no label for--- @animalAbsurd@, check documentation for 'LabelOptic'.+-- @animalAbsurd@, see "Optics.Label#limitations". -- -- @ -- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules'@@ -340,6 +342,17 @@ ---------------------------------------- -- Classy +-- $deprecatedClassy+--+-- This method of optics generation should only be used when migrating an+-- existing codebase from the @lens@ library to @optics@ as it:+--+-- - Doesn't support prefixless fields.+--+-- - Doesn't support type changing updates.+--+-- See "Optics.Label" for our recommended pattern.+ -- | Make lenses and traversals for a type, and create a class when the type has -- no arguments. --@@ -463,6 +476,27 @@ ---------------------------------------- -- Fields++-- $deprecatedFields+--+-- This method of optics generation should only be used when migrating an+-- existing codebase from the @lens@ library to @optics@ as it:+--+-- - Doesn't support type changing updates.+--+-- - Introduces tight coupling between types in your application as either all+-- types need to be put in a single module (for @HasX@ class generation to+-- work properly) or there needs to be a single, written by hand module with+-- all the @HasX@ classes the application will use. Both approaches don't+-- scale.+--+-- - Can't be leveraged by libraries because of the above problem lifted to the+-- library level: there would have to exist a library with all possible @HasX@+-- classes written by hand that is imported by all the other+-- libraries. Otherwise for a given @field@ independent libraries would+-- provide multiple @HasField@ classes incompatible with each other.+--+-- See "Optics.Label" for our recommended pattern. -- | Generate overloaded field accessors. --
src/Optics/TH/Internal/Product.hs view
@@ -28,6 +28,7 @@ import qualified Data.Set as S import qualified Data.Traversable as T import qualified Language.Haskell.TH.Datatype as D+import qualified Language.Haskell.TH.Syntax as TH import Data.Either.Optics import Data.Tuple.Optics@@ -75,7 +76,7 @@ do perDef <- lift $ do fieldCons <- traverse (normalizeConstructor info) cons let allFields = toListOf (folded % _2 % folded % _1 % folded) fieldCons- let defCons = over normFieldLabels (expandName allFields) fieldCons+ let defCons = over normFieldLabels (expandName rules tyName cons allFields) fieldCons allDefs = setOf (normFieldLabels % folded) defCons T.sequenceA (M.fromSet (buildScaffold False rules s defCons) allDefs) @@ -95,10 +96,35 @@ normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b normFieldLabels = traversed % _2 % traversed % _1 - -- Map a (possibly missing) field's name to zero-to-many optic definitions- expandName :: [Name] -> Maybe Name -> [DefName]- expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList+-- | Map a (possibly missing) field's name to zero-to-many optic definitions+expandName :: LensRules -> Name -> [D.ConstructorInfo] -> [Name] -> Maybe Name -> [DefName]+expandName rules tyName cons allFields =+ concatMap (_fieldToDef rules tyName allFields . over nameString stripSel) . maybeToList+ where+ -- When DuplicateRecordFields is enabled, reified datatypes contain+ -- "mangled" field names that look like $sel:foo:MkT where foo is the field+ -- name and MkT is the first data constructor of the type (regardless of+ -- whether that constructor contains the field or not). If they are both+ -- present, we strip off the prefix and suffix to get back to the underlying+ -- field name. See #323.+ stripSel :: String -> String+ stripSel n = fromMaybe n $ stripSuffix (':':first_con_name)+ =<< stripPrefix "$sel:" n + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+ stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse++ -- We have to look up the actual name of the first constructor, rather than+ -- trying to split the string on colons, because either the field name or+ -- the constructor name might themselves contain colons.+ first_con_name = case cons of+ con:_ -> view nameString (D.constructorName con)+ [] -> error "expandName: impossible for a record type with fields to have no constructors!"++nameString :: Lens' Name String+nameString = lens (\ (TH.Name (TH.OccName s) _) -> s)+ (\ (TH.Name _ f) s -> TH.Name (TH.OccName s) f)+ makeFieldLabelsForDec :: LensRules -> Dec -> DecsQ makeFieldLabelsForDec rules = makeFieldLabelsForDatatype rules <=< D.normalizeDec @@ -113,7 +139,7 @@ do perDef <- do fieldCons <- traverse (normalizeConstructor info) cons let allFields = toListOf (folded % _2 % folded % _1 % folded) fieldCons- let defCons = over normFieldLabels (expandName allFields) fieldCons+ let defCons = over normFieldLabels (expandName rules tyName cons allFields) fieldCons allDefs = setOf (normFieldLabels % folded) defCons T.sequenceA (M.fromSet (buildScaffold True rules s defCons) allDefs) @@ -135,10 +161,6 @@ normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b normFieldLabels = traversed % _2 % traversed % _1 - -- Map a (possibly missing) field's name to zero-to-many optic definitions- expandName :: [Name] -> Maybe Name -> [DefName]- expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList- makeFieldLabel :: LensRules -> (DefName, (OpticStab, [(Name, Int, [Int])]))@@ -394,11 +416,12 @@ go (VarT n) = modify' (S.delete n) *> pure Nothing - -- If type family is encountered, descend down and collect all of its- -- arguments for processing.+ -- If a non-nullary type family is encountered, descend down and collect+ -- all of its arguments for processing. go (ConT nm) = do- let getVarLen tf@(TypeFamilyHead _ varBndrs _ _) = (length varBndrs, tf, [])- preview (_FamilyI % _1 % typeFamilyHead % to getVarLen) <$> lift (reify nm)+ let getVarLen = afolding $ \tf@(TypeFamilyHead _ varBndrs _ _) ->+ if null varBndrs then Nothing else Just (length varBndrs, tf, [])+ preview (_FamilyI % _1 % typeFamilyHead % getVarLen) <$> lift (reify nm) go (AppT ty1 ty2) = go ty1 >>= \case Just (n, tf, !args)
tests/Optics/TH/Tests.hs view
@@ -533,14 +533,19 @@ (Proxy (a' :: k')) checkKinded2Thing = #thing +type family Fam0+ type family Fam (a :: k) type instance Fam Int = String --- unambiguous type family application-data FamRec1 a = FamRec1 { _famRec1Thing :: a -> Fam a }+-- nullary type family + unambiguous type family application+data FamRec1 a = FamRec1 { _famRec1Thing :: Fam0 -> a -> Fam a } makeFieldLabels ''FamRec1 -checkFamRec1Thing :: Iso (FamRec1 a) (FamRec1 b) (a -> Fam a) (b -> Fam b)+checkFamRec1Thing :: Iso (FamRec1 a)+ (FamRec1 b)+ (Fam0 -> a -> Fam a)+ (Fam0 -> b -> Fam b) checkFamRec1Thing = #thing type family FamInj1 (a :: k) b = r | r -> a
+ tests/Optics/TH/Tests/DuplicateRecordFields.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Test that 'declareFieldLabels' and 'declareLenses' work in the presence of+-- @DuplicateRecordFields@ (see issue #323), including when the data constructor+-- or field name contain a colon, and with data families (because data families+-- are weird).+module Optics.TH.Tests.DuplicateRecordFields where++import Optics.Core+import Optics.TH++$(declareFieldLabels [d|data T = Z | MkT { foo :: Int, (<:) :: Int -> Int }|])+$(declareLenses [d|data U = MkU { foo :: Int, (<:) :: Int -> Int }|])+$(declareLenses [d|data (:::) = (:::) { (>:) :: Int -> Int }|])++foo' :: T -> [Int]+foo' = toListOf #foo++foo'' :: U -> Int+foo'' = view foo++(<::) :: U -> Int -> Int+(<::) = view (<:)++(>::) :: (:::) -> Int -> Int+(>::) = view (>:)++$(declareFieldLabels+ [d|data family F x+ data instance F Int = MkF { foo :: Int }|])+$(declareLenses+ [d|data family G x+ data instance G Int = MkG { bar :: Int }|])++foo''' :: F Int -> Int+foo''' = view #foo++bar' :: G Int -> Int+bar' = view bar