diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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. diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -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 diff --git a/src/Control/Lens/At.hs b/src/Control/Lens/At.hs --- a/src/Control/Lens/At.hs +++ b/src/Control/Lens/At.hs @@ -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 diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs --- a/src/Control/Lens/Internal/FieldTH.hs +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -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) diff --git a/src/Control/Lens/Internal/PrismTH.hs b/src/Control/Lens/Internal/PrismTH.hs --- a/src/Control/Lens/Internal/PrismTH.hs +++ b/src/Control/Lens/Internal/PrismTH.hs @@ -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 <> <> 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)) diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs --- a/src/Control/Lens/Internal/TH.hs +++ b/src/Control/Lens/Internal/TH.hs @@ -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" diff --git a/src/Control/Lens/Internal/TupleIxedTH.hs b/src/Control/Lens/Internal/TupleIxedTH.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/TupleIxedTH.hs +++ /dev/null @@ -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 --- 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" diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -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 -- @ diff --git a/src/System/IO/Error/Lens.hs b/src/System/IO/Error/Lens.hs --- a/src/System/IO/Error/Lens.hs +++ b/src/System/IO/Error/Lens.hs @@ -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