microlens-th 0.4.3.2 → 0.4.3.4

raw patch · 4 files changed

+209/−130 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• microlens-th.cabal +4/−2
• src/Lens/Micro/TH.hs +6/−128
• src/Lens/Micro/TH/Internal.hs +191/−0

@@ -1,3 +1,11 @@+# 0.4.3.4++* Backported changes needed for template-haskell-2.15.++# 0.4.3.3++* Exported internal utilities from `Lens.Micro.TH.Internal`.+ # 0.4.3.2  * Bumped template-haskell version.

@@ -1,5 +1,5 @@ name:                microlens-th-version:             0.4.3.2+version:             0.4.3.4 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).@@ -23,7 +23,8 @@                      GHC==8.0.2                      GHC==8.2.2                      GHC==8.4.4-                     GHC==8.6.4+                     GHC==8.6.5+                     GHC==8.8.1  source-repository head   type:                git@@ -31,6 +32,7 @@  library   exposed-modules:     Lens.Micro.TH+                       Lens.Micro.TH.Internal   -- other-modules:   -- other-extensions:   build-depends:       base >=4.5 && <5

@@ -35,7 +35,7 @@   -- * 'SimpleGetter' and 'SimpleFold'   -- $getter-fold-note -  -- * Making lenses+  -- * Generating lenses   makeLenses,   makeLensesFor,   makeLensesWith,@@ -77,6 +77,7 @@ import           Data.Maybe import           Lens.Micro import           Lens.Micro.Internal (phantom)+import           Lens.Micro.TH.Internal import           Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D @@ -722,99 +723,6 @@   , _fieldToDef      = underscoreNoPrefixNamer   } --- Language.Haskell.TH.Lens---- Has a 'Name'-class HasName t where-  -- Extract (or modify) the 'Name' of something-  name :: Lens' t Name--instance HasName TyVarBndr where-  name f (PlainTV n) = PlainTV <$> f n-  name f (KindedTV n k) = (`KindedTV` k) <$> f n--instance HasName Name where-  name = id---- | On @template-haskell-2.11.0.0@ or later, if a 'GadtC' or 'RecGadtC' has--- multiple 'Name's, the leftmost 'Name' will be chosen.-instance HasName Con where-  name f (NormalC n tys)       = (`NormalC` tys) <$> f n-  name f (RecC n tys)          = (`RecC` tys) <$> f n-  name f (InfixC l n r)        = (\n' -> InfixC l n' r) <$> f n-  name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con-#if MIN_VERSION_template_haskell(2,11,0)-  name f (GadtC ns argTys retTy) =-    (\n -> GadtC [n] argTys retTy) <$> f (head ns)-  name f (RecGadtC ns argTys retTy) =-    (\n -> RecGadtC [n] argTys retTy) <$> f (head ns)-#endif---- Provides for the extraction of free type variables, and alpha renaming.-class HasTypeVars t where-  -- When performing substitution into this traversal you're not allowed-  -- to substitute in a name that is bound internally or you'll violate-  -- the 'Traversal' laws, when in doubt generate your names with 'newName'.-  typeVarsEx :: Set Name -> Traversal' t Name--instance HasTypeVars TyVarBndr where-  typeVarsEx s f b-    | Set.member (b^.name) s = pure b-    | otherwise              = name f b--instance HasTypeVars Name where-  typeVarsEx s f n-    | Set.member n s = pure n-    | otherwise      = f n--instance HasTypeVars Type where-  typeVarsEx s f (VarT n)            = VarT <$> typeVarsEx s f n-  typeVarsEx s f (AppT l r)          = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r-  typeVarsEx s f (SigT t k)          = (`SigT` k) <$> typeVarsEx s f t-  typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty-       where s' = s `Set.union` Set.fromList (bs ^.. typeVars)-  typeVarsEx _ _ t                   = pure t--#if !MIN_VERSION_template_haskell(2,10,0)-instance HasTypeVars Pred where-  typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts-  typeVarsEx s f (EqualP l r)  = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r-#endif--instance HasTypeVars Con where-  typeVarsEx s f (NormalC n ts)     =-    NormalC n <$> (traverse . _2) (typeVarsEx s f) ts-  typeVarsEx s f (RecC n ts)        =-    RecC n <$> (traverse . _3) (typeVarsEx s f) ts-  typeVarsEx s f (InfixC l n r)     =-    InfixC <$> g l <*> pure n <*> g r-      where g (i, t) = (,) i <$> typeVarsEx s f t-  typeVarsEx s f (ForallC bs ctx c) =-    ForallC bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f c-      where s' = s `Set.union` Set.fromList (bs ^.. typeVars)-#if MIN_VERSION_template_haskell(2,11,0)-  typeVarsEx s f (GadtC ns argTys retTy) =-    GadtC ns <$> (traverse . _2) (typeVarsEx s f) argTys-             <*> typeVarsEx s f retTy-  typeVarsEx s f (RecGadtC ns argTys retTy) =-    RecGadtC ns <$> (traverse . _3) (typeVarsEx s f) argTys-                <*> typeVarsEx s f retTy-#endif--instance HasTypeVars t => HasTypeVars [t] where-  typeVarsEx s = traverse . typeVarsEx s--instance HasTypeVars t => HasTypeVars (Maybe t) where-  typeVarsEx s = traverse . typeVarsEx s---- Traverse /free/ type variables-typeVars :: HasTypeVars t => Traversal' t Name-typeVars = typeVarsEx mempty---- Substitute using a map of names in for /free/ type variables-substTypeVars :: HasTypeVars t => Map Name Name -> t -> t-substTypeVars m = over typeVars $ \n -> fromMaybe n (Map.lookup n m)- -- FieldTH.hs  ------------------------------------------------------------------------@@ -1186,7 +1094,7 @@ -- constructor. makePureClause :: Name -> Int -> ClauseQ makePureClause conName fieldCount =-  do xs <- replicateM fieldCount (newName "x")+  do xs <- newNames "x" fieldCount      -- clause: _ (Con x1..xn) = pure (Con x1..xn)      clause [wildP, conP conName (map varP xs)]             (normalB (appE (varE 'pure) (appsE (conE conName : map varE xs))))@@ -1198,7 +1106,7 @@ makeGetterClause conName fieldCount []     = makePureClause conName fieldCount makeGetterClause conName fieldCount fields =   do f  <- newName "f"-     xs <- replicateM (length fields) (newName "x")+     xs <- newNames "x" (length fields)       let pats (i:is) (y:ys)            | i `elem` fields = varP y : pats is ys@@ -1223,8 +1131,8 @@   makePureClause conName fieldCount makeFieldOpticClause conName fieldCount (field:fields) irref =   do f  <- newName "f"-     xs <- replicateM fieldCount          (newName "x")-     ys <- replicateM (1 + length fields) (newName "y")+     xs <- newNames "x" fieldCount+     ys <- newNames "y" (1 + length fields)       let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) @@ -1344,33 +1252,3 @@  liftState :: Monad m => m a -> StateT s m a liftState act = StateT (\s -> liftM (flip (,) s) act)---- Apply arguments to a type constructor.-conAppsT :: Name -> [Type] -> Type-conAppsT conName = foldl AppT (ConT conName)---- Template Haskell wants type variables declared in a forall, so--- we find all free type variables in a given type and declare them.-quantifyType :: Cxt -> Type -> Type-quantifyType = quantifyType' Set.empty---- This function works like 'quantifyType' except that it takes--- a list of variables to exclude from quantification.-quantifyType' :: Set Name -> Cxt -> Type -> Type-quantifyType' exclude c t = ForallT vs c t-  where-    vs = map PlainTV-       $ filter (`Set.notMember` exclude)-       $ nub -- stable order-       $ toListOf typeVars t----------------------------------------------------------------------------- Support for generating inline pragmas---------------------------------------------------------------------------inlinePragma :: Name -> [DecQ]-#if MIN_VERSION_template_haskell(2,8,0)-inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]-#else-inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]-#endif

@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++#ifndef MIN_VERSION_template_haskell+#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)+#endif++-- Language.Haskell.TH was not marked as Safe before template-haskell-2.12.0+#if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module      :  Lens.Micro.TH.Internal+Copyright   :  (C) 2013-2016 Eric Mertens, Edward Kmett; 2018 Monadfix+License     :  BSD-style (see the file LICENSE)++Functions used by "Lens.Micro.TH". This is an internal module and it may go+away or change at any time; do not depend on it.+-}+module Lens.Micro.TH.Internal+(+  -- * Name utilities+  HasName(..),+  newNames,++  -- * Type variable utilities+  HasTypeVars(..),+  typeVars,+  substTypeVars,++  -- * Miscellaneous utilities+  inlinePragma,+  conAppsT,+  quantifyType, quantifyType',+)+where++import qualified Data.Map as Map+import           Data.Map (Map)+import qualified Data.Set as Set+import           Data.Set (Set)+import           Data.List (nub)+import           Data.Maybe+import           Lens.Micro+import           Language.Haskell.TH++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+import           Data.Monoid+import           Data.Traversable (traverse)+#endif++-- | Has a 'Name'+class HasName t where+  -- | Extract (or modify) the 'Name' of something+  name :: Lens' t Name++instance HasName TyVarBndr where+  name f (PlainTV n) = PlainTV <$> f n+  name f (KindedTV n k) = (`KindedTV` k) <$> f n++instance HasName Name where+  name = id++-- | On @template-haskell-2.11.0.0@ or later, if a 'GadtC' or 'RecGadtC' has+-- multiple 'Name's, the leftmost 'Name' will be chosen.+instance HasName Con where+  name f (NormalC n tys)       = (`NormalC` tys) <$> f n+  name f (RecC n tys)          = (`RecC` tys) <$> f n+  name f (InfixC l n r)        = (\n' -> InfixC l n' r) <$> f n+  name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con+#if MIN_VERSION_template_haskell(2,11,0)+  name f (GadtC ns argTys retTy) =+    (\n -> GadtC [n] argTys retTy) <$> f (head ns)+  name f (RecGadtC ns argTys retTy) =+    (\n -> RecGadtC [n] argTys retTy) <$> f (head ns)+#endif++-- | 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] ]++-- | Provides for the extraction of free type variables, and alpha renaming.+class HasTypeVars t where+  -- When performing substitution into this traversal you're not allowed+  -- to substitute in a name that is bound internally or you'll violate+  -- the 'Traversal' laws, when in doubt generate your names with 'newName'.+  typeVarsEx :: Set Name -> Traversal' t Name++instance HasTypeVars TyVarBndr where+  typeVarsEx s f b+    | Set.member (b^.name) s = pure b+    | otherwise              = name f b++instance HasTypeVars Name where+  typeVarsEx s f n+    | Set.member n s = pure n+    | otherwise      = f n++instance HasTypeVars Type where+  typeVarsEx s f (VarT n)             = VarT <$> typeVarsEx s f n+  typeVarsEx s f (AppT l r)           = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r+#if MIN_VERSION_template_haskell(2,8,0)+  typeVarsEx s f (SigT t k)           = SigT <$> typeVarsEx s f t+                                             <*> typeVarsEx s f k+#else+  typeVarsEx s f (SigT t k)           = (`SigT` k) <$> typeVarsEx s f t+#endif+  typeVarsEx s f (ForallT bs ctx ty)  = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty+       where s' = s `Set.union` Set.fromList (bs ^.. typeVars)+#if MIN_VERSION_template_haskell(2,11,0)+  typeVarsEx s f (InfixT  t1 n t2)    = InfixT  <$> typeVarsEx s f t1+                                                <*> pure n+                                                <*> typeVarsEx s f t2+  typeVarsEx s f (UInfixT t1 n t2)    = UInfixT <$> typeVarsEx s f t1+                                                <*> pure n+                                                <*> typeVarsEx s f t2+  typeVarsEx s f (ParensT t)          = ParensT <$> typeVarsEx s f t+#endif+#if MIN_VERSION_template_haskell(2,15,0)+  typeVarsEx s f (AppKindT t k)       = AppKindT <$> typeVarsEx s f t+                                                 <*> typeVarsEx s f k+  typeVarsEx s f (ImplicitParamT n t) = ImplicitParamT n <$> typeVarsEx s f t+#endif+  typeVarsEx _ _ t                    = pure t++#if !MIN_VERSION_template_haskell(2,10,0)+instance HasTypeVars Pred where+  typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts+  typeVarsEx s f (EqualP l r)  = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r+#endif++instance HasTypeVars Con where+  typeVarsEx s f (NormalC n ts) = NormalC n <$> (traverse . _2) (typeVarsEx s f) ts+  typeVarsEx s f (RecC n ts) = RecC n <$> (traverse . _3) (typeVarsEx s f) ts+  typeVarsEx s f (InfixC l n r) = InfixC <$> g l <*> pure n <*> g r+       where g (i, t) = (,) i <$> typeVarsEx s f t+  typeVarsEx s f (ForallC bs ctx c) = ForallC bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f c+       where s' = s `Set.union` Set.fromList (bs ^.. typeVars)+#if MIN_VERSION_template_haskell(2,11,0)+  typeVarsEx s f (GadtC ns argTys retTy) =+    GadtC ns <$> (traverse . _2) (typeVarsEx s f) argTys+             <*> typeVarsEx s f retTy+  typeVarsEx s f (RecGadtC ns argTys retTy) =+    RecGadtC ns <$> (traverse . _3) (typeVarsEx s f) argTys+                <*> typeVarsEx s f retTy+#endif++instance HasTypeVars t => HasTypeVars [t] where+  typeVarsEx s = traverse . typeVarsEx s++instance HasTypeVars t => HasTypeVars (Maybe t) where+  typeVarsEx s = traverse . typeVarsEx s++-- Traverse /free/ type variables+typeVars :: HasTypeVars t => Traversal' t Name+typeVars = typeVarsEx mempty++-- Substitute using a map of names in for /free/ type variables+substTypeVars :: HasTypeVars t => Map Name Name -> t -> t+substTypeVars m = over typeVars $ \n -> fromMaybe n (Map.lookup n m)++-- | Generate an INLINE pragma.+inlinePragma :: Name -> [DecQ]+#if MIN_VERSION_template_haskell(2,8,0)+inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]+#else+inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]+#endif++-- | Apply arguments to a type constructor.+conAppsT :: Name -> [Type] -> Type+conAppsT conName = foldl AppT (ConT conName)++-- | Template Haskell wants type variables declared in a forall, so we find+-- all free type variables in a given type and declare them.+quantifyType :: Cxt -> Type -> Type+quantifyType = quantifyType' Set.empty++-- | This function works like 'quantifyType' except that it takes a list of+-- variables to exclude from quantification.+quantifyType' :: Set Name -> Cxt -> Type -> Type+quantifyType' exclude c t = ForallT vs c t+  where+    vs = map PlainTV+       $ filter (`Set.notMember` exclude)+       $ nub -- stable order+       $ toListOf typeVars t