generic-override 0.2.0.0 → 0.3.0.0

raw patch · 7 files changed

+193/−31 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• README.md +9/−8
• generic-override.cabal +5/−2
• src/Data/Override/Instances.hs +1/−1
• src/Data/Override/Internal.hs +43/−19
• test/Encode.hs +82/−0
• test/Test.hs +47/−0

@@ -1,6 +1,11 @@ # Changelog for generic-override -## 0.1.0.0+## 0.3.0.0++* 'Override' support for sum types+* 'As' support for higher kinds up (up to arity 10)++## 0.2.0.0  * Instances for Eq, Ord, Semigroup, Monoid * Added With combinator

@@ -1,16 +1,16 @@ # generic-override -[![Hackage](https://img.shields.io/hackage/v/generic-override.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override) [![Build](https://img.shields.io/travis/estatico/generic-override.svg?logo=travis)](http://travis-ci.org/estatico/generic-override) -For the associated blog post describing how this works, see-[Overriding Type Class Instances](http://caryrobbins.com/dev/overriding-type-class-instances-2/).+| Library                | Version |+| ---------------------- | ------- |+| generic-override       | [![generic-override](https://img.shields.io/hackage/v/generic-override.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override) |+| generic-override-aeson | [![generic-override-aeson](https://img.shields.io/hackage/v/generic-override-aeson.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override-aeson) |  ------------------------- -This repo contains the following libraries --* [generic-override](https://hackage.haskell.org/package/generic-override)-* [generic-override-aeson](https://hackage.haskell.org/package/generic-override-aeson)+For the associated blog post describing how this works, see+[Overriding Type Class Instances](http://caryrobbins.com/dev/overriding-type-class-instances-2/).  ------------------------- @@ -71,5 +71,6 @@ {"foo":12,"bar":["h","i"],"baz":"BYE"} ``` -For more examples, see the test suite in-[generic-override-aeson](https://github.com/estatico/generic-override/blob/master/generic-override-aeson/test/Test.hs).+For more examples, see the test suites in -+* [generic-override](https://github.com/estatico/generic-override/blob/master/generic-override/test/Test.hs).+* [generic-override-aeson](https://github.com/estatico/generic-override/blob/master/generic-override-aeson/test/Test.hs).

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               generic-override-version:            0.2.0.0+version:            0.3.0.0 license:            BSD3 license-file:       LICENSE copyright:          2020 Estatico Studios LLC@@ -39,7 +39,10 @@     type:             exitcode-stdio-1.0     main-is:          Test.hs     hs-source-dirs:   test-    other-modules:    Paths_generic_override+    other-modules:+        Encode+        Paths_generic_override+     default-language: Haskell2010     ghc-options:      -threaded -rtsopts -with-rtsopts=-N     build-depends:

@@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Override.Instances where+module Data.Override.Instances () where  import Data.Coerce (Coercible, coerce) import Data.Function (on)

@@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -19,14 +20,12 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Override.Internal where -import Data.Type.Bool (If)-import Data.Type.Equality (type (==)) import GHC.Generics import GHC.TypeLits (Symbol)  -- | The feature of this library. For use with DerivingVia.--- Apply it to a type 'a' and supply a type-level list of instance--- overrides 'xs'.+-- Apply it to a type @a@ and supply a type-level list of instance+-- overrides @xs@. newtype Override a (xs :: [*]) = Override a  -- | Unwrap an 'Override' value.@@ -38,7 +37,7 @@ override a _ = Override a  -- | Used to construct a type-level override. Usually used infix.--- The 'o' should be either a type (kind '*') or a type-level string+-- The @o@ should be either a type (kind '*') or a type-level string -- (kind 'Symbol'). data As (o :: k) n @@ -86,29 +85,54 @@   overrideFrom (f :*: g) = overrideFrom @xs f :*: overrideFrom @xs g   overrideTo (f :*: g) = overrideTo @xs f :*: overrideTo @xs g +instance (GOverride xs f, GOverride xs g) => GOverride xs (f :+: g) where+  type OverrideRep xs (f :+: g) = OverrideRep xs f :+: OverrideRep xs g++  overrideFrom = \case+    L1 f -> L1 $ overrideFrom @xs f+    R1 g -> R1 $ overrideFrom @xs g++  overrideTo = \case+    L1 f -> L1 $ overrideTo @xs f+    R1 g -> R1 $ overrideTo @xs g+ 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) --- | Type family used to determine which override from 'xs'--- to replace 'x' with, if any. The 'ms' holds the field name--- for 'x', if applicable.-type family Using (ms :: Maybe Symbol) (x :: *) (xs :: [*]) where+instance GOverride xs U1 where+  type OverrideRep xs U1 = U1+  overrideFrom U1 = U1+  overrideTo U1 = U1++-- | 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   -- No matching override found.-  Using ms x '[] = x+  Using ms a '[] = a    -- Override the matching field.-  Using ms x (As (o :: Symbol) n ': xs) =-    If (ms == 'Just o) n (Using ms x xs)--  Using ms x (With (o :: Symbol) w ': xs) =-    If (ms == 'Just o) (w x) (Using ms x xs)+  Using ('Just o) a (As o n ': xs) = n+  Using ('Just o) a (With o w ': xs) = w a    -- Override the matching type.-  Using ms x (As (o :: *) n ': xs) =-    If (x == o) n (Using ms x xs)+  Using ms a (As a n ': xs) = n+  Using ms a (With a w ': xs) = w a -  Using ms x (With (o :: *) w ': xs) =-    If (x == o) (w x) (Using ms x xs)+  -- 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++  -- No match on this override, recurse.+  Using ms a (x ': xs) = Using ms a xs

@@ -0,0 +1,82 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Encode where++import Data.Coerce+import Data.List+import Data.Override.Internal+import GHC.Generics++class Encode a where+  encode :: a -> String+  default encode :: (Generic a, GEncode (Rep a)) => a -> String+  encode = gencode . from++instance+  ( Generic a+  , GOverride xs (Rep a)+  , 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++instance (GEncode f) => GEncode (M1 D x f) where+  gencode (M1 f) = gencode f++instance (GEncode f, Constructor c) => GEncode (M1 C c f) where+  gencode m@(M1 f) = conName m <> ":" <> gencode f++instance (GEncode f, GEncode g) => GEncode (f :*: g) where+  gencode (f :*: g) = gencode f <> "," <> gencode g++instance (GEncode f, GEncode g) => GEncode (f :+: g) where+  gencode = \case+    L1 f -> gencode f+    R1 g -> gencode g++instance (GEncode f, Selector s) => GEncode (M1 S s f) where+  gencode m@(M1 f) =+    if null (selName m) then+      gencode f+    else+      selName m <> "=" <> gencode f++instance (Encode a) => GEncode (K1 R a) where+  gencode (K1 a) = encode a++instance GEncode U1 where+  gencode _ = ""++instance Encode Int where+  encode = show++instance Encode Char where+  encode = pure++instance {-# OVERLAPPING #-} Encode String where+  encode = id++instance (Encode a) => Encode [a] where+  encode = intercalate "," . map encode++newtype ListOf a = ListOf { unListOf :: [a] }++instance (Encode a) => Encode (ListOf a) where+  encode = intercalate "," . map encode . unListOf

@@ -3,11 +3,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Main where  import Data.Monoid import Data.Override+import Encode import GHC.Generics (Generic) import Test.Hspec @@ -20,8 +22,13 @@       it "Rec1" testRec1'Monoid     describe "Eq" do       it "Rec2" testRec2'Eq+      it "Sum1" testSum1'Eq     describe "Ord" do       it "Rec2" testRec2'Ord+    describe "Encode" do+      it "Sum1" testSum1'Encode+      it "Sum2" testSum2'Encode+      it "Sum3" testSum3'Encode  -- | Overriding instances by type. data Rec1 = Rec1@@ -70,3 +77,43 @@   (Rec2 "foo" 0 <= Rec2 "bar" 0) `shouldBe` True   (Rec2 "foo" 1 <= Rec2 "bar" 0) `shouldBe` False   (Rec2 ""    0 >= Rec2 "bar" 0) `shouldBe` False++-- | Override support for sum types.+data Sum1 = Sum1String String | Sum1Int Int+  deriving stock (Show, Generic)+  deriving (Eq) via (Override Sum1 '[String `As` ByLength])+  deriving (Encode) via (Override Sum1 '[String `As` ListOf Char])++testSum1'Eq :: IO ()+testSum1'Eq = do+  (Sum1String "foo" == Sum1String "bar") `shouldBe` True+  (Sum1Int 3 == Sum1Int 3) `shouldBe` True+  (Sum1String "foo" == Sum1String "ba") `shouldBe` False+  (Sum1String "foo" == Sum1Int 3) `shouldBe` False+  (Sum1Int 3 == Sum1Int 2) `shouldBe` False++testSum1'Encode :: IO ()+testSum1'Encode = do+  encode (Sum1String "foo") `shouldBe` "Sum1String:f,o,o"+  encode (Sum1Int 1) `shouldBe` "Sum1Int:1"++-- | Override using 'As' which includes a type variable.+data Sum2 a = Sum2List [a] | Sum2Null+  deriving stock (Show, Eq, Generic)+  deriving (Encode) via (Override (Sum2 a) '[[a] `As` ListOf a])++testSum2'Encode :: IO ()+testSum2'Encode = do+  encode (Sum2List [1, 2, 3 :: Int]) `shouldBe` "Sum2List:1,2,3"+  encode (Sum2Null @Int) `shouldBe` "Sum2Null:"++-- | Override using 'As' which uses a kind of @* -> *@. Convenient+-- so you don't have to apply the type parameter.+data Sum3 a = Sum3List [a] | Sum3Null+  deriving stock (Show, Eq, Generic)+  deriving (Encode) via (Override (Sum3 a) '[[] `As` ListOf])++testSum3'Encode :: IO ()+testSum3'Encode = do+  encode (Sum3List [1, 2, 3 :: Int]) `shouldBe` "Sum3List:1,2,3"+  encode (Sum3Null @Int) `shouldBe` "Sum3Null:"