lens 4.15.2 → 4.15.3
raw patch · 13 files changed
+151/−310 lines, 13 filesdep +th-abstractionsetup-changed
Dependencies added: th-abstraction
Files
- .travis.yml +6/−6
- CHANGELOG.markdown +7/−0
- Setup.lhs +10/−147
- Warning.hs +5/−0
- lens.cabal +4/−1
- src/Control/Lens/At.hs +2/−4
- src/Control/Lens/Internal/CTypes.hs +28/−0
- src/Control/Lens/Internal/FieldTH.hs +18/−85
- src/Control/Lens/Internal/PrismTH.hs +31/−52
- src/Control/Lens/Internal/TH.hs +30/−0
- src/Control/Lens/Plated.hs +8/−8
- src/Control/Lens/Review.hs +1/−1
- src/Control/Lens/Wrapped.hs +1/−6
.travis.yml view
@@ -22,15 +22,15 @@ - env: CABALVER=1.24 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=7.8.4+ - env: CABALVER=1.24 GHCVER=7.8.4 compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-head,ghc-7.8.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=7.6.3+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-head,ghc-7.6.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=7.4.2+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-head,ghc-7.4.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head CABALFLAGS=--allow-newer compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+next+----+* Generalized types of `transformMOf`, `transformOf`, `transformMOnOf`,+ `transformOnOf`, `rewriteMOf`, `rewriteOf`, `rewriteMOnOf` and `rewriteOnOf`.+* Depend on `th-abstraction` package for normalizing differences across+ `template-haskell` versions+ 4.15.2 ---- * Build with GHC 8.2
Setup.lhs view
@@ -17,159 +17,22 @@ import System.FilePath ( (</>) ) #if MIN_VERSION_cabal_doctest(1,0,0)-import Distribution.Extra.Doctest (generateBuildModule )-#else -#ifndef MIN_VERSION_Cabal-#define MIN_VERSION_Cabal(x,y,z) 0-#endif-#ifndef MIN_VERSION_directory-#define MIN_VERSION_directory(x,y,z) 0-#endif-#if MIN_VERSION_Cabal(1,24,0)-#define InstalledPackageId UnitId-#endif--import Control.Monad ( when )-import Data.List ( nub )-import Data.String ( fromString )-import Distribution.Package ( InstalledPackageId )-import Distribution.Package ( PackageId, Package (..), packageVersion )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)-import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )-import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))-import Distribution.Text ( display , simpleParse )--#if MIN_VERSION_Cabal(1,25,0)-import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )-#endif+import Distribution.Extra.Doctest ( generateBuildModule ) -#if MIN_VERSION_directory(1,2,2)-import System.Directory (makeAbsolute) #else-import System.Directory (getCurrentDirectory)-import System.FilePath (isAbsolute) -makeAbsolute :: FilePath -> IO FilePath-makeAbsolute p | isAbsolute p = return p- | otherwise = do- cwd <- getCurrentDirectory- return $ cwd </> p-#endif--generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule testsuiteName flags pkg lbi = do- let verbosity = fromFlag (buildVerbosity flags)- let distPref = fromFlag (buildDistPref flags)-- -- Package DBs- let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]- let dbFlags = "-hide-all-packages" : packageDbArgs dbStack-- withLibLBI pkg lbi $ \lib libcfg -> do- let libBI = libBuildInfo lib-- -- modules- let modules = exposedModules lib ++ otherModules libBI- -- it seems that doctest is happy to take in module names, not actual files!- let module_sources = modules-- -- We need the directory with library's cabal_macros.h!-#if MIN_VERSION_Cabal(1,25,0)- let libAutogenDir = autogenComponentModulesDir lbi libcfg-#else- let libAutogenDir = autogenModulesDir lbi+#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+import Warning () #endif - -- Lib sources and includes- iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI- includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI-- -- CPP includes, i.e. include cabal_macros.h- let cppFlags = map ("-optP"++) $- [ "-include", libAutogenDir ++ "/cabal_macros.h" ]- ++ cppOptions libBI-- withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do-- -- get and create autogen dir-#if MIN_VERSION_Cabal(1,25,0)- let testAutogenDir = autogenComponentModulesDir lbi suitecfg-#else- let testAutogenDir = autogenModulesDir lbi-#endif- createDirectoryIfMissingVerbose verbosity True testAutogenDir-- -- write autogen'd file- rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines- [ "module Build_doctests where"- , ""- -- -package-id etc. flags- , "pkgs :: [String]"- , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)- , ""- , "flags :: [String]"- , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)- , ""- , "module_sources :: [String]"- , "module_sources = " ++ show (map display module_sources)- ]- where- -- we do this check in Setup, as then doctests don't need to depend on Cabal- isOldCompiler = maybe False id $ do- a <- simpleParse $ showCompilerId $ compiler lbi- b <- simpleParse "7.5"- return $ packageVersion (a :: PackageId) < b-- formatDeps = map formatOne- formatOne (installedPkgId, pkgId)- -- The problem is how different cabal executables handle package databases- -- when doctests depend on the library- | packageId pkg == pkgId = "-package=" ++ display pkgId- | otherwise = "-package-id=" ++ display installedPkgId-- -- From Distribution.Simple.Program.GHC- packageDbArgs :: [PackageDB] -> [String]- packageDbArgs | isOldCompiler = packageDbArgsConf- | otherwise = packageDbArgsDb-- -- GHC <7.6 uses '-package-conf' instead of '-package-db'.- packageDbArgsConf :: [PackageDB] -> [String]- packageDbArgsConf dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> ("-no-user-package-conf")- : concatMap specific dbs- _ -> ierror- where- specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]- specific _ = ierror- ierror = error $ "internal error: unexpected package db stack: "- ++ show dbstack-- -- GHC >= 7.6 uses the '-package-db' flag. See- -- https://ghc.haskell.org/trac/ghc/ticket/5977.- packageDbArgsDb :: [PackageDB] -> [String]- -- special cases to make arguments prettier in common scenarios- packageDbArgsDb dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs)- | all isSpecific dbs -> concatMap single dbs- (GlobalPackageDB:dbs)- | all isSpecific dbs -> "-no-user-package-db"- : concatMap single dbs- dbs -> "-clear-package-db"- : concatMap single dbs- where- single (SpecificPackageDB db) = [ "-package-db=" ++ db ]- single GlobalPackageDB = [ "-global-package-db" ]- single UserPackageDB = [ "-user-package-db" ]- isSpecific (SpecificPackageDB _) = True- isSpecific _ = False--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+generateBuildModule :: a -> b -> c -> d -> IO ()+generateBuildModule _ _ _ _ = return () #endif
+ Warning.hs view
@@ -0,0 +1,5 @@+module Warning+ {-# WARNING ["You are configuring this package without cabal-doctest installed.",+ "The doctests test-suite will not work as a result.",+ "To fix this, install cabal-doctest before configuring."] #-}+ () where
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.15.2+version: 4.15.3 license: BSD2 cabal-version: >= 1.8 license-file: LICENSE@@ -103,6 +103,7 @@ travis/cabal-apt-install travis/config HLint.hs+ Warning.hs AUTHORS.markdown CHANGELOG.markdown README.markdown@@ -211,6 +212,7 @@ semigroups >= 0.8.4 && < 1, tagged >= 0.4.4 && < 1, template-haskell >= 2.4 && < 2.13,+ th-abstraction >= 0.2.1 && < 0.3, text >= 0.11 && < 1.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.4 && < 1,@@ -239,6 +241,7 @@ Control.Lens.Internal.ByteString Control.Lens.Internal.Coerce Control.Lens.Internal.Context+ Control.Lens.Internal.CTypes Control.Lens.Internal.Deque Control.Lens.Internal.Exception Control.Lens.Internal.FieldTH
src/Control/Lens/At.hs view
@@ -180,12 +180,10 @@ -- | This provides a common notion of a value at an index that is shared by both 'Ixed' and 'At'. type family IxValue (m :: *) :: * --- | This simple 'Traversal' lets you 'traverse' the value at a given+-- | Provides a simple 'Traversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. class Ixed m where- -- | This simple 'Traversal' lets you 'traverse' the value at a given- -- key in a 'Map' or element at an ordinal position in a list or 'Seq'.- --+ -- | -- /NB:/ Setting the value of this 'Traversal' will only set the value in -- 'at' if it is already present. --
+ src/Control/Lens/Internal/CTypes.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.CTypes+-- Copyright : (C) 2012-2016 Edward Kmett, (C) 2017 Ryan Scott+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- In "Control.Lens.Wrapped", we need to muck around with the internals of the+-- newtypes in "Foreign.C.Types". Unfortunately, the exact types used varies+-- wildly from platform to platform, so trying to manage the imports necessary+-- to bring these types in scope can be unwieldy.+--+-- To make things easier, we use this module as a way to import everything+-- carte blanche that might be used internally in "Foreign.C.Types". For+-- now, this consists of all the exports from the "Data.Int" and "Data.Word"+-- modules, as well as the 'Ptr' type.+----------------------------------------------------------------------------+module Control.Lens.Internal.CTypes+ ( module Data.Int+ , Ptr+ , module Data.Word+ ) where++import Data.Int+import Data.Word+import Foreign.Ptr (Ptr)
src/Control/Lens/Internal/FieldTH.hs view
@@ -4,9 +4,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.FieldTH@@ -32,12 +29,13 @@ import Control.Lens.Prism import Control.Lens.Setter import Control.Lens.Getter-import Control.Lens.Traversal import Control.Lens.Tuple+import Control.Lens.Traversal import Control.Applicative import Control.Monad import Language.Haskell.TH.Lens import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D import Data.Maybe (isJust,maybeToList) import Data.List (nub, findIndices) import Data.Either (partitionEithers)@@ -58,43 +56,17 @@ -- | Compute the field optics for the type identified by the given type name. -- Lenses will be computed when possible, Traversals otherwise. makeFieldOptics :: LensRules -> Name -> DecsQ-makeFieldOptics rules tyName =- do info <- reify tyName- case info of- TyConI dec -> makeFieldOpticsForDec rules dec- _ -> fail "makeFieldOptics: Expected type constructor name"+makeFieldOptics rules = makeFieldOpticsForDec' rules <=< D.reifyDatatype makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ-makeFieldOpticsForDec rules dec = case dec of-#if MIN_VERSION_template_haskell(2,11,0)- DataD _ tyName vars _ cons _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) cons- NewtypeD _ tyName vars _ con _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) [con]- DataInstD _ tyName args _ cons _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) cons- NewtypeInstD _ tyName args _ con _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) [con]-#else- DataD _ tyName vars cons _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) cons- NewtypeD _ tyName vars con _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) [con]- DataInstD _ tyName args cons _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) cons- NewtypeInstD _ tyName args con _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) [con]-#endif- _ -> fail "makeFieldOptics: Expected data or newtype type-constructor"- where- mkS tyName vars = tyName `conAppsT` map VarT (toListOf typeVars vars)+makeFieldOpticsForDec rules = makeFieldOpticsForDec' rules <=< D.normalizeDec -- | Compute the field optics for a deconstructed Dec -- When possible build an Iso otherwise build one optic per field.-makeFieldOpticsForDec' :: LensRules -> Name -> Type -> [Con] -> DecsQ-makeFieldOpticsForDec' rules tyName s cons =+makeFieldOpticsForDec' :: LensRules -> D.DatatypeInfo -> DecsQ+makeFieldOpticsForDec' rules info = do fieldCons <- traverse normalizeConstructor cons let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons@@ -109,6 +81,9 @@ return (concat decss) where+ tyName = D.datatypeName info+ s = D.datatypeType info+ cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b@@ -124,29 +99,17 @@ -- -- For 'GadtC' and 'RecGadtC', the leftmost name is chosen. normalizeConstructor ::- Con ->+ D.ConstructorInfo -> Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type -normalizeConstructor (RecC n xs) =- return (n, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])--normalizeConstructor (NormalC n xs) =- return (n, [ (Nothing, ty) | (_,ty) <- xs])--normalizeConstructor (InfixC (_,ty1) n (_,ty2)) =- return (n, [ (Nothing, ty1), (Nothing, ty2) ])--normalizeConstructor (ForallC _ _ con) =- do con' <- normalizeConstructor con- return (set (_2 . mapped . _1) Nothing con')--#if MIN_VERSION_template_haskell(2,11,0)-normalizeConstructor (GadtC ns xs _) =- return (head ns, [ (Nothing, ty) | (_,ty) <- xs])--normalizeConstructor (RecGadtC ns xs _) =- return (head ns, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])-#endif+normalizeConstructor con =+ return (D.constructorName con, zip fieldNames (D.constructorFields con))+ where+ fieldNames =+ case D.constructorVariant con of+ D.RecordConstructor xs -> fmap Just xs+ D.NormalConstructor -> repeat Nothing+ D.InfixConstructor -> repeat Nothing data OpticType = GetterType | LensType | IsoType @@ -602,33 +565,3 @@ $ filter (`Set.notMember` exclude) $ nub -- stable order $ toListOf typeVars t------------------------------------------------------------------------------ Support for generating inline pragmas---------------------------------------------------------------------------inlinePragma :: Name -> [DecQ]--#ifdef INLINING--#if MIN_VERSION_template_haskell(2,8,0)--# ifdef OLD_INLINE_PRAGMAS--- 7.6rc1?-inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase Inline False)]-# else--- 7.7.20120830-inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]-# endif--#else--- GHC <7.6, TH <2.8.0-inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]-#endif--#else--inlinePragma _ = []--#endif
src/Control/Lens/Internal/PrismTH.hs view
@@ -29,14 +29,13 @@ import Control.Lens.Internal.TH import Control.Lens.Lens import Control.Lens.Setter-import Control.Lens.Tuple import Control.Monad import Data.Char (isUpper) import Data.List-import Data.Monoid import Data.Set.Lens import Data.Traversable import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D import Language.Haskell.TH.Lens import qualified Data.Map as Map import qualified Data.Set as Set@@ -109,35 +108,21 @@ -- | Main entry point into Prism generation for a given type constructor name. makePrisms' :: Bool -> Name -> DecsQ makePrisms' normal typeName =- do info <- reify typeName- case info of- TyConI dec -> makeDecPrisms normal dec- _ -> fail "makePrisms: expected type constructor name"+ do info <- D.reifyDatatype typeName+ let cls | normal = Nothing+ | otherwise = Just (D.datatypeName info)+ cons = D.datatypeCons info+ makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls -- | Generate prisms for the given 'Dec' makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ-makeDecPrisms normal dec = case dec of-#if MIN_VERSION_template_haskell(2,11,0)- DataD _ ty vars _ cons _ -> next ty (convertTVBs vars) cons- NewtypeD _ ty vars _ con _ -> next ty (convertTVBs vars) [con]- DataInstD _ ty tys _ cons _ -> next ty tys cons- NewtypeInstD _ ty tys _ con _ -> next ty tys [con]-#else- DataD _ ty vars cons _ -> next ty (convertTVBs vars) cons- NewtypeD _ ty vars con _ -> next ty (convertTVBs vars) [con]- DataInstD _ ty tys cons _ -> next ty tys cons- NewtypeInstD _ ty tys con _ -> next ty tys [con]-#endif- _ -> fail "makePrisms: expected type constructor dec"- where- convertTVBs = map (VarT . bndrName)-- next ty args cons =- makeConsPrisms (conAppsT ty args) (concatMap normalizeCon cons) cls- where- cls | normal = Nothing- | otherwise = Just ty+makeDecPrisms normal dec =+ do info <- D.normalizeDec dec+ let cls | normal = Nothing+ | otherwise = Just (D.datatypeName info)+ cons = D.datatypeCons info+ makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls -- | Generate prisms for the given type, normalized constructors, and@@ -147,7 +132,7 @@ makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ -- special case: single constructor, not classy -> make iso-makeConsPrisms t [con@(NCon _ Nothing _)] Nothing = makeConIso t con+makeConsPrisms t [con@(NCon _ [] [] _)] Nothing = makeConIso t con -- top-level definitions makeConsPrisms t cons Nothing =@@ -201,9 +186,9 @@ computeOpticType :: Type -> [NCon] -> NCon -> Q Stab computeOpticType t cons con = do let cons' = delete con cons- case view nconCxt con of- Just xs -> computeReviewType t xs (view nconTypes con)- Nothing -> computePrismType t cons' con+ if null (_nconVars con)+ then computePrismType t (view nconCxt con) cons' con+ else computeReviewType t (view nconCxt con) (view nconTypes con) computeReviewType :: Type -> Cxt -> [Type] -> Q Stab@@ -218,15 +203,15 @@ -- | Compute the full type-changing Prism type given an outer type, -- list of constructors, and target constructor name. Additionally -- return 'True' if the resulting type is a "simple" prism.-computePrismType :: Type -> [NCon] -> NCon -> Q Stab-computePrismType t cons con =+computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab+computePrismType t cx cons con = do let ts = view nconTypes con unbound = setOf typeVars t Set.\\ setOf typeVars cons sub <- sequenceA (fromSet (newName . nameBase) unbound) b <- toTupleT (map return ts) a <- toTupleT (map return (substTypeVars sub ts)) let s = substTypeVars sub t- return (Stab [] PrismType s t a b)+ return (Stab cx PrismType s t a b) computeIsoType :: Type -> [Type] -> TypeQ@@ -355,7 +340,7 @@ do x <- newName "x" lam1E (varP x) (caseE (varE x) (map mkMatch cons)) where- mkMatch (NCon conName _ n) =+ mkMatch (NCon conName _ _ n) = do xs <- newNames "y" (length n) match (conP conName (map varP xs)) (normalB@@ -458,18 +443,20 @@ -- | Normalized constructor data NCon = NCon { _nconName :: Name- , _nconCxt :: Maybe Cxt+ , _nconVars :: [Name]+ , _nconCxt :: Cxt , _nconTypes :: [Type] } deriving (Eq) instance HasTypeVars NCon where- typeVarsEx s f (NCon x y z) = NCon x <$> typeVarsEx s f y <*> typeVarsEx s f z+ typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z+ where s' = foldl' (flip Set.insert) s vars nconName :: Lens' NCon Name nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x)) -nconCxt :: Lens' NCon (Maybe Cxt)+nconCxt :: Lens' NCon Cxt nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x)) nconTypes :: Lens' NCon [Type]@@ -479,20 +466,12 @@ -- | Normalize a single 'Con' to its constructor name and field types. -- Because GADT syntax allows multiple constructors to be defined at -- the same time, this function can return multiple normalized results.-normalizeCon :: Con -> [NCon]-normalizeCon (RecC conName xs) = [NCon conName Nothing (map (view _3) xs)]-normalizeCon (NormalC conName xs) = [NCon conName Nothing (map (view _2) xs)]-normalizeCon (InfixC (_,x) conName (_,y)) = [NCon conName Nothing [x,y]]-normalizeCon (ForallC [] [] con) = normalizeCon con -- happens in GADTs-normalizeCon (ForallC _ cx1 con) =- [NCon n (Just cx1 <> cx2) tys- | NCon n cx2 tys <- normalizeCon con ]-#if MIN_VERSION_template_haskell(2,11,0)-normalizeCon (GadtC conNames xs _) =- [ NCon conName Nothing (map (view _2) xs) | conName <- conNames ]-normalizeCon (RecGadtC conNames xs _) =- [ NCon conName Nothing (map (view _3) xs) | conName <- conNames ]-#endif+normalizeCon :: D.ConstructorInfo -> NCon+normalizeCon info = NCon (D.constructorName info)+ (D.tvName <$> D.constructorVars info)+ (D.constructorContext info)+ (D.constructorFields info)+ -- | Compute a prism's name by prefixing an underscore for normal -- constructors and period for operators.
src/Control/Lens/Internal/TH.hs view
@@ -205,3 +205,33 @@ leftDataName :: Name leftDataName = mkNameG_d "base" "Data.Either" "Left"+++------------------------------------------------------------------------+-- Support for generating inline pragmas+------------------------------------------------------------------------++inlinePragma :: Name -> [DecQ]++#ifdef INLINING++#if MIN_VERSION_template_haskell(2,8,0)++# ifdef OLD_INLINE_PRAGMAS+-- 7.6rc1?+inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase Inline False)]+# else+-- 7.7.20120830+inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]+# endif++#else+-- GHC <7.6, TH <2.8.0+inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]+#endif++#else++inlinePragma _ = []++#endif
src/Control/Lens/Plated.hs view
@@ -335,7 +335,7 @@ -- 'rewriteOf' :: 'Traversal'' a a -> (a -> 'Maybe' a) -> a -> a -- 'rewriteOf' :: 'Setter'' a a -> (a -> 'Maybe' a) -> a -> a -- @-rewriteOf :: ASetter' a a -> (a -> Maybe a) -> a -> a+rewriteOf :: ASetter a b a b -> (b -> Maybe a) -> a -> b rewriteOf l f = go where go = transformOf l (\x -> maybe x go (f x)) {-# INLINE rewriteOf #-}@@ -360,7 +360,7 @@ -- 'rewriteOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s -- @-rewriteOnOf :: ASetter s t a a -> ASetter' a a -> (a -> Maybe a) -> s -> t+rewriteOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> Maybe a) -> s -> t rewriteOnOf b l = over b . rewriteOf l {-# INLINE rewriteOnOf #-} @@ -372,7 +372,7 @@ -- | Rewrite by applying a monadic rule everywhere you recursing with a user-specified 'Traversal'. -- Ensures that the rule cannot be applied anywhere in the result.-rewriteMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> a -> m a+rewriteMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b rewriteMOf l f = go where go = transformMOf l (\x -> f x >>= maybe (return x) go) {-# INLINE rewriteMOf #-}@@ -385,7 +385,7 @@ -- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal', -- using a user-specified 'Traversal' for recursion. Ensures that the rule cannot be applied anywhere in the result.-rewriteMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> s -> m t+rewriteMOnOf :: Monad m => LensLike (WrappedMonad m) s t a b -> LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> s -> m t rewriteMOnOf b l = mapMOf b . rewriteMOf l {-# INLINE rewriteMOnOf #-} @@ -489,7 +489,7 @@ -- 'transformOf' :: 'Traversal'' a a -> (a -> a) -> a -> a -- 'transformOf' :: 'Setter'' a a -> (a -> a) -> a -> a -- @-transformOf :: ASetter' a a -> (a -> a) -> a -> a+transformOf :: ASetter a b a b -> (b -> b) -> a -> b transformOf l f = go where go = f . over l go {-# INLINE transformOf #-}@@ -501,7 +501,7 @@ -- 'transformOnOf' :: 'Setter'' s a -> 'Traversal'' a a -> (a -> a) -> s -> s -- 'transformOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> a) -> s -> s -- @-transformOnOf :: ASetter s t a a -> ASetter' a a -> (a -> a) -> s -> t+transformOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> b) -> s -> t transformOnOf b l = over b . transformOf l {-# INLINE transformOnOf #-} @@ -524,7 +524,7 @@ -- @ -- 'transformMOf' :: 'Monad' m => 'Traversal'' a a -> (a -> m a) -> a -> m a -- @-transformMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m a) -> a -> m a+transformMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b transformMOf l f = go where go t = mapMOf l go t >>= f {-# INLINE transformMOf #-}@@ -535,7 +535,7 @@ -- @ -- 'transformMOnOf' :: 'Monad' m => 'Traversal'' s a -> 'Traversal'' a a -> (a -> m a) -> s -> m s -- @-transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m a) -> s -> m t+transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a b -> LensLike (WrappedMonad m) a b a b -> (b -> m b) -> s -> m t transformMOnOf b l = mapMOf b . transformMOf l {-# INLINE transformMOnOf #-}
src/Control/Lens/Review.hs view
@@ -6,7 +6,7 @@ #endif #if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif ------------------------------------------------------------------------------- -- |
src/Control/Lens/Wrapped.hs view
@@ -95,6 +95,7 @@ import Control.Comonad.Trans.Traced import Control.Exception import Control.Lens.Getter+import Control.Lens.Internal.CTypes import Control.Lens.Iso #if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Review@@ -132,7 +133,6 @@ import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable-import Data.Int import Data.IntSet as IntSet import Data.IntMap as IntMap import Data.HashSet as HashSet@@ -154,7 +154,6 @@ import Data.Vector.Primitive as Prim import Data.Vector.Unboxed as Unboxed import Data.Vector.Storable as Storable-import Data.Word import Foreign.C.Error import Foreign.C.Types import qualified GHC.Generics as Generic@@ -169,10 +168,6 @@ #if MIN_VERSION_base(4,8,0) import qualified Data.Monoid as Monoid-#endif--#if MIN_VERSION_base(4,10,0) && defined(HTYPE_TIMER_T)-import GHC.Exts (HTYPE_TIMER_T) #endif #ifdef HLINT