generic-override (empty) → 0.0.0.0

raw patch · 7 files changed

+243/−0 lines, 7 filesdep +basesetup-changed

Dependencies added: base

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +66/−0
Setup.hs +2/−0
generic-override.cabal +33/−0
src/Data/Override.hs +9/−0
src/Data/Override/Internal.hs +100/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for scoped-instances++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Estatico Studios LLC (c) 2020++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 Estatico Studios LLC 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+OWNER 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.

+ README.md view

@@ -0,0 +1,66 @@+# 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/).++-------------------------++This library provides the ability to override instances used by generic derivation.++## Example++```haskell+-- Needed for constructing our 'Override' type in the DerivingVia clause.+import Data.Override (Override(Override), As)+-- Provides aeson support for generic-override (lives in generic-override-aeson).+import Data.Override.Aeson ()+-- Basic imports we need for the example.+import Data.Aeson (ToJSON(toJSON))+import Data.Text (Text)+import qualified Data.Text as Text++-- | A simple record type. We'll use generic derivation for the 'ToJSON' instance+-- but override the instances used by derivation for the 'String' and 'baz'+-- fields.+data MyRec = MyRec+  { foo :: Int+  , bar :: String+  , baz :: Text+  } deriving stock (Show, Eq, Generic)+    deriving (ToJSON)+      via Override MyRec+            '[ -- Derive the 'String' field via 'CharArray'.+               String `As` CharArray+               -- Derive the 'baz' field via 'Uptext'.+             , "baz" `As` Uptext+             ]++-- | Newtype wrapper to override 'ToJSON Text' instances with ones that+-- encode the 'Text' as uppercase.+newtype Uptext = Uptext { unUptext :: Text }++instance ToJSON Uptext where+  toJSON = toJSON . Text.toUpper . unUptext++-- | Newtype wrapper to override 'ToJSON String' instances with ones that+-- encode the 'String' as a JSON array of characters.+newtype CharArray = CharArray { unCharArray :: String }++instance ToJSON CharArray where+  toJSON = toJSON . map (:[]) . unCharArray+```++Let's serialize an example `MyRec` to JSON -++```haskell+% ghci+> :{+  Data.ByteString.Lazy.Char8.putStrLn+    $ Data.Aeson.encode+    $ Data.Aeson.toJSON MyRec { foo = 12, bar = "hi", baz = "bye" }+  :}+{"foo":12,"bar":["h","i"],"baz":"BYE"}+```++For more examples, see the test suite in+[generic-override-aeson](./aeson/test/Test.hs).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ generic-override.cabal view

@@ -0,0 +1,33 @@+cabal-version: 1.12+name: generic-override+version: 0.0.0.0+license: BSD3+license-file: LICENSE+copyright: 2020 Estatico Studios LLC+maintainer: carymrobbins@gmail.com+author: Cary Robbins+homepage: https://github.com/estatico/generic-override#readme+bug-reports: https://github.com/estatico/generic-override/issues+synopsis: Provides functionality for overriding instances for generic derivation+description:+    Please see the README on GitHub at <https://github.com/estatico/generic-override#readme>+category: Generics+build-type: Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type: git+    location: https://github.com/estatico/generic-override++library+    exposed-modules:+        Data.Override+        Data.Override.Internal+    hs-source-dirs: src+    other-modules:+        Paths_generic_override+    default-language: Haskell2010+    build-depends:+        base >=4.7 && <5

+ src/Data/Override.hs view

@@ -0,0 +1,9 @@+module Data.Override (module X) where++import Data.Override.Internal as X+  ( Override(Override), unOverride+  , Overridden(Overridden), unOverridden+  , As+  , Using+  , override+  )

+ src/Data/Override/Internal.hs view

@@ -0,0 +1,100 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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'.+newtype Override a (xs :: [*]) = Override a+  deriving stock (Show, Eq)++-- | Unwrap an 'Override' value.+unOverride :: Override a xs -> a+unOverride (Override a) = a++-- | Construct an 'Override' using a proxy of overrides.+override :: a -> proxy xs -> Override a xs+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+-- (kind 'Symbol').+data As (o :: k) n++-- | 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++-- | 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 xs (Rep a)+  from = overrideFrom @xs . from . unOverride+  to = Override . to . overrideTo @xs++-- | 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++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 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)++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 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+  -- No matching override found.+  Using ms x '[] = x++  -- Override the matching field.+  Using ms x (As (o :: Symbol) n ': xs) =+    If (ms == 'Just o) n (Using ms x xs)++  -- Override the matching type.+  Using ms x (As (o :: *) n ': xs) =+    If (x == o) n (Using ms x xs)