diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics -version: 4.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 diff --git a/src/Control/Lens/At.hs b/src/Control/Lens/At.hs --- a/src/Control/Lens/At.hs +++ b/src/Control/Lens/At.hs @@ -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 #-} diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -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] diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -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 +-- 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 diff --git a/src/Control/Lens/Internal/Instances.hs b/src/Control/Lens/Internal/Instances.hs --- a/src/Control/Lens/Internal/Instances.hs +++ b/src/Control/Lens/Internal/Instances.hs @@ -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 diff --git a/src/Control/Lens/Internal/PrismTH.hs b/src/Control/Lens/Internal/PrismTH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/PrismTH.hs @@ -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 +-- 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 <> <> +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 <> <> +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 <> | r -> <> 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 = <> +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 diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs --- a/src/Control/Lens/Internal/TH.hs +++ b/src/Control/Lens/Internal/TH.hs @@ -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 diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs --- a/src/Control/Lens/Plated.hs +++ b/src/Control/Lens/Plated.hs @@ -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 diff --git a/src/Control/Lens/Review.hs b/src/Control/Lens/Review.hs --- a/src/Control/Lens/Review.hs +++ b/src/Control/Lens/Review.hs @@ -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 diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -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 [] diff --git a/src/Data/Aeson/Lens.hs b/src/Data/Aeson/Lens.hs deleted file mode 100644 --- a/src/Data/Aeson/Lens.hs +++ /dev/null @@ -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 --- 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" diff --git a/src/Generics/Deriving/Lens.hs b/src/Generics/Deriving/Lens.hs --- a/src/Generics/Deriving/Lens.hs +++ b/src/Generics/Deriving/Lens.hs @@ -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 #-} diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -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 diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -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