stock-deepseq (empty) → 0.1.0.0
raw patch · 5 files changed
+459/−0 lines, 5 filesdep +basedep +deepseqdep +ghc
Dependencies added: base, deepseq, ghc, inspection-testing, stock, stock-deepseq
Files
- LICENSE +29/−0
- Stock/NFData.hs +209/−0
- inspection/Inspection.hs +45/−0
- stock-deepseq.cabal +103/−0
- test/Test.hs +73/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Baldur Blondal++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ * Neither the name of Baldur Blondal nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Stock/NFData.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- the @DeriveStock(1)@ registrations are necessarily orphans++-- | A companion \"solver\" package teaching the @stock@ plugin to derive+-- @NFData@ (and its higher order variant @NFData1@) from @deepseq@, without+-- being a plugin itself. It depends only on the SDK ("Stock.Derive" /+-- "Stock.Internal") + @deepseq@.+--+-- Downstream: @data T = … deriving NFData via Stock T@ (or @NFData1 via Stock1+-- T@), just depend on @stock-deepseq@; no extra @-fplugin@.+module Stock.NFData+ ( NFData(..)+ , NFData1(..)+ , NFData2(..)+ ) where++import GHC.Plugins+import GHC.Core.Class (Class, classSCTheta, classTyVars)+import GHC.Tc.Plugin (newWanted)+import GHC.Tc.Types.Constraint (ctEvExpr, mkNonCanonical)+import GHC.Core.Predicate (mkClassPred, classifyPredType, Pred(ClassPred, ForAllPred))+import GHC.Core.TyCo.Subst (substTy)+import GHC.Core.Multiplicity (scaledThing)+import Control.DeepSeq (NFData(..), NFData1(..), NFData2(..))+import Control.Monad (forM, zipWithM)+import Data.Maybe (listToMaybe, fromMaybe)+import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))+import Stock.Derive+import Stock.Internal+import Stock.Bifunctor (BiField(..), classifyBiField)++-- | Recover a base class from a lifted class's quantified superclass+-- @forall a. C a => C' (f a)@ (so @NFData2 -> NFData1 -> NFData@).+baseClassOf :: Class -> Maybe Class+baseClassOf c1 = listToMaybe+ [ c | sc <- classSCTheta c1+ , ForAllPred _ _ hd <- [classifyPredType sc]+ , ClassPred c _ <- [classifyPredType hd] ]++-- | @rnf@ dispatches on the constructor ('matchSOP') and chains each field's+-- @rnf@ with @seq@ ('cfoldlFields').+instance DeriveStock NFData where+ deriveStock :: Deriver+ deriveStock = Deriver \cls dt -> do+ let rnfSel = classMethod "rnf" cls -- rnf :: a -> ()+ unit = Var (dataConWorkId unitDataCon)+ rnfOf ft d e = mkApps (Var rnfSel) [Type ft, d, e] -- rnf @ft d e :: ()+ xId <- fresh (dtVia dt) "x"+ -- rnf x = case x of Cᵢ f.. -> rnf f0 `seq` rnf f1 `seq` … `seq` ()+ body <- matchSOP dt unitTy (Var xId) \_ con fields ->+ cfoldlFields cls+ (\acc ft d e -> do w <- fresh unitTy "w"+ pure (Case (rnfOf ft d e) w unitTy [Alt DEFAULT [] acc]))+ unit con fields+ pure (classDict cls (dtVia dt) [mkLams [xId] body])++-- | @liftRnf g@ forces each field: the parameter via the supplied @g :: a ->+-- ()@, a constant via its own @rnf@, an @h a@ field via @liftRnf@ of @h@; all+-- chained with @seq@.+instance DeriveStock1 NFData1 where+ deriveStock1 :: Deriver1+ deriveStock1 = Deriver1 \nf1Cls loc wrappedTy f -> do+ mNf <- lookupClassMaybe "Control.DeepSeq" "NFData"+ tcs <- lookupOvTcs "Override1"+ let mOv1 = ovWrap tcs ; mKeep = ovKeep tcs+ -- @f@ may be @Override1 cfg realF@ (positional or field-keyed): peel it.+ (realF, mMods) = peelOverride1With tcs f+ case (tyConAppTyCon_maybe wrappedTy, tyConAppTyCon_maybe realF, mNf) of+ (Just st1Tc, Just fTc, Just nfCls) -> do+ let fixed = tyConAppArgs realF+ dcons = tyConDataCons fTc+ liftRnfSel = classMethod "liftRnf" nf1Cls+ rnfSel = classMethod "rnf" nfCls+ unit = Var (dataConWorkId unitDataCon)+ coAt t = coDown1With mOv1 st1Tc wrappedTy f realF t+ atv <- freshTyVar "a"+ let aTy = mkTyVarTy atv+ innerA = mkTyConApp fTc (fixed ++ [aTy])+ gId <- freshId (mkVisFunTyMany aTy unitTy) "g"+ tId <- freshId (mkAppTy wrappedTy aTy) "t"+ cb <- freshId innerA "cb"+ -- one field's contribution (a @()@), or 'Nothing' if its shape is+ -- unsupported (contravariant / nested parameter).+ let contrib i x ftA = case classifyField atv aTy ftA of+ Nothing -> pure Nothing+ Just FParam -> pure (Just (App (Var gId) (Var x), []))+ Just FConst -> do ev <- newWanted loc (mkClassPred nfCls [ftA])+ pure (Just ( mkApps (Var rnfSel) [Type ftA, ctEvExpr ev, Var x]+ , [mkNonCanonical ev] ))+ -- under @Override1@, force the @h a@ field via the modifier @m@'s+ -- @liftRnf@, coercing the field value @h a ~R m a@ first.+ Just (FApp h) -> do let mMod = override1ModWith mKeep mMods i+ m = fromMaybe h mMod+ xv = case mMod of+ Nothing -> Var x+ Just _ -> Cast (Var x) (mkStockCo (PluginProv "stock")+ Representational (mkAppTy h aTy) (mkAppTy m aTy))+ ev <- newWanted loc (mkClassPred nf1Cls [m])+ pure (Just ( mkApps (Var liftRnfSel)+ [Type m, ctEvExpr ev, Type aTy, Var gId, xv]+ , [mkNonCanonical ev] ))+ -- c0 `seq` c1 `seq` … `seq` ()+ seqChain [] = pure unit+ seqChain (c : cs) = do w <- freshId unitTy "w"+ rest <- seqChain cs+ pure (Case c w unitTy [Alt DEFAULT [] rest])+ malts <- forM dcons \dc -> do+ let ftsA = fieldsAt fixed dc aTy+ xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] ftsA+ mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs ftsA)+ case sequence mcs of+ Nothing -> pure Nothing+ Just cs -> do let (es, wss) = unzip cs+ body <- seqChain es+ pure (Just (Alt (DataAlt dc) xs body, concat wss))+ case sequence malts of+ Nothing -> pure Nothing+ Just altWss -> do+ let (alts, wss) = unzip altWss+ impl = mkLams [atv, gId, tId]+ (destructInner fTc (fixed ++ [aTy]) (Cast (Var tId) (coAt aTy)) cb unitTy alts)+ -- NFData1's quantified superclass forall a. NFData a => NFData (f a):+ -- since rnf @(f a) = liftRnf (rnf @a), it is just the method above+ -- instantiated with the given @NFData a@.+ bTv <- freshTyVar "b"+ let bTy = mkTyVarTy bTv+ dB <- freshId (mkClassPred nfCls [bTy]) "d"+ let rnfAtB = mkApps impl [Type bTy, mkApps (Var rnfSel) [Type bTy, Var dB]]+ superEv = mkLams [bTv, dB] (mkClassDict nfCls (mkAppTy wrappedTy bTy) [rnfAtB])+ pure (Just (classDict nf1Cls wrappedTy [superEv, impl], concat wss))+ _ -> pure Nothing++-- | @liftRnf2 gA gB@ forces each field: the first parameter via @gA@, the+-- second via @gB@, a constant via its own @rnf@, an @h a@\/@h b@ field via+-- @liftRnf@ of @h@; all chained with @seq@. NFData2's superclass+-- @forall a. NFData a => NFData1 (p a)@ is requested as a wanted and discharged+-- via the @Stock2@-newtype passthrough from the user's own @NFData1 (P a)@.+instance DeriveStock2 NFData2 where+ deriveStock2 :: Deriver2+ deriveStock2 = Deriver2 \nf2Cls loc wrappedTy p -> do+ tcs <- lookupOvTcs "Override2"+ let mOv2 = ovWrap tcs ; mKeep = ovKeep tcs+ -- @p@ may be @Override2 cfg realP@ (positional or field-keyed): peel it.+ (realP, mMods) = peelOverride2With tcs p+ case (tyConAppTyCon_maybe wrappedTy, tyConAppTyCon_maybe realP, baseClassOf nf2Cls) of+ (Just st2Tc, Just pTc, Just nf1Cls) -> case baseClassOf nf1Cls of+ Nothing -> pure Nothing+ Just nfCls -> do+ let fixed = tyConAppArgs realP+ dcons = tyConDataCons pTc+ liftRnfSel = classMethod "liftRnf" nf1Cls+ rnfSel = classMethod "rnf" nfCls+ unit = Var (dataConWorkId unitDataCon)+ coAt t1 t2 = coDown2With mOv2 st2Tc wrappedTy p realP t1 t2+ atv <- freshTyVar "a" ; btv <- freshTyVar "b"+ let aTy = mkTyVarTy atv ; bTy = mkTyVarTy btv+ innerAB = mkTyConApp pTc (fixed ++ [aTy, bTy])+ gA <- freshId (mkVisFunTyMany aTy unitTy) "gA"+ gB <- freshId (mkVisFunTyMany bTy unitTy) "gB"+ tId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"+ cb <- freshId innerAB "cb"+ let -- consume an @h pTy@ field via the (optional) modifier @m@'s liftRnf,+ -- coercing the field value @h pTy ~R m pTy@ under @Override2@.+ liftRnfOf h mMod g pTy x = do+ let m = fromMaybe h mMod+ xv = case mMod of+ Nothing -> Var x+ Just _ -> Cast (Var x) (mkStockCo (PluginProv "stock")+ Representational (mkAppTy h pTy) (mkAppTy m pTy))+ ev <- newWanted loc (mkClassPred nf1Cls [m])+ pure (Just ( mkApps (Var liftRnfSel) [Type m, ctEvExpr ev, Type pTy, Var g, xv]+ , [mkNonCanonical ev] ))+ contrib i x ft = case classifyBiField atv btv aTy bTy ft of+ Nothing -> pure Nothing+ Just BFA -> pure (Just (App (Var gA) (Var x), []))+ Just BFB -> pure (Just (App (Var gB) (Var x), []))+ Just BFConst -> do ev <- newWanted loc (mkClassPred nfCls [ft])+ pure (Just ( mkApps (Var rnfSel) [Type ft, ctEvExpr ev, Var x]+ , [mkNonCanonical ev] ))+ Just (BFFoldA h) -> liftRnfOf h (override1ModWith mKeep mMods i) gA aTy x+ Just (BFFoldB h) -> liftRnfOf h (override1ModWith mKeep mMods i) gB bTy x+ seqChain [] = pure unit+ seqChain (c : cs) = do w <- freshId unitTy "w"+ rest <- seqChain cs+ pure (Case c w unitTy [Alt DEFAULT [] rest])+ malts <- forM dcons \dc -> do+ let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+ xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+ mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs fts)+ case sequence mcs of+ Nothing -> pure Nothing+ Just contribs -> do let (es, wss) = unzip contribs+ body <- seqChain es+ pure (Just (Alt (DataAlt dc) xs body, concat wss))+ case sequence malts of+ Nothing -> pure Nothing+ Just altWss -> do+ let (alts, wss) = unzip altWss+ impl = mkLams [atv, btv, gA, gB, tId]+ (destructInner pTc (fixed ++ [aTy, bTy]) (Cast (Var tId) (coAt aTy bTy)) cb unitTy alts)+ subst = case classTyVars nf2Cls of+ (tv : _) -> zipTvSubst [tv] [wrappedTy]+ _ -> emptySubst+ scPreds = map (substTy subst) (classSCTheta nf2Cls)+ scEvs <- forM scPreds (newWanted loc)+ pure (Just ( classDict nf2Cls wrappedTy (map ctEvExpr scEvs ++ [impl])+ , map mkNonCanonical scEvs ++ concat wss ))+ _ -> pure Nothing
+ inspection/Inspection.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Stock -fplugin=Test.Inspection.Plugin #-}++-- | Zero-cost proof for the @stock-deepseq@ companion: @NFData@\/@NFData1@\/+-- @NFData2@ are all /consumers/ (@rnf :: a -> ()@), so wrapping the argument+-- with the @Stock@\/@Stock1@\/@Stock2@ constructor lets the plugin's own unwrap+-- coercion cancel it, and 'hasNoType' certifies that no wrapper type survives+-- optimisation. See @inspection/Inspection.hs@ in @stock@ for the full rationale.+module Main (main) where++import Stock+import Stock.NFData ()+import Control.DeepSeq (NFData, NFData1, NFData2, rnf, liftRnf, liftRnf2)+import Test.Inspection++data T = T Int Bool | U deriving NFData via Stock T++data F a = F Int a [a]+ deriving NFData via Stock (F a)+ deriving NFData1 via Stock1 F++data P a b = P a b [a]+ deriving NFData via Stock (P a b)+ deriving NFData1 via Stock1 (P a)+ deriving NFData2 via Stock2 P++-- force via @seq@ into a non-@()@ result so GHC can't eta-reduce @\t -> rnf+-- (Stock t)@ to a bare @rnf@ dictionary cast (the wrapped value is the trailing+-- arg here, unlike 'sLiftRnf' whose function arg blocks that).+sRnf :: T -> Int+sRnf t = rnf (Stock t) `seq` 0++sLiftRnf :: F Int -> ()+sLiftRnf x = liftRnf rnf (Stock1 x)++sLiftRnf2 :: P Int Int -> ()+sLiftRnf2 x = liftRnf2 rnf rnf (Stock2 x)++inspect $ 'sRnf `hasNoType` ''Stock+inspect $ 'sLiftRnf `hasNoType` ''Stock1+inspect $ 'sLiftRnf2 `hasNoType` ''Stock2++main :: IO ()+main = putStrLn "ok: NFData/NFData1/NFData2 erase the Stock wrapper (zero cost)"
+ stock-deepseq.cabal view
@@ -0,0 +1,103 @@+cabal-version: 3.0+name: stock-deepseq+version: 0.1.0.0+synopsis: Derive NFData via the stock plugin+description:+ The @stock@ plugin provides a datatype for deriving and synthesising+ instances at compile time. @stock-deepseq@ extends the @stock@ with+ support for @NFData@ and higher-kinded variants.++ > {-# options_ghc -fplugin Stock -Wno-unused-top-binds #-}+ > + > {-# language DerivingVia #-}+ > {-# language DataKinds #-}+ >+ > import Stock+ > import Stock.NFData+ > import Stock.Override+ > + > import Control.Exception+ > + > data Person = P { name :: String, age :: Int, secret :: Person }+ > deriving (Eq, Ord, Show, NFData) via + > Stock Person+ > + > -- >> try @SomeException (evaluate (rnf geir))+ > -- Left stack overflow+ > -- >> geir == geir+ > -- <loop>+ > -- >> geir+ > -- P {name = "Geir", age = 10, secret = P {name = "Geir", .. } }+ > geir :: Person+ > geir = P { name = "Geir", age = 10, secret = geir }++ The @rnf@ function triggers the loop, but by pinning @secret@ as an+ ignored field, we can happily force the other fields.++ > newtype Ignore a = Ignore a+ > instance NFData (Ignore a) where rnf _ = ()+ > instance Eq (Ignore a) where _ == _ = True+ > instance Ord (Ignore a) where compare _ _ = EQ+ > instance Show (Ignore a) where show _ = "<ignored>"+ >+ > data Person = P { name :: String, age :: Int, secret :: Person }+ > deriving (Eq, Ord, Show, NFData) via + > Overriding Person '[ secret via Ignore ]+ >+ > -- >> try @SomeException (evaluate (rnf geir))+ > -- Right ()+ > -- >> geir == geir+ > -- True+ > -- >> geir+ > -- P {name = "Geir", age = 10, secret = <ignored>}++ @stock-deepseq@ provides three instances, that signal to the+ plugin how to derive @NFData@, @NFData1@, @NFData2@.++ > instance DeriveStock NFData ..+ > instance DeriveStock1 NFData1 ..+ > instance DeriveStock2 NFData2 ..+license: BSD-3-Clause+license-file: LICENSE+author: Baldur Blöndal+maintainer: baldur.blondal@iohk.io+category: Type System+build-type: Simple+tested-with: GHC == 9.8.1+ , GHC == 9.10.3+ , GHC == 9.12.4+ , GHC == 9.14.1++library+ exposed-modules: Stock.NFData+ build-depends: base >=4.18 && <5+ , ghc >=9.8 && <9.16+ , stock >=0.1 && <0.2+ , deepseq >=1.4 && <1.6+ hs-source-dirs: .+ default-language: GHC2021+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ build-depends: base, stock, stock-deepseq, deepseq+ ghc-options: -fplugin=Stock+ hs-source-dirs: test+ default-language: GHC2021++-- Zero-cost proof: Stock is fully erased+test-suite inspection+ type: exitcode-stdio-1.0+ main-is: Inspection.hs+ build-depends: base, stock, stock-deepseq, deepseq, inspection-testing+ ghc-options: -fplugin=Stock+ hs-source-dirs: inspection+ default-language: GHC2021+ if impl(ghc >= 9.14)+ buildable: False++source-repository head+ type: git+ location: https://github.com/Icelandjack/stock.git+ subdir: deepseq
+ test/Test.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin Stock #-}+module Main (main) where+import Stock (Stock(..), Stock1(..), Stock2(..))+import Stock.NFData (NFData(..), NFData1(..), NFData2(..)) -- class + registers DeriveStock(1,2)+import Stock.Override (Override(..), Overriding1, Overriding2, Override1(..), Override2(..), Keep, type (:=))+import Control.DeepSeq (deepseq)+import Control.Exception (try, evaluate, SomeException)++data T = T Int Bool | U deriving NFData via Stock T++-- NFData1's quantified superclass (forall a. NFData a => NFData (F a)) needs an+-- NFData (F a) instance too, exactly as Eq1 needs Eq.+data F a = F Int a [a]+ deriving NFData via Stock (F a)+ deriving NFData1 via Stock1 F++-- NFData2 chains the superclasses: NFData (P a b), NFData1 (P a), NFData2 P.+data P a b = P a b [a]+ deriving NFData via Stock (P a b)+ deriving NFData1 via Stock1 (P a)+ deriving NFData2 via Stock2 P++-- An observable modifier: @Lazily@ is a newtype over @[a]@ (so coercible to the+-- real field) whose 'NFData1' forces /nothing/. Honoring Override is therefore+-- visible: an @undefined@ list element is never touched.+newtype Lazily a = Lazily [a]+instance NFData (Lazily a) where rnf _ = () -- NFData1's quantified superclass+instance NFData1 Lazily where liftRnf _ _ = ()++-- NFData1 via Override1: the @[a]@ field is forced through @Lazily@. (As with+-- @F@, NFData1's quantified superclass needs an @NFData (NL a)@ instance too.)+data NL a = NL [a]+ deriving NFData via Stock (NL a)+ deriving NFData1 via Overriding1 NL '[ '[Lazily] ]++-- NFData2 via Override2: the @[a]@ field (first parameter) forced through+-- @Lazily@; the @b@ field kept.+data NL2 a b = NL2 [a] b+ deriving NFData via Stock (NL2 a b)+ deriving NFData1 via Stock1 (NL2 a)+ deriving NFData2 via Overriding2 NL2 '[ '[Lazily, Keep] ]++-- value-level NFData via Override: @Lazy@ is a newtype over @Int@ whose @rnf@+-- forces nothing, so field 0 is never evaluated (an @undefined@ survives).+newtype Lazy = Lazy Int+instance NFData Lazy where rnf _ = ()+-- complex config (type-keyed): every @Int@ field forced through @Lazy@.+data NV = NV Int Bool+ deriving NFData via Stock (Override NV '[ Int := Lazy ])++-- True iff forcing does NOT blow up (i.e. Override was honored and the lazy+-- modifier skipped the bottom element).+survives :: () -> IO Bool+survives u = either (const False) (const True)+ <$> (try (evaluate u) :: IO (Either SomeException ()))++main :: IO ()+main = do+ ( T 1 True `deepseq` U+ `deepseq` liftRnf rnf (F 1 (2 :: Int) [3, 4])+ `deepseq` liftRnf2 rnf rnf (P (1 :: Int) 'c' [2, 3]) ) `seq` pure ()+ -- Override1: NL's [a] forced through Lazily, so the undefined survives.+ ok1 <- survives (liftRnf rnf (NL [undefined :: Int]))+ -- Override2: NL2's [a] forced through Lazily; the 'b' is still forced normally.+ ok2 <- survives (liftRnf2 rnf rnf (NL2 [undefined :: Int] 'c'))+ -- value Override: NV's Int field forced through Lazy (no-op), so undefined survives.+ ok3 <- survives (rnf (NV undefined True))+ if ok1 && ok2 && ok3+ then putStrLn "ok: NFData + NFData1 + NFData2 (incl. Override + Override1/2) via stock-deepseq"+ else error "Override not honored for NFData/NFData1/NFData2"