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/Profunctor.hs b/Stock/Profunctor.hs new file mode 100644 --- /dev/null +++ b/Stock/Profunctor.hs @@ -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 diff --git a/stock-profunctors.cabal b/stock-profunctors.cabal new file mode 100644 --- /dev/null +++ b/stock-profunctors.cabal @@ -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 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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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"