lens 4.3.3 → 4.4
raw patch · 15 files changed
+1765/−1776 lines, 15 filesdep −aesondep −attoparsecdep −scientific
Dependencies removed: aeson, attoparsec, scientific
Files
- CHANGELOG.markdown +14/−0
- lens.cabal +3/−5
- src/Control/Lens/At.hs +4/−13
- src/Control/Lens/Fold.hs +3/−3
- src/Control/Lens/Internal/FieldTH.hs +580/−0
- src/Control/Lens/Internal/Instances.hs +1/−1
- src/Control/Lens/Internal/PrismTH.hs +490/−0
- src/Control/Lens/Internal/TH.hs +27/−0
- src/Control/Lens/Plated.hs +0/−7
- src/Control/Lens/Review.hs +1/−1
- src/Control/Lens/TH.hs +625/−1328
- src/Data/Aeson/Lens.hs +0/−405
- src/Generics/Deriving/Lens.hs +12/−12
- src/Language/Haskell/TH/Lens.hs +3/−0
- tests/templates.hs +2/−1
CHANGELOG.markdown view
@@ -1,3 +1,17 @@+4.4+----+* Internals of Template Haskell code generation rewritten. makeLenses,+ makeClassy, and makeFields have been unified into the same generator.+* TH generated single constructor Lens use irrefutable pattern matching to+ enable construction starting with undefined.+* TH generated traverals unify their field arguments (type synonyms not+ currently expanded) enabling exotic traversals to be generated.+* Added instances for `Text` to `Data.Aeson.Lens`+* Reimplemented `makePrisms`, adding support for `makeClassyPrisms`, infix constructrs generate periods (.) prefixed prisms.+* Added `Choice` to `Review` so that `Prism` is a proper subtype of `Review`+* Migrated `Data.Aeson.Lens` to `lens-aeson` package.+* Fixed `GHC.Generics.Lens.tinplate` behavior on single-field data types and empty data types.+ 4.3.3 ----- * `semigroupoids` 4.2 support
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.3.3+version: 4.4 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -181,8 +181,6 @@ library build-depends:- aeson >= 0.7.0.5 && < 0.9,- attoparsec >= 0.10 && < 0.13, array >= 0.3.0.2 && < 0.6, base >= 4.3 && < 5, bifunctors >= 4 && < 5,@@ -201,7 +199,6 @@ primitive >= 0.4.0.1 && < 0.6, profunctors >= 4 && < 5, reflection >= 1.1.6 && < 2,- scientific >= 0.3.2 && < 0.4, semigroupoids >= 4 && < 5, semigroups >= 0.8.4 && < 1, split >= 0.2 && < 0.3,@@ -237,6 +234,8 @@ Control.Lens.Internal.Context Control.Lens.Internal.Deque Control.Lens.Internal.Exception+ Control.Lens.Internal.FieldTH+ Control.Lens.Internal.PrismTH Control.Lens.Internal.Fold Control.Lens.Internal.Getter Control.Lens.Internal.Indexed@@ -270,7 +269,6 @@ Control.Monad.Primitive.Lens Control.Parallel.Strategies.Lens Control.Seq.Lens- Data.Aeson.Lens Data.Array.Lens Data.Bits.Lens Data.ByteString.Lens
src/Control/Lens/At.hs view
@@ -46,7 +46,6 @@ import Control.Lens.Setter import Control.Lens.Type import Control.Lens.Internal.TupleIxedTH (makeAllTupleIxed)-import Data.Aeson as Aeson import Data.Array.IArray as Array import Data.Array.Unboxed import Data.ByteString as StrictB@@ -105,7 +104,6 @@ type instance Index LazyT.Text = Int64 type instance Index StrictB.ByteString = Int type instance Index LazyB.ByteString = Int64-type instance Index Aeson.Value = StrictT.Text -- $setup -- >>> :set -XNoOverloadedStrings@@ -148,14 +146,14 @@ -- | 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 'AffineTraversal' lets you 'traverse' the value at a given+-- | 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'. class Ixed m where- -- | This simple 'AffineTraversal' lets you 'traverse' the value at a given+ -- | 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 'AffineTraversal' will only set the value in the- -- 'Lens' if it is already present.+ -- /NB:/ Setting the value of this 'Traversal' will only set the value in+ -- 'at' if it is already present. -- -- If you want to be able to insert /missing/ values, you want 'at'. --@@ -359,13 +357,6 @@ (l, mr) -> case LazyB.uncons mr of Nothing -> pure s Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs)- {-# INLINE ix #-}---type instance IxValue Aeson.Value = Aeson.Value-instance Ixed Aeson.Value where- ix i f (Object o) = Object <$> ix i f o- ix _ _ v = pure v {-# INLINE ix #-}
src/Control/Lens/Fold.hs view
@@ -287,9 +287,9 @@ go a = g a .> go (f a) {-# INLINE iterated #-} --- | Obtain an 'AffineFold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal').+-- | Obtain an 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). ----- Note: This is /not/ a legal 'AffineTraversal', unless you are very careful not to invalidate the predicate on the target.+-- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target. -- -- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that matches the predicate. --@@ -299,7 +299,7 @@ -- 'Control.Lens.Setter.over' evens 'succ' '.' 'Control.Lens.Setter.over' evens 'succ' '/=' 'Control.Lens.Setter.over' evens ('succ' '.' 'succ') -- @ ----- So, in order for this to qualify as a legal 'AffineTraversal' you can only use it for actions that preserve the result of the predicate!+-- So, in order for this to qualify as a legal 'Traversal' you can only use it for actions that preserve the result of the predicate! -- -- >>> [1..10]^..folded.filtered even -- [2,4,6,8,10]
+ src/Control/Lens/Internal/FieldTH.hs view
@@ -0,0 +1,580 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.FieldTH+-- Copyright : (C) 2014 Edward Kmett, (C) 2014 Eric Mertens+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------++module Control.Lens.Internal.FieldTH+ ( LensRules(..)+ , DefName(..)+ , makeFieldOptics+ , makeFieldOpticsForDec+ ) where++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+import Language.Haskell.TH+import Data.Traversable (sequenceA)+import Data.Foldable (toList)+import Data.Maybe (isJust,maybeToList)+import Data.List (nub, findIndices)+import Data.Either (partitionEithers)+import Data.Set.Lens+import Data.Map ( Map )+import qualified Data.Set as Set+import qualified Data.Map as Map+++------------------------------------------------------------------------+-- Field generation entry point+------------------------------------------------------------------------+++-- | 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"+++makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ+makeFieldOpticsForDec rules dec = case dec of+ 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]+ _ -> fail "makeFieldOptics: Expected data or newtype type-constructor"+ where+ mkS tyName vars = tyName `conAppsT` map VarT (toListOf typeVars vars)+++-- | 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 =+ do fieldCons <- traverse normalizeConstructor cons+ let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons+ let defCons = over normFieldLabels (expandName allFields) fieldCons+ allDefs = setOf (normFieldLabels . folded) defCons+ perDef <- sequenceA (fromSet (buildScaffold rules s defCons) allDefs)++ let defs = Map.toList perDef+ case _classyLenses rules tyName of+ Just (className, methodName) ->+ makeClassyDriver rules className methodName defs+ Nothing -> do decss <- traverse (makeFieldOptic rules) defs+ return (concat decss)++ where++ -- Traverse the field labels of a normalized constructor+ normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b+ normFieldLabels = traverse . _2 . traverse . _1++ -- Map a (possibly missing) field's name to zero-to-many optic definitions+ expandName :: [Name] -> Maybe Name -> [DefName]+ expandName allFields = concatMap (_fieldToDef rules allFields) . maybeToList++-- | Normalized the Con type into a uniform positional representation,+-- eliminating the variance between records, infix constructors, and normal+-- constructors.+normalizeConstructor ::+ Con ->+ 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')++++data OpticType = GetterType | LensType | IsoType++-- | Compute the positional location of the fields involved in+-- each constructor for a given optic definition as well as the+-- type of clauses to generate and the type to annotate the declaration+-- with.+buildScaffold ::+ LensRules ->+ Type {- ^ outer type -} ->+ [(Name, [([DefName], Type)])] {- ^ normalized constructors -} ->+ DefName {- ^ target definition -} ->+ Q (OpticType, OpticStab, [(Name, Int, [Int])])+ {- ^ optic type, definition type, field count, target fields -}+buildScaffold rules s cons defName =++ do (s',t,a,b) <- buildStab s (concatMap snd consForDef)++ let defType+ | Just (_,cx,a') <- preview _ForallT a =+ let optic | lensCase = ''Getter+ | otherwise = ''Fold+ in OpticSa cx optic s' a'++ | _simpleLenses rules || s' == t && a == b =+ let optic | isoCase && _allowIsos rules = ''Iso'+ | lensCase = ''Lens'+ | otherwise = ''Traversal'+ in OpticSa [] optic s' a++ | otherwise =+ let optic | isoCase && _allowIsos rules = ''Iso+ | lensCase = ''Lens+ | otherwise = ''Traversal+ in OpticStab optic s' t a b++ opticType | has _ForallT a = GetterType+ | isoCase = IsoType+ | otherwise = LensType++ return (opticType, defType, scaffolds)+ where+ consForDef :: [(Name, [Either Type Type])]+ consForDef = over (mapped . _2 . mapped) categorize cons++ scaffolds :: [(Name, Int, [Int])]+ scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ]++ rightIndices :: [Either Type Type] -> [Int]+ rightIndices = findIndices (has _Right)++ -- Right: types for this definition+ -- Left : other types+ categorize :: ([DefName], Type) -> Either Type Type+ categorize (defNames, t)+ | defName `elem` defNames = Right t+ | otherwise = Left t++ lensCase :: Bool+ lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef++ isoCase :: Bool+ isoCase = case scaffolds of+ [(_,1,[0])] -> True+ _ -> False+++data OpticStab = OpticStab Name Type Type Type Type+ | OpticSa Cxt Name Type Type++stabToType :: OpticStab -> Type+stabToType (OpticStab c s t a b) = quantifyType [] (c `conAppsT` [s,t,a,b])+stabToType (OpticSa cx c s a ) = quantifyType cx (c `conAppsT` [s,a])++stabToOptic :: OpticStab -> Name+stabToOptic (OpticStab c _ _ _ _) = c+stabToOptic (OpticSa _ c _ _) = c++stabToS :: OpticStab -> Type+stabToS (OpticStab _ s _ _ _) = s+stabToS (OpticSa _ _ s _) = s++stabToA :: OpticStab -> Type+stabToA (OpticStab _ _ _ a _) = a+stabToA (OpticSa _ _ _ a) = a++-- | Compute the s 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 :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)+buildStab s categorizedFields =+ do (subA,a) <- unifyTypes targetFields+ let s' = applyTypeSubst subA s++ -- compute possible type changes+ sub <- sequenceA (fromSet (newName . nameBase) unfixedTypeVars)+ let (t,b) = over both (substTypeVars sub) (s',a)++ return (s',t,a,b)++ where+ (fixedFields, targetFields) = partitionEithers categorizedFields+ fixedTypeVars = setOf typeVars fixedFields+ unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars+++-- | Build the signature and definition for a single field optic.+-- In the case of a singleton constructor irrefutable matches are+-- used to enable the resulting lenses to be used on a bottom value.+makeFieldOptic ::+ LensRules ->+ (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->+ DecsQ+makeFieldOptic rules (defName, (opticType, defType, cons)) =+ do cls <- mkCls+ sequenceA (cls ++ sig ++ def)+ where+ mkCls = case defName of+ MethodName c n | _generateClasses rules ->+ do classExists <- isJust <$> lookupTypeName (show c)+ return (if classExists then [] else [makeFieldClass defType c n])+ _ -> return []++ sig = case defName of+ _ | not (_generateSigs rules) -> []+ TopName n -> [sigD n (return (stabToType defType))]+ MethodName{} -> []++ fun n = funD n clauses : inlinePragma n++ def = case defName of+ TopName n -> fun n+ MethodName c n -> [makeFieldInstance defType c (fun n)]++ clauses = makeFieldClauses opticType cons+++------------------------------------------------------------------------+-- Classy class generator+------------------------------------------------------------------------+++makeClassyDriver ::+ LensRules ->+ Name ->+ Name ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ DecsQ+makeClassyDriver rules className methodName defs = sequenceA (cls ++ inst)++ where+ cls | _generateClasses rules = [makeClassyClass className methodName defs]+ | otherwise = []++ inst = [makeClassyInstance rules className methodName defs]+++makeClassyClass ::+ Name ->+ Name ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ DecQ+makeClassyClass className methodName defs = do+ let ss = map (stabToS . view (_2 . _2)) defs+ (sub,s') <- unifyTypes ss+ c <- newName "c"+ let vars = toListOf typeVars s'+ fd | null vars = []+ | otherwise = [FunDep [c] vars]+++ classD (cxt[]) className (map PlainTV (c:vars)) fd+ $ sigD methodName (return (''Lens' `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) |]) []+ ] +++ inlinePragma defName+ | (TopName defName, (_, stab, _)) <- defs ]++ where+++makeClassyInstance ::+ LensRules ->+ Name ->+ Name ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ DecQ+makeClassyInstance rules className methodName defs = do+ methodss <- traverse (makeFieldOptic rules') defs++ instanceD (cxt[]) (return instanceHead)+ $ valD (varP methodName) (normalB [|id|]) []+ : map return (concat methodss)++ where+ instanceHead = className `conAppsT` (s : map VarT vars)+ s = stabToS (view (_2 . _2) (head defs))+ vars = toListOf typeVars s+ rules' = rules { _generateSigs = False+ , _generateClasses = False+ }++------------------------------------------------------------------------+-- Field class generation+------------------------------------------------------------------------++makeFieldClass :: OpticStab -> Name -> Name -> DecQ+makeFieldClass defType className methodName =+ classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]]+ [sigD methodName (return methodType)]+ where+ methodType = stabToOptic defType `conAppsT` [VarT s,VarT a]+ s = mkName "s"+ a = mkName "a"++makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ+makeFieldInstance defType className =+ instanceD (cxt [])+ (return (className `conAppsT` [stabToS defType, stabToA defType]))++------------------------------------------------------------------------+-- Optic clause generators+------------------------------------------------------------------------+++makeFieldClauses :: OpticType -> [(Name, Int, [Int])] -> [ClauseQ]+makeFieldClauses opticType cons =+ case opticType of++ IsoType -> [ makeIsoClause conName | (conName, _, _) <- cons ]++ GetterType -> [ makeGetterClause conName fieldCount fields+ | (conName, fieldCount, fields) <- cons ]++ LensType -> let irref = length cons == 1 in+ [ makeFieldOpticClause conName fieldCount fields irref+ | (conName, fieldCount, fields) <- cons ]+++-- | Construct an optic clause that returns an unmodified value+-- given a constructor name and the number of fields on that+-- constructor.+makePureClause :: Name -> Int -> ClauseQ++makePureClause conName 0 =+ -- clause: _ _ = pure Con+ clause [wildP, wildP] (normalB [| pure $(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)) |])+ []+++-- | Construct an optic clause suitable for a Getter or Fold+-- by visited the fields identified by their 0 indexed positions+makeGetterClause :: Name -> Int -> [Int] -> ClauseQ+makeGetterClause conName fieldCount [] = makePureClause conName fieldCount+makeGetterClause conName fieldCount fields =+ do f <- newName "f"+ xs <- replicateM (length fields) (newName "x")++ let pats (i:is) (y:ys)+ | i `elem` fields = varP y : pats is ys+ | 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) |]+ (tail fxs)++ -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn+ clause [varP f, conP conName (pats [0..fieldCount - 1] xs)]+ (normalB body)+ []++-- | Build a clause that updates the field at the given indexes+-- When irref is 'True' the value with me matched with an irrefutable+-- pattern. This is suitable for Lens and Traversal construction+makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ+makeFieldOpticClause conName fieldCount [] _ =+ 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")++ let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys)++ mkFx i = [| $(varE f) $(varE (xs !! i)) |]++ body0 = [| $(lamE (map varP ys) (appsE (conE conName : map varE xs')))+ <$> $(mkFx field) |]++ body = foldl (\a b -> [| $a <*> $(mkFx b) |]) body0 fields++ let wrap = if irref then tildeP else id++ clause [varP f, wrap (conP conName (map varP xs))]+ (normalB body)+ []+++-- | Build a clause that constructs an Iso+makeIsoClause :: Name -> ClauseQ+makeIsoClause conName = clause [] (normalB [| iso $destruct $construct |]) []+ where+ destruct = do x <- newName "x"+ lam1E (conP conName [varP x]) (varE x)++ construct = conE conName+++------------------------------------------------------------------------+-- Unification logic+------------------------------------------------------------------------++-- The field-oriented optic generation supports incorporating fields+-- with distinct but unifiable types into a single definition.++++-- | Unify the given list of types, if possible, and return the+-- substitution used to unify the types for unifying the outer+-- type when building a definition's type signature.+unifyTypes :: [Type] -> Q (Map Name Type, Type)+unifyTypes (x:xs) = foldM (uncurry unify1) (Map.empty, x) xs+unifyTypes [] = fail "unifyTypes: Bug: Unexpected empty list"+++-- | Attempt to unify two given types using a running substitution+unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)+unify1 sub (VarT x) y+ | Just r <- Map.lookup x sub = unify1 sub r y+unify1 sub x (VarT y)+ | Just r <- Map.lookup y sub = unify1 sub x r+unify1 sub x y+ | x == y = return (sub, x)+unify1 sub (AppT f1 x1) (AppT f2 x2) =+ do (sub1, f) <- unify1 sub f1 f2+ (sub2, x) <- unify1 sub1 x1 x2+ return (sub2, AppT (applyTypeSubst sub2 f) x)+unify1 sub x (VarT y)+ | elemOf typeVars y (applyTypeSubst sub x) =+ fail "Failed to unify types: occurs check"+ | otherwise = return (Map.insert y x sub, x)+unify1 sub (VarT x) y = unify1 sub y (VarT x)++-- TODO: Unify contexts+unify1 sub (ForallT v1 [] t1) (ForallT v2 [] t2) =+ -- This approach works out because by the time this code runs+ -- all of the type variables have been renamed. No risk of shadowing.+ do (sub1,t) <- unify1 sub t1 t2+ v <- fmap nub (traverse (limitedSubst sub1) (v1++v2))+ return (sub1, ForallT v [] t)++unify1 _ x y = fail ("Failed to unify types: " ++ show (x,y))+++-- | Perform a limited substitution on type variables. This is used+-- when unifying rank-2 fields when trying to achieve a Getter or Fold.+limitedSubst :: Map Name Type -> TyVarBndr -> Q TyVarBndr+limitedSubst sub (PlainTV n)+ | Just r <- Map.lookup n sub =+ case r of+ VarT m -> limitedSubst sub (PlainTV m)+ _ -> fail "Unable to unify exotic higher-rank type"+limitedSubst sub (KindedTV n k)+ | Just r <- Map.lookup n sub =+ case r of+ VarT m -> limitedSubst sub (KindedTV m k)+ _ -> fail "Unable to unify exotic higher-rank type"+limitedSubst _ tv = return tv+++-- | Apply a substitution to a type. This is used after unifying+-- the types of the fields in unifyTypes.+applyTypeSubst :: Map Name Type -> Type -> Type+applyTypeSubst sub = rewrite aux+ where+ aux (VarT n) = Map.lookup n sub+ aux _ = Nothing+++------------------------------------------------------------------------+-- Field generation parameters+------------------------------------------------------------------------+++data LensRules = LensRules+ { _simpleLenses :: Bool+ , _generateSigs :: Bool+ , _generateClasses :: Bool+ , _allowIsos :: Bool+ , _fieldToDef :: [Name] -> Name -> [DefName]+ , _classyLenses :: Name -> Maybe (Name,Name)+ -- type name to class name and top method+ }+++-- | Name to give to generated field optics.+data DefName+ = TopName Name -- ^ Simple top-level definiton name+ | MethodName Name Name -- ^ makeFields-style class name and method name+ deriving (Show, Eq, Ord)++------------------------------------------------------------------------+-- Miscellaneous utility functions+------------------------------------------------------------------------+++-- | 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 c t = ForallT vs c t+ where+ vs = map PlainTV (toList (setOf 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/Instances.hs view
@@ -24,7 +24,7 @@ import Data.Traversable.Instances () -#if !(MIN_VERSION_semigroupoids(0,4,2))+#if !(MIN_VERSION_semigroupoids(4,2,0)) import Control.Applicative import Data.Semigroup.Foldable
+ src/Control/Lens/Internal/PrismTH.hs view
@@ -0,0 +1,490 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.PrismTH+-- Copyright : (C) 2014 Edward Kmett, (C) 2014 Eric Mertens+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------++module Control.Lens.Internal.PrismTH+ ( makePrisms+ , makeClassyPrisms+ , makeDecPrisms+ ) where++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+import Data.Char (isUpper)+import Data.List+import Data.Monoid+import Data.Set.Lens+import Data.Traversable (for,sequenceA,traverse)+import Language.Haskell.TH+import Language.Haskell.TH.Lens+import qualified Data.Map as Map+import qualified Data.Set as Set++-- | Generate a 'Prism' for each constructor of a data type.+-- Isos generated when possible.+-- Reviews are created for constructors with existentially+-- quantified constructors and GADTs.+--+-- /e.g./+--+-- @+-- data FooBarBaz a+-- = Foo Int+-- | Bar a+-- | Baz Int Char+-- makePrisms ''FooBarBaz+-- @+--+-- will create+--+-- @+-- _Foo :: Prism' (FooBarBaz a) Int+-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b+-- _Baz :: Prism' (FooBarBaz a) (Int, Char)+-- @+makePrisms :: Name {- ^ Type constructor name -} -> DecsQ+makePrisms = makePrisms' True+++-- | Generate a 'Prism' for each constructor of a data type+-- and combine them into a single class. No Isos are created.+-- Reviews are created for constructors with existentially+-- quantified constructors and GADTs.+--+-- /e.g./+--+-- @+-- data FooBarBaz a+-- = Foo Int+-- | Bar a+-- | Baz Int Char+-- makeClassyPrisms ''FooBarBaz+-- @+--+-- will create+--+-- @+-- class AsFooBarBaz s a | s -> a where+-- _FooBarBaz :: Prism' s (FooBarBaz a)+-- _Foo :: Prism' s Int+-- _Bar :: Prism' s a+-- _Baz :: Prism' s (Int,Char)+--+-- _Foo = _FooBarBaz . _Foo+-- _Bar = _FooBarBaz . _Bar+-- _Baz = _FooBarBaz . _Baz+--+-- instance AsFooBarBaz (FooBarBaz a) a+-- @+-- | Generate an "As" class of prisms. Names are selected by prefixing the constructor+-- name with an underscore. Constructors with multiple fields will+-- construct Prisms to tuples of those fields.+makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ+makeClassyPrisms = makePrisms' False+++-- | 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"+++-- | Generate prisms for the given 'Dec'+makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ+makeDecPrisms normal dec = case dec of+ 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]+ _ -> fail "makePrisms: expected type constructor dec"+ where+ convertTVBs = map (VarT . bndrName)++ next ty args cons =+ makeConsPrisms (conAppsT ty args) (map normalizeCon cons) cls+ where+ cls | normal = Nothing+ | otherwise = Just ty+++-- | Generate prisms for the given type, normalized constructors, and+-- an optional name to be used for generating a prism class.+-- This function dispatches between Iso generation, normal top-level+-- prisms, and classy prisms.+makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ++-- special case: single constructor, not classy -> make iso+makeConsPrisms t [con@(NCon _ Nothing _)] Nothing = makeConIso t con++-- top-level definitions+makeConsPrisms t cons Nothing =+ fmap concat $ for cons $ \con ->+ do let conName = view nconName con+ stab <- computeOpticType t cons con+ let n = prismName conName+ sequence+ [ sigD n (close (stabToType stab))+ , valD (varP n) (normalB (makeConOpticExp stab cons con)) []+ ]+++-- classy prism class and instance+makeConsPrisms t cons (Just typeName) =+ sequence+ [ makeClassyPrismClass t className methodName cons+ , makeClassyPrismInstance t className methodName cons+ ]+ where+ className = mkName ("As" ++ nameBase typeName)+ methodName = prismName typeName+++data OpticType = PrismType | ReviewType+data Stab = Stab Cxt OpticType Type Type Type Type++simplifyStab :: Stab -> Stab+simplifyStab (Stab cx ty _ t _ b) = Stab 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++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]++ where+ vs = map PlainTV (Set.toList (setOf typeVars cx))++stabType :: Stab -> OpticType+stabType (Stab _ o _ _ _ _) = o++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+++computeReviewType :: Type -> Cxt -> [Type] -> Q Stab+computeReviewType s' cx tys =+ do let t = s'+ s <- fmap VarT (newName "s")+ a <- fmap VarT (newName "a")+ b <- toTupleT (map return tys)+ return (Stab cx ReviewType s t a b)+++-- | 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 =+ 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)+++computeIsoType :: Type -> [Type] -> TypeQ+computeIsoType t' fields =+ do sub <- sequenceA (fromSet (newName . nameBase) (setOf typeVars t'))+ let t = return t'+ s = return (substTypeVars sub t')+ b = toTupleT (map return fields)+ a = toTupleT (map return (substTypeVars sub fields))++#ifndef HLINT+ ty | Map.null sub = [t| Iso' $t $b |]+ | otherwise = [t| Iso $s $t $a $b |]+#endif++ close =<< ty++++-- | Construct either a Review or Prism as appropriate+makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ+makeConOpticExp stab cons con =+ case stabType stab of+ PrismType -> makeConPrismExp stab cons con+ ReviewType -> makeConReviewExp con+++-- | Construct an iso declaration+makeConIso :: Type -> NCon -> DecsQ+makeConIso s con =+ do let ty = computeIsoType s (view nconTypes con)+ defName = prismName (view nconName con)+ sequence+ [ sigD defName ty+ , valD (varP defName) (normalB (makeConIsoExp con)) []+ ]+++-- | Construct prism expression+--+-- prism <<reviewer>> <<remitter>>+makeConPrismExp ::+ Stab ->+ [NCon] {- ^ constructors -} ->+ NCon {- ^ target constructor -} ->+ ExpQ+makeConPrismExp stab cons con = [| prism $reviewer $remitter |]+ where+ ts = view nconTypes con+ fields = length ts+ conName = view nconName con++ reviewer = makeReviewer conName fields+ remitter | stabSimple stab = makeSimpleRemitter conName fields+ | otherwise = makeFullRemitter cons conName+++-- | Construct an Iso expression+--+-- iso <<reviewer>> <<remitter>>+makeConIsoExp :: NCon -> ExpQ+makeConIsoExp con = [| iso $remitter $reviewer |]+ where+ conName = view nconName con+ fields = length (view nconTypes con)++ reviewer = makeReviewer conName fields+ remitter = makeIsoRemitter conName fields+++-- | Construct a Review expression+--+-- unto (\(x,y,z) -> Con x y z)+makeConReviewExp :: NCon -> ExpQ+makeConReviewExp con = [| unto $reviewer |]+ where+ conName = view nconName con+ fields = length (view nconTypes con)++ reviewer = makeReviewer conName fields+++------------------------------------------------------------------------+-- Prism and Iso component builders+------------------------------------------------------------------------+++-- | Construct the review portion of a prism.+--+-- (\(x,y,z) -> Con x y z) :: b -> t+makeReviewer :: Name -> Int -> ExpQ+makeReviewer conName fields =+ do xs <- replicateM fields (newName "x")+ lam1E (toTupleP (map varP xs))+ (conE conName `appsE1` map varE xs)+++-- | Construct the remit portion of a prism.+-- Pattern match only target constructor, no type changing+--+-- (\x -> case s of+-- Con x y z -> Right (x,y,z)+-- _ -> Left x+-- ) :: s -> Either s a+makeSimpleRemitter :: Name -> Int -> ExpQ+makeSimpleRemitter conName fields =+ do x <- newName "x"+ xs <- replicateM fields (newName "y")+ let matches =+ [ match (conP conName (map varP xs))+ (normalB [| Right $(toTupleE (map varE xs)) |])+ []+ , match wildP (normalB [| Left $(varE x) |]) []+ ]+ lam1E (varP x) (caseE (varE x) matches)+++-- | Pattern match all constructors to enable type-changing+--+-- (\x -> case s of+-- Con x y z -> Right (x,y,z)+-- Other_n w -> Left (Other_n w)+-- ) :: s -> Either t a+makeFullRemitter :: [NCon] -> Name -> ExpQ+makeFullRemitter cons target =+ do x <- newName "x"+ lam1E (varP x) (caseE (varE x) (map mkMatch cons))+ where+ mkMatch (NCon conName _ n) =+ do xs <- replicateM (length n) (newName "y")+ match (conP conName (map varP xs))+ (normalB+ (if conName == target+ then [| Right $(toTupleE (map varE xs)) |]+ else [| Left $(conE conName `appsE1` map varE xs) |]))+ []+++-- | Construct the remitter suitable for use in an 'Iso'+--+-- (\(Con x y z) -> (x,y,z)) :: s -> a+makeIsoRemitter :: Name -> Int -> ExpQ+makeIsoRemitter conName fields =+ do xs <- replicateM fields (newName "x")+ lam1E (conP conName (map varP xs))+ (toTupleE (map varE xs))+++------------------------------------------------------------------------+-- Classy prisms+------------------------------------------------------------------------+++-- | Construct the classy prisms class for a given type and constructors.+--+-- class ClassName r <<vars in type>> | r -> <<vars in Type>> where+-- topMethodName :: Prism' r Type+-- conMethodName_n :: Prism' r conTypes_n+-- conMethodName_n = topMethodName . conMethodName_n+makeClassyPrismClass ::+ Type {- Outer type -} ->+ Name {- Class name -} ->+ Name {- Top method name -} ->+ [NCon] {- Constructors -} ->+ DecQ+makeClassyPrismClass t className methodName cons =+ do r <- newName "r"+#ifndef HLINT+ let methodType = [t| Prism' $(varT r) $(return t) |]+#endif+ methodss <- traverse (mkMethod (VarT r)) cons'+ 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 t cons con+ let stab' = Stab cx o r r b b+ defName = view nconName con+ sequence+ [ sigD defName (return (stabToType stab'))+ , valD (varP defName) (normalB [| $(varE methodName) . $(varE defName) |]) []+ ]++ cons' = map (over nconName prismName) cons+ vs = Set.toList (setOf typeVars t)+ fds r+ | null vs = []+ | otherwise = [FunDep [r] vs]++++-- | Construct the classy prisms instance for a given type and constructors.+--+-- instance Classname OuterType where+-- topMethodName = id+-- conMethodName_n = <<prism>>+makeClassyPrismInstance ::+ Type ->+ Name {- Class name -} ->+ Name {- Top method name -} ->+ [NCon] {- Constructors -} ->+ DecQ+makeClassyPrismInstance s className methodName cons =+ do let vs = Set.toList (setOf typeVars s)+ cls = className `conAppsT` (s : map VarT vs)++ instanceD (cxt[]) (return cls)+ ( valD (varP methodName)+ (normalB [| id |]) []+ : [ do stab <- computeOpticType s cons con+ let stab' = simplifyStab stab+ valD (varP (prismName conName))+ (normalB (makeConOpticExp stab' cons con)) []+ | con <- cons+ , let conName = view nconName con+ ]+ )+++------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------+++-- | Normalized constructor+data NCon = NCon+ { _nconName :: Name+ , _nconCxt :: Maybe 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++nconName :: Lens' NCon Name+nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x))++nconCxt :: Lens' NCon (Maybe Cxt)+nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x))++nconTypes :: Lens' NCon [Type]+nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x))+++-- | Normalize 'Con' to its constructor name and field types.+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 _ cx con) = NCon n (cx1 <> cx2) tys+ where+ cx1 = Just cx+ NCon n cx2 tys = normalizeCon con+++-- | Compute a prism's name by prefixing an underscore for normal+-- constructors and period for operators.+prismName :: Name -> Name+prismName n = case nameBase n of+ [] -> error "prismName: empty name base?"+ x:xs | isUpper x -> mkName ('_':x:xs)+ | otherwise -> mkName ('.':x:xs) -- operator+++-- | Quantify all the free variables in a type.+close :: Type -> TypeQ+close t = forallT (map PlainTV (Set.toList vs)) (cxt[]) (return t)+ where+ vs = setOf typeVars t
src/Control/Lens/Internal/TH.hs view
@@ -6,6 +6,10 @@ #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) #endif++#ifndef MIN_VERSION_containers+#define MIN_VERSION_containers(x,y,z) 1+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.TH@@ -19,6 +23,8 @@ module Control.Lens.Internal.TH where import Language.Haskell.TH+import qualified Data.Map as Map+import qualified Data.Set as Set -- | Compatibility shim for recent changes to template haskell's 'tySynInstD' tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ@@ -28,21 +34,42 @@ tySynInstD' = tySynInstD #endif +-- | Apply arguments to a type constructor appsT :: TypeQ -> [TypeQ] -> TypeQ appsT = foldl appT +-- | Apply arguments to a function appsE1 :: ExpQ -> [ExpQ] -> ExpQ appsE1 = foldl appE +-- | Construct a tuple type given a list of types. toTupleT :: [TypeQ] -> TypeQ toTupleT [x] = x toTupleT xs = appsT (tupleT (length xs)) xs +-- | Construct a tuple value given a list of expressions. toTupleE :: [ExpQ] -> ExpQ toTupleE [x] = x toTupleE xs = tupE xs +-- | Construct a tuple pattern given a list of patterns. toTupleP :: [PatQ] -> PatQ toTupleP [x] = x toTupleP xs = tupP xs +-- | Apply arguments to a type constructor.+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++fromSet :: Ord k => (k -> v) -> Set.Set k -> Map.Map k v+#if MIN_VERSION_containers(0,5,0)+fromSet = Map.fromSet+#else+fromSet f x = Map.fromList [ (k,f k) | k <- Set.toList x ]+#endif
src/Control/Lens/Plated.hs view
@@ -99,7 +99,6 @@ import Control.MonadPlus.Free as MonadPlus #endif import qualified Language.Haskell.TH as TH-import Data.Aeson import Data.Bitraversable import Data.Data import Data.Data.Lens@@ -241,12 +240,6 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as--instance Plated Value where- plate f (Object o) = Object <$> traverse f o- plate f (Array a) = Array <$> traverse f a- plate _ xs = pure xs- {-# INLINE plate #-} {- Default uniplate instances -} instance Plated TH.Exp
src/Control/Lens/Review.hs view
@@ -63,7 +63,7 @@ -- -- You can generate a 'Review' by using 'unto'. You can also use any 'Prism' or 'Iso' -- directly as a 'Review'.-type Review s t a b = forall p f. (Profunctor p, Bifunctor p, Settable f) => Optic p f s t a b+type Review s t a b = forall p f. (Choice p, Bifunctor p, Settable f) => Optic p f s t a b -- | A 'Simple' 'Review' type Review' t b = Review t t b b
src/Control/Lens/TH.hs view
@@ -25,1334 +25,631 @@ makeLenses, makeLensesFor , makeClassy, makeClassyFor, makeClassy_ , makePrisms- , makeWrapped- , makeFields- -- * Constructing Lenses Given a Declaration Quote- , declareLenses, declareLensesFor- , declareClassy, declareClassyFor- , declarePrisms- , declareWrapped- , declareFields- -- * Configuring Lenses- , makeLensesWith- , makeFieldsWith- , declareLensesWith- , declareFieldsWith- , defaultRules- , defaultFieldRules- , camelCaseFields- , underscoreFields- , LensRules(LensRules)- , FieldRules(FieldRules)- , lensRules- , classyRules- , classyRules_- , lensIso- , lensField- , lensClass- , lensFlags- , LensFlag(..)- , simpleLenses- , partialLenses- , buildTraversals- , handleSingletons- , singletonIso- , singletonRequired- , createClass- , createInstance- , classRequired- , singletonAndField- , generateSignatures- ) where--import Control.Applicative-import Control.Monad ((<=<), when, replicateM)-#if !(MIN_VERSION_template_haskell(2,7,0))-import Control.Monad (ap)-#endif-import qualified Control.Monad.Trans as Trans-import Control.Monad.Trans.Writer-import Control.Lens.At-import Control.Lens.Fold-import Control.Lens.Getter-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.Lens.Traversal-import Control.Lens.Wrapped-import Control.Lens.Internal.TH-import Data.Char (toLower, toUpper, isUpper)-import Data.Either (lefts)-import Data.Foldable hiding (concat, any)-import Data.Function (on)-import Data.List as List-import Data.Map as Map hiding (toList,map,filter)-import Data.Maybe as Maybe (isNothing,isJust,catMaybes,fromJust,mapMaybe)-import Data.Monoid-import Data.Ord (comparing)-import Data.Set as Set hiding (toList,map,filter)-import Data.Set.Lens-import Data.Traversable hiding (mapM)-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Lens--#ifdef HLINT-{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Use fewer imports" #-}-{-# ANN module "HLint: ignore Use foldl" #-}-#endif---- | Flags for 'Lens' construction-data LensFlag- = SimpleLenses- | PartialLenses- | BuildTraversals- | SingletonAndField- | SingletonIso- | HandleSingletons- | SingletonRequired- | CreateClass- | CreateInstance- | ClassRequired- | GenerateSignatures- deriving (Eq,Ord,Show,Read)---- | Only Generate valid 'Control.Lens.Type.Simple' lenses.-simpleLenses :: Lens' LensRules Bool-simpleLenses = lensFlags.contains SimpleLenses---- | Enables the generation of partial lenses, generating runtime errors for--- every constructor that does not have a valid definition for the 'Lens'. This--- occurs when the constructor lacks the field, or has multiple fields mapped--- to the same 'Lens'.-partialLenses :: Lens' LensRules Bool-partialLenses = lensFlags.contains PartialLenses---- | In the situations that a 'Lens' would be partial, when 'partialLenses' is--- used, this flag instead causes traversals to be generated. Only one can be--- used, and if neither are, then compile-time errors are generated.-buildTraversals :: Lens' LensRules Bool-buildTraversals = lensFlags.contains BuildTraversals---- | Handle singleton constructors specially.-handleSingletons :: Lens' LensRules Bool-handleSingletons = lensFlags.contains HandleSingletons---- | When building a singleton 'Iso' (or 'Lens') for a record constructor, build--- both the 'Iso' (or 'Lens') for the record and the one for the field.-singletonAndField :: Lens' LensRules Bool-singletonAndField = lensFlags.contains SingletonAndField---- | Use 'Iso' for singleton constructors.-singletonIso :: Lens' LensRules Bool-singletonIso = lensFlags.contains SingletonIso---- | Expect a single constructor, single field newtype or data type.-singletonRequired :: Lens' LensRules Bool-singletonRequired = lensFlags.contains SingletonRequired---- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches.-createClass :: Lens' LensRules Bool-createClass = lensFlags.contains CreateClass---- | Create the instance if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches.-createInstance :: Lens' LensRules Bool-createInstance = lensFlags.contains CreateInstance---- | Die if the 'lensClass' fails to match.-classRequired :: Lens' LensRules Bool-classRequired = lensFlags.contains ClassRequired---- | Indicate whether or not to supply the signatures for the generated--- lenses.------ Disabling this can be useful if you want to provide a more restricted type--- signature or if you want to supply hand-written haddocks.-generateSignatures :: Lens' LensRules Bool-generateSignatures = lensFlags.contains GenerateSignatures---- | This configuration describes the options we'll be using to make--- isomorphisms or lenses.-data LensRules = LensRules- { _lensIso :: String -> Maybe String- , _lensField :: String -> Maybe String- , _lensClass :: String -> Maybe (String, String)- , _lensFlags :: Set LensFlag- }---- | 'Lens'' to access the convention for naming top level isomorphisms in our--- 'LensRules'.------ Defaults to lowercasing the first letter of the constructor.-lensIso :: Lens' LensRules (String -> Maybe String)-lensIso f (LensRules i n c o) = f i <&> \i' -> LensRules i' n c o---- | 'Lens'' to access the convention for naming fields in our 'LensRules'.------ Defaults to stripping the _ off of the field name, lowercasing the name, and--- rejecting the field if it doesn't start with an '_'.-lensField :: Lens' LensRules (String -> Maybe String)-lensField f (LensRules i n c o) = f n <&> \n' -> LensRules i n' c o---- | Retrieve options such as the name of the class and method to put in it to--- build a class around monomorphic data types.-lensClass :: Lens' LensRules (String -> Maybe (String, String))-lensClass f (LensRules i n c o) = f c <&> \c' -> LensRules i n c' o---- | Retrieve options such as the name of the class and method to put in it to--- build a class around monomorphic data types.-lensFlags :: Lens' LensRules (Set LensFlag)-lensFlags f (LensRules i n c o) = f o <&> LensRules i n c---- | Default 'LensRules'.-defaultRules :: LensRules-defaultRules = LensRules mLowerName fld (const Nothing) $- Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals, GenerateSignatures]- where- fld ('_':cs) = mLowerName cs- fld _ = Nothing--mLowerName :: String -> Maybe String-mLowerName (c:cs) = Just (toLower c:cs)-mLowerName _ = Nothing---- | Rules for making fairly simple partial lenses, ignoring the special cases--- for isomorphisms and traversals, and not making any classes.-lensRules :: LensRules-lensRules = defaultRules- & lensIso .~ const Nothing- & lensClass .~ const Nothing- & handleSingletons .~ True- & partialLenses .~ False- & buildTraversals .~ True--lensRulesFor :: [(String, String)] -> LensRules-lensRulesFor fields = lensRules & lensField .~ (`Prelude.lookup` fields)---- | Rules for making lenses and traversals that precompose another 'Lens'.-classyRules :: LensRules-classyRules = defaultRules- & lensIso .~ const Nothing- & handleSingletons .~ False- & lensClass .~ classy- & classRequired .~ True- & partialLenses .~ False- & buildTraversals .~ True- where- classy :: String -> Maybe (String, String)- classy n@(a:as) = Just ("Has" ++ n, toLower a:as)- classy _ = Nothing--classyRulesFor- :: (String -> Maybe (String, String)) -> [(String, String)] -> LensRules-classyRulesFor classFun fields = classyRules- & lensClass .~ classFun- & lensField .~ (`Prelude.lookup` fields)--underscorePrefixRules :: LensRules-underscorePrefixRules = LensRules mLowerName fld (const Nothing) $- Set.fromList [SingletonIso, SingletonAndField, CreateClass,- CreateInstance, BuildTraversals, GenerateSignatures]- where- fld cs = Just ('_':cs)--classyRules_ :: LensRules-classyRules_ = underscorePrefixRules- & lensIso .~ const Nothing- & handleSingletons .~ False- & lensClass .~ classy- & classRequired .~ True- & partialLenses .~ False- & buildTraversals .~ True- where- classy :: String -> Maybe (String, String)- classy n@(a:as) = Just ("Has" ++ n, toLower a:as)- classy _ = Nothing---- | Build lenses (and traversals) with a sensible default configuration.------ /e.g./------ @--- data FooBar--- = Foo { _x, _y :: 'Int' }--- | Bar { _x :: 'Int' }--- 'makeLenses' ''FooBar--- @------ will create------ @--- x :: 'Lens'' FooBar 'Int'--- x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a--- x f (Bar a) = Bar \<$\> f a--- y :: 'Traversal'' FooBar 'Int'--- y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b--- y _ c\@(Bar _) = pure c--- @------ @--- 'makeLenses' = 'makeLensesWith' 'lensRules'--- @-makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesWith lensRules---- | Make lenses and traversals for a type, and create a class when the--- type has no arguments.------ /e.g./------ @--- data Foo = Foo { _fooX, _fooY :: 'Int' }--- 'makeClassy' ''Foo--- @------ will create------ @--- class HasFoo t where--- foo :: 'Lens'' t Foo--- fooX :: 'Lens'' t 'Int'--- fooX = foo . go where go f (Foo x y) = (\\x\' -> Foo x' y) \<$\> f x--- fooY :: 'Lens'' t 'Int'--- fooY = foo . go where go f (Foo x y) = (\\y\' -> Foo x y') \<$\> f y--- instance HasFoo Foo where--- foo = id--- @------ @--- 'makeClassy' = 'makeLensesWith' 'classyRules'--- @-makeClassy :: Name -> Q [Dec]-makeClassy = makeLensesWith classyRules---- | Make lenses and traversals for a type, and create a class when the type--- has no arguments. Works the same as 'makeClassy' except that (a) it--- expects that record field names do not begin with an underscore, (b) all--- record fields are made into lenses, and (c) the resulting lens is prefixed--- with an underscore.-makeClassy_ :: Name -> Q [Dec]-makeClassy_ = makeLensesWith classyRules_---- | Derive lenses and traversals, specifying explicit pairings--- of @(fieldName, lensName)@.------ If you map multiple names to the same label, and it is present in the same--- constructor then this will generate a 'Traversal'.------ /e.g./------ @--- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo--- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar--- @-makeLensesFor :: [(String, String)] -> Name -> Q [Dec]-makeLensesFor fields = makeLensesWith $ lensRulesFor fields---- | Derive lenses and traversals, using a named wrapper class, and--- specifying explicit pairings of @(fieldName, traversalName)@.------ Example usage:------ @--- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo--- @-makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]-makeClassyFor clsName funName fields = makeLensesWith $- classyRulesFor (const $ Just (clsName, funName)) fields---- | Build lenses with a custom configuration.-makeLensesWith :: LensRules -> Name -> Q [Dec]-makeLensesWith cfg nm = do- inf <- reify nm- case inf of- TyConI decl -> makeLensesForDec cfg decl- _ -> fail "makeLensesWith: Expected the name of a data type or newtype"---- | Generate a 'Prism' for each constructor of a data type.------ /e.g./------ @--- data FooBarBaz a--- = Foo Int--- | Bar a--- | Baz Int Char--- makePrisms ''FooBarBaz--- @------ will create------ @--- _Foo :: Prism' (FooBarBaz a) Int--- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b--- _Baz :: Prism' (FooBarBaz a) (Int, Char)--- @-makePrisms :: Name -> Q [Dec]-makePrisms nm = do- inf <- reify nm- case inf of- TyConI decl -> makePrismsForDec decl- _ -> fail "makePrisms: Expected the name of a data type or newtype"---- | Make lenses for all records in the given declaration quote. All record--- syntax in the input will be stripped off.------ /e.g./------ @--- declareLenses [d|--- data Foo = Foo { fooX, fooY :: 'Int' }--- deriving 'Show'--- |]--- @------ will create------ @--- data Foo = Foo 'Int' 'Int' deriving 'Show'--- fooX, fooY :: 'Lens'' Foo Int--- @------ @ declareLenses = 'declareLensesWith' ('lensRules' '&' 'lensField' '.~' 'Just') @-declareLenses :: Q [Dec] -> Q [Dec]-declareLenses = declareLensesWith (lensRules & lensField .~ Just)---- | Similar to 'makeLensesFor', but takes a declaration quote.-declareLensesFor :: [(String, String)] -> Q [Dec] -> Q [Dec]-declareLensesFor fields = declareLensesWith $- lensRulesFor fields & lensField .~ Just---- | For each record in the declaration quote, make lenses and traversals for--- it, and create a class when the type has no arguments. All record syntax--- in the input will be stripped off.------ /e.g./------ @--- declareClassy [d|--- data Foo = Foo { fooX, fooY :: 'Int' }--- deriving 'Show'--- |]--- @------ will create------ @--- data Foo = Foo 'Int' 'Int' deriving 'Show'--- class HasFoo t where--- foo :: 'Lens'' t Foo--- instance HasFoo Foo where foo = 'id'--- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'--- @------ @ declareClassy = 'declareLensesWith' ('classyRules' '&' 'lensField' '.~' 'Just') @-declareClassy :: Q [Dec] -> Q [Dec]-declareClassy = declareLensesWith (classyRules & lensField .~ Just)---- | Similar to 'makeClassyFor', but takes a declaration quote.-declareClassyFor :: [(String, (String, String))] -> [(String, String)] -> Q [Dec] -> Q [Dec]-declareClassyFor classes fields = declareLensesWith $- classyRulesFor (`Prelude.lookup`classes) fields & lensField .~ Just---- | Generate a 'Prism' for each constructor of each data type.------ /e.g./------ @--- declarePrisms [d|--- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }--- |]--- @------ will create------ @--- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }--- _Lit :: 'Prism'' Exp Int--- _Var :: 'Prism'' Exp String--- _Lambda :: 'Prism'' Exp (String, Exp)--- @-declarePrisms :: Q [Dec] -> Q [Dec]-declarePrisms = declareWith $ \dec -> do- emit =<< Trans.lift (makePrismsForDec dec)- return dec---- | Build 'Wrapped' instance for each newtype.-declareWrapped :: Q [Dec] -> Q [Dec]-declareWrapped = declareWith $ \dec -> do- maybeDecs <- Trans.lift (makeWrappedForDec dec)- forM_ maybeDecs emit- return dec---- | @ declareFields = 'declareFieldsWith' 'defaultFieldRules' @-declareFields :: Q [Dec] -> Q [Dec]-declareFields = declareFieldsWith defaultFieldRules---- | Declare lenses for each records in the given declarations, using the--- specified 'LensRules'. Any record syntax in the input will be stripped--- off.-declareLensesWith :: LensRules -> Q [Dec] -> Q [Dec]-declareLensesWith rules = declareWith $ \dec -> do- emit =<< Trans.lift (makeLensesForDec rules dec)- return $ stripFields dec---- | Declare fields for each records in the given declarations, using the--- specified 'FieldRules'. Any record syntax in the input will be stripped--- off.-declareFieldsWith :: FieldRules -> Q [Dec] -> Q [Dec]-declareFieldsWith rules = declareWith $ \dec -> do- emit =<< Trans.lift (makeFieldsForDec rules dec)- return $ stripFields dec---------------------------------------------------------------------------------- Internal TH Implementation---------------------------------------------------------------------------------- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to--- @DataInstD@s.-deNewtype :: Dec -> Dec-deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d-deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d-deNewtype d = d--makePrismsForDec :: Dec -> Q [Dec]-makePrismsForDec decl = case makeDataDecl decl of- Just dataDecl -> makePrismsForCons dataDecl- _ -> fail "makePrisms: Unsupported data type"--makePrismsForCons :: DataDecl -> Q [Dec]-makePrismsForCons dataDecl@(DataDecl _ _ _ _ [_]) = case constructors dataDecl of- -- Iso promotion via tuples- [NormalC dataConName xs] ->- makeIsoLenses rules dataDecl dataConName Nothing $ map (view _2) xs- [RecC dataConName xs] ->- makeIsoLenses rules dataDecl dataConName Nothing $ map (view _3) xs- _ ->- fail "makePrismsForCons: A single-constructor data type is required"- where- rules = defaultRules- & handleSingletons .~ True- & singletonRequired .~ True- & singletonAndField .~ True- & lensIso .~ (Just . ('_':))--makePrismsForCons dataDecl =- concat <$> mapM (makePrismOrReviewForCon dataDecl canModifyTypeVar ) (constructors dataDecl)- where- conTypeVars = map (Set.fromList . toListOf typeVars) (constructors dataDecl)- canModifyTypeVar = (`Set.member` typeVarsOnlyInOneCon) . view name- typeVarsOnlyInOneCon = Set.fromList . concat . filter (\xs -> length xs == 1) . List.group . List.sort $ conTypeVars >>= toList--onlyBuildReview :: Con -> Bool-onlyBuildReview ForallC{} = True-onlyBuildReview _ = False--makePrismOrReviewForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec]-makePrismOrReviewForCon dataDecl canModifyTypeVar con- | onlyBuildReview con = makeReviewForCon dataDecl con- | otherwise = makePrismForCon dataDecl canModifyTypeVar con--makeReviewForCon :: DataDecl -> Con -> Q [Dec]-makeReviewForCon dataDecl con = do- let functionName = mkName ('_': nameBase dataConName)- (dataConName, fieldTypes) = ctrNameAndFieldTypes con-- sName <- newName "s"- aName <- newName "a"- fieldNames <- replicateM (length fieldTypes) (newName "x")-- -- Compute the type: Constructor Constraints => Review s (Type x y z) a fieldTypes- let s = varT sName- t = return (fullType dataDecl (map (VarT . view name) (dataParameters dataDecl)))- a = varT aName- b = toTupleT (map return fieldTypes)-- (conTyVars, conCxt) = case con of ForallC x y _ -> (x,y)- _ -> ([],[])-- functionType = forallT (map PlainTV [sName, aName] ++ conTyVars ++ dataParameters dataDecl)- (return conCxt)- (conT ''Review `appsT` [s,t,a,b])-- -- Compute expression: unto (\(fields) -> Con fields)- let pat = toTupleP (map varP fieldNames)- lam = lam1E pat (conE dataConName `appsE1` map varE fieldNames)- body = varE 'unto `appE` lam-- Prelude.sequence- [ sigD functionName functionType- , funD functionName [clause [] (normalB body) []]- ]--makePrismForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec]-makePrismForCon dataDecl canModifyTypeVar con = do- remitterName <- newName "remitter"- reviewerName <- newName "reviewer"- xName <- newName "x"- let resName = mkName $ '_': nameBase dataConName- varNames <- for [0..length fieldTypes -1] $ \i -> newName ('x' : show i)- let args = dataParameters dataDecl- altArgsList <- forM (view name <$> filter isAltArg args) $ \arg ->- (,) arg <$> newName (nameBase arg)- let altArgs = Map.fromList altArgsList- hitClause =- clause [conP dataConName (fmap varP varNames)]- (normalB $ appE (conE 'Right) $ toTupleE $ varE <$> varNames) []- otherCons = filter (/= con) (constructors dataDecl)- missClauses- | List.null otherCons = []- | Map.null altArgs = [clause [varP xName] (normalB (appE (conE 'Left) (varE xName))) []]- | otherwise = reviewerIdClause <$> otherCons- Prelude.sequence [- sigD resName . forallT- (args ++ (PlainTV <$> Map.elems altArgs))- (return $ List.nub (dataContext dataDecl ++ substTypeVars altArgs (dataContext dataDecl))) $- if List.null altArgsList then- conT ''Prism' `appsT`- [ return $ fullType dataDecl $ VarT . view name <$> args- , toTupleT $ pure <$> fieldTypes- ]- else- conT ''Prism `appsT`- [ return $ fullType dataDecl $ VarT . view name <$> args- , return $ fullType dataDecl $ VarT . view name <$> substTypeVars altArgs args- , toTupleT $ pure <$> fieldTypes- , toTupleT $ pure <$> substTypeVars altArgs fieldTypes- ]- , funD resName- [ clause []- (normalB (appsE [varE 'prism, varE remitterName, varE reviewerName]))- [ funD remitterName- [ clause [toTupleP (varP <$> varNames)] (normalB (conE dataConName `appsE1` fmap varE varNames)) [] ]- , funD reviewerName $ hitClause : missClauses- ]- ]- ]- where- (dataConName, fieldTypes) = ctrNameAndFieldTypes con- conArgs = setOf typeVars fieldTypes- isAltArg arg = canModifyTypeVar arg && conArgs^.contains(arg^.name)--ctrNameAndFieldTypes :: Con -> (Name, [Type])-ctrNameAndFieldTypes (NormalC n ts) = (n, snd <$> ts)-ctrNameAndFieldTypes (RecC n ts) = (n, view _3 <$> ts)-ctrNameAndFieldTypes (InfixC l n r) = (n, [snd l, snd r])-ctrNameAndFieldTypes (ForallC _ _ c) = ctrNameAndFieldTypes c---- When a 'Prism' can change type variables it needs to pattern match on all--- other data constructors and rebuild the data so it will have the new type.-reviewerIdClause :: Con -> ClauseQ-reviewerIdClause con = do- let (dataConName, fieldTypes) = ctrNameAndFieldTypes con- varNames <- for [0 .. length fieldTypes - 1] $ \i ->- newName ('x' : show i)- clause [conP dataConName (fmap varP varNames)]- (normalB (appE (conE 'Left) (conE dataConName `appsE1` fmap varE varNames)))- []---- | Given a set of names, build a map from those names to a set of fresh names--- based on them.-freshMap :: Set Name -> Q (Map Name Name)-freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))---- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String)--- --> (\(x, y) -> Rect x y)-makeIsoFrom :: Type -> Name -> Q ([Name], Exp)-makeIsoFrom ty conName = lam <$> deCom ty- where- lam (ns, e) = (ns, LamE [TupP (map VarP ns)] e)- deCom (TupleT _) = return ([], ConE conName)- deCom (AppT l _) = do- (ln, l') <- deCom l- x <- newName "x"- return (ln ++ [x], AppE l' (VarE x))- deCom t = fail $ "unable to create isomorphism for: " ++ show t---- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String)--- --> (\(Rect x y) -> (x, y))-makeIsoTo :: [Name] -> Name -> ExpQ-makeIsoTo ns conName = lamE [conP conName (map varP ns)]- $ tupE $ map varE ns--makeIsoBody :: Name -> Exp -> Exp -> DecQ-makeIsoBody lensName f t = funD lensName [clause [] (normalB body) []] where- body = appsE [ varE 'iso- , return f- , return t- ]--makeLensBody :: Name -> Exp -> Exp -> DecQ-makeLensBody lensName i o = do- f <- newName "f"- a <- newName "a"- funD lensName [clause [] (normalB (- lamE [varP f, varP a] $- appsE [ varE 'fmap- , return o- , varE f `appE` (return i `appE` varE a)- ])) []]--plain :: TyVarBndr -> TyVarBndr-plain (KindedTV t _) = PlainTV t-plain (PlainTV t) = PlainTV t--apps :: Type -> [Type] -> Type-apps = Prelude.foldl AppT--makeLensesForDec :: LensRules -> Dec -> Q [Dec]-makeLensesForDec cfg decl = case makeDataDecl decl of- Just dataDecl -> makeLensesForCons cfg dataDecl- Nothing -> fail "makeLensesWith: Unsupported data type"--makeLensesForCons :: LensRules -> DataDecl -> Q [Dec]-makeLensesForCons cfg dataDecl = case constructors dataDecl of- [NormalC dataConName [( _,ty)]]- | cfg^.handleSingletons ->- makeIsoLenses cfg dataDecl dataConName Nothing [ty]- [RecC dataConName [(fld,_,ty)]]- | cfg^.handleSingletons ->- makeIsoLenses cfg dataDecl dataConName (Just fld) [ty]- _ | cfg^.singletonRequired ->- fail "makeLensesWith: A single-constructor single-argument data type is required"- | otherwise ->- makeFieldLenses cfg dataDecl--makeDataDecl :: Dec -> Maybe DataDecl-makeDataDecl dec = case deNewtype dec of- DataD ctx tyName args cons _ -> Just DataDecl- { dataContext = ctx- , tyConName = Just tyName- , dataParameters = args- , fullType = apps $ ConT tyName- , constructors = cons- }- DataInstD ctx familyName args cons _ -> Just DataDecl- { dataContext = ctx- , tyConName = Nothing- , dataParameters = map PlainTV vars- , fullType = \tys -> apps (ConT familyName) $- substType (Map.fromList $ zip vars tys) args- , constructors = cons- }- where- -- The list of "type parameters" to a data family instance is not- -- explicitly specified in the source. Here we define it to be- -- the set of distinct type variables that appear in the LHS. e.g.- --- -- data instance F a Int (Maybe (a, b)) = G- --- -- has 2 type parameters: a and b.- vars = toList $ setOf typeVars args- _ -> Nothing---- | A data, newtype, data instance or newtype instance declaration.-data DataDecl = DataDecl- { dataContext :: Cxt -- ^ Datatype context.- , tyConName :: Maybe Name- -- ^ Type constructor name, or Nothing for a data family instance.- , dataParameters :: [TyVarBndr] -- ^ List of type parameters- , fullType :: [Type] -> Type- -- ^ Create a concrete record type given a substitution to- -- 'detaParameters'.- , constructors :: [Con] -- ^ Constructors- -- , derivings :: [Name] -- currently not needed- }--makeIsoLenses :: LensRules- -> DataDecl- -> Name- -> Maybe Name- -> [Type]- -> Q [Dec]-makeIsoLenses cfg dataDecl dataConName maybeFieldName partTy = do- let tyArgs = map plain (dataParameters dataDecl)- m <- freshMap $ setOf typeVars tyArgs- let aty = List.foldl' AppT (TupleT $ length partTy) partTy- bty = substTypeVars m aty- sty = fullType dataDecl $ map (VarT . view name) tyArgs- tty = substTypeVars m sty- quantified = ForallT (tyArgs ++ substTypeVars m tyArgs)- (dataContext dataDecl ++ substTypeVars m (dataContext dataDecl))- maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName)- lensOnly = not $ cfg^.singletonIso- isoCon | lensOnly = ConT ''Lens- | otherwise = ConT ''Iso- isoCon' | lensOnly = ConT ''Lens'- | otherwise = ConT ''Iso'- makeBody | lensOnly = makeLensBody- | otherwise = makeIsoBody- isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do- let decl = SigD isoName $ quantified $- if cfg^.simpleLenses || Map.null m- then isoCon' `apps` [sty,aty]- else isoCon `apps` [sty,tty,aty,bty]- (ns, f) <- makeIsoFrom aty dataConName- t <- makeIsoTo ns dataConName- body <- makeBody isoName t f-#ifndef INLINING- return $ if cfg^.generateSignatures then [decl, body] else [body]-#else- inlining <- inlinePragma isoName- return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]-#endif- accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of- jfn@(Just lensName)- | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do- let decl = SigD lensName $ quantified $- if cfg^.simpleLenses || Map.null m- then isoCon' `apps` [sty,aty]- else isoCon `apps` [sty,tty,aty,bty]- (ns, f) <- makeIsoFrom aty dataConName- t <- makeIsoTo ns dataConName- body <- makeBody lensName t f-#ifndef INLINING- return $ if cfg^.generateSignatures then [decl, body] else [body]-#else- inlining <- inlinePragma lensName- return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]-#endif- _ -> return []- return $ isoDecls ++ accessorDecls--makeFieldGetterBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec-makeFieldGetterBody isFold lensName conList maybeMethodName- = case maybeMethodName of- Just methodName -> do- go <- newName "go"- let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go)- funD lensName [ clause [] (normalB expr) [funD go clauses] ]- Nothing -> funD lensName clauses- where- clauses = map buildClause conList-- buildClause (con, fields) | isRecord con = do- f <- newName "_f"- vars <- for (con^..conNamedFields._1) $ \fld ->- if fld `List.elem` fields- then Just <$> newName ('_':(nameBase fld++""))- else return Nothing- let cpats = maybe wildP varP <$> vars -- Deconstruction- fvals = map (appE (varE f) . varE) (catMaybes vars) -- Functor applications- conName = con^.name-- fpat- | List.null fvals = wildP- | otherwise = varP f-- expr- | not isFold && length fields /= 1- = appE (varE 'error) . litE . stringL- $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields)- | List.null fields- = [| coerce (pure ()) |]- | List.null fvals = [| coerce (pure ()) |]- | otherwise- = let add x y = [| $x *> $y |]- in [| coerce $(List.foldl1 add fvals) |]- clause [fpat, conP conName cpats] (normalB expr) []-- -- Non-record are never the target of a generated field lens body- buildClause (con, _fields) =- -- clause: _ c@Con{} = expr- -- expr: pure c- clause [wildP, recP (con^.name) []] (normalB [| coerce (pure ()) |]) []--isRecord :: Con -> Bool-isRecord RecC{} = True-isRecord NormalC{} = False-isRecord InfixC{} = False-isRecord (ForallC _ _ c) = isRecord c--makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec-makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of- Just methodName -> do- go <- newName "go"- let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go)- funD lensName [ clause [] (normalB expr) [funD go clauses] ]- Nothing -> funD lensName clauses- where- clauses = map buildClause conList-- buildClause (con, fields) | isRecord con = do- f <- newName "_f"- vars <- for (con^..conNamedFields._1) $ \fld ->- if fld `List.elem` fields- then Left <$> ((,) <$> newName ('_':(nameBase fld++"'")) <*> newName ('_':nameBase fld))- else Right <$> newName ('_':nameBase fld)- let cpats = map (varP . either fst id) vars -- Deconstruction- cvals = map (varE . either snd id) vars -- Reconstruction- fpats = map (varP . snd) $ lefts vars -- Lambda patterns- fvals = map (appE (varE f) . varE . fst) $ lefts vars -- Functor applications- conName = con^.name- recon = conE conName `appsE1` cvals-- fpat- | List.null fields = wildP- | otherwise = varP f- expr- | not isTraversal && length fields /= 1- = appE (varE 'error) . litE . stringL- $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields)- | List.null fields- = appE (varE 'pure) recon- | otherwise- = let step Nothing r = Just $ infixE (Just $ lamE fpats recon) (varE '(<$>)) (Just r)- step (Just l) r = Just $ infixE (Just l) (varE '(<*>)) (Just r)- in fromJust $ List.foldl step Nothing fvals- -- = infixE (Just $ lamE fpats recon) (varE '(<$>)) $ Just $ List.foldl1 (\l r -> infixE (Just l) (varE '(<*>)) (Just r)) fvals- clause [fpat, conP conName cpats] (normalB expr) []-- -- Non-record are never the target of a generated field lens body- buildClause (con, _fields) = do- let fieldCount = lengthOf conFields con- vars <- replicateM fieldCount (newName "x")- let conName = con^.name- expr- | isTraversal = [| pure $(conE conName `appsE1` map varE vars) |] -- We must rebuild the value to support type changing- | otherwise = [| error errorMsg |]- where errorMsg = show lensName ++ ": non-record constructors require traversals to be generated"-- -- clause: _ c@Con{} = expr- -- expr: pure c- clause [wildP, conP conName (map varP vars)] (normalB expr) []--makeFieldLenses :: LensRules- -> DataDecl- -> Q [Dec]-makeFieldLenses cfg dataDecl = do- let tyArgs = map plain $ dataParameters dataDecl- maybeLensClass = view lensClass cfg . nameBase =<< tyConName dataDecl- maybeClassName = fmap (^._1.to mkName) maybeLensClass- cons = constructors dataDecl- t <- newName "t"- a <- newName "a"-- --TODO: there's probably a more efficient way to do this.- lensFields <- map (\xs -> (fst $ head xs, map snd xs))- . groupBy ((==) `on` fst) . sortBy (comparing fst)- . concat- <$> mapM (getLensFields $ view lensField cfg) cons-- -- varMultiSet knows how many usages of the type variables there are.- let varMultiSet = List.concatMap (toListOf (conFields._2.typeVars)) cons- varSet = Set.fromList $ map (view name) tyArgs-- bodies <- for lensFields $ \(lensName, fields) -> do- let fieldTypes = map (view _3) fields- -- All of the polymorphic variables not involved in these fields- otherVars = varMultiSet List.\\ fieldTypes^..typeVars- -- New type variable binders, and the type to represent the selected fields- (tyArgs', cty) <- unifyTypes tyArgs fieldTypes- -- Map for the polymorphic variables that are only involved in these fields, to new names for them.- m <- freshMap . Set.difference varSet $ Set.fromList otherVars- let aty | isJust maybeClassName = VarT t- | otherwise = fullType dataDecl $ map (VarT . view name) tyArgs'- bty = substTypeVars m aty- dty = substTypeVars m cty-- s = setOf folded m- relevantBndr b = s^.contains (b^.name)- relevantCtx = not . Set.null . Set.intersection s . setOf typeVars- tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs')- ctx = dataContext dataDecl- ps = filter relevantCtx (substTypeVars m ctx)- qs = case maybeClassName of-#if MIN_VERSION_template_haskell(2,10,0)- Just n | not (cfg^.createClass) -> AppT (ConT n) (VarT t) : (ctx ++ ps)-#else- Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps)-#endif- | otherwise -> ps- _ -> ctx ++ ps- tvs' = case maybeClassName of- Just _ | not (cfg^.createClass) -> PlainTV t : tvs- | otherwise -> []- _ -> tvs-- --TODO: Better way to write this?- fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields- conList = map (\c -> (c, Map.findWithDefault [] (view name c) fieldMap)) cons- maybeMethodName = fmap (mkName . view _2) maybeLensClass-- isTraversal <- do- let notSingular = filter ((/= 1) . length . snd) conList- showCon (c, fs) = pprint (c^.name) ++ " { " ++ intercalate ", " (map pprint fs) ++ " }"- case (cfg^.buildTraversals, cfg^.partialLenses) of- (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses."- (False, True) -> return False- (True, False) | List.null notSingular -> return False- | otherwise -> return True- (False, False) | List.null notSingular -> return False- | otherwise -> fail . unlines $- [ "Cannot use 'makeLensesWith' with constructors that don't map just one field"- , "to a lens, without using either the buildTraversals or partialLenses flags."- , if length conList == 1- then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:"- else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:"- ] ++ map showCon conList-- let decl = SigD lensName- $ case cty of- ForallT innerTys innerCxt cty' ->- ForallT (tvs'++innerTys) (qs++innerCxt)- $ apps (ConT (if isTraversal then ''Fold else ''Getter)) [aty,cty']- _ ->- ForallT tvs' qs- $ if aty == bty && cty == dty || cfg^.simpleLenses || isJust maybeClassName- then apps (ConT (if isTraversal then ''Traversal' else ''Lens')) [aty,cty]- else apps (ConT (if isTraversal then ''Traversal else ''Lens)) [aty,bty,cty,dty]-- body <- case cty of- ForallT {} -> makeFieldGetterBody isTraversal lensName conList maybeMethodName- _ -> makeFieldLensBody isTraversal lensName conList maybeMethodName-#ifndef INLINING- return $ if cfg^.generateSignatures then [decl, body] else [body]-#else- inlining <- inlinePragma lensName- return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining]-#endif- let defs = Prelude.concat bodies- case maybeLensClass of- Nothing -> return defs- Just (clsNameString, methodNameString) -> do- let clsName = mkName clsNameString- methodName = mkName methodNameString- varArgs = varT . view name <$> tyArgs- appliedCon = fullType dataDecl <$> sequenceA varArgs- Prelude.sequence $- filter (\_ -> cfg^.createClass) [- classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) (- sigD methodName (appsT (conT ''Lens') [varT t, appliedCon]) :- map return defs)]- ++ filter (\_ -> cfg^.createInstance) [- instanceD (return []) ((conT clsName `appT` appliedCon) `appsT` varArgs) [- funD methodName [clause [varP a] (normalB (varE a)) []]-#ifdef INLINING- , inlinePragma methodName-#endif- ]]- ++ filter (\_ -> not $ cfg^.createClass) (map return defs)---- | Gets @[(lens name, (constructor name, field name, type))]@ from a record constructor.-getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))]-getLensFields f (RecC cn fs)- = return . catMaybes- $ fs <&> \(fn,_,t) -> f (nameBase fn) <&> \ln -> (mkName ln, (cn,fn,t))-getLensFields f (ForallC tvs cxts con) = fmap (filter p) (getLensFields f con)- where- -- Only select fields which do not mention existentially- -- quantified type variables or variables mentioned in internal class constraints- prohibitedTypes = tvs^..typeVars ++ cxts^..typeVars- p field = not (any (\t -> elemOf (_2._3.typeVars) t field) prohibitedTypes)--getLensFields _ _- = return []---- TODO: properly fill this out------ Ideally this would unify the different field types, and figure out which polymorphic variables--- need to be the same. For now it just leaves them the same and yields the first type.--- (This leaves us open to inscrutable compile errors in the generated code)-unifyTypes :: [TyVarBndr] -> [Type] -> Q ([TyVarBndr], Type)-unifyTypes tvs tys = return (tvs, head tys)---- | Build 'Wrapped' instance for a given newtype-makeWrapped :: Name -> DecsQ-makeWrapped nm = do- inf <- reify nm- case inf of- TyConI decl -> do- maybeDecs <- makeWrappedForDec decl- maybe (fail "makeWrapped: Unsupported data type") return maybeDecs- _ -> fail "makeWrapped: Expected the name of a newtype or datatype"--makeWrappedForDec :: Dec -> Q (Maybe [Dec])-makeWrappedForDec decl = case makeDataDecl decl of- Just dataDecl | [con] <- constructors dataDecl- , [field] <- toListOf (conFields._2) con- -> do wrapped <- makeWrappedInstance dataDecl con field- rewrapped <- makeRewrappedInstance dataDecl- return (Just [rewrapped, wrapped])- _ -> return Nothing--makeRewrappedInstance :: DataDecl -> DecQ-makeRewrappedInstance dataDecl = do-- t <- varT <$> newName "t"-- let typeArgs = map (view name) (dataParameters dataDecl)-- typeArgs' <- do- m <- freshMap (Set.fromList typeArgs)- return (substTypeVars m typeArgs)-- -- Con a b c...- let appliedType = return (fullType dataDecl (map VarT typeArgs))-- -- Con a' b' c'...- appliedType' = return (fullType dataDecl (map VarT typeArgs'))-- -- Con a' b' c'... ~ t-#if MIN_VERSION_template_haskell(2,10,0)- eq = AppT. AppT EqualityT <$> appliedType' <*> t-#else- eq = equalP appliedType' t-#endif-- -- Rewrapped (Con a b c...) t- klass = conT ''Rewrapped `appsT` [appliedType, t]-- -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t- instanceD (cxt [eq]) klass []--makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ-makeWrappedInstance dataDecl con fieldType = do-- let conName = view name con- let typeArgs = toListOf typeVars (dataParameters dataDecl)-- -- Con a b c...- let appliedType = fullType dataDecl (map VarT typeArgs)-- -- type Unwrapped (Con a b c...) = $fieldType- let unwrappedATF = tySynInstD' ''Unwrapped [return appliedType] (return fieldType)-- -- Wrapped (Con a b c...)- let klass = conT ''Wrapped `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|]) []]-- -- instance Wrapped (Con a b c...) where- -- type Unwrapped (Con a b c...) = fieldType- -- _Wrapped' = iso (\(Con x) -> x) Con- instanceD (cxt []) klass [unwrappedATF, isoMethod]--#if !(MIN_VERSION_template_haskell(2,7,0))--- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse.-instance Applicative Q where- pure = return- (<*>) = ap-#endif--#ifdef INLINING--inlinePragma :: Name -> Q Dec-#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--#endif--data FieldRules = FieldRules- { _getPrefix :: [String] -> String -> Maybe String- , _rawLensNaming :: String -> String- , _niceLensNaming :: String -> Maybe String- , _classNaming :: String -> Maybe String- }--data Field = Field- { _fieldName :: Name- , _fieldLensPrefix :: String- , _fieldLensName :: Name- , _fieldClassName :: Name- , _fieldClassLensName :: Name- , _fieldNameType :: Type- }--overHead :: (a -> a) -> [a] -> [a]-overHead _ [] = []-overHead f (x:xs) = f x : xs---- | Field rules for fields in the form @ _prefix_fieldname @-underscoreFields :: FieldRules-underscoreFields = FieldRules prefix rawLens niceLens classNaming- where- prefix _ ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)- prefix _ _ = Nothing- rawLens x = x ++ "_lens"- niceLens x = prefix [] x <&> \n -> drop (length n + 2) x- classNaming x = niceLens x <&> ("Has_" ++)---- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @--- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.--- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.-camelCaseFields :: FieldRules-camelCaseFields = FieldRules prefix rawLens niceLens classNaming- where- sepUpper x = case break isUpper x of- (p, s) | List.null p || List.null s -> Nothing- | otherwise -> Just (p,s)-- prefix fields = fmap fst . sepUpper <=< dealWith_ fields-- rawLens x = x ++ "Lens"- niceLens x = overHead toLower . snd <$> sepUpper x- classNaming x = niceLens x <&> \ (n:ns) -> "Has" ++ toUpper n : ns-- dealWith_ :: [String] -> String -> Maybe String- dealWith_ fields field | not $ any (fst . leading_) fields = Just field- | otherwise = if leading then Just trailing else Nothing- where- leading_ ('_':xs) = (True, xs)- leading_ xs = (False, xs)- (leading, trailing) = leading_ field----collectRecords :: [Con] -> [VarStrictType]-collectRecords cons = nubBy varEq allRecordFields- where- varEq (name1,_,_) (name2,_,_) = name1 == name2- allRecordFields = [ field | RecC _ fields <- cons , field <- fields ]--verboseLenses :: FieldRules -> Dec -> Q [Dec]-verboseLenses c decl = do- cons <- case deNewtype decl of- DataD _ _ _ cons _ -> return cons- DataInstD _ _ _ cons _ -> return cons- _ -> fail "verboseLenses: Unsupported data type"- let rs = collectRecords cons- if List.null rs- then fail "verboseLenses: Expected the name of a record type"- else flip makeLenses' decl- $ mkFields c rs- & map (\(Field n _ l _ _ _) -> (show n, show l))- where- makeLenses' fields' =- makeLensesForDec $ lensRules- & lensField .~ (`Prelude.lookup` fields')- & buildTraversals .~ False- & partialLenses .~ True--mkFields :: FieldRules -> [VarStrictType] -> [Field]-mkFields (FieldRules prefix' raw' nice' clas') rs- = Maybe.mapMaybe namer fieldNamesAndTypes- & List.groupBy (on (==) _fieldLensPrefix)- & (\ gs -> case gs of- x:_ -> x- _ -> [])- where- fieldNamesAndTypes = [(nameBase n, t) | (n,_,t) <- rs]- fieldNames = map fst fieldNamesAndTypes-- namer (field, fieldType) = do- let rawlens = mkName (raw' field)- prefix <- prefix' fieldNames field- nice <- mkName <$> nice' field- clas <- mkName <$> clas' field- return (Field (mkName field) prefix rawlens clas nice fieldType)--hasClassAndInstance :: FieldRules -> Dec -> Q [Dec]-hasClassAndInstance cfg decl = do- c <- newName "c"- e <- newName "e"- dataDecl <- case makeDataDecl decl of- Just dataDecl -> return dataDecl- _ -> fail "hasClassAndInstance: Unsupported data type"- let rs = collectRecords $ constructors dataDecl- when (List.null rs) $- fail "hasClassAndInstance: Expected the name of a record type"- fmap concat . forM (mkFields cfg rs) $ \(Field _ _ fullLensName className lensName fieldType) -> do- classHas <- classD- (return [])- className- [ PlainTV c, PlainTV e ]- [ FunDep [c] [e] ]- [ sigD lensName (conT ''Lens' `appsT` [varT c, varT e])]- instanceHas <- instanceD- (return [])- (return $ ConT className `apps`- [fullType dataDecl $ map (VarT . view name) (dataParameters dataDecl)- , fieldType])- [-#ifdef INLINING- inlinePragma lensName,-#endif- funD lensName [ clause [] (normalB (varE fullLensName)) [] ]- ]- classAlreadyExists <- isJust `fmap` lookupTypeName (show className)- return (if classAlreadyExists then [instanceHas] else [classHas, instanceHas])---- | Make fields with the specified 'FieldRules'.-makeFieldsWith :: FieldRules -> Name -> Q [Dec]-makeFieldsWith c n = do- inf <- reify n- case inf of- TyConI decl -> makeFieldsForDec c decl- _ -> fail "makeFieldsWith: Expected the name of a data type or newtype"--makeFieldsForDec :: FieldRules -> Dec -> Q [Dec]-makeFieldsForDec cfg decl = liftA2 (++)- (verboseLenses cfg decl)- (hasClassAndInstance cfg decl)---- | Generate overloaded field accessors.------ /e.g/------ @--- data Foo a = Foo { _fooX :: 'Int', _fooY : a }--- newtype Bar = Bar { _barX :: 'Char' }--- makeFields ''Foo--- makeFields ''Bar--- @------ 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--- x = _fooXLens--- class HasY s a | s -> a where--- y :: Lens' s a--- instance HasY (Foo a) a where--- y = _fooYLens--- _barXLens :: Iso' Bar Char--- instance HasX Bar Char where--- x = _barXLens--- @------ @--- makeFields = 'makeFieldsWith' 'defaultFieldRules'--- @-makeFields :: Name -> Q [Dec]-makeFields = makeFieldsWith defaultFieldRules---- | @ defaultFieldRules = 'camelCaseFields' @-defaultFieldRules :: FieldRules-defaultFieldRules = camelCaseFields---- Declaration quote stuff--declareWith :: (Dec -> Declare Dec) -> Q [Dec] -> Q [Dec]-declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)---- | Monad for emitting top-level declarations as a side effect.-type Declare = WriterT (Endo [Dec]) Q--runDeclare :: Declare [Dec] -> Q [Dec]+ , makeClassyPrisms+ , makeWrapped+ , makeFields+ , makeFieldsWith+ -- * Constructing Lenses Given a Declaration Quote+ , declareLenses, declareLensesFor+ , declareClassy, declareClassyFor+ , declarePrisms+ , declareWrapped+ , declareFields+ -- * Configuring Lenses+ , makeLensesWith+ , declareLensesWith+ , fieldRules+ , camelCaseFields+ , underscoreFields+ , LensRules+ , DefName(..)+ , lensRules+ , lensRulesFor+ , classyRules+ , classyRules_+ , lensField+ , lensClass+ , simpleLenses+ , createClass+ , generateSignatures+ ) where++import Control.Applicative+#if !(MIN_VERSION_template_haskell(2,7,0))+import Control.Monad (ap)+#endif+import qualified Control.Monad.Trans as Trans+import Control.Monad.Trans.Writer+import Control.Lens.Fold+import Control.Lens.Getter+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+import Data.Char (toLower, toUpper, isUpper)+import Data.Foldable hiding (concat, any)+import Data.List as List+import Data.Map as Map hiding (toList,map,filter)+import Data.Maybe (maybeToList)+import Data.Monoid+import Data.Set as Set hiding (toList,map,filter)+import Data.Set.Lens+import Data.Traversable hiding (mapM)+import Language.Haskell.TH+import Language.Haskell.TH.Lens++#ifdef HLINT+{-# ANN module "HLint: ignore Eta reduce" #-}+{-# ANN module "HLint: ignore Use fewer imports" #-}+{-# ANN module "HLint: ignore Use foldl" #-}+#endif++simpleLenses :: Lens' LensRules Bool+simpleLenses f r = fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r))++-- | Indicate whether or not to supply the signatures for the generated+-- lenses.+--+-- Disabling this can be useful if you want to provide a more restricted type+-- signature or if you want to supply hand-written haddocks.+generateSignatures :: Lens' LensRules Bool+generateSignatures f r =+ fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r))++-- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the+-- 'lensClass' rule matches.+createClass :: Lens' LensRules Bool+createClass f r =+ fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r))++-- | 'Lens'' to access the convention for naming fields in our 'LensRules'.+--+-- Defaults to stripping the _ off of the field name, lowercasing the name, and+-- skipping the field if it doesn't start with an '_'. The field naming rule+-- provides the names of all fields in the type as well as the current field.+-- This extra generality enables field naming conventions that depend on the+-- full set of names in a type.+lensField :: Lens' LensRules ([Name] -> Name -> [DefName])+lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r))++-- | Retrieve options such as the name of the class and method to put in it to+-- build a class around monomorphic data types. "Classy" lenses are generated+-- when this naming convention is provided.+-- TypeName -> Maybe (ClassName, MainMethodName)+lensClass :: Lens' LensRules (Name -> Maybe (Name, Name))+lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r))++-- | Rules for making fairly simple partial lenses, ignoring the special cases+-- for isomorphisms and traversals, and not making any classes.+lensRules :: LensRules+lensRules = LensRules+ { _simpleLenses = False+ , _generateSigs = True+ , _generateClasses = False+ , _allowIsos = True+ , _classyLenses = const Nothing+ , _fieldToDef = \_ n ->+ case nameBase n of+ '_':x:xs -> [TopName (mkName (toLower x:xs))]+ _ -> []+ }++-- | Construct a 'LensRules' value for generating top-level definitions+-- using the given map from field names to definition names.+lensRulesFor ::+ [(String, String)] {- ^ [(Field Name, Definition Name)] -} ->+ LensRules+lensRulesFor fields = lensRules & lensField .~ mkNameLookup fields++mkNameLookup :: [(String,String)] -> [Name] -> Name -> [DefName]+mkNameLookup kvs _ field =+ [ TopName (mkName v) | (k,v) <- kvs, k == nameBase field]++-- | Rules for making lenses and traversals that precompose another 'Lens'.+classyRules :: LensRules+classyRules = LensRules+ { _simpleLenses = True+ , _generateSigs = True+ , _generateClasses = True+ , _allowIsos = False -- generating Isos would hinder "subtyping"+ , _classyLenses = \n ->+ case nameBase n of+ x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs))+ [] -> Nothing+ , _fieldToDef = \_ n ->+ case nameBase n of+ '_':x:xs -> [TopName (mkName (toLower x:xs))]+ _ -> []+ }++-- | Rules for making lenses and traversals that precompose another 'Lens'+-- using a custom function for naming the class, main class method, and a+-- mapping from field names to definition names.+classyRulesFor+ :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} ->+ [(String, String)] {- ^ [(Field Name, Method Name)] -} ->+ LensRules+classyRulesFor classFun fields = classyRules+ & lensClass .~ (over (mapped . both) mkName . classFun . nameBase)+ & lensField .~ mkNameLookup fields++classyRules_ :: LensRules+classyRules_+ = classyRules & lensField .~ \_ n -> [TopName (mkName ('_':nameBase n))]++-- | Build lenses (and traversals) with a sensible default configuration.+--+-- /e.g./+--+-- @+-- data FooBar+-- = Foo { _x, _y :: 'Int' }+-- | Bar { _x :: 'Int' }+-- 'makeLenses' ''FooBar+-- @+--+-- will create+--+-- @+-- x :: 'Lens'' FooBar 'Int'+-- x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a+-- x f (Bar a) = Bar \<$\> f a+-- y :: 'Traversal'' FooBar 'Int'+-- y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b+-- y _ c\@(Bar _) = pure c+-- @+--+-- @+-- 'makeLenses' = 'makeLensesWith' 'lensRules'+-- @+makeLenses :: Name -> DecsQ+makeLenses = makeFieldOptics lensRules++-- | Make lenses and traversals for a type, and create a class when the+-- type has no arguments.+--+-- /e.g./+--+-- @+-- data Foo = Foo { _fooX, _fooY :: 'Int' }+-- 'makeClassy' ''Foo+-- @+--+-- will create+--+-- @+-- class HasFoo t where+-- foo :: 'Lens'' t Foo+-- fooX :: 'Lens'' t 'Int'+-- fooX = foo . go where go f (Foo x y) = (\\x\' -> Foo x' y) \<$\> f x+-- fooY :: 'Lens'' t 'Int'+-- fooY = foo . go where go f (Foo x y) = (\\y\' -> Foo x y') \<$\> f y+-- instance HasFoo Foo where+-- foo = id+-- @+--+-- @+-- 'makeClassy' = 'makeLensesWith' 'classyRules'+-- @+makeClassy :: Name -> DecsQ+makeClassy = makeFieldOptics classyRules++-- | Make lenses and traversals for a type, and create a class when the type+-- has no arguments. Works the same as 'makeClassy' except that (a) it+-- expects that record field names do not begin with an underscore, (b) all+-- record fields are made into lenses, and (c) the resulting lens is prefixed+-- with an underscore.+makeClassy_ :: Name -> DecsQ+makeClassy_ = makeFieldOptics classyRules_++-- | Derive lenses and traversals, specifying explicit pairings+-- of @(fieldName, lensName)@.+--+-- If you map multiple names to the same label, and it is present in the same+-- constructor then this will generate a 'Traversal'.+--+-- /e.g./+--+-- @+-- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo+-- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar+-- @+makeLensesFor :: [(String, String)] -> Name -> DecsQ+makeLensesFor fields = makeFieldOptics (lensRulesFor fields)++-- | Derive lenses and traversals, using a named wrapper class, and+-- specifying explicit pairings of @(fieldName, traversalName)@.+--+-- Example usage:+--+-- @+-- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo+-- @+makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ+makeClassyFor clsName funName fields = makeFieldOptics $+ classyRulesFor (const (Just (clsName, funName))) fields++-- | Build lenses with a custom configuration.+makeLensesWith :: LensRules -> Name -> DecsQ+makeLensesWith = makeFieldOptics++++-- | Make lenses for all records in the given declaration quote. All record+-- syntax in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareLenses [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- fooX, fooY :: 'Lens'' Foo Int+-- @+declareLenses :: DecsQ -> DecsQ+declareLenses+ = declareLensesWith+ $ lensRules+ & lensField .~ \_ n -> [TopName n]++-- | Similar to 'makeLensesFor', but takes a declaration quote.+declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ+declareLensesFor fields+ = declareLensesWith+ $ lensRulesFor fields+ & lensField .~ \_ n -> [TopName n]++-- | For each record in the declaration quote, make lenses and traversals for+-- it, and create a class when the type has no arguments. All record syntax+-- in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareClassy [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- class HasFoo t where+-- foo :: 'Lens'' t Foo+-- instance HasFoo Foo where foo = 'id'+-- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'+-- @+declareClassy :: DecsQ -> DecsQ+declareClassy+ = declareLensesWith+ $ classyRules+ & lensField .~ \_ n -> [TopName n]++-- | Similar to 'makeClassyFor', but takes a declaration quote.+declareClassyFor ::+ [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ+declareClassyFor classes fields+ = declareLensesWith+ $ classyRulesFor (`Prelude.lookup`classes) fields+ & lensField .~ \_ n -> [TopName n]++-- | Generate a 'Prism' for each constructor of each data type.+--+-- /e.g./+--+-- @+-- declarePrisms [d|+-- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }+-- |]+-- @+--+-- will create+--+-- @+-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+-- _Lit :: 'Prism'' Exp Int+-- _Var :: 'Prism'' Exp String+-- _Lambda :: 'Prism'' Exp (String, Exp)+-- @+declarePrisms :: DecsQ -> DecsQ+declarePrisms = declareWith $ \dec -> do+ emit =<< Trans.lift (makeDecPrisms True dec)+ return dec++-- | Build 'Wrapped' instance for each newtype.+declareWrapped :: DecsQ -> DecsQ+declareWrapped = declareWith $ \dec -> do+ maybeDecs <- Trans.lift (makeWrappedForDec dec)+ forM_ maybeDecs emit+ return dec++-- | @ declareFields = 'declareFieldsWith' 'fieldRules' @+declareFields :: DecsQ -> DecsQ+declareFields = declareLensesWith fieldRules++-- | Declare lenses for each records in the given declarations, using the+-- specified 'LensRules'. Any record syntax in the input will be stripped+-- off.+declareLensesWith :: LensRules -> DecsQ -> DecsQ+declareLensesWith rules = declareWith $ \dec -> do+ emit =<< Trans.lift (makeFieldOpticsForDec rules dec)+ return $ stripFields dec++-----------------------------------------------------------------------------+-- Internal TH Implementation+-----------------------------------------------------------------------------++-- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to+-- @DataInstD@s.+deNewtype :: Dec -> Dec+deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d+deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d+deNewtype d = d+++-- | Given a set of names, build a map from those names to a set of fresh names+-- based on them.+freshMap :: Set Name -> Q (Map Name Name)+freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))+++apps :: Type -> [Type] -> Type+apps = Prelude.foldl AppT+++makeDataDecl :: Dec -> Maybe DataDecl+makeDataDecl dec = case deNewtype dec of+ DataD ctx tyName args cons _ -> Just DataDecl+ { dataContext = ctx+ , tyConName = Just tyName+ , dataParameters = args+ , fullType = apps $ ConT tyName+ , constructors = cons+ }+ DataInstD ctx familyName args cons _ -> Just DataDecl+ { dataContext = ctx+ , tyConName = Nothing+ , dataParameters = map PlainTV vars+ , fullType = \tys -> apps (ConT familyName) $+ substType (Map.fromList $ zip vars tys) args+ , constructors = cons+ }+ where+ -- The list of "type parameters" to a data family instance is not+ -- explicitly specified in the source. Here we define it to be+ -- the set of distinct type variables that appear in the LHS. e.g.+ --+ -- data instance F a Int (Maybe (a, b)) = G+ --+ -- has 2 type parameters: a and b.+ vars = toList $ setOf typeVars args+ _ -> Nothing++-- | A data, newtype, data instance or newtype instance declaration.+data DataDecl = DataDecl+ { dataContext :: Cxt -- ^ Datatype context.+ , tyConName :: Maybe Name+ -- ^ Type constructor name, or Nothing for a data family instance.+ , dataParameters :: [TyVarBndr] -- ^ List of type parameters+ , fullType :: [Type] -> Type+ -- ^ Create a concrete record type given a substitution to+ -- 'detaParameters'.+ , constructors :: [Con] -- ^ Constructors+ -- , derivings :: [Name] -- currently not needed+ }++++-- | Build 'Wrapped' instance for a given newtype+makeWrapped :: Name -> DecsQ+makeWrapped nm = do+ inf <- reify nm+ case inf of+ TyConI decl -> do+ maybeDecs <- makeWrappedForDec decl+ maybe (fail "makeWrapped: Unsupported data type") return maybeDecs+ _ -> fail "makeWrapped: Expected the name of a newtype or datatype"++makeWrappedForDec :: Dec -> Q (Maybe [Dec])+makeWrappedForDec decl = case makeDataDecl decl of+ Just dataDecl | [con] <- constructors dataDecl+ , [field] <- toListOf (conFields._2) con+ -> do wrapped <- makeWrappedInstance dataDecl con field+ rewrapped <- makeRewrappedInstance dataDecl+ return (Just [rewrapped, wrapped])+ _ -> return Nothing++makeRewrappedInstance :: DataDecl -> DecQ+makeRewrappedInstance dataDecl = do++ t <- varT <$> newName "t"++ let typeArgs = map (view name) (dataParameters dataDecl)++ typeArgs' <- do+ m <- freshMap (Set.fromList typeArgs)+ return (substTypeVars m typeArgs)++ -- Con a b c...+ let appliedType = return (fullType dataDecl (map VarT typeArgs))++ -- Con a' b' c'...+ appliedType' = return (fullType dataDecl (map VarT typeArgs'))++ -- Con a' b' c'... ~ t+#if MIN_VERSION_template_haskell(2,10,0)+ eq = AppT. AppT EqualityT <$> appliedType' <*> t+#else+ eq = equalP appliedType' t+#endif++ -- Rewrapped (Con a b c...) t+ klass = conT ''Rewrapped `appsT` [appliedType, t]++ -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t+ instanceD (cxt [eq]) klass []++makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ+makeWrappedInstance dataDecl con fieldType = do++ let conName = view name con+ let typeArgs = toListOf typeVars (dataParameters dataDecl)++ -- Con a b c...+ let appliedType = fullType dataDecl (map VarT typeArgs)++ -- type Unwrapped (Con a b c...) = $fieldType+ let unwrappedATF = tySynInstD' ''Unwrapped [return appliedType] (return fieldType)++ -- Wrapped (Con a b c...)+ let klass = conT ''Wrapped `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|]) []]++ -- instance Wrapped (Con a b c...) where+ -- type Unwrapped (Con a b c...) = fieldType+ -- _Wrapped' = iso (\(Con x) -> x) Con+ instanceD (cxt []) klass [unwrappedATF, isoMethod]++#if !(MIN_VERSION_template_haskell(2,7,0))+-- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse.+instance Applicative Q where+ pure = return+ (<*>) = ap+#endif++overHead :: (a -> a) -> [a] -> [a]+overHead _ [] = []+overHead f (x:xs) = f x : xs++-- | Field rules for fields in the form @ _prefix_fieldname @+underscoreFields :: LensRules+underscoreFields = fieldRules & lensField .~ underscoreNamer++underscoreNamer :: [Name] -> Name -> [DefName]+underscoreNamer _ field = maybeToList $ do+ _ <- prefix field'+ method <- niceLens+ cls <- classNaming+ return (MethodName (mkName cls) (mkName method))+ where+ field' = nameBase field+ prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)+ prefix _ = Nothing+ niceLens = prefix field' <&> \n -> drop (length n + 2) field'+ classNaming = niceLens <&> ("Has_" ++)++-- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @+-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.+-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.+camelCaseFields :: LensRules+camelCaseFields = fieldRules & lensField .~ camelCaseNamer++camelCaseNamer :: [Name] -> Name -> [DefName]+camelCaseNamer fields field = maybeToList $ do+ _ <- prefix+ method <- niceLens+ cls <- classNaming+ return (MethodName (mkName cls) (mkName method))+ where+ field' = nameBase field+ fields' = map nameBase fields+ sepUpper x = case break isUpper x of+ (p, s) | List.null p || List.null s -> Nothing+ | otherwise -> Just (p,s)++ prefix = fmap fst . sepUpper =<< dealWith_++ niceLens = overHead toLower . snd <$> sepUpper field'+ classNaming = niceLens <&> \ (n:ns) -> "Has" ++ toUpper n : ns++ dealWith_ :: Maybe String+ dealWith_ | not $ any (fst . leading_) fields' = Just field'+ | otherwise = if leading then Just trailing else Nothing+ where+ leading_ ('_':xs) = (True, xs)+ leading_ xs = (False, xs)+ (leading, trailing) = leading_ field'+++-- | Generate overloaded field accessors.+--+-- /e.g/+--+-- @+-- data Foo a = Foo { _fooX :: 'Int', _fooY : a }+-- newtype Bar = Bar { _barX :: 'Char' }+-- makeFields ''Foo+-- makeFields ''Bar+-- @+--+-- 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+-- x = _fooXLens+-- class HasY s a | s -> a where+-- y :: Lens' s a+-- instance HasY (Foo a) a where+-- y = _fooYLens+-- _barXLens :: Iso' Bar Char+-- instance HasX Bar Char where+-- x = _barXLens+-- @+--+-- @+-- makeFields = 'makeLensesWith' 'fieldRules'+-- @+makeFields :: Name -> DecsQ+makeFields = makeFieldOptics fieldRules++makeFieldsWith :: LensRules -> Name -> DecsQ+makeFieldsWith = makeLensesWith+{-# DEPRECATED makeFieldsWith "Use `makeLensesWith`, functionality merged" #-}++fieldRules :: LensRules+fieldRules = LensRules+ { _simpleLenses = True+ , _generateSigs = True+ , _generateClasses = True -- classes will still be skipped if they already exist+ , _allowIsos = False -- generating Isos would hinder field class reuse+ , _classyLenses = const Nothing+ , _fieldToDef = \_ n -> let rest = dropWhile (not.isUpper) (nameBase n)+ in [MethodName (mkName ("Has"++rest))+ (mkName (overHead toLower rest))]+ }+++-- Declaration quote stuff++declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ+declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)++-- | Monad for emitting top-level declarations as a side effect.+type Declare = WriterT (Endo [Dec]) Q++runDeclare :: Declare [Dec] -> DecsQ runDeclare dec = do (out, endo) <- runWriterT dec return $ out ++ appEndo endo []
− src/Data/Aeson/Lens.hs
@@ -1,405 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DefaultSignatures #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}------------------------------------------------------------------------ |--- Copyright : (c) Edward Kmett 2013-2014, (c) Paul Wilson 2012--- License : BSD3--- Maintainer: Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability: non-portable-------------------------------------------------------------------------module Data.Aeson.Lens- (- -- * Numbers- AsNumber(..)- , _Integral- , nonNull- -- * Primitive- , Primitive(..)- , AsPrimitive(..)- -- * Objects and Arrays- , AsValue(..)- , key, members- , nth, values- -- * Decoding- , AsJSON(..)- ) where--import Control.Lens-import Data.Aeson-import Data.Aeson.Parser (value)-import Data.Attoparsec.ByteString.Lazy (maybeResult, parse)-import Data.Scientific (Scientific)-import qualified Data.Scientific as Scientific-import qualified Data.ByteString as Strict-import Data.ByteString.Lazy.Char8 as Lazy hiding (putStrLn)-import Data.Data-import Data.HashMap.Strict (HashMap)-import Data.Text as Text-import Data.Text.Encoding-import Data.Vector (Vector)-import Prelude hiding (null)---- $setup--- >>> import Data.ByteString.Char8 as Strict.Char8--- >>> :set -XOverloadedStrings----------------------------------------------------------------------------------- Scientific prisms---------------------------------------------------------------------------------class AsNumber t where- -- |- -- >>> "[1, \"x\"]" ^? nth 0 . _Number- -- Just 1.0- --- -- >>> "[1, \"x\"]" ^? nth 1 . _Number- -- Nothing- _Number :: Prism' t Scientific-#ifndef HLINT- default _Number :: AsPrimitive t => Prism' t Scientific- _Number = _Primitive._Number- {-# INLINE _Number #-}-#endif-- -- |- -- Prism into an 'Double' over a 'Value', 'Primitive' or 'Scientific'- --- -- >>> "[10.2]" ^? nth 0 . _Double- -- Just 10.2- _Double :: Prism' t Double- _Double = _Number.iso Scientific.toRealFloat realToFrac- {-# INLINE _Double #-}-- -- |- -- Prism into an 'Integer' over a 'Value', 'Primitive' or 'Scientific'- --- -- >>> "[10]" ^? nth 0 . _Integer- -- Just 10- --- -- >>> "[10.5]" ^? nth 0 . _Integer- -- Just 10- --- -- >>> "42" ^? _Integer- -- Just 42- _Integer :: Prism' t Integer- _Integer = _Number.iso floor fromIntegral- {-# INLINE _Integer #-}--instance AsNumber Value where- _Number = prism Number $ \v -> case v of Number n -> Right n; _ -> Left v- {-# INLINE _Number #-}--instance AsNumber Scientific where- _Number = id- {-# INLINE _Number #-}--instance AsNumber Strict.ByteString-instance AsNumber Lazy.ByteString-instance AsNumber String----------------------------------------------------------------------------------- Conversion Prisms----------------------------------------------------------------------------------- | Access Integer 'Value's as Integrals.------ >>> "[10]" ^? nth 0 . _Integral--- Just 10------ >>> "[10.5]" ^? nth 0 . _Integral--- Just 10-_Integral :: (AsNumber t, Integral a) => Prism' t a-_Integral = _Number . iso floor fromIntegral-{-# INLINE _Integral #-}----------------------------------------------------------------------------------- Null values and primitives----------------------------------------------------------------------------------- | Primitives of 'Value'-data Primitive- = StringPrim !Text- | NumberPrim !Scientific- | BoolPrim !Bool- | NullPrim- deriving (Eq,Ord,Show,Data,Typeable)--instance AsNumber Primitive where- _Number = prism NumberPrim $ \v -> case v of NumberPrim s -> Right s; _ -> Left v- {-# INLINE _Number #-}--class AsNumber t => AsPrimitive t where- -- |- -- >>> "[1, \"x\", null, true, false]" ^? nth 0 . _Primitive- -- Just (NumberPrim 1.0)- --- -- >>> "[1, \"x\", null, true, false]" ^? nth 1 . _Primitive- -- Just (StringPrim "x")- --- -- >>> "[1, \"x\", null, true, false]" ^? nth 2 . _Primitive- -- Just NullPrim- --- -- >>> "[1, \"x\", null, true, false]" ^? nth 3 . _Primitive- -- Just (BoolPrim True)- --- -- >>> "[1, \"x\", null, true, false]" ^? nth 4 . _Primitive- -- Just (BoolPrim False)- _Primitive :: Prism' t Primitive-#ifndef HLINT- default _Primitive :: AsValue t => Prism' t Primitive- _Primitive = _Value._Primitive- {-# INLINE _Primitive #-}-#endif-- -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _String- -- Just "xyz"- --- -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _String- -- Nothing- --- -- >>> _Object._Wrapped # [("key" :: Text, _String # "value")]- -- "{\"key\":\"value\"}"- _String :: Prism' t Text- _String = _Primitive.prism StringPrim (\v -> case v of StringPrim s -> Right s; _ -> Left v)- {-# INLINE _String #-}-- -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _Bool- -- Just True- --- -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _Bool- -- Nothing- --- -- >>> _Bool # True- -- "true"- --- -- >>> _Bool # False- -- "false"- _Bool :: Prism' t Bool- _Bool = _Primitive.prism BoolPrim (\v -> case v of BoolPrim b -> Right b; _ -> Left v)- {-# INLINE _Bool #-}-- -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . _Null- -- Just ()- --- -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . _Null- -- Nothing- --- -- >>> _Null # ()- -- "null"- _Null :: Prism' t ()- _Null = _Primitive.prism (const NullPrim) (\v -> case v of NullPrim -> Right (); _ -> Left v)- {-# INLINE _Null #-}---instance AsPrimitive Value where- _Primitive = prism fromPrim toPrim- where- toPrim (String s) = Right $ StringPrim s- toPrim (Number n) = Right $ NumberPrim n- toPrim (Bool b) = Right $ BoolPrim b- toPrim Null = Right NullPrim- toPrim v = Left v- {-# INLINE toPrim #-}- fromPrim (StringPrim s) = String s- fromPrim (NumberPrim n) = Number n- fromPrim (BoolPrim b) = Bool b- fromPrim NullPrim = Null- {-# INLINE fromPrim #-}- {-# INLINE _Primitive #-}- _String = prism String $ \v -> case v of String s -> Right s; _ -> Left v- {-# INLINE _String #-}- _Bool = prism Bool (\v -> case v of Bool b -> Right b; _ -> Left v)- {-# INLINE _Bool #-}- _Null = prism (const Null) (\v -> case v of Null -> Right (); _ -> Left v)- {-# INLINE _Null #-}--instance AsPrimitive Strict.ByteString-instance AsPrimitive Lazy.ByteString-instance AsPrimitive String--instance AsPrimitive Primitive where- _Primitive = id- {-# INLINE _Primitive #-}---- | Prism into non-'Null' values------ >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . nonNull--- Just (String "xyz")------ >>> "{\"a\": {}, \"b\": null}" ^? key "a" . nonNull--- Just (Object (fromList []))------ >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . nonNull--- Nothing-nonNull :: Prism' Value Value-nonNull = prism id (\v -> if isn't _Null v then Right v else Left v)-{-# INLINE nonNull #-}----------------------------------------------------------------------------------- Non-primitive traversals---------------------------------------------------------------------------------class AsPrimitive t => AsValue t where- -- |- -- >>> "[1,2,3]" ^? _Value- -- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0]))- _Value :: Prism' t Value-- -- |- -- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . _Object- -- Just (fromList [])- --- -- >>> "{\"a\": {}, \"b\": null}" ^? key "b" . _Object- -- Nothing- --- -- >>> _Object._Wrapped # [("key" :: Text, _String # "value")] :: String- -- "{\"key\":\"value\"}"- _Object :: Prism' t (HashMap Text Value)- _Object = _Value.prism Object (\v -> case v of Object o -> Right o; _ -> Left v)- {-# INLINE _Object #-}-- -- |- -- >>> "[1,2,3]" ^? _Array- -- Just (fromList [Number 1.0,Number 2.0,Number 3.0])- _Array :: Prism' t (Vector Value)- _Array = _Value.prism Array (\v -> case v of Array a -> Right a; _ -> Left v)- {-# INLINE _Array #-}--instance AsValue Value where- _Value = id- {-# INLINE _Value #-}--instance AsValue Strict.ByteString where- _Value = _JSON- {-# INLINE _Value #-}--instance AsValue Lazy.ByteString where- _Value = _JSON- {-# INLINE _Value #-}--instance AsValue String where- _Value = utf8._JSON- {-# INLINE _Value #-}---- |--- Like 'ix', but for 'Object' with Text indices. This often has better--- inference than 'ix' when used with OverloadedStrings.------ >>> "{\"a\": 100, \"b\": 200}" ^? key "a"--- Just (Number 100.0)------ >>> "[1,2,3]" ^? key "a"--- Nothing-key :: AsValue t => Text -> Traversal' t Value-key i = _Object . ix i-{-# INLINE key #-}---- | An indexed Traversal into Object properties------ > "{\"a\": 4, \"b\": 7}" ^@.. members--- [("a",Number 4.0),("b",Number 7.0)]------ > "{\"a\": 4, \"b\": 7}" & members . _Number *~ 10--- "{\"a\":40,\"b\":70}"-members :: AsValue t => IndexedTraversal' Text t Value-members = _Object . itraversed-{-# INLINE members #-}---- | Like 'ix', but for Arrays with Int indexes------ >>> "[1,2,3]" ^? nth 1--- Just (Number 2.0)------ >>> "\"a\": 100, \"b\": 200}" ^? nth 1--- Nothing------ >>> "[1,2,3]" & nth 1 .~ Number 20--- "[1,20,3]"-nth :: AsValue t => Int -> Traversal' t Value-nth i = _Array . ix i-{-# INLINE nth #-}---- | An indexed Traversal into Array elements------ >>> "[1,2,3]" ^.. values--- [Number 1.0,Number 2.0,Number 3.0]------ >>> "[1,2,3]" & values . _Number *~ 10--- "[10,20,30]"-values :: AsValue t => IndexedTraversal' Int t Value-values = _Array . traversed-{-# INLINE values #-}--utf8 :: Iso' String Strict.ByteString-utf8 = iso (encodeUtf8 . Text.pack) (Text.unpack . decodeUtf8)--class AsJSON t where- -- | '_JSON' is a 'Prism' from something containing JSON to something encoded in that structure- _JSON :: (FromJSON a, ToJSON a) => Prism' t a--instance AsJSON Strict.ByteString where- _JSON = lazy._JSON- {-# INLINE _JSON #-}--instance AsJSON Lazy.ByteString where- _JSON = prism' encode decodeValue- where- decodeValue :: (FromJSON a) => Lazy.ByteString -> Maybe a- decodeValue s = maybeResult (parse value s) >>= \x -> case fromJSON x of- Success v -> Just v- _ -> Nothing- {-# INLINE _JSON #-}--instance AsJSON String where- _JSON = utf8._JSON- {-# INLINE _JSON #-}--instance AsJSON Value where- _JSON = prism toJSON $ \x -> case fromJSON x of- Success y -> Right y;- _ -> Left x- {-# INLINE _JSON #-}----------------------------------------------------------------------------------- Some additional tests for prismhood; see https://github.com/ekmett/lens/issues/439.----------------------------------------------------------------------------------- $LazyByteStringTests--- >>> "42" ^? (_JSON :: Prism' Lazy.ByteString Value)--- Just (Number 42.0)------ >>> preview (_Integer :: Prism' Lazy.ByteString Integer) "42"--- Just 42------ >>> Lazy.unpack (review (_Integer :: Prism' Lazy.ByteString Integer) 42)--- "42"---- $StrictByteStringTests--- >>> "42" ^? (_JSON :: Prism' Strict.ByteString Value)--- Just (Number 42.0)------ >>> preview (_Integer :: Prism' Strict.ByteString Integer) "42"--- Just 42------ >>> Strict.Char8.unpack (review (_Integer :: Prism' Strict.ByteString Integer) 42)--- "42"---- $StringTests--- >>> "42" ^? (_JSON :: Prism' String Value)--- Just (Number 42.0)------ >>> preview (_Integer :: Prism' String Integer) "42"--- Just 42------ >>> review (_Integer :: Prism' String Integer) 42--- "42"
src/Generics/Deriving/Lens.hs view
@@ -64,7 +64,7 @@ -- hello -- world! tinplate :: (Generic a, GTraversal (Generic.Rep a), Typeable b) => Traversal' a b-tinplate = generic . tinplated True+tinplate = generic . tinplated Nothing {-# INLINE tinplate #-} maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c@@ -73,33 +73,33 @@ -- | Used to traverse 'Generic' data by 'uniplate'. class GTraversal f where- tinplated :: Typeable b => Bool -> Traversal' (f a) b+ tinplated :: Typeable b => Maybe TypeRep -> Traversal' (f a) b instance (Generic a, GTraversal (Generic.Rep a), Typeable a) => GTraversal (K1 i a) where tinplated rec f (K1 a) = case cast a `maybeArg1Of` f of Just b -> K1 . fromJust . cast <$> f b- Nothing | rec -> K1 <$> fmap generic (tinplated False) f a- | otherwise -> pure $ K1 a+ Nothing -> case rec of+ Just rep | rep == typeOf a -> pure (K1 a)+ _ -> K1 <$> fmap generic (tinplated (Just (typeOf a))) f a {-# INLINE tinplated #-} instance GTraversal U1 where tinplated _ _ U1 = pure U1 {-# INLINE tinplated #-} +instance GTraversal V1 where+ tinplated _ _ v = v `seq` undefined+ {-# INLINE tinplated #-}+ instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where- tinplated _ f (x :*: y) = (:*:) <$> tinplated True f x <*> tinplated True f y+ tinplated _ f (x :*: y) = (:*:) <$> tinplated Nothing f x <*> tinplated Nothing f y {-# INLINE tinplated #-} instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where- tinplated _ f (L1 x) = L1 <$> tinplated True f x- tinplated _ f (R1 x) = R1 <$> tinplated True f x+ tinplated _ f (L1 x) = L1 <$> tinplated Nothing f x+ tinplated _ f (R1 x) = R1 <$> tinplated Nothing f x {-# INLINE tinplated #-} instance GTraversal a => GTraversal (M1 i c a) where tinplated rec f (M1 x) = M1 <$> tinplated rec f x- {-# INLINE tinplated #-}---- ?-instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where- tinplated _ f (Comp1 fgp) = Comp1 <$> traverse (tinplated True f) fgp {-# INLINE tinplated #-}
src/Language/Haskell/TH/Lens.hs view
@@ -341,6 +341,9 @@ 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
tests/templates.hs view
@@ -66,7 +66,7 @@ data Danger a = Zone { _highway :: a } | Twilight-makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger+--makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger -- highway :: Lens (Danger a) (Danger a') a a' data Task a = Task@@ -169,6 +169,7 @@ data Associated Int = AssociatedInt { mochi :: Double } method = id |]+ -- instance Class Int where -- data Associated Int = AssociatedInt Double -- method = id