diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Stock/NFData.hs b/Stock/NFData.hs new file mode 100644 --- /dev/null +++ b/Stock/NFData.hs @@ -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 diff --git a/inspection/Inspection.hs b/inspection/Inspection.hs new file mode 100644 --- /dev/null +++ b/inspection/Inspection.hs @@ -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)" diff --git a/stock-deepseq.cabal b/stock-deepseq.cabal new file mode 100644 --- /dev/null +++ b/stock-deepseq.cabal @@ -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 + > -- + > -- >> 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 _ = "" + > + > 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 = } + + @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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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"