lens 4.4.0.1 → 4.4.0.2
raw patch · 9 files changed
+257/−181 lines, 9 filesdep ~text
Dependency ranges changed: text
Files
- CHANGELOG.markdown +5/−0
- lens.cabal +3/−3
- src/Control/Lens/At.hs +42/−5
- src/Control/Lens/Internal/FieldTH.hs +26/−28
- src/Control/Lens/Internal/PrismTH.hs +17/−20
- src/Control/Lens/Internal/TH.hs +101/−0
- src/Control/Lens/Internal/TupleIxedTH.hs +0/−111
- src/Control/Lens/TH.hs +7/−11
- src/System/IO/Error/Lens.hs +56/−3
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+4.4.0.2+---+* `text` 1.2.0.0 support+* Remove the use of the TemplateHaskell extension from the library to enable lens to be used on stage1 cross-compilers+ 4.4.0.1 ---- * Restore previous default of `makeFields` using the camel case field namer.
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.4.0.1+version: 4.4.0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -204,7 +204,7 @@ split >= 0.2 && < 0.3, tagged >= 0.4.4 && < 1, template-haskell >= 2.4 && < 2.11,- text >= 0.11 && < 1.2,+ text >= 0.11 && < 1.3, transformers >= 0.2 && < 0.5, transformers-compat >= 0.3 && < 1, unordered-containers >= 0.2 && < 0.3,@@ -300,7 +300,7 @@ Numeric.Lens other-modules:- Control.Lens.Internal.TupleIxedTH+ Paths_lens cpp-options: -traditional
src/Control/Lens/At.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-}@@ -42,10 +41,10 @@ ) where import Control.Applicative+import Control.Lens.Each+import Control.Lens.Traversal import Control.Lens.Lens import Control.Lens.Setter-import Control.Lens.Type-import Control.Lens.Internal.TupleIxedTH (makeAllTupleIxed) import Data.Array.IArray as Array import Data.Array.Unboxed import Data.ByteString as StrictB@@ -63,7 +62,6 @@ import Data.Sequence as Seq import Data.Text as StrictT import Data.Text.Lazy as LazyT-import Data.Traversable import Data.Tree import Data.Vector as Vector hiding (indexed) import Data.Vector.Primitive as Prim@@ -432,4 +430,43 @@ where mv = if HashSet.member k m then Just () else Nothing {-# INLINE at #-} -makeAllTupleIxed++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a) a@+type instance IxValue (a,a2) = a+instance (a~a2) => Ixed (a,a2) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a) a@+type instance IxValue (a,a2,a3) = a+instance (a~a2, a~a3) => Ixed (a,a2,a3) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a) a@+type instance IxValue (a,a2,a3,a4) = a+instance (a~a2, a~a3, a~a4) => Ixed (a,a2,a3,a4) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a) a@+type instance IxValue (a,a2,a3,a4,a5) = a+instance (a~a2, a~a3, a~a4, a~a5) => Ixed (a,a2,a3,a4,a5) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a) a@+type instance IxValue (a,a2,a3,a4,a5,a6) = a+instance (a~a2, a~a3, a~a4, a~a5, a~a6) => Ixed (a,a2,a3,a4,a5,a6) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a) a@+type instance IxValue (a,a2,a3,a4,a5,a6,a7) = a+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7) => Ixed (a,a2,a3,a4,a5,a6,a7) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a) a@+type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8) = a+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8) => Ixed (a,a2,a3,a4,a5,a6,a7,a8) where+ ix = elementOf each++-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a,a) a@+type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8,a9) = a+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9) => Ixed (a,a2,a3,a4,a5,a6,a7,a8,a9) where+ ix = elementOf each
src/Control/Lens/Internal/FieldTH.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -22,16 +21,13 @@ import Control.Lens.At import Control.Lens.Fold-import Control.Lens.Internal.Getter import Control.Lens.Internal.TH-import Control.Lens.Iso import Control.Lens.Plated import Control.Lens.Prism import Control.Lens.Setter import Control.Lens.Getter import Control.Lens.Traversal import Control.Lens.Tuple-import Control.Lens.Type import Control.Applicative import Control.Monad import Language.Haskell.TH.Lens@@ -145,20 +141,20 @@ let defType | Just (_,cx,a') <- preview _ForallT a =- let optic | lensCase = ''Getter- | otherwise = ''Fold+ let optic | lensCase = getterTypeName+ | otherwise = foldTypeName in OpticSa cx optic s' a' | _simpleLenses rules || s' == t && a == b =- let optic | isoCase && _allowIsos rules = ''Iso'- | lensCase = ''Lens'- | otherwise = ''Traversal'+ let optic | isoCase && _allowIsos rules = iso'TypeName+ | lensCase = lens'TypeName+ | otherwise = traversal'TypeName in OpticSa [] optic s' a | otherwise =- let optic | isoCase && _allowIsos rules = ''Iso- | lensCase = ''Lens- | otherwise = ''Traversal+ let optic | isoCase && _allowIsos rules = isoTypeName+ | lensCase = lensTypeName+ | otherwise = traversalTypeName in OpticStab optic s' t a b opticType | has _ForallT a = GetterType@@ -298,15 +294,15 @@ classD (cxt[]) className (map PlainTV (c:vars)) fd- $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s']))+ $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return (stabToOptic stab `conAppsT` [VarT c, applyTypeSubst sub (stabToA stab)]))- ,valD (varP defName) (normalB [| $(varE methodName) . $(varE defName) |]) []+ ,valD (varP defName) (normalB body) [] ] ++ inlinePragma defName- | (TopName defName, (_, stab, _)) <- defs ]-- where+ | (TopName defName, (_, stab, _)) <- defs+ , let body = appsE [varE composeValName, varE methodName, varE defName]+ ] makeClassyInstance ::@@ -319,7 +315,7 @@ methodss <- traverse (makeFieldOptic rules') defs instanceD (cxt[]) (return instanceHead)- $ valD (varP methodName) (normalB [|id|]) []+ $ valD (varP methodName) (normalB (varE idValName)) [] : map return (concat methodss) where@@ -374,13 +370,13 @@ makePureClause conName 0 = -- clause: _ _ = pure Con- clause [wildP, wildP] (normalB [| pure $(conE conName) |]) []+ clause [wildP, wildP] (normalB (appE (varE pureValName) (conE conName))) [] makePureClause conName fieldCount = do xs <- replicateM fieldCount (newName "x") -- clause: _ (Con x1..xn) = pure (Con x1..xn) clause [wildP, conP conName (map varP xs)]- (normalB [| pure $(appsE (conE conName : map varE xs)) |])+ (normalB (appE (varE pureValName) (appsE (conE conName : map varE xs)))) [] @@ -397,9 +393,9 @@ | otherwise = wildP : pats is (y:ys) pats is _ = map (const wildP) is - fxs = [ [| $(varE f) $(varE x) |] | x <- xs ]- body = foldl (\a b -> [| $a <*> $b |])- [| coerce $(head fxs) |]+ fxs = [ appE (varE f) (varE x) | x <- xs ]+ body = foldl (\a b -> appsE [varE apValName, a, b])+ (appE (varE coerceValName) (head fxs)) (tail fxs) -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn@@ -420,12 +416,14 @@ let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) - mkFx i = [| $(varE f) $(varE (xs !! i)) |]+ mkFx i = appE (varE f) (varE (xs !! i)) - body0 = [| $(lamE (map varP ys) (appsE (conE conName : map varE xs')))- <$> $(mkFx field) |]+ body0 = appsE [ varE fmapValName+ , lamE (map varP ys) (appsE (conE conName : map varE xs'))+ , mkFx field+ ] - body = foldl (\a b -> [| $a <*> $(mkFx b) |]) body0 fields+ body = foldl (\a b -> appsE [varE apValName, a, mkFx b]) body0 fields let wrap = if irref then tildeP else id @@ -436,7 +434,7 @@ -- | Build a clause that constructs an Iso makeIsoClause :: Name -> ClauseQ-makeIsoClause conName = clause [] (normalB [| iso $destruct $construct |]) []+makeIsoClause conName = clause [] (normalB (appsE [varE isoValName, destruct, construct])) [] where destruct = do x <- newName "x" lam1E (conP conName [varP x]) (varE x)
src/Control/Lens/Internal/PrismTH.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -21,10 +20,7 @@ import Control.Applicative import Control.Lens.Getter import Control.Lens.Internal.TH-import Control.Lens.Iso import Control.Lens.Lens-import Control.Lens.Prism-import Control.Lens.Review import Control.Lens.Setter import Control.Lens.Tuple import Control.Monad@@ -174,10 +170,10 @@ stabToType :: Stab -> Type stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $ case ty of- PrismType | stabSimple stab -> ''Prism' `conAppsT` [t,b]- | otherwise -> ''Prism `conAppsT` [s,t,a,b]- ReviewType | stabSimple stab -> ''Review' `conAppsT` [t,b]- | otherwise -> ''Review `conAppsT` [s,t,a,b]+ PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b]+ | otherwise -> prismTypeName `conAppsT` [s,t,a,b]+ ReviewType | stabSimple stab -> review'TypeName `conAppsT` [t,b]+ | otherwise -> reviewTypeName `conAppsT` [s,t,a,b] where vs = map PlainTV (Set.toList (setOf typeVars cx))@@ -225,8 +221,8 @@ a = toTupleT (map return (substTypeVars sub fields)) #ifndef HLINT- ty | Map.null sub = [t| Iso' $t $b |]- | otherwise = [t| Iso $s $t $a $b |]+ ty | Map.null sub = appsT (conT iso'TypeName) [t,b]+ | otherwise = appsT (conT isoTypeName) [s,t,a,b] #endif close =<< ty@@ -260,7 +256,7 @@ [NCon] {- ^ constructors -} -> NCon {- ^ target constructor -} -> ExpQ-makeConPrismExp stab cons con = [| prism $reviewer $remitter |]+makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter] where ts = view nconTypes con fields = length ts@@ -275,7 +271,7 @@ -- -- iso <<reviewer>> <<remitter>> makeConIsoExp :: NCon -> ExpQ-makeConIsoExp con = [| iso $remitter $reviewer |]+makeConIsoExp con = appsE [varE isoValName, remitter, reviewer] where conName = view nconName con fields = length (view nconTypes con)@@ -288,7 +284,7 @@ -- -- unto (\(x,y,z) -> Con x y z) makeConReviewExp :: NCon -> ExpQ-makeConReviewExp con = [| unto $reviewer |]+makeConReviewExp con = appE (varE untoValName) reviewer where conName = view nconName con fields = length (view nconTypes con)@@ -324,9 +320,9 @@ xs <- replicateM fields (newName "y") let matches = [ match (conP conName (map varP xs))- (normalB [| Right $(toTupleE (map varE xs)) |])+ (normalB (appE (conE rightDataName) (toTupleE (map varE xs)))) []- , match wildP (normalB [| Left $(varE x) |]) []+ , match wildP (normalB (appE (conE leftDataName) (varE x))) [] ] lam1E (varP x) (caseE (varE x) matches) @@ -347,8 +343,8 @@ match (conP conName (map varP xs)) (normalB (if conName == target- then [| Right $(toTupleE (map varE xs)) |]- else [| Left $(conE conName `appsE1` map varE xs) |]))+ then appE (conE rightDataName) (toTupleE (map varE xs))+ else appE (conE leftDataName) (conE conName `appsE1` map varE xs))) [] @@ -382,7 +378,7 @@ makeClassyPrismClass t className methodName cons = do r <- newName "r" #ifndef HLINT- let methodType = [t| Prism' $(varT r) $(return t) |]+ let methodType = appsT (conT prism'TypeName) [varT r,return t] #endif methodss <- traverse (mkMethod (VarT r)) cons' classD (cxt[]) className (map PlainTV (r : vs)) (fds r)@@ -395,9 +391,10 @@ do Stab cx o _ _ _ b <- computeOpticType t cons con let stab' = Stab cx o r r b b defName = view nconName con+ body = appsE [varE composeValName, varE methodName, varE defName] sequence [ sigD defName (return (stabToType stab'))- , valD (varP defName) (normalB [| $(varE methodName) . $(varE defName) |]) []+ , valD (varP defName) (normalB body) [] ] cons' = map (over nconName prismName) cons@@ -425,7 +422,7 @@ instanceD (cxt[]) (return cls) ( valD (varP methodName)- (normalB [| id |]) []+ (normalB (varE idValName)) [] : [ do stab <- computeOpticType s cons con let stab' = simplifyStab stab valD (varP (prismName conName))
src/Control/Lens/Internal/TH.hs view
@@ -3,6 +3,10 @@ {-# LANGUAGE Trustworthy #-} #endif +#ifdef HLINT+{-# ANN module "HLint: ignore Use camelCase" #-}+#endif+ #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) #endif@@ -23,8 +27,11 @@ module Control.Lens.Internal.TH where import Language.Haskell.TH+import Language.Haskell.TH.Syntax import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Version (showVersion)+import Paths_lens (version) -- | Compatibility shim for recent changes to template haskell's 'tySynInstD' tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ@@ -73,3 +80,97 @@ #else fromSet f x = Map.fromList [ (k,f k) | k <- Set.toList x ] #endif++------------------------------------------------------------------------+-- Manually quoted names+------------------------------------------------------------------------+-- By manually generating these names we avoid needing to use the+-- TemplateHaskell language extension when compiling the lens library.+-- This allows the library to be used in stage1 cross-compilers.++mkLensName_tc :: String -> String -> Name+mkLensName_tc = mkNameG_tc ("lens-" ++ showVersion version)++mkLensName_v :: String -> String -> Name+mkLensName_v = mkNameG_v ("lens-" ++ showVersion version)++traversalTypeName :: Name+traversalTypeName = mkLensName_tc "Control.Lens.Type" "Traversal"++traversal'TypeName :: Name+traversal'TypeName = mkLensName_tc "Control.Lens.Type" "Traversal'"++lensTypeName :: Name+lensTypeName = mkLensName_tc "Control.Lens.Type" "Lens"++lens'TypeName :: Name+lens'TypeName = mkLensName_tc "Control.Lens.Type" "Lens'"++isoTypeName :: Name+isoTypeName = mkLensName_tc "Control.Lens.Type" "Iso"++iso'TypeName :: Name+iso'TypeName = mkLensName_tc "Control.Lens.Type" "Iso'"++getterTypeName :: Name+getterTypeName = mkLensName_tc "Control.Lens.Type" "Getter"++foldTypeName :: Name+foldTypeName = mkLensName_tc "Control.Lens.Type" "Fold"++prismTypeName :: Name+prismTypeName = mkLensName_tc "Control.Lens.Type" "Prism"++prism'TypeName :: Name+prism'TypeName = mkLensName_tc "Control.Lens.Type" "Prism'"++reviewTypeName :: Name+reviewTypeName = mkLensName_tc "Control.Lens.Type" "Review"++review'TypeName :: Name+review'TypeName = mkLensName_tc "Control.Lens.Type" "Review'"++wrappedTypeName :: Name+wrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Wrapped"++unwrappedTypeName :: Name+unwrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Unwrapped"++rewrappedTypeName :: Name+rewrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Rewrapped"++_wrapped'ValName :: Name+_wrapped'ValName = mkLensName_v "Control.Lens.Wrapped" "_Wrapped'"++isoValName :: Name+isoValName = mkLensName_v "Control.Lens.Iso" "iso"++prismValName :: Name+prismValName = mkLensName_v "Control.Lens.Prism" "prism"++untoValName :: Name+untoValName = mkLensName_v "Control.Lens.Review" "unto"++coerceValName :: Name+coerceValName = mkLensName_v "Control.Lens.Internal.Getter" "coerce"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."++idValName :: Name+idValName = mkNameG_v "base" "GHC.Base" "id"++fmapValName :: Name+fmapValName = mkNameG_v "base" "GHC.Base" "fmap"++pureValName :: Name+pureValName = mkNameG_v "base" "Control.Applicative" "pure"++apValName :: Name+apValName = mkNameG_v "base" "Control.Applicative" "<*>"++rightDataName :: Name+rightDataName = mkNameG_d "base" "Data.Either" "Right"++leftDataName :: Name+leftDataName = mkNameG_d "base" "Data.Either" "Left"
− src/Control/Lens/Internal/TupleIxedTH.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif---------------------------------------------------------------------------------- |--- Module : Control.Lens.Internal.TupleIxedTH--- Copyright : (C) 2014 Edward Kmett--- (C) 2012-13 Eric Mertens--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable---------------------------------------------------------------------------------module Control.Lens.Internal.TupleIxedTH- ( makeAllTupleIxed- ) where--import Control.Applicative-import Data.Traversable (traverse)-import Language.Haskell.TH--import Control.Lens.Internal.TH---- This module needs to be used by Control.Lens.At which defines these names-indexN, ixValueN, ixedN, ixN :: Name-indexN = mkName "Index"-ixValueN = mkName "IxValue"-ixedN = mkName "Ixed"-ixN = mkName "ix"---- While GHC supports tuples up to 62, it can't cope with the resulting--- large definitions. 9-tuples should be enough for anyone.---- This generates all of the Ixed instances for tuples up to 9.-makeAllTupleIxed :: DecsQ-makeAllTupleIxed = fmap concat (traverse makeTupleIxed [2..9])---- type instance Index (a,..) = Int--- type instance IxValue (a,..) = a--- instance (a~b,a~c...) => Ixed (a,b,c..) where--- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z)--- ix _ f x = pure x-makeTupleIxed :: Int -> DecsQ-makeTupleIxed n = sequence [tupleIndex n, tupleIxValue n, tupleIxed n]---- type instance Index (a,..) = Int-tupleIndex :: Int -> DecQ-tupleIndex n = tySynInstD' indexN [fullTupleT n] [t|Int|]---- type instance IxValue (a,..) = a-tupleIxValue :: Int -> DecQ-tupleIxValue n = tySynInstD' ixValueN [fullTupleT n] (head tupleVarTypes)---- (a,..)-fullTupleT :: Int -> TypeQ-fullTupleT n = toTupleT (take n tupleVarTypes)---- instance (a~b,a~c...) => Ixed (a,b,c..) where--- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z)--- ix _ f x = pure x-tupleIxed :: Int -> DecQ-tupleIxed n = instanceD (cxt eqs) (conT ixedN `appT` fullTupleT n) [funD ixN clauses]- where- ty0:tyN = take n tupleVarTypes-#if MIN_VERSION_template_haskell(2,10,0)- eqs = [AppT . AppT EqualityT <$> ty0 <*> ty | ty <- tyN]-#else- eqs = [ty0 `equalP` ty | ty <- tyN]-#endif- clauses = map nClause [0..n-1] ++ [otherClause]-- -- ix i f (a,..) = fmap (\x->(a,..x..)) (f z)- nClause i = do- let iP = litP (integerL (fromIntegral i))- f <- newName "f"- let fP = varP f- fE = varE f- xs <- mapM newName (take n nameSource)- let xsP = map varP xs- xsE = map varE xs- xE = varE (xs !! i)- clause [iP, fP, toTupleP xsP]- (normalB [| fmap (\x -> $(toTupleE (replaceAt i [|x|] xsE))) ($fE $xE) |])- []-- -- ix _ _ x = pure x- otherClause = do- x <- newName "x"- clause [wildP, wildP, varP x] (normalB [|pure $(varE x)|]) []--tupleVarTypes :: [TypeQ]-tupleVarTypes = map (varT . mkName) nameSource---- [a,b,c,d...a1,b1,b2...a2,b2,c3...]-nameSource :: [String]-nameSource = [ a:n | n <- "" : map show [1 :: Int ..]- , a <- ['a'..'z']- ]---- While this could be easily implemented as 'set . ix'--- this local definition removes any circular dependency--- issues.-replaceAt :: Int -> a -> [a] -> [a]-replaceAt 0 x (_:ys) = x : ys-replaceAt i x (y:ys) = y : replaceAt (i-1) x ys-replaceAt _ _ [] = error "replaceAt: index too large"
src/Control/Lens/TH.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif@@ -65,9 +63,7 @@ import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Tuple-import Control.Lens.Iso import Control.Lens.Traversal-import Control.Lens.Wrapped import Control.Lens.Internal.TH import Control.Lens.Internal.FieldTH import Control.Lens.Internal.PrismTH@@ -89,6 +85,8 @@ {-# ANN module "HLint: ignore Use foldl" #-} #endif +-- | Generate "simple" optics even when type-changing optics are possible.+-- (e.g. 'Lens'' instead of 'Lens') simpleLenses :: Lens' LensRules Bool simpleLenses f r = fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r)) @@ -498,7 +496,7 @@ #endif -- Rewrapped (Con a b c...) t- klass = conT ''Rewrapped `appsT` [appliedType, t]+ klass = conT rewrappedTypeName `appsT` [appliedType, t] -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t instanceD (cxt [eq]) klass []@@ -513,15 +511,16 @@ let appliedType = fullType dataDecl (map VarT typeArgs) -- type Unwrapped (Con a b c...) = $fieldType- let unwrappedATF = tySynInstD' ''Unwrapped [return appliedType] (return fieldType)+ let unwrappedATF = tySynInstD' unwrappedTypeName [return appliedType] (return fieldType) -- Wrapped (Con a b c...)- let klass = conT ''Wrapped `appT` return appliedType+ let klass = conT wrappedTypeName `appT` return appliedType -- _Wrapped' = iso (\(Con x) -> x) Con let wrapFun = conE conName let unwrapFun = newName "x" >>= \x -> lam1E (conP conName [varP x]) (varE x)- let isoMethod = funD '_Wrapped' [clause [] (normalB [|iso $unwrapFun $wrapFun|]) []]+ let body = appsE [varE isoValName, unwrapFun, wrapFun]+ let isoMethod = funD _wrapped'ValName [clause [] (normalB body) []] -- instance Wrapped (Con a b c...) where -- type Unwrapped (Con a b c...) = fieldType@@ -603,8 +602,6 @@ -- will create -- -- @--- _fooXLens :: Lens' (Foo a) Int--- _fooYLens :: Lens (Foo a) (Foo b) a b -- class HasX s a | s -> a where -- x :: Lens' s a -- instance HasX (Foo a) Int where@@ -613,7 +610,6 @@ -- y :: Lens' s a -- instance HasY (Foo a) a where -- y = _fooYLens--- _barXLens :: Iso' Bar Char -- instance HasX Bar Char where -- x = _barXLens -- @
src/System/IO/Error/Lens.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -60,6 +59,60 @@ -- * IOErrorType Prisms ----- (These prisms are generated automatically) -makePrisms ''IOErrorType+_AlreadyExists :: Prism' IOErrorType ()+_AlreadyExists = only AlreadyExists++_NoSuchThing :: Prism' IOErrorType ()+_NoSuchThing = only NoSuchThing++_ResourceBusy :: Prism' IOErrorType ()+_ResourceBusy = only ResourceBusy++_ResourceExhausted :: Prism' IOErrorType ()+_ResourceExhausted = only ResourceExhausted++_EOF :: Prism' IOErrorType ()+_EOF = only EOF++_IllegalOperation :: Prism' IOErrorType ()+_IllegalOperation = only IllegalOperation++_PermissionDenied :: Prism' IOErrorType ()+_PermissionDenied = only PermissionDenied++_UserError :: Prism' IOErrorType ()+_UserError = only UserError++_UnsatisfiedConstraints :: Prism' IOErrorType ()+_UnsatisfiedConstraints = only UnsatisfiedConstraints++_SystemError :: Prism' IOErrorType ()+_SystemError = only SystemError++_ProtocolError :: Prism' IOErrorType ()+_ProtocolError = only ProtocolError++_OtherError :: Prism' IOErrorType ()+_OtherError = only OtherError++_InvalidArgument :: Prism' IOErrorType ()+_InvalidArgument = only InvalidArgument++_InappropriateType :: Prism' IOErrorType ()+_InappropriateType = only InappropriateType++_HardwareFault :: Prism' IOErrorType ()+_HardwareFault = only HardwareFault++_UnsupportedOperation :: Prism' IOErrorType ()+_UnsupportedOperation = only UnsupportedOperation++_TimeExpired :: Prism' IOErrorType ()+_TimeExpired = only TimeExpired++_ResourceVanished :: Prism' IOErrorType ()+_ResourceVanished = only ResourceVanished++_Interrupted :: Prism' IOErrorType ()+_Interrupted = only Interrupted