stock-profunctors (empty) → 0.1.0.0
raw patch · 4 files changed
+249/−0 lines, 4 filesdep +basedep +ghcdep +profunctors
Dependencies added: base, ghc, profunctors, stock, stock-profunctors
Files
- LICENSE +29/−0
- Stock/Profunctor.hs +111/−0
- stock-profunctors.cabal +43/−0
- test/Test.hs +66/−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/Profunctor.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- the @DeriveStock2@ registration is necessarily an orphan++-- | A companion \"solver\" package teaching the @stock@ plugin to derive+-- @Profunctor@ (from @profunctors@) without being a plugin itself.+--+-- @Profunctor@ is the @[Contra, Co]@ instance of the plugin's /n-ary variance+-- functor/ engine ('Stock.Internal.varMapN') — the very same recursion behind+-- @Functor@ @[Co]@, @Contravariant@ @[Contra]@ and @Bifunctor@ @[Co, Co]@. So+-- @dimap@ is built by walking each field with the first parameter marked+-- contravariant and the second covariant: a function field @a -> b@ pre\/post+-- composes, a covariant @b@\/@h b@ field maps forward, constants are kept.+--+-- Downstream: @data P a b = … deriving Profunctor via Stock2 P@; just depend on+-- @stock-profunctors@, no extra @-fplugin@.+module Stock.Profunctor (Profunctor(..)) where++import GHC.Plugins+import GHC.Core.Class (classMethods)+import GHC.Core.Predicate (mkClassPred)+import GHC.Tc.Plugin (newWanted, tcLookupClass)+import GHC.Tc.Types.Constraint (ctEvExpr, mkNonCanonical)+import GHC.Tc.Types.Evidence (EvTerm(EvExpr))+import GHC.Core.Multiplicity (scaledThing)+import GHC.Builtin.Names (functorClassName)+import Control.Monad (forM, zipWithM)+import Data.Profunctor (Profunctor(..))+import Stock.Derive+import Stock.Internal -- 'reshapeCo' / 'castReshape' (field reshape) come from here+import Stock.Bifunctor (BiField(..), classifyBiField)++-- | @dimap :: (a -> b) -> (c -> d) -> p b c -> p a d@ — synthesized by 'varMapN'+-- at the variance vector @[Contra, Co]@. The first parameter's source+-- instantiation is @b@ (the input is @p b c@) with @f :: a -> b@ as its+-- /contravariant/ mapper; the second's is @c@ with @g :: c -> d@ as its+-- /covariant/ mapper. Each constructor is rebuilt at @(a, d)@.+instance DeriveStock2 Profunctor where+ deriveStock2 :: Deriver2+ deriveStock2 = Deriver2 \proCls loc wrappedTy p -> do+ tcs <- lookupOvTcs "Override2"+ -- @p@ may be @Override2 cfg realP@ (positional or field-keyed): peel it (else+ -- 'varMapN' would treat the wrapper as a nested @pro a b@ field and recurse).+ let mOv2 = ovWrap tcs ; mKeep = ovKeep tcs+ (realP, mMods) = peelOverride2With tcs p+ case (tyConAppTyCon_maybe wrappedTy, tyConAppTyCon_maybe realP) of+ (Just st2Tc, Just pTc) -> do+ functorCls <- tcLookupClass functorClassName+ let fixed = tyConAppArgs realP+ dcons = tyConDataCons pTc+ dimapIdx = case [ i | (i, m) <- zip [0 :: Int ..] (classMethods proCls)+ , occNameString (getOccName m) == "dimap" ] of+ (i : _) -> i+ [] -> 0+ coAt t1 t2 = coDown2With mOv2 st2Tc wrappedTy p realP t1 t2+ -- dimap :: forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d+ aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+ cTv <- freshTyVar "c" ; dTv <- freshTyVar "d"+ let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+ cTy = mkTyVarTy cTv ; dTy = mkTyVarTy dTv+ fId <- freshId (mkVisFunTyMany aTy bTy) "f" -- a -> b (contravariant slot)+ gId <- freshId (mkVisFunTyMany cTy dTy) "g" -- c -> d (covariant slot)+ tId <- freshId (mkAppTy (mkAppTy wrappedTy bTy) cTy) "t" -- p b c+ cb <- freshId (mkTyConApp pTc (fixed ++ [bTy, cTy])) "cb"+ let dimapSel = classMethod "dimap" proCls+ -- per parameter: (source tyvar, target, covFwd, conFwd)+ params = [ (bTv, aTy, Nothing, Just (Var fId)) -- Contra: f used negatively+ , (cTv, dTy, Just (Var gId), Nothing) ] -- Co: g used positively+ resTy = mkAppTy (mkAppTy wrappedTy aTy) dTy -- p a d+ -- a nested @pro a b@ field: recurse via @pro@'s own @dimap@ (the+ -- same [Contra, Co] shape), so e.g. a @Kleisli m a b@ field works.+ selfPro q = do+ ev <- newWanted loc (mkClassPred proCls [q])+ pure (Just ( mkApps (Var dimapSel)+ [ Type q, ctEvExpr ev, Type aTy, Type bTy, Type cTy, Type dTy+ , Var fId, Var gId ]+ , [mkNonCanonical ev] ))+ mapPlain x ft = do+ m <- varMapN functorCls Nothing loc params (Just selfPro) Cov ft+ pure (fmap (\(e, ws) -> (App e (Var x), ws)) m)+ -- under @Override2@, a covariant @h c@ field is reshaped to @mod c@:+ -- map @c -> d@ through @mod@'s @fmap@ on the coerced value, coerce back.+ mapField i x ft = case (override1ModWith mKeep mMods i, classifyBiField bTv cTv bTy cTy ft) of+ (Just mod_, Just (BFFoldB h)) -> do+ m <- varMapN functorCls Nothing loc params (Just selfPro) Cov (mkAppTy mod_ cTy)+ pure $ flip fmap m \(e, ws) ->+ ( Cast (App e (castReshape (Var x) (reshapeCo h mod_ cTy))) (mkSymCo (reshapeCo h mod_ dTy)), ws )+ _ -> mapPlain x ft+ malts <- forM dcons \dc -> do+ let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [bTy, cTy]))+ xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+ mfs <- sequence (zipWith3 mapField [0 :: Int ..] xs fts)+ case sequence mfs of+ Nothing -> pure Nothing+ Just pairs ->+ let (vals, wss) = unzip pairs+ body = Cast (mkCoreConApps dc (map Type (fixed ++ [aTy, dTy]) ++ vals))+ (mkSymCo (coAt aTy dTy)) -- p a d -> Stock2 P a d+ in 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, cTv, dTv, fId, gId, tId]+ (destructInner pTc (fixed ++ [bTy, cTy])+ (Cast (Var tId) (coAt bTy cTy)) cb resTy alts)+ -- supply dimap; lmap / rmap / (#.) / (.#) come from the class defaults+ dict <- recDictWith proCls wrappedTy [] [(dimapIdx, impl)]+ pure (Just (EvExpr dict, concat wss))+ _ -> pure Nothing
+ stock-profunctors.cabal view
@@ -0,0 +1,43 @@+cabal-version: 3.0+name: stock-profunctors+version: 0.1.0.0+synopsis: Derive Profunctor via the stock plugin+description:+ A companion for the <https://hackage.haskell.org/package/stock stock> plugin: depend on @stock-profunctors@ and you can+ write @data P a b = … deriving Profunctor via Stock2 P@. It is /not/ a plugin+ , it registers an @instance DeriveStock2 Profunctor@ (on the "Stock.Derive"+ SDK) that the @stock@ plugin discovers and runs, so no extra @-fplugin@ is+ needed.++ @Profunctor@ is the @[Contra, Co]@ case of the plugin's n-ary variance functor+ engine, the same recursion as @Functor@ \/ @Contravariant@ \/ @Bifunctor@.+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.Profunctor+ build-depends: base >=4.18 && <5,+ ghc >=9.6 && <9.16,+ stock >=0.1 && <0.2,+ profunctors >=5.6 && <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-profunctors, profunctors+ ghc-options: -fplugin=Stock+ hs-source-dirs: test+ default-language: GHC2021++source-repository head+ type: git+ location: https://github.com/Icelandjack/stock.git+ subdir: profunctors
+ test/Test.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin Stock #-}+module Main (main) where++import Stock (Stock2(..))+import Stock.Profunctor (Profunctor(..)) -- class + registers DeriveStock2 Profunctor+import Stock.Override (Overriding2, Override2(..), Keep, type (:=))+import Control.Arrow (Kleisli(..))+import System.Exit (exitFailure)+import Control.Monad (unless)++-- the function profunctor field: dimap pre/post-composes+newtype Hom a b = Hom (a -> b)+ deriving Profunctor via Stock2 Hom++runHom :: Hom a b -> a -> b+runHom (Hom f) = f++-- a product: an arrow field (contravariant a, covariant b), a covariant [b],+-- and a constant. dimap f g = (compose f/g into the arrow, map g over [b],+-- keep the Int).+data P a b = P (a -> b) [b] Int+ deriving Profunctor via Stock2 P++runP :: P a b -> (a -> b, [b], Int)+runP (P f bs n) = (f, bs, n)++-- a NESTED profunctor field: Kleisli Maybe a b = q a b — handled by recursing+-- through Kleisli's own dimap (the self-application case in the engine).+newtype Nest a b = Nest (Kleisli Maybe a b)+ deriving Profunctor via Stock2 Nest++runNest :: Nest a b -> a -> Maybe b+runNest (Nest (Kleisli f)) = f++-- Profunctor via Override2: the covariant [b] field is reshaped to RevL, whose+-- fmap reverses — so dimap maps g over the list AND reverses it (observably+-- different from plain []). The arrow field is kept.+newtype RevL a = RevL [a]+instance Functor RevL where fmap f (RevL xs) = RevL (reverse (map f xs))+-- complex config (field-keyed): the covariant @poList@ field reshaped to RevL.+data PO a b = PO { poFn :: a -> b, poList :: [b] }+ deriving Profunctor via Overriding2 PO '[ poList := RevL ]+runPO :: PO a b -> (a -> b, [b])+runPO (PO f bs) = (f, bs)++main :: IO ()+main = do+ let -- dimap (+1) (*2) (Hom (*10)) :: a=3 -> (+1)=4 -> (*10)=40 -> (*2)=80+ d = runHom (dimap (+ 1) (* 2) (Hom (* 10)) :: Hom Int Int) 3 == 80+ -- lmap f = dimap f id ; rmap g = dimap id g+ l = runHom (lmap (+ 1) (Hom (* 10)) :: Hom Int Int) 3 == 40+ r = runHom (rmap (* 2) (Hom (* 10)) :: Hom Int Int) 3 == 60+ (pf, pbs, pn) = runP (dimap (+ 1) (* 2) (P (* 10) [1, 2, 3] 7) :: P Int Int)+ p = pf 3 == 80 && pbs == [2, 4, 6] && pn == 7+ -- nested Kleisli Maybe field: dimap (+1) (*2) over Nest (\b -> Just (b*10))+ -- a=3 -> (+1)=4 -> Kleisli=Just 40 -> fmap (*2)=Just 80+ n = runNest (dimap (+ 1) (* 2) (Nest (Kleisli (\b -> Just (b * 10)))) :: Nest Int Int) 3+ == Just 80+ -- Override2: [b] reshaped to RevL ⇒ dimap maps (*2) AND reverses the list+ (of_, obs) = runPO (dimap (+ 1) (* 2) (PO (* 10) [1, 2, 3]) :: PO Int Int)+ o = of_ 3 == 80 && obs == [6, 4, 2] -- reversed, not [2,4,6]+ unless (and [d, l, r, p, n, o]) exitFailure+ putStrLn "ok: Profunctor (dimap/lmap/rmap, nested q a b, Override2) via stock-profunctors"