packages feed

linear-generics 0.1.0.1 → 0.2

raw patch · 5 files changed

+139/−89 lines, 5 files

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.2+* The `Generic1` instance for `Generically1` no longer uses+  `GHC.Generics.Generic1`; it now uses `GHC.Generics.Generic` instead.  This+  allows far more instances to be derived.+ # 0.1.0.1 * Make `Generic1` deriving properly polykinded. There was an old kind check   that has not been valid for a long time.
README.md view
@@ -48,10 +48,9 @@   deriving instances of `Generic(1)`.  * `Generics.Linear.Unsafe.ViaGHCGenerics` offers `DerivingVia` targets to-  derive `Generic` and (some) `Generic1` instances from their-  `GHC.Generics` counterparts. Because these instances necessarily-  use unsafe coercions, their use will likely inhibit full optimization-  of code using them (see+  derive both `Generic` and `Generic1` instances from `GHC.Generics.Generic`.+  Because these instances necessarily use unsafe coercions, their+  use will likely inhibit full optimization of code using them (see   [this wiki page](https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/multiplicity-evidence)   for more on the GHC internals, along with commentary in `Unsafe.Coerce`).
linear-generics.cabal view
@@ -1,5 +1,5 @@ name:                   linear-generics-version:                0.1.0.1+version:                0.2 synopsis:               Generic programming library for generalised deriving. description:   This package offers a version of@@ -32,10 +32,10 @@     deriving instances of @Generic(1)@.   .   * "Generics.Linear.Unsafe.ViaGHCGenerics" offers @DerivingVia@ targets to-    derive @Generic@ and (some) @Generic1@ instances from their-    "GHC.Generics" counterparts. Because these instances necessarily-    use unsafe coercions, their use will likely inhibit full optimization-    of code using them.+    derive @Generic@ and @Generic1@ instances from+    @"GHC.Generics".'GHC.Generics.Generic'@. Because these instances necessarily+    use unsafe coercions, their use will likely inhibit full optimization of+    code using them.   .   Educational code: the educational modules exported by   <https://hackage.haskell.org/package/generic-deriving generic-deriving>@@ -60,7 +60,7 @@ build-type:             Simple cabal-version:          >= 1.10 tested-with:            GHC == 9.0.1-                      , GHC == 9.2.*+                      , GHC == 9.2.1 extra-source-files:     CHANGELOG.md                       , README.md
src/Generics/Linear/Unsafe/ViaGHCGenerics.hs view
@@ -1,33 +1,20 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} --- | 'DerivingVia' targets to instantiate 'Generic' and 'Generic1' using--- @"GHC.Generics".'G.Generic'@ and @"GHC.Generics".'G.Generic1'@,--- respectively.+-- | 'DerivingVia' targets to instantiate 'Generic' and 'Generic1',+-- both using @"GHC.Generics".'G.Generic'@. -- -- === Caution @@ -44,7 +31,7 @@   , GHCGenerically1(..)   ) where import Data.Coerce (Coercible, coerce)-import Data.Kind (Constraint, Type)+import Data.Kind (Type) import Generics.Linear import qualified GHC.Generics as G import Unsafe.Coerce@@ -84,8 +71,31 @@   to = toLinear (GHCGenerically #. G.to)   from = toLinear (G.from .# unGHCGenerically) --- | When @a@ is an instance of @"GHC.Generics".'G.Generic1'@, and its 'G.Rep1'--- contains no compositions, @GHCGenerically1 a@ is an instance of 'Generic1'.+-- Stolen from linear-base, but without some polymorphism+-- we don't need here.++toLinear+  :: forall a b p q.+     (a %p-> b) %1-> (a %q-> b)+toLinear f = case unsafeEqualityProof @p @q of+  UnsafeRefl -> f++-- Stolen from profunctors++infixr 9 #.+(#.) :: Coercible b c => p b c -> (a -> b) -> a -> c+(#.) _ = coerce++infixl 8 .#+(.#) :: Coercible a b => (b -> c) -> p a b -> a -> c+f .# _ = coerce f++-- --------+-- Generic1+-- --------++-- | When @f a@ is an instance of @"GHC.Generics".'G.Generic'@+-- for all @a@, @GHCGenerically1 f@ is an instance of 'Generic1'. -- -- === Warning --@@ -97,7 +107,7 @@ -- completely bogus results, breaking the linearity rules. -- -- @GHCGenerically1@ is otherwise safe to use with /derived/--- @"GHC.Generics".'G.Generic1'@ instances, which are linear. If+-- @"GHC.Generics".'G.Generic'@ instances, which are linear. If -- you choose to use it with a hand-written instance, you should -- check that the underlying instance is linear. --@@ -105,76 +115,69 @@ -- -- @ -- data Foo a = Bar a (Either Int a) | Baz (Maybe a) Int---   deriving stock (Show, "GHC.Generics".'G.Generic1')+--   deriving stock (Show, "GHC.Generics".'G.Generic') --   deriving 'Generic1' via GHCGenerically1 Foo -- @ type GHCGenerically1 :: forall k. (k -> Type) -> k -> Type newtype GHCGenerically1 f a = GHCGenerically1 { unGHCGenerically1 :: f a } -instance (G.Generic1 f, Repairable ('ShowType f) (G.Rep1 f)) => Generic1 (GHCGenerically1 f) where-  type Rep1 (GHCGenerically1 f) = Repair (G.Rep1 f)+instance forall k (f :: k -> Type).+  (forall (a :: k). G.Generic (f a)) => Generic1 (GHCGenerically1 f) where+  type Rep1 (GHCGenerically1 (f :: k -> Type)) = MakeRep1 @k (G.Rep ((MarkOtherPars f) (LastPar :: k))) -  -- Why do we use 'unsafeCoerce' for these rather than just 'toLinear'?-  -- While @Rec1 f@ and @Par1 :.: f@ are represented the same way in-  -- memory, they are not @Coercible@. So we'd have to tear down the-  -- representation and build it back up again. Since we need an unsafe-  -- coercion anyway (in 'toLinear'), there's no operational benefit.-  -- That would shrink the trusted code base slightly, in a sense, but-  -- I don't think it's worth it.+  -- Why do we use unsafeCoerce here? While @G.Rep (f a)@ and @Rep1 f a@ are+  -- the same in memory, they're not (generally) Coercible. This largely has to+  -- do with the "modular" way GHC handles Coercible constraints for datatypes+  -- (as opposed to newtypes), including (:+:) and (:*:). Even if+  --+  --   f `Coercible` f' and g `Coercible` g',+  --+  -- we *don't* have+  --+  --   (f :+: g) `Coercible` (f' :+: g').+  --+  -- So we either need to use an unsafe coercion or completely tear down and+  -- rebuild the representation value.  Since we need an unsafe coercion to get+  -- linearity anyway, there's little to be gained by doing the latter.    to1 :: forall a m. Rep1 (GHCGenerically1 f) a %m-> GHCGenerically1 f a-  to1 = unsafeCoerce (GHCGenerically1 #. G.to1 @_ @f @a)+  to1 = unsafeCoerce (G.to :: G.Rep (f a) Any -> f a)    from1 :: forall a m. GHCGenerically1 f a %m-> Rep1 (GHCGenerically1 f) a-  from1 = unsafeCoerce (G.from1 @_ @f @a .# unGHCGenerically1)+  from1 = unsafeCoerce (G.from :: f a -> G.Rep (f a) Any) --- | A @"GHC.Generics".'G.Rep1'@ is @Repairable@ if it contains no--- compositions. The 'ErrorMessage' argument should be 'ShowType'--- of the type whose representation this is.-type Repairable :: forall k. ErrorMessage -> (k -> Type) -> Constraint-class Repairable tn (grep1 :: k -> Type) where-  -- | Convert a @"GHC.Generics".'G.Rep1'@ representation into a 'Rep1'-  -- representation.-  type Repair grep1 :: k -> Type-instance Repairable tn f => Repairable tn (M1 i c f) where-  type Repair (M1 i c f) = M1 i c (Repair f)-instance Repairable tn (G.Rec1 f) where-  type Repair (G.Rec1 f) = Par1 :.: f-instance Repairable tn (K1 i c) where-  type Repair (K1 i c) = K1 i c-instance Repairable tn Par1 where-  type Repair Par1 = Par1-instance (Repairable tn f, Repairable tn g) => Repairable tn (f :*: g) where-  type Repair (f :*: g) = Repair f :*: Repair g-instance (Repairable tn f, Repairable tn g) => Repairable tn (f :+: g) where-  type Repair (f :+: g) = Repair f :+: Repair g-instance Repairable tn U1 where-  type Repair U1 = U1-instance Repairable tn V1 where-  type Repair V1 = V1-instance Repairable tn (URec r) where-  type Repair (URec r) = URec r-instance-     TypeError ('Text "Could not derive linear Generic1 from GHC Generic1 for type" ':$$:-                tn ':<>: 'Text "." ':$$: 'Text "Its Rep1 instance includes composition.")-  => Repairable tn (f :.: g) where-  type Repair (_ :.: _) = Any+-- This marking technique is inspired by Csongor Kiss's `GenericN`, part of his+-- generic-lens package family. --- Stolen from linear-base, but without some polymorphism--- we don't need here.+data family LastPar :: k+data family OtherPar :: k -> k -toLinear-  :: forall a b p q.-     (a %p-> b) %1-> (a %q-> b)-toLinear f = case unsafeEqualityProof @p @q of-  UnsafeRefl -> f+type MakeRep1 :: forall k. (Type -> Type) -> k -> Type+type family MakeRep1 (rep :: Type -> Type) :: k -> Type where+  MakeRep1 (M1 i c f) = M1 i c (MakeRep1 f)+  MakeRep1 (x :+: y) = MakeRep1 x :+: MakeRep1 y+  MakeRep1 (x :*: y) = MakeRep1 x :*: MakeRep1 y+  MakeRep1 U1 = U1+  MakeRep1 V1 = V1+  MakeRep1 (Rec0 c) = MakeRep1Field (Rec0 (Unmark c)) Par1 c --- Stolen from profunctors+type MarkOtherPars :: forall k. k -> k+type family MarkOtherPars (f :: k) :: k where+  MarkOtherPars ((f :: j -> k) (a :: j)) = MarkOtherPars f (OtherPar a)+  MarkOtherPars f = f -infixr 9 #.-(#.) :: Coercible b c => p b c -> (a -> b) -> a -> c-(#.) _ = coerce+type Unmark :: forall k. k -> k+type family Unmark (f :: k) :: k where+  Unmark LastPar = TypeError ('Text "Cannot create Generic1 instance: the last parameter appears in an invalid location.")+  Unmark (OtherPar a) = a+  Unmark ((f :: j -> k) (a :: j)) = Unmark f (Unmark a)+  Unmark a = a -infixl 8 .#-(.#) :: Coercible a b => (b -> c) -> p a b -> a -> c-f .# _ = coerce f+type MakeRep1Field :: forall j k. (k -> Type) -> (j -> Type) -> j -> k -> Type+type family MakeRep1Field fk acc c where+  -- Watch out! Order matters here. The third clause will match+  -- OtherPar _ as well, and that's no good.+  MakeRep1Field fk (acc :: k -> Type) (LastPar :: k) = acc+  MakeRep1Field fk (_ :: b -> Type) (OtherPar _) = fk+  MakeRep1Field fk (acc :: b -> Type) ((f :: a -> b) (x :: a)) = MakeRep1Field fk (acc :.: Unmark f) x+  MakeRep1Field fk _ _ = fk
tests/ExampleSpec.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}@@ -17,7 +19,7 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} -module ExampleSpec (main, spec) where+module ExampleSpec (main, spec, Op (..), Plain (..)) where  import           Examples import           Generics.Linear.TH@@ -29,7 +31,10 @@ import           Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)  import qualified Text.Read.Lex (Lexeme)-import Data.Kind (Type)+import           Data.Kind (Type)+import           Generics.Linear.Unsafe.ViaGHCGenerics+import qualified GHC.Generics as GHCG+import qualified Prelude as Prelude  ------------------------------------------------------------------------------- -- Example: Haskell's lists and Maybe@@ -211,6 +216,33 @@ data Fix f a = Fix (f (Fix f a)) $(deriveGenericAnd1 ''Fix) +-------------------------------------------------------------------------------+-- Example: GHCGenerically1 compilation+-------------------------------------------------------------------------------++-- A contravariant functor+newtype Op a b = Op (b -> a)+data Plain a b c+  = Plain [a] (Either Int (Op b c))+  | Unplain (Either a (Op b (Maybe c)))+  deriving stock GHCG.Generic+  deriving Generic1 via GHCGenerically1 (Plain a b)++-------------------------------------------------------------------------------+-- Example: GHCGenerically1 running+-------------------------------------------------------------------------------++data GG a b c+  = GG1 [a] (Prelude.Either Int (Maybe (b, c)))+  | GG2 c+  | GG3 (Maybe c)+  | GG4 (Prelude.Either a b)+  deriving stock (GHCG.Generic, Show, Eq)+  deriving Generic1 via GHCGenerically1 (GG a b)++instance GFunctor (GG a b) where+  gmap = gmapdefault+ -------------------------------------------------------------------------------- -- Temporary tests for TH generation --------------------------------------------------------------------------------@@ -394,3 +426,14 @@         it "gshow (gmap gshow bush1)" $             gshow (gmap gshow bush1) `shouldBe`                 "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)"++    describe "Tests or GG" $ do+      it "gmap GG1" $+        gmap show (GG1 [12 :: Integer] (Prelude.Right (Just (7 :: Integer, 13 :: Integer)))) `shouldBe`+                   GG1 [12] (Prelude.Right (Just (7, "13")))+      it "gmap GG2" $+        gmap show (GG2 'a' :: GG Int Bool Char) `shouldBe` GG2 "'a'"+      it "gmap GG3" $+        gmap show (GG3 (Just 'a') :: GG Int Bool Char) `shouldBe` GG3 (Just "'a'")+      it "gmap GG4" $+        gmap show (GG4 (Prelude.Left 'a') :: GG Char Bool ()) `shouldBe` GG4 (Prelude.Left 'a')