optics-th 0.3.0.2 → 0.4
raw patch · 8 files changed
+366/−163 lines, 8 filesdep ~basedep ~containersdep ~optics-core
Dependency ranges changed: base, containers, optics-core, template-haskell, th-abstraction
Files
- CHANGELOG.md +17/−0
- optics-th.cabal +7/−7
- src/Language/Haskell/TH/Optics/Internal.hs +13/−3
- src/Optics/TH.hs +17/−4
- src/Optics/TH/Internal/Product.hs +95/−60
- src/Optics/TH/Internal/Sum.hs +55/−45
- src/Optics/TH/Internal/Utils.hs +81/−13
- tests/Optics/TH/Tests.hs +81/−31
CHANGELOG.md view
@@ -1,3 +1,20 @@+# optics-th-0.4 (2021-02-22)+* Add support for GHC-9.0+* Print missing language extensions during TH generation of labels if there are+ any ([#352](https://github.com/well-typed/optics/pull/352))+* Add support for getters of rank1 polymorphic fields to optics generated with+ the `makeFieldLabels` family of functions+ ([#365](https://github.com/well-typed/optics/pull/365))+* Extend support of type-changing optics generated with the `makeFieldLabels`+ family to type parameters that are phantom and applied to non-injective type+ families+ ([#365](https://github.com/well-typed/optics/pull/365))+* Fix TH generation of optics for poly-kinded data families+ ([#378](https://github.com/well-typed/optics/pull/378))+* Fix `declareFieldLabels` when a field type refers to a type defined in the+ same quote+ ([#380](https://github.com/well-typed/optics/pull/380))+ # optics-th-0.3.0.2 (2020-08-20) * Fix tests on GHC 8.10.2
optics-th.cabal view
@@ -1,12 +1,12 @@ name: optics-th-version: 0.3.0.2+version: 0.4 license: BSD3 license-file: LICENSE build-type: Simple maintainer: optics@well-typed.com author: Andrzej Rybczak cabal-version: 1.24-tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2, GHCJS ==8.4+tested-with: ghc ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3, GHCJS ==8.4 synopsis: Optics construction using TemplateHaskell category: Data, Optics, Lenses description:@@ -29,12 +29,12 @@ hs-source-dirs: src ghc-options: -Wall - build-depends: base >= 4.9 && <5- , containers >= 0.5.7.1 && <0.7+ build-depends: base >= 4.10 && <5+ , containers >= 0.5.10.2 && <0.7 , mtl >= 2.2.2 && <2.3- , optics-core >= 0.3 && <0.4- , template-haskell >= 2.11 && <2.17- , th-abstraction >= 0.2.1 && <0.4+ , optics-core >= 0.4 && <0.5+ , template-haskell >= 2.12 && <2.18+ , th-abstraction >= 0.4 && <0.5 , transformers >= 0.5 && <0.6 exposed-modules: Optics.TH
src/Language/Haskell/TH/Optics/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeSynonymInstances #-} module Language.Haskell.TH.Optics.Internal ( -- * Traversals@@ -14,6 +15,9 @@ , _ClosedTypeFamilyD , _OpenTypeFamilyD , _ForallT++ -- * TyVarBndr compatiblity+ , TyVarBndrSpec ) where import Data.Map as Map hiding (map, toList)@@ -21,6 +25,7 @@ import Data.Foldable (traverse_) import Data.Set as Set hiding (map, toList) import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import Data.Set.Optics import Optics.Core@@ -30,10 +35,15 @@ -- | Extract (or modify) the 'Name' of something name :: Lens' t Name -instance HasName TyVarBndr where+instance HasName (TyVarBndr_ flag) where name = lensVL $ \f -> \case+#if MIN_VERSION_template_haskell(2,17,0)+ PlainTV n flag -> (\n' -> PlainTV n' flag) <$> f n+ KindedTV n flag k -> (\n' -> KindedTV n' flag k ) <$> f n+#else PlainTV n -> PlainTV <$> f n KindedTV n k -> (`KindedTV` k) <$> f n+#endif -- | Provides for the extraction of free type variables, and alpha renaming. class HasTypeVars t where@@ -42,7 +52,7 @@ -- 'Traversal' laws, when in doubt generate your names with 'newName'. typeVarsEx :: Set Name -> Traversal' t Name -instance HasTypeVars TyVarBndr where+instance HasTypeVars (TyVarBndr_ flag) where typeVarsEx s = traversalVL $ \f b -> if view name b `Set.member` s then pure b@@ -159,7 +169,7 @@ remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type)+_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where
src/Optics/TH.hs view
@@ -3,6 +3,7 @@ -- * Generation of field optics -- ** Labels makeFieldLabels+ , makeFieldLabelsNoPrefix , makeFieldLabelsFor , makeFieldLabelsWith , declareFieldLabels@@ -124,19 +125,31 @@ -- labelOptic = atraversalVL $ \\point f s -> case s of -- Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2) -- Dog x1 x2 -> point (Dog x1 x2)+--+-- instance+-- ( Dysfunctional "absurd" k Animal Animal a b+-- , k ~ An_AffineFold, a ~ (x -> y), b ~ (x -> y)+-- ) => LabelOptic "absurd" k Animal Animal a b where+-- labelOptic = afolding $ \\s -> case s of+-- Cat _ _ -> Nothing+-- Dog _ f -> Just f -- @ ----- which can be used as @#age@ and @#name@ with the @OverloadedLabels@ language--- extension.+-- which can be used as @#age@, @#name@ and @#absurd@ with the+-- @OverloadedLabels@ language extension. ----- /Note:/ if you wonder about the form of instances or why there is no label for--- @animalAbsurd@, see "Optics.Label#limitations".+-- /Note:/ if you wonder about the structure of instances, see+-- "Optics.Label#structure". -- -- @ -- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules' -- @ makeFieldLabels :: Name -> DecsQ makeFieldLabels = makeFieldLabelsWith fieldLabelsRules++-- | An alias for @makeFieldLabels noPrefixFieldLabels@.+makeFieldLabelsNoPrefix :: Name -> DecsQ+makeFieldLabelsNoPrefix = makeFieldLabelsWith noPrefixFieldLabels -- | Derive field optics as labels, specifying explicit pairings of @(fieldName, -- labelName)@.
src/Optics/TH/Internal/Product.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -35,6 +36,7 @@ import Data.Set.Optics import Language.Haskell.TH.Optics.Internal import Optics.Core hiding (cons)+import Optics.Internal.Magic import Optics.TH.Internal.Utils ------------------------------------------------------------------------@@ -44,8 +46,13 @@ typeSelf :: Traversal' Type Type typeSelf = traversalVL $ \f -> \case ForallT tyVarBndrs ctx ty ->+#if MIN_VERSION_template_haskell(2,17,0)+ let go (KindedTV nam flag kind) = KindedTV <$> pure nam <*> pure flag <*> f kind+ go (PlainTV nam flag) = pure (PlainTV nam flag)+#else let go (KindedTV nam kind) = KindedTV <$> pure nam <*> f kind go (PlainTV nam) = pure (PlainTV nam)+#endif in ForallT <$> traverse go tyVarBndrs <*> traverse f ctx <*> f ty AppT ty1 ty2 -> AppT <$> f ty1 <*> f ty2 SigT ty kind -> SigT <$> f ty <*> f kind@@ -84,12 +91,15 @@ case _classyLenses rules tyName of Just (className, methodName) -> makeClassyDriver rules className methodName s defs- Nothing -> do decss <- traverse (makeFieldOptic rules) defs- return (concat decss)+ Nothing -> do+ when (has (traversed % _1 % _MethodName) defs) $ do+ lift requireExtensionsForFields+ decss <- traverse (makeFieldOptic rules) defs+ return (concat decss) where tyName = D.datatypeName info- s = addKindVars info $ D.datatypeType info+ s = addKindInfo info $ D.datatypeType info cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor@@ -135,26 +145,19 @@ -- | Compute the field optics for a deconstructed datatype Dec -- When possible build an Iso otherwise build one optic per field. makeFieldLabelsForDatatype :: LensRules -> D.DatatypeInfo -> Q [Dec]-makeFieldLabelsForDatatype rules info =- do perDef <- do- fieldCons <- traverse (normalizeConstructor info) cons- let allFields = toListOf (folded % _2 % folded % _1 % folded) 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)-- let defs = filter isRank1 $ M.toList perDef- traverse (makeFieldLabel rules) defs-+makeFieldLabelsForDatatype rules info = do+ requireExtensionsForLabels+ perDef <- do+ fieldCons <- traverse (normalizeConstructor info) cons+ let allFields = toListOf (folded % _2 % folded % _1 % folded) 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)+ let defs = M.toList perDef+ traverse (makeFieldLabel info rules) defs where- -- LabelOptic doesn't support higher rank fields because of functional- -- dependencies (s -> a, t -> b), so just skip them.- isRank1 = \case- (_, (OpticSa vs _ _ _ _, _)) -> null vs- _ -> True- tyName = D.datatypeName info- s = addKindVars info $ D.datatypeType info+ s = addKindInfo info $ D.datatypeType info cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor@@ -162,23 +165,38 @@ normFieldLabels = traversed % _2 % traversed % _1 makeFieldLabel- :: LensRules+ :: D.DatatypeInfo+ -> LensRules -> (DefName, (OpticStab, [(Name, Int, [Int])])) -> Q Dec-makeFieldLabel rules (defName, (defType, cons)) = do+makeFieldLabel info rules (defName, (defType, cons)) = do (context, instHead) <- case defType of- OpticSa _ _ otype s a -> do+ OpticSa vs cx otype s a0 -> do+ -- 'tv' might have info about type variables of 'a' that need filling in.+ let a = addKindInfo' (map tyVarBndrToType vs) info a0 (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" (a', cxtA) <- eqSubst a "a" (b', cxtB) <- eqSubst a "b"- pure (pure [cxtK, cxtA, cxtB], pure $ conAppsT ''LabelOptic- [LitT (StrTyLit fieldName), k, s, s, a', b'])- OpticStab otype s t a b -> do+ let tyArgs = [LitT (StrTyLit fieldName), k, s, s, a', b']+ context = concat+ [ -- If the field is polymorphic, the instance is dysfunctional.+ if null vs then [] else [conAppsT ''Dysfunctional tyArgs]+ , [cxtK, cxtA, cxtB]+ , cx+ ]+ pure (pure context, pure $ conAppsT ''LabelOptic tyArgs)+ OpticStab tvsCovered otype s t a b -> do (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k" (a', cxtA) <- eqSubst a "a" (b', cxtB) <- eqSubst b "b"- pure (pure [cxtK, cxtA, cxtB], pure $ conAppsT ''LabelOptic- [LitT (StrTyLit fieldName), k, s, t, a', b'])+ let tyArgs = [LitT (StrTyLit fieldName), k, s, t, a', b']+ context = concat+ [ -- If some of the type variables are not covered, the instance is+ -- dysfunctional.+ if tvsCovered then [] else [conAppsT ''Dysfunctional tyArgs]+ , [cxtK, cxtA, cxtB]+ ]+ pure (pure context, pure $ conAppsT ''LabelOptic tyArgs) instanceD context instHead (fun 'labelOptic) where opticTypeToTag AffineFoldType = ''An_AffineFold@@ -221,11 +239,11 @@ -- elligible for TH generated optics. checkForExistentials _ fieldtype | any (\tv -> D.tvName tv `S.member` used) unallowable- = (Nothing, addKindVars info fieldtype)+ = (Nothing, addKindInfo info fieldtype) where used = setOf typeVars fieldtype unallowable = D.constructorVars con- checkForExistentials fieldname fieldtype = (fieldname, addKindVars info fieldtype)+ checkForExistentials fieldname fieldtype = (fieldname, addKindInfo info fieldtype) -- | Compute the positional location of the fields involved in -- each constructor for a given optic definition as well as the@@ -241,29 +259,30 @@ {- ^ optic type, definition type, field count, target fields -} buildScaffold forClassInstance rules s cons defName = - do (s',t,a,b) <- buildStab forClassInstance s (concatMap snd consForDef)+ do (t,a,b, tvsCovered) <- buildTab forClassInstance s $+ concatMap snd consForDef let defType | Just (tyvars, cx, a') <- preview _ForallT a = let optic | lensCase = GetterType | affineCase = AffineFoldType | otherwise = FoldType- in OpticSa tyvars cx optic s' a'+ in OpticSa tyvars cx optic s a' -- Getter and Fold are always simple | not (_allowUpdates rules) = let optic | lensCase = GetterType | affineCase = AffineFoldType | otherwise = FoldType- in OpticSa [] [] optic s' a+ in OpticSa [] [] optic s a -- Generate simple Lens and Traversal where possible- | _simpleLenses rules || s' == t && a == b =+ | _simpleLenses rules || s == t && a == b = let optic | isoCase && _allowIsos rules = IsoType | lensCase = LensType | affineCase = AffineTraversalType | otherwise = TraversalType- in OpticSa [] [] optic s' a+ in OpticSa [] [] optic s a -- Generate type-changing Lens and Traversal otherwise | otherwise =@@ -271,7 +290,7 @@ | lensCase = LensType | affineCase = AffineTraversalType | otherwise = TraversalType- in OpticStab optic s' t a b+ in OpticStab tvsCovered optic s t a b return (defType, scaffolds) where@@ -333,12 +352,12 @@ else ''Traversal' data OpticStab- = OpticStab OpticType Type Type Type Type- | OpticSa [TyVarBndr] Cxt OpticType Type Type+ = OpticStab Bool OpticType Type Type Type Type+ | OpticSa [TyVarBndrSpec] Cxt OpticType Type Type deriving Show stabToType :: OpticStab -> Type-stabToType (OpticStab c s t a b) =+stabToType (OpticStab _ c s t a b) = quantifyType [] [] (opticTypeName True c `conAppsT` [s,t,a,b]) stabToType (OpticSa vs cx c s a) = quantifyType vs cx (opticTypeName False c `conAppsT` [s,a])@@ -348,31 +367,33 @@ stabToContext (OpticSa _ cx _ _ _) = cx stabToOpticType :: OpticStab -> OpticType-stabToOpticType (OpticStab c _ _ _ _) = c+stabToOpticType (OpticStab _ c _ _ _ _) = c stabToOpticType (OpticSa _ _ c _ _) = c stabToOptic :: OpticStab -> Name-stabToOptic (OpticStab c _ _ _ _) = opticTypeName True c+stabToOptic (OpticStab _ c _ _ _ _) = opticTypeName True c stabToOptic (OpticSa _ _ c _ _) = opticTypeName False c stabToS :: OpticStab -> Type-stabToS (OpticStab _ s _ _ _) = s+stabToS (OpticStab _ _ s _ _ _) = s stabToS (OpticSa _ _ _ s _) = s stabToA :: OpticStab -> Type-stabToA (OpticStab _ _ _ a _) = a+stabToA (OpticStab _ _ _ _ a _) = a stabToA (OpticSa _ _ _ _ a) = a --- | Compute the s t a b types given the outer type 's' and the+-- | Compute the t a b types given the outer type 's' and the -- categorized field types. Left for fixed and Right for visited. -- These types are "raw" and will be packaged into an 'OpticStab' -- shortly after creation.-buildStab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Type)-buildStab forClassInstance s categorizedFields = do- -- compute possible type changes- sub <- T.sequenceA . M.fromSet (newName . nameBase) =<< unfixedTypeVars+buildTab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Bool)+buildTab forClassInstance s categorizedFields = do+ -- Compute possible type changes and check whether we have to lift the+ -- coverage condition in case we're generating a class instance.+ (unfixedTypeVars, tvsCovered) <- mkUnfixedTypeVars+ sub <- T.sequenceA $ M.fromSet (newName . nameBase) unfixedTypeVars let (t, b) = over each (substTypeVars sub) (s, a)- pure (s, t, a, b)+ pure (t, a, b, tvsCovered) where -- Just take the type of the first field and let GHC do the unification. a = fromMaybe@@ -385,7 +406,11 @@ (fixedFields, targetFields) = partitionEithers categorizedFields - unfixedTypeVars+ mkUnfixedTypeVars+ | S.null freeTypeVars =+ -- If there are no free type vars, don't bother searching for ambiguous+ -- type family applications because there are none.+ pure (S.empty, True) | forClassInstance = do ambiguousTypeVars <- getAmbiguousTypeFamilyTypeVars --runIO $ do@@ -395,10 +420,10 @@ -- putStrLn $ "FIXED: " ++ show fixedTypeVars -- putStrLn $ "PHANTOM: " ++ show phantomTypeVars -- putStrLn $ "AMBIGUOUS: " ++ show ambiguousTypeVars- pure $ freeTypeVars S.\\ fixedTypeVars- S.\\ phantomTypeVars- S.\\ ambiguousTypeVars- | otherwise = pure $ freeTypeVars S.\\ fixedTypeVars+ pure ( freeTypeVars S.\\ fixedTypeVars+ , S.null phantomTypeVars && S.null ambiguousTypeVars+ )+ | otherwise = pure (freeTypeVars S.\\ fixedTypeVars, True) where freeTypeVars = setOf typeVars s fixedTypeVars = setOf typeVars fixedFields@@ -421,7 +446,7 @@ go (ConT nm) = do let getVarLen = afolding $ \tf@(TypeFamilyHead _ varBndrs _ _) -> if null varBndrs then Nothing else Just (length varBndrs, tf, [])- preview (_FamilyI % _1 % typeFamilyHead % getVarLen) <$> lift (reify nm)+ tryReify (preview $ _FamilyI % _1 % typeFamilyHead % getVarLen) nm go (AppT ty1 ty2) = go ty1 >>= \case Just (n, tf, !args)@@ -433,18 +458,23 @@ go _ = pure Nothing procInfix ty1 nm ty2 = do- mtf <- preview (_FamilyI % _1 % typeFamilyHead) <$> lift (reify nm)+ mtf <- tryReify (preview $ _FamilyI % _1 % typeFamilyHead) nm case mtf of Just tf -> procTF tf [ty1, ty2] Nothing -> go ty1 *> go ty2 *> pure () + -- If reification fails (e.g. because the type contains local names),+ -- assume there are no type families (the best we can do really).+ tryReify :: (Info -> Maybe a) -> Name -> StateT (S.Set Name) Q (Maybe a)+ tryReify f nm = lift $ recover (pure Nothing) (f <$> reify nm)+ -- Once fully applied type family is collected, the only arguments that -- should be traversed further are these with injectivity annotation. procTF :: TypeFamilyHead -> [Type] -> StateT (S.Set Name) Q () procTF tf args = case tf of TypeFamilyHead _ varBndrs _ (Just (InjectivityAnn _ ins)) -> do let insSet = S.fromList ins- vars = map bndrName varBndrs+ vars = map D.tvName varBndrs --lift . runIO $ do -- putStrLn $ "INS: " ++ show ins -- putStrLn $ "VARS: " ++ show vars@@ -528,7 +558,7 @@ | otherwise = [FunDep [c] vars] - classD (cxt[]) className (map PlainTV (c:vars)) fd+ classD (cxt[]) className (map plainTV (c:vars)) fd $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s])) : concat [ [sigD defName (return ty)@@ -572,7 +602,7 @@ makeFieldClass :: OpticStab -> Name -> Name -> DecQ makeFieldClass defType className methodName =- classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]]+ classD (cxt []) className [plainTV s, plainTV a] [FunDep [s] [a]] [sigD methodName (return methodType)] where methodType = quantifyType' (S.fromList [s,a])@@ -878,6 +908,11 @@ = TopName Name -- ^ Simple top-level definition name | MethodName Name Name -- ^ makeFields-style class name and method name deriving (Show, Eq, Ord)++_MethodName :: Prism' DefName (Name, Name)+_MethodName = prism' (uncurry MethodName) $ \case+ TopName{} -> Nothing+ MethodName c n -> Just (c, n) -- | The optional rule to create a class and method around a -- monomorphic data type. If this naming convention is provided, it
src/Optics/TH/Internal/Sum.hs view
@@ -11,6 +11,7 @@ import Data.Maybe import Data.Traversable import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import qualified Data.Map as M import qualified Data.Set as S import qualified Language.Haskell.TH.Datatype as D@@ -18,6 +19,7 @@ import Data.Set.Optics import Language.Haskell.TH.Optics.Internal import Optics.Core hiding (cons)+import Optics.Internal.Magic import Optics.TH.Internal.Utils -- | Generate a 'Prism' for each constructor of a data type. Isos generated when@@ -82,29 +84,31 @@ makePrismLabels :: Name -> DecsQ makePrismLabels typeName = do+ requireExtensionsForLabels info <- D.reifyDatatype typeName let cons = map (normalizeCon info) $ D.datatypeCons info catMaybes <$> traverse (makeLabel info cons) cons where makeLabel :: D.DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec) makeLabel info cons con = do- stab@(Stab cx otype s t a b) <- computeOpticType labelConfig ty cons con- case otype of- -- Reviews are for existentially quantified types and these don't fit- -- into OpticLabel because of functional dependencies, just skip them.- ReviewType -> pure Nothing- _ -> do- (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k"- (a', cxtA) <- eqSubst a "a"- (b', cxtB) <- eqSubst b "b"- let label = nameBase . prismName $ view nconName con- instHead = pure $ conAppsT ''LabelOptic- [LitT (StrTyLit label), k, s, t, a', b']- Just <$> instanceD (pure $ cx ++ [cxtK, cxtA, cxtB])- instHead- (fun stab 'labelOptic)+ stab@(Stab tvsCovered cx otype s t a b) <- computeOpticType labelConfig ty cons con+ (k, cxtK) <- eqSubst (ConT $ opticTypeToTag otype) "k"+ (a', cxtA) <- eqSubst a "a"+ (b', cxtB) <- eqSubst b "b"+ let label = nameBase . prismName $ view nconName con+ tyArgs = [LitT (StrTyLit label), k, s, t, a', b']+ context = concat+ [ -- If some of the type variables are not covered, instance is+ -- dysfunctional.+ if tvsCovered then [] else [conAppsT ''Dysfunctional tyArgs]+ , [cxtK, cxtA, cxtB]+ , cx+ ]+ Just <$> instanceD (pure context)+ (pure $ conAppsT ''LabelOptic tyArgs)+ (fun stab 'labelOptic) where- ty = addKindVars info $ D.datatypeType info+ ty = addKindInfo info $ D.datatypeType info isNewtype = D.datatypeVariant info == D.Newtype opticTypeToTag IsoType = ''An_Iso@@ -156,7 +160,7 @@ , valD (varP n) (normalB body) [] ] ++ inlinePragma n where- ty = addKindVars info $ D.datatypeType info+ ty = addKindInfo info $ D.datatypeType info isNewtype = D.datatypeVariant info == D.Newtype -- classy prism class and instance@@ -173,41 +177,42 @@ ---------------------------------------- data StabConfig = StabConfig- { scAllowPhantomsChange :: Bool- , scAllowIsos :: Bool+ { scForLabelInstance :: Bool+ , scAllowIsos :: Bool } defaultConfig :: StabConfig defaultConfig = StabConfig- { scAllowPhantomsChange = True- , scAllowIsos = True+ { scForLabelInstance = False+ , scAllowIsos = True } classyConfig :: StabConfig classyConfig = StabConfig- { scAllowPhantomsChange = True- , scAllowIsos = False+ { scForLabelInstance = False+ , scAllowIsos = False } labelConfig :: StabConfig labelConfig = StabConfig- { scAllowPhantomsChange = False- , scAllowIsos = True+ { scForLabelInstance = True+ , scAllowIsos = True } data OpticType = IsoType | PrismType | ReviewType-data Stab = Stab Cxt OpticType Type Type Type Type+ deriving Eq+data Stab = Stab Bool Cxt OpticType Type Type Type Type simplifyStab :: Stab -> Stab-simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b+simplifyStab (Stab tvsCovered cx ty _ t _ b) = Stab tvsCovered cx ty t t b b -- simplification uses t and b because those types -- are interesting in the Review case stabSimple :: Stab -> Bool-stabSimple (Stab _ _ s t a b) = s == t && a == b+stabSimple (Stab _ _ _ s t a b) = s == t && a == b stabToType :: Stab -> Type-stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $+stabToType stab@(Stab _ cx ty s t a b) = ForallT vs cx $ case ty of IsoType | stabSimple stab -> ''Iso' `conAppsT` [s,a] | otherwise -> ''Iso `conAppsT` [s,t,a,b]@@ -216,12 +221,13 @@ ReviewType -> ''Review `conAppsT` [t,b] where- vs = D.freeVariablesWellScoped+ vs = changeTVFlags SpecifiedSpec+ . D.freeVariablesWellScoped . S.toList $ setOf (folded % typeVarsKinded) cx stabType :: Stab -> OpticType-stabType (Stab _ o _ _ _ _) = o+stabType (Stab _ _ o _ _ _ _) = o computeOpticType :: StabConfig -> Type -> [NCon] -> NCon -> Q Stab computeOpticType conf t cons con =@@ -230,11 +236,10 @@ then computePrismType conf t (view nconCxt con) cons' con else computeReviewType t (view nconCxt con) (view nconTypes con) - computeReviewType :: Type -> Cxt -> [Type] -> Q Stab computeReviewType t cx tys = do b <- toTupleT (map return tys)- return (Stab cx ReviewType t t b b)+ return (Stab False cx ReviewType t t b b) -- | Compute the full type-changing Prism type given an outer type, list of -- constructors, and target constructor name.@@ -244,9 +249,11 @@ free = setOf typeVars s fixed = setOf typeVars cons phantoms = free S.\\ setOf (folded % nconTypes % typeVars) (con : cons)- unbound = if scAllowPhantomsChange conf- then free S.\\ fixed- else free S.\\ fixed S.\\ phantoms++ unbound = free S.\\ fixed+ tvsCovered = if scForLabelInstance conf+ then S.null phantoms+ else True sub <- sequenceA (M.fromSet (newName . nameBase) unbound) a <- toTupleT (map return ts) b <- toTupleT (map return (substTypeVars sub ts))@@ -262,7 +269,7 @@ otype = if null cons && scAllowIsos conf then IsoType else PrismType- return (Stab cx' otype s t a b)+ return (Stab tvsCovered cx' otype s t a b) -- | Construct either a Review or Prism as appropriate makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ@@ -403,15 +410,15 @@ do r <- newName "r" let methodType = appsT (conT ''Prism') [varT r,return t] methodss <- traverse (mkMethod (VarT r)) cons'- classD (cxt[]) className (map PlainTV (r : vs)) (fds r)+ classD (cxt[]) className (map plainTV (r : vs)) (fds r) ( sigD methodName methodType : map return (concat methodss) ) where mkMethod r con =- do Stab cx o _ _ _ b <- computeOpticType classyConfig t cons con- let stab' = Stab cx o r r b b+ do Stab tvsCovered cx o _ _ _ b <- computeOpticType classyConfig t cons con+ let stab' = Stab tvsCovered cx o r r b b defName = view nconName con body = appsE [varE '(%), varE methodName, varE defName] sequenceA@@ -467,7 +474,7 @@ , _nconCxt :: Cxt , _nconTypes :: [Type] }- deriving (Eq)+ deriving (Eq, Show) instance HasTypeVars NCon where typeVarsEx s = traversalVL $ \f (NCon x vars y z) ->@@ -487,10 +494,13 @@ -- | Normalize a single 'Con' to its constructor name and field types. normalizeCon :: D.DatatypeInfo -> D.ConstructorInfo -> NCon-normalizeCon di info = NCon (D.constructorName info)- (D.tvName <$> D.constructorVars info)- (D.constructorContext info)- (map (addKindVars di) $ D.constructorFields info)+normalizeCon di info = NCon+ { _nconName = D.constructorName info+ , _nconVars = D.tvName <$> D.constructorVars info+ , _nconCxt = D.constructorContext info+ , _nconTypes = let tyVars = map tyVarBndrToType (D.constructorVars info)+ in addKindInfo' tyVars di <$> D.constructorFields info+ } -- | Compute a prism's name by prefixing an underscore for normal
src/Optics/TH/Internal/Utils.hs view
@@ -1,7 +1,10 @@ module Optics.TH.Internal.Utils where +import Control.Monad import Data.Maybe+import Data.List import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import qualified Data.Map as M import qualified Data.Set as S import qualified Language.Haskell.TH.Datatype as D@@ -37,11 +40,6 @@ conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) --- | Return 'Name' contained in a 'TyVarBndr'.-bndrName :: TyVarBndr -> Name-bndrName (PlainTV n ) = n-bndrName (KindedTV n _) = n- -- | Generate many new names from a given base name. newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] newNames base n = sequence [ newName (base++show i) | i <- [1..n] ]@@ -55,31 +53,101 @@ placeholder <- VarT <$> newName n pure (placeholder, D.equalPred placeholder ty) +addKindInfo :: D.DatatypeInfo -> Type -> Type+addKindInfo = addKindInfo' []+ -- | Fill in kind variables using info from datatype type parameters.-addKindVars :: D.DatatypeInfo -> Type -> Type-addKindVars = substType . M.fromList . mapMaybe var . D.datatypeInstTypes+addKindInfo' :: [Type] -> D.DatatypeInfo -> Type -> Type+addKindInfo' additionalInfo di =+ substType . M.fromList . mapMaybe var $ additionalInfo ++ D.datatypeInstTypes di where+ -- If the type is a data/newtype family instance, we need to fill in all of+ -- the kinds for weird cases such as:+ --+ -- data family KDF (a :: k)+ -- data instance KDF (a :: Type) = Kinded3 { _kdf :: Proxy a }+ --+ -- Otherwise we only need info about kind variables.+ --+ -- More info at https://github.com/ekmett/lens/pull/945.+ isDataFamily = D.datatypeVariant di == D.DataInstance+ || D.datatypeVariant di == D.NewtypeInstance+ var t@(SigT (VarT n) k)+ | isDataFamily = Just (n, t) | has typeVars k = Just (n, t) | otherwise = Nothing var _ = Nothing -- | Template Haskell wants type variables declared in a forall, so -- we find all free type variables in a given type and declare them.-quantifyType :: [TyVarBndr] -> Cxt -> Type -> Type+quantifyType :: [TyVarBndrSpec] -> Cxt -> Type -> Type quantifyType = quantifyType' S.empty -- | This function works like 'quantifyType' except that it takes -- a list of variables to exclude from quantification.-quantifyType' :: S.Set Name -> [TyVarBndr] -> Cxt -> Type -> Type+quantifyType' :: S.Set Name -> [TyVarBndrSpec] -> Cxt -> Type -> Type quantifyType' exclude vars cx t = ForallT vs cx t where- vs = filter (\v -> bndrName v `S.notMember` exclude)+ vs = filter (\v -> D.tvName v `S.notMember` exclude)+ . changeTVFlags SpecifiedSpec . D.freeVariablesWellScoped- $ map bndrToType vars ++ S.toList (setOf typeVarsKinded t)+ $ map tyVarBndrToType vars ++ S.toList (setOf typeVarsKinded t) - bndrToType (PlainTV n) = VarT n- bndrToType (KindedTV n k) = SigT (VarT n) k+-- | Transform 'TyVarBndr' into a 'Type' so it's suitable e.g. for+-- freeVariablesWellScoped or type substitution.+tyVarBndrToType :: TyVarBndr_ flag -> Type+tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k)++-- | Pass in a list of lists of extensions, where any of the given extensions+-- will satisfy it. For example, you might need either GADTs or+-- ExistentialQuantification, so you'd write:+--+-- > requireExtensions [[GADTs, ExistentialQuantification]]+--+-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd write:+--+-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]]+--+requireExtensions :: String -> [[Extension]] -> Q ()+requireExtensions what extLists = do+ -- Taken from the persistent library+ required <- filterM (fmap (not . or) . traverse isExtEnabled) extLists+ case mapMaybe listToMaybe required of+ [] -> pure ()+ [extension] -> fail $ mconcat+ [ "Generating " ++ what ++ " requires the "+ , show extension+ , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"+ , extensionToPragma extension+ , "\n\nTo enable it in a GHCi session, use the following command:\n\n"+ , ":seti -X" ++ show extension+ ]+ extensions -> fail $ mconcat+ [ "Generating " ++ what ++ " requires the following language extensions:\n\n"+ , intercalate "\n" (map (("- " ++) . show) extensions)+ , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"+ , intercalate "\n" (map extensionToPragma extensions)+ , "\n\nTo enable them in a GHCi session, use the following command:\n\n"+ , ":seti " ++ unwords (map (("-X" ++) . show) extensions)+ ]+ where+ extensionToPragma ext = "{-# LANGUAGE " ++ show ext ++ " #-}"++requireExtensionsForLabels :: Q ()+requireExtensionsForLabels = requireExtensions "LabelOptic instances"+ [ [DataKinds]+ , [FlexibleInstances]+ , [MultiParamTypeClasses]+ , [TypeFamilies, GADTs]+ , [UndecidableInstances]+ ]++requireExtensionsForFields :: Q ()+requireExtensionsForFields = requireExtensions "field optics"+ [ [FlexibleInstances]+ , [FunctionalDependencies]+ ] ------------------------------------------------------------------------ -- Support for generating inline pragmas
tests/Optics/TH/Tests.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}@@ -67,7 +68,7 @@ checkPairEq_ :: (Eq a', Eq b')- => Iso (PairEq a b c) (PairEq a' b' c) (a, b) (a', b')+ => Iso (PairEq a b c) (PairEq a' b' c') (a, b) (a', b') checkPairEq_ = #_PairEq data Brr a where@@ -97,15 +98,13 @@ checkBzztShow :: Show a => Prism (Bzzt a b c) (Bzzt a b c') a a checkBzztShow = _BzztShow --- We can't change b because of LabelOptic fundeps.-checkBzztShow_ :: Show a => Prism' (Bzzt a b c) a+checkBzztShow_ :: Show a => Prism (Bzzt a b c) (Bzzt a b c') a a checkBzztShow_ = #_BzztShow checkBzztRead :: Read b => Prism (Bzzt a b c) (Bzzt a b c') b b checkBzztRead = _BzztRead --- We can't change b because of LabelOptic fundeps.-checkBzztRead_ :: Read b => Prism' (Bzzt a b c) b+checkBzztRead_ :: Read b => Prism (Bzzt a b c) (Bzzt a b c') b b checkBzztRead_ = #_BzztRead data FooX a where@@ -116,15 +115,13 @@ checkFooX1 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX1 = _FooX1 --- We can't change a because of LabelOptic fundeps.-checkFooX1_ :: Prism' (FooX a) (Int, Int)+checkFooX1_ :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX1_ = #_FooX1 checkFooX2 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX2 = _FooX2 --- We can't change a because of LabelOptic fundeps.-checkFooX2_ :: Prism' (FooX a) (Int, Int)+checkFooX2_ :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int) checkFooX2_ = #_FooX2 data ClassyTest = ClassyT1 Int | ClassyT2 String | ClassyT3 Char@@ -173,9 +170,11 @@ checkWeird2 = _Weird2 checkWeird2_- :: forall (a :: Type -> Type)- (b :: Type -> Type)- . Iso (Weird2 a b) (Weird2 a b) () ()+ :: forall k (a :: k -> Type)+ (b :: k -> Type)+ (a' :: Type -> Type)+ (b' :: Type -> Type)+ . Iso (Weird2 a b) (Weird2 a' b') () () checkWeird2_ = #_Weird2 data Weird3 (a :: k) where@@ -186,7 +185,7 @@ checkWeird3 :: forall k (a :: k) (b :: Type). Iso (Weird3 a) (Weird3 b) () () checkWeird3 = _Weird3 -checkWeird3_ :: forall (a :: Type). Iso (Weird3 a) (Weird3 a) () ()+checkWeird3_ :: forall k (a :: k) (b :: Type). Iso (Weird3 a) (Weird3 b) () () checkWeird3_ = #_Weird3 ----------------------------------------@@ -198,8 +197,7 @@ checkBaz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') checkBaz = baz --- We can't change c because of LabelOptic fundeps.-checkBaz_ :: Iso (Bar a b c) (Bar a' b' c) (a, b) (a', b')+checkBaz_ :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') checkBaz_ = #baz data Quux a b = Quux { _quaffle :: Int, _quartz :: Double }@@ -209,15 +207,13 @@ checkQuaffle :: Lens (Quux a b) (Quux a' b') Int Int checkQuaffle = quaffle --- We can't change a and b because of LabelOptic fundeps.-checkQuaffle_ :: Lens (Quux a b) (Quux a b) Int Int+checkQuaffle_ :: Lens (Quux a b) (Quux a' b') Int Int checkQuaffle_ = #quaffle checkQuartz :: Lens (Quux a b) (Quux a' b') Double Double checkQuartz = quartz --- We can't change a and b because of LabelOptic fundeps.-checkQuartz_ :: Lens (Quux a b) (Quux a b) Double Double+checkQuartz_ :: Lens (Quux a b) (Quux a' b') Double Double checkQuartz_ = #quartz data Quark a = Qualified { _gaffer :: a }@@ -289,9 +285,15 @@ checkAbsurdity1 :: Eq x => Getter (Perambulation a b) (x -> y) checkAbsurdity1 = absurdity1 +checkAbsurdity1_ :: Eq x => Getter (Perambulation a b) (x -> y)+checkAbsurdity1_ = #absurdity1+ checkAbsurdity2 :: Eq x => AffineFold (Perambulation a b) (x -> y) checkAbsurdity2 = absurdity2 +checkAbsurdity2_ :: Eq x => AffineFold (Perambulation a b) (x -> y)+checkAbsurdity2_ = #absurdity2+ checkDunes :: AffineTraversal' (Perambulation a b) a checkDunes = dunes @@ -507,10 +509,14 @@ { _kinded0Thing :: forall a. Proxy (a :: k) } makeLenses ''Kinded0+makeFieldLabelsWith lensRules ''Kinded0 checkKinded0Thing :: Getter (Kinded0 k) (Proxy (a :: k)) checkKinded0Thing = kinded0Thing +checkKinded0Thing_ :: Getter (Kinded0 k) (Proxy (a :: k))+checkKinded0Thing_ = #kinded0Thing+ data Kinded1 (a :: k1) (b :: k2) = Kinded { _kinded1Thing :: Tagged '(a, b) Int }@@ -533,6 +539,17 @@ (Proxy (a' :: k')) checkKinded2Thing = #thing +data family KDF (a :: k)+data instance KDF (a :: Type) = Kinded3 { _kdf :: Proxy a }+makeLenses 'Kinded3+makeFieldLabelsWith lensRules 'Kinded3++checkKdf :: forall (a :: Type) (b :: Type). Iso (KDF a) (KDF b) (Proxy a) (Proxy b)+checkKdf = kdf++checkKdf_ :: forall (a :: Type) (b :: Type). Iso (KDF a) (KDF b) (Proxy a) (Proxy b)+checkKdf_ = #kdf+ type family Fam0 type family Fam (a :: k)@@ -554,7 +571,7 @@ data FamRec2 a b = FamRec2 { _famRec2Thing :: FamInj1 a b } makeFieldLabels ''FamRec2 -checkFamRec2Thing :: Iso (FamRec2 a b) (FamRec2 a' b) (FamInj1 a b) (FamInj1 a' b)+checkFamRec2Thing :: Iso (FamRec2 a b) (FamRec2 a' b') (FamInj1 a b) (FamInj1 a' b') checkFamRec2Thing = #thing type family a :#: b = r | r -> b@@ -563,15 +580,14 @@ data FamRec3 a b = FamRec3 { _famRec3Thing :: a :#: b } makeFieldLabels ''FamRec3 -checkFamRec3Thing :: Iso (FamRec3 a b) (FamRec3 a b') (a :#: b) (a :#: b')+checkFamRec3Thing :: Iso (FamRec3 a b) (FamRec3 a' b') (a :#: b) (a' :#: b') checkFamRec3Thing = #thing -- ambiguous type family application, type-preserving optic data FamRec4 a = FamRec4 { _famRec4Thing :: FamInj1 (Fam a) a } makeFieldLabels ''FamRec4 -- no error --- no type changing optic here-checkFamRec4Thing :: Iso' (FamRec4 a) (FamInj1 (Fam a) a)+checkFamRec4Thing :: Iso (FamRec4 a) (FamRec4 b) (FamInj1 (Fam a) a) (FamInj1 (Fam b) b) checkFamRec4Thing = #thing type family FamInj2 a b (c :: k) = r | r -> a b c@@ -601,10 +617,10 @@ } makeFieldLabels ''FamRec7 -checkFamRec7Thing :: Iso (FamRec7 a b (c :: [k ]))- (FamRec7 a' b (c' :: [k']))+checkFamRec7Thing :: Iso (FamRec7 a b (c :: [k ]))+ (FamRec7 a' b' (c' :: [k'])) (FamInj1 (b :#: (a -> FamInj1 c b)) b)- (FamInj1 (b :#: (a' -> FamInj1 c' b)) b)+ (FamInj1 (b' :#: (a' -> FamInj1 c' b')) b') checkFamRec7Thing = #thing data FamRec a = FamRec@@ -687,7 +703,14 @@ data Quark2 a = Qualified2 { gaffer2 :: a } | Unqualified2 { gaffer2 :: a, tape2 :: a } |]+makePrismLabels ''Quark2 -- after declareFieldLabels +checkQualified2 :: Prism' (Quark2 a) a+checkQualified2 = #_Qualified2++checkUnqualified2 :: Prism' (Quark2 a) (a, a)+checkUnqualified2 = #_Unqualified2+ checkGaffer2 :: Lens' (Quark2 a) a checkGaffer2 = #gaffer2 @@ -781,6 +804,24 @@ checkCoffee :: Iso' (Associated Double) Double checkCoffee = #coffee +declareFieldLabels+ [d| data User a = User+ { user_name :: Name -- local type+ , user_age :: a+ }++ newtype Name = Name { name_unwrap :: String }+ |]++checkUserName :: Lens' (User a) Name+checkUserName = #user_name++checkUserAge :: Lens (User a) (User b) a b+checkUserAge = #user_age++checkNameUnwrap :: Iso' Name String+checkNameUnwrap = #name_unwrap+ declareFields [d| data DeclaredFields f a = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int }@@ -824,25 +865,34 @@ | C2 { _r2length :: forall a. [a] -> Int } makeLenses ''Rank2Tests-makeFieldLabelsWith lensRules ''Rank2Tests -- doesn't generate anything+makeFieldLabelsWith lensRules ''Rank2Tests checkR2length :: Getter Rank2Tests ([a] -> Int) checkR2length = r2length +checkR2length_ :: Getter Rank2Tests ([a] -> Int)+checkR2length_ = #r2length+ checkR2nub :: Eq a => AffineFold Rank2Tests ([a] -> [a]) checkR2nub = r2nub +checkR2nub_ :: Eq a => AffineFold Rank2Tests ([a] -> [a])+checkR2nub_ = #r2nub+ data PureNoFields = PureNoFieldsA | PureNoFieldsB { _pureNoFields :: Int } makeLenses ''PureNoFields makeFieldLabels ''PureNoFields -data ReviewTest where- ReviewTest :: (Typeable a, Typeable b) => a -> b -> ReviewTest+data ReviewTest k where+ ReviewTest :: Typeable t => t -> Proxy (a :: k) -> ReviewTest k makePrisms ''ReviewTest-makePrismLabels ''ReviewTest -- doesn't generate anything+makePrismLabels ''ReviewTest -checkReviewTest :: (Typeable a, Typeable b) => Review ReviewTest (a, b)+checkReviewTest :: Typeable t => Review (ReviewTest k) (t, Proxy (a :: k)) checkReviewTest = _ReviewTest++checkReviewTest_ :: Typeable t => Review (ReviewTest k) (t, Proxy (a :: k))+checkReviewTest_ = #_ReviewTest -- test FieldNamers