generic-override 0.3.0.0 → 0.4.0.0

raw patch · 7 files changed

+232/−126 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−2
• generic-override.cabal +3/−2
• src/Data/Override.hs +2/−1
• src/Data/Override/Instances.hs +1/−33
• src/Data/Override/Internal.hs +177/−70
• test/Encode.hs +8/−15
• test/Test.hs +33/−3

@@ -1,9 +1,15 @@ # Changelog for generic-override +## 0.4.0.0++* `At` support for overriding by constructor name and parameter index+* Simplify encoding by removing `Overridden`+* Implementation of `Generic` derivation a la `GOverride` now use `INLINE`+ ## 0.3.0.0 -* 'Override' support for sum types-* 'As' support for higher kinds up (up to arity 10)+* `Override` support for sum types+* `As` support for higher kinds up (up to arity 10)  ## 0.2.0.0 

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               generic-override-version:            0.3.0.0+version:            0.4.0.0 license:            BSD3 license-file:       LICENSE copyright:          2020 Estatico Studios LLC@@ -33,6 +33,7 @@     hs-source-dirs:   src     other-modules:    Paths_generic_override     default-language: Haskell2010+    ghc-options:      -Wall     build-depends:    base >=4.7 && <5  test-suite generic-override-test@@ -44,7 +45,7 @@         Paths_generic_override      default-language: Haskell2010-    ghc-options:      -threaded -rtsopts -with-rtsopts=-N+    ghc-options:      -Wall -threaded -rtsopts -with-rtsopts=-N     build-depends:         base >=4.7 && <5,         generic-override -any,

@@ -2,8 +2,9 @@ module Data.Override   ( Override(Override)   , As+  , At   , With   ) where -import Data.Override.Internal (Override(Override), As, With)+import Data.Override.Internal (Override(Override), As, At, With) import Data.Override.Instances ()

@@ -7,12 +7,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Override.Instances () where -import Data.Coerce (Coercible, coerce) import Data.Function (on)+import Data.Override.Internal (Override) import GHC.Generics (Generic(Rep, from, to)) -import Data.Override.Internal- -- The @foo `on` from'@ idiom is taken from @generic-data@ by Li-yao Xia. from' :: Generic a => a -> Rep a () from' = from@@ -29,13 +27,6 @@   where   (==) = (==) `on` from' -instance-  ( Coercible a (Using ms a xs)-  , Eq (Using ms a xs)-  ) => Eq (Overridden ms a xs)-  where-  x == y = (==) @(Using ms a xs) (coerce x) (coerce y)- -- Ord  instance@@ -45,14 +36,6 @@   where   compare = compare `on` from' -instance-  ( Coercible a (Using ms a xs)-  , Ord (Using ms a xs)-  ) => Ord (Overridden ms a xs)-  where-  compare x y = compare @(Using ms a xs) (coerce x) (coerce y)-- -- Semigroup  instance@@ -62,13 +45,6 @@   where   x <> y = to (from' x <> from' y) -instance-  ( Coercible a (Using ms a xs)-  , Semigroup (Using ms a xs)-  ) => Semigroup (Overridden ms a xs)-  where-  x <> y = coerce $ (<>) @(Using ms a xs) (coerce x) (coerce y)- -- Monoid  instance@@ -78,11 +54,3 @@   where   mempty = to' mempty   x `mappend` y = to (from' x `mappend` from' y)--instance-  ( Coercible a (Using ms a xs)-  , Monoid (Using ms a xs)-  ) => Monoid (Overridden ms a xs)-  where-  mempty = coerce $ mempty @(Using ms a xs)-  x `mappend` y = coerce $ mappend @(Using ms a xs) (coerce x) (coerce y)

@@ -1,18 +1,19 @@ -- | This is the internal generic-override API and should be considered--- unstable and subject to change. This module is exposed for library integrators--- (e.g. generic-override-aeson). In general, unless you are integrating--- some type class with generic-override, you should prefer to use the--- public, stable API provided by 'Data.Override'.-+-- unstable and subject to change. In general, you should prefer to use the+-- public, stable API provided by "Data.Override". {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -20,8 +21,9 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Override.Internal where +import Data.Coerce (Coercible, coerce) import GHC.Generics-import GHC.TypeLits (Symbol)+import GHC.TypeLits (type (+), Nat, Symbol)  -- | The feature of this library. For use with DerivingVia. -- Apply it to a type @a@ and supply a type-level list of instance@@ -44,95 +46,200 @@ -- | Used to wrap a field into a something of kind @* -> *@, for example another newtype. data With (o :: k) (w :: * -> *) --- | Used at the leaf nodes of a generic 'Rep'-newtype Overridden (ms :: Maybe Symbol) a (xs :: [*]) = Overridden a---- | Unwrap an 'Overridden' value.-unOverridden :: Overridden ms a xs -> a-unOverridden (Overridden a) = a+-- | Used to construct a type-level override for the given constructor+-- name @c@ and parameter index @p@.+data At (c :: Symbol) (p :: Nat) (n :: *) --- | Same as 'override' but for 'Overridden' types.-overridden-  :: forall a (ms :: Maybe Symbol) (xs :: [*]) proxy0 proxy1.-     a -> proxy0 ms -> proxy1 xs -> Overridden ms a xs-overridden a _ _ = Overridden a+instance+  ( Generic a+  , GOverride xs (Rep a)+  ) => Generic (Override a xs)+  where+  type Rep (Override a xs) = OverrideRep EmptyInspect xs (Rep a)+  from = overrideFrom @EmptyInspect @xs . from . unOverride+  to = Override . to . overrideTo @EmptyInspect @xs -instance (Generic a, GOverride xs (Rep a)) => Generic (Override a xs) where-  type Rep (Override a xs) = OverrideRep xs (Rep a)-  from = overrideFrom @xs . from . unOverride-  to = Override . to . overrideTo @xs+-- | Shorthand for the starting point of 'GOverride''.+--+-- You generally shouldn't need this. If GHC asks you to add it as+-- a constraint, prefer using the instance @Generic (Override a xs)@ instead,+-- which may require @MonoLocalBinds@.+type GOverride = GOverride' EmptyInspect  -- | Type class used to build the 'Generic' instance for 'Override'.-class GOverride (xs :: [*]) (f :: * -> *) where-  -- | Analogous to 'Rep'; rewrites the type for a given 'Rep' and injects-  -- 'Overridden' at the leaves.-  type OverrideRep xs f :: * -> *-  overrideFrom :: f x -> OverrideRep xs f x-  overrideTo :: OverrideRep xs f x -> f x+--+-- You generally shouldn't need this. If GHC asks you to add it as+-- a constraint, prefer using the instance @Generic (Override a xs)@ instead,+-- which may require @MonoLocalBinds@.+class GOverride' (i :: Inspect) (xs :: [*]) (f :: * -> *) where+  type OverrideRep i xs f :: * -> *+  overrideFrom :: f x -> OverrideRep i xs f x+  overrideTo :: OverrideRep i xs f x -> f x -instance (GOverride xs f) => GOverride xs (M1 D c f) where-  type OverrideRep xs (M1 D c f) = M1 D c (OverrideRep xs f)-  overrideFrom (M1 x) = M1 (overrideFrom @xs x)-  overrideTo (M1 x) = M1 (overrideTo @xs x)+instance (GOverride' i xs f) => GOverride' i xs (M1 D c f) where+  type OverrideRep i xs (M1 D c f) = M1 D c (OverrideRep i xs f)+  overrideFrom (M1 x) = M1 (overrideFrom @i @xs x)+  {-# INLINE overrideFrom #-} -instance (GOverride xs f) => GOverride xs (M1 C c f) where-  type OverrideRep xs (M1 C c f) = M1 C c (OverrideRep xs f)-  overrideFrom (M1 x) = M1 (overrideFrom @xs x)-  overrideTo (M1 x) = M1 (overrideTo @xs x)+  overrideTo (M1 x) = M1 (overrideTo @i @xs x)+  {-# INLINE overrideTo #-} -instance (GOverride xs f, GOverride xs g) => GOverride xs (f :*: g) where-  type OverrideRep xs (f :*: g) = OverrideRep xs f :*: OverrideRep xs g-  overrideFrom (f :*: g) = overrideFrom @xs f :*: overrideFrom @xs g-  overrideTo (f :*: g) = overrideTo @xs f :*: overrideTo @xs g+instance+  ( GOverride' ('Inspect ('Just conName) ms mp) xs f+  ) => GOverride' ('Inspect ignore ms mp) xs+        (M1 C ('MetaCons conName conFixity conIsRecord) f)+  where+  type OverrideRep ('Inspect ignore ms mp) xs+        (M1 C ('MetaCons conName conFixity conIsRecord) f) =+          M1 C+            ('MetaCons conName conFixity conIsRecord)+            (OverrideRep ('Inspect ('Just conName) ms mp) xs f) -instance (GOverride xs f, GOverride xs g) => GOverride xs (f :+: g) where-  type OverrideRep xs (f :+: g) = OverrideRep xs f :+: OverrideRep xs g+  overrideFrom (M1 x) = M1 (overrideFrom @('Inspect ('Just conName) ms mp) @xs x)+  {-# INLINE overrideFrom #-} +  overrideTo (M1 x) = M1 (overrideTo @('Inspect ('Just conName) ms mp) @xs x)+  {-# INLINE overrideTo #-}++instance+  ( GOverride' ('Inspect mc ms ('Just 0)) xs f+  , GOverride' ('Inspect mc ms ('Just 1)) xs g+  ) => GOverride' ('Inspect mc ms 'Nothing) xs (f :*: g)+  where+  type OverrideRep ('Inspect mc ms 'Nothing) xs (f :*: g) =+    OverrideRep ('Inspect mc ms ('Just 0)) xs f+      :*: OverrideRep ('Inspect mc ms ('Just 1)) xs g++  overrideFrom (f :*: g) =+    overrideFrom @('Inspect mc ms ('Just 0)) @xs f+      :*: overrideFrom @('Inspect mc ms ('Just 1)) @xs g+  {-# INLINE overrideFrom #-}++  overrideTo (f :*: g) =+    overrideTo @('Inspect mc ms ('Just 0)) @xs f+      :*: overrideTo @('Inspect mc ms ('Just 1)) @xs g+  {-# INLINE overrideTo #-}++instance+  ( GOverride' ('Inspect mc ms ('Just p)) xs f+  , GOverride' ('Inspect mc ms ('Just (p + 1))) xs g+  ) => GOverride' ('Inspect mc ms ('Just p)) xs (f :*: g)+  where+  type OverrideRep ('Inspect mc ms ('Just p)) xs (f :*: g) =+    OverrideRep ('Inspect mc ms ('Just p)) xs f+      :*: OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g++  overrideFrom (f :*: g) =+    overrideFrom @('Inspect mc ms ('Just p)) @xs f+      :*: overrideFrom @('Inspect mc ms ('Just (p + 1))) @xs g+  {-# INLINE overrideFrom #-}++  overrideTo (f :*: g) =+    overrideTo @('Inspect mc ms ('Just p)) @xs f+      :*: overrideTo @('Inspect mc ms ('Just (p + 1))) @xs g+  {-# INLINE overrideTo #-}++instance+  ( GOverride' i xs f+  , GOverride' i xs g+  ) => GOverride' i xs (f :+: g)+  where+  type OverrideRep i xs (f :+: g) = OverrideRep i xs f :+: OverrideRep i xs g+   overrideFrom = \case-    L1 f -> L1 $ overrideFrom @xs f-    R1 g -> R1 $ overrideFrom @xs g+    L1 f -> L1 $ overrideFrom @i @xs f+    R1 g -> R1 $ overrideFrom @i @xs g+  {-# INLINE overrideFrom #-}    overrideTo = \case-    L1 f -> L1 $ overrideTo @xs f-    R1 g -> R1 $ overrideTo @xs g+    L1 f -> L1 $ overrideTo @i @xs f+    R1 g -> R1 $ overrideTo @i @xs g+  {-# INLINE overrideTo #-} -instance GOverride xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) where-  type OverrideRep xs (M1 S ('MetaSel ms su ss ds) (K1 R c)) =-    M1 S ('MetaSel ms su ss ds) (K1 R (Overridden ms c xs))-  overrideFrom (M1 (K1 x)) = M1 (K1 (Overridden @ms x))-  overrideTo (M1 (K1 (Overridden x))) = M1 (K1 x)+instance+  ( GOverride' ('Inspect mc selName mp) xs f+  ) => GOverride' ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f)+  where+  type OverrideRep ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f) =+    M1 S ('MetaSel selName selSU selSS selDS) (OverrideRep ('Inspect mc selName mp) xs f) -instance GOverride xs U1 where-  type OverrideRep xs U1 = U1+  overrideFrom (M1 x) = M1 (overrideFrom @('Inspect mc selName mp) @xs x)+  {-# INLINE overrideFrom #-}++  overrideTo (M1 x) = M1 (overrideTo @('Inspect mc selName mp) @xs x)+  {-# INLINE overrideTo #-}++instance+  ( Coercible a (Using ('Inspect mc ms ('Just 0)) a xs)+  ) => GOverride' ('Inspect mc ms 'Nothing) xs (K1 R a)+  where+  type OverrideRep ('Inspect mc ms 'Nothing) xs (K1 R a) =+    K1 R (Using ('Inspect mc ms ('Just 0)) a xs)++  overrideFrom (K1 a) = K1 (coerce a :: Using ('Inspect mc ms ('Just 0)) a xs)+  {-# INLINE overrideFrom #-}++  overrideTo (K1 u) = K1 (coerce u :: a)+  {-# INLINE overrideTo #-}++instance+  ( Coercible a (Using ('Inspect mc ms ('Just p)) a xs)+  ) => GOverride' ('Inspect mc ms ('Just p)) xs (K1 R a)+  where+  type OverrideRep ('Inspect mc ms ('Just p)) xs (K1 R a) =+    K1 R (Using ('Inspect mc ms ('Just p)) a xs)++  overrideFrom (K1 a) = K1 (coerce a :: Using ('Inspect mc ms ('Just p)) a xs)+  {-# INLINE overrideFrom #-}++  overrideTo (K1 u) = K1 (coerce u :: a)+  {-# INLINE overrideTo #-}++instance GOverride' i xs U1 where+  type OverrideRep i xs U1 = U1   overrideFrom U1 = U1+  {-# INLINE overrideFrom #-}+   overrideTo U1 = U1+  {-# INLINE overrideTo #-} +data Inspect =+  Inspect+    (Maybe Symbol) -- ^ Constructor name+    (Maybe Symbol) -- ^ Selector name+    (Maybe Nat)    -- ^ Selector index++type EmptyInspect = 'Inspect 'Nothing 'Nothing 'Nothing+ -- | Type family used to determine which override from @xs@ -- to replace @a@ with, if any. The @ms@ holds the field name -- for @a@, if applicable.-type family Using (ms :: Maybe Symbol) (a :: *) (xs :: [*]) where+type family Using (i :: Inspect) (a :: *) (xs :: [*]) where   -- No matching override found.-  Using ms a '[] = a+  Using i a '[] = a    -- Override the matching field.-  Using ('Just o) a (As o n ': xs) = n-  Using ('Just o) a (With o w ': xs) = w a+  Using ('Inspect mc ('Just o) mp) a (As o n ': xs) = n+  Using ('Inspect mc ('Just o) mp) a (With o w ': xs) = w a    -- Override the matching type.-  Using ms a (As a n ': xs) = n-  Using ms a (With a w ': xs) = w a+  Using i a (With a w ': xs) = w a -  -- Override the matching kind (up to 10).-  Using ms (f a0) (As f g ': xs) = g a0-  Using ms (f a0 a1) (As f g ': xs) = g a0 a1-  Using ms (f a0 a1 a2) (As f g ': xs) = g a0 a1 a2-  Using ms (f a0 a1 a2 a3) (As f g ': xs) = g a0 a1 a2 a3-  Using ms (f a0 a1 a2 a3 a4) (As f g ': xs) = g a0 a1 a2 a3 a4-  Using ms (f a0 a1 a2 a3 a4 a5) (As f g ': xs) = g a0 a1 a2 a3 a4 a5-  Using ms (f a0 a1 a2 a3 a4 a5 a6) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6-  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7-  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7 a8) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8-  Using ms (f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8 a9+  -- Override the matching type (arity 0-10).+  Using i a (As a n ': xs) = n+  Using i (f a0) (As f g ': xs) = g a0+  Using i (f a0 a1) (As f g ': xs) = g a0 a1+  Using i (f a0 a1 a2) (As f g ': xs) = g a0 a1 a2+  Using i (f a0 a1 a2 a3) (As f g ': xs) = g a0 a1 a2 a3+  Using i (f a0 a1 a2 a3 a4) (As f g ': xs) = g a0 a1 a2 a3 a4+  Using i (f a0 a1 a2 a3 a4 a5) (As f g ': xs) = g a0 a1 a2 a3 a4 a5+  Using i (f a0 a1 a2 a3 a4 a5 a6) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6+  Using i (f a0 a1 a2 a3 a4 a5 a6 a7) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7+  Using i (f a0 a1 a2 a3 a4 a5 a6 a7 a8) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8+  Using i (f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 +  -- Override the matching constructor parameter.+  Using ('Inspect ('Just c) ms ('Just p)) a (At c p n ': xs) = n+   -- No match on this override, recurse.-  Using ms a (x ': xs) = Using ms a xs+  Using i a (x ': xs) = Using i a xs

@@ -1,8 +1,10 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -10,9 +12,8 @@ {-# LANGUAGE UndecidableInstances #-} module Encode where -import Data.Coerce-import Data.List-import Data.Override.Internal+import Data.List (intercalate)+import Data.Override (Override) import GHC.Generics  class Encode a where@@ -21,19 +22,10 @@   encode = gencode . from  instance-  ( Generic a-  , GOverride xs (Rep a)+  ( Generic (Override a xs)   , GEncode (Rep (Override a xs))   ) => Encode (Override a xs) -instance-  ( u ~ Using ms a xs-  , Coercible a u-  , Encode u-  ) => Encode (Overridden ms a xs)-  where-  encode = encode @u . coerce- class GEncode f where   gencode :: f a -> String @@ -70,11 +62,12 @@ instance Encode Char where   encode = pure +-- | Create an overlapping instance to verify that overriding with+-- 'ListOf' avoids this instance. instance {-# OVERLAPPING #-} Encode String where   encode = id -instance (Encode a) => Encode [a] where-  encode = intercalate "," . map encode+deriving via (ListOf a) instance (Encode a) => Encode [a]  newtype ListOf a = ListOf { unListOf :: [a] } 

@@ -7,9 +7,9 @@ {-# LANGUAGE TypeOperators #-} module Main where -import Data.Monoid-import Data.Override-import Encode+import Data.Monoid (Any(..))+import Data.Override (Override(..), As, At)+import Encode (Encode(encode), ListOf(..)) import GHC.Generics (Generic) import Test.Hspec @@ -29,6 +29,8 @@       it "Sum1" testSum1'Encode       it "Sum2" testSum2'Encode       it "Sum3" testSum3'Encode+      it "Sum4" testSum4'Encode+      it "Sum5" testSum5'Encode  -- | Overriding instances by type. data Rec1 = Rec1@@ -117,3 +119,31 @@ testSum3'Encode = do   encode (Sum3List [1, 2, 3 :: Int]) `shouldBe` "Sum3List:1,2,3"   encode (Sum3Null @Int) `shouldBe` "Sum3Null:"++-- | Override using 'At' which includes a type variable.+data Sum4 a = Sum4List [a] | Sum4String String+  deriving stock (Show, Eq, Generic)+  deriving (Encode)+    via Override (Sum4 a)+      '[ At "Sum4List" 0 (ListOf a)+       ]++testSum4'Encode :: IO ()+testSum4'Encode = do+  encode (Sum4List [1, 2, 3 :: Int]) `shouldBe` "Sum4List:1,2,3"+  encode (Sum4List "foo") `shouldBe` "Sum4List:f,o,o"+  encode (Sum4String @Char "foo") `shouldBe` "Sum4String:foo"++-- | Override using 'At' which uses a kind of @* -> *@.+data Sum5 a = Sum5String String | Sum5List Char [a]+  deriving stock (Show, Eq, Generic)+  deriving (Encode)+    via Override (Sum5 a)+      '[ At "Sum5List" 1 (ListOf a)+       ]++testSum5'Encode :: IO ()+testSum5'Encode = do+  encode (Sum5List 'a' [1, 2, 3 :: Int]) `shouldBe` "Sum5List:a,1,2,3"+  encode (Sum5List 'a' "foo") `shouldBe` "Sum5List:a,f,o,o"+  encode (Sum5String @Char "foo") `shouldBe` "Sum5String:foo"