overloaded-records 0.3.0.0 → 0.4.0.0

raw patch · 8 files changed

+2149/−806 lines, 8 filesdep +overloaded-recordsdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: overloaded-records, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +30/−0
• README.md +111/−18
• overloaded-records.cabal +15/−4
• src/Data/OverloadedLabels.hs +9/−5
• src/Data/OverloadedRecords.hs +1159/−151
• src/Data/OverloadedRecords/TH.hs +17/−624
• src/Data/OverloadedRecords/TH/Internal.hs +689/−0
• test/TestCase/Data/OverloadedRecords.hs +119/−4

@@ -1,6 +1,36 @@ # ChangeLog / ReleaseNotes  +## Version 0.4.0.0++* Renamed `SetField` type class to `ModifyField`, it now contains following+  methods (**breaking change**):+    * `modifyField :: Proxy# l -> (a -> b) -> s -> t`+    * `setField :: Proxy# l -> s -> b -> t`+    * `fieldLens :: Functor f => Proxy# l -> (a -> f b) -> s -> f t`+* Instances for tuples (i.e. `(a, b)`, `(a, b, c)`, ...) and lists (i.e.+  `[a]`). (**new**)+* Definitions from `Data.OverloadedRecords.TH` were moved to+  `Data.OverloadedRecords.TH.Internal`, so that API can be split in to stable+  and unstable (internal) API. (**change**)+* Aliases `HasField'` and `ModifyField'` that enforce `s = t` and `a = b`. This+  is similar to definitions like `Lens'`. Simplified versions of methods and+  functions are included using the same naming convention. (**new**)+* `Setter` and `Setter'` changed to type aliases for `Modifier` type.+  (**breaking change**)+* Introducing `Setting` type alias for `Modifier` along with `setting`, which+  is an alternative to `set` operation. (**new**)+    * `setting :: Setting a s t b -> Proxy a -> b -> s -> t`+* Changed order of arguments of functions `set` and `set'` (**breaking+  change**):+    * `set :: Setter s t b -> b -> s -> t`+    * `set' :: Setter' s a -> a -> s -> s`+* Introduced type family `R` that can be used to define more compact type+  signatures when mentioning multiple record fields in it. (**new**)+* Uploaded to [Hackage][]:+  <http://hackage.haskell.org/package/overloaded-records-0.4.0.0>++ ## Version 0.3.0.0  * Fixed defaultMakeFieldName, which actually behaved correctly only in very few

@@ -14,7 +14,7 @@ is built on top of functionality that is included in GHC 8.0.1, but it works on older GHC versions as well. Most importantly, this library provides Template Haskell functions for automatic deriving of instancess for `HasField` and-`SetField` type classes. With these instances overloaded fields can be used+`ModifyField` type classes. With these instances overloaded fields can be used directly as getters and lenses.  ```Haskell@@ -57,37 +57,127 @@  ## Usage Example +Following is a more complex usage example that demonstrates some of the+possibilities of *Overloaded Labels* provided by this library.+ ```Haskell-{-# LANGUAGE DataKinds #-}              -- overloadedRecord, labels-{-# LANGUAGE FlexibleContexts #-}       -- labels-{-# LANGUAGE FlexibleInstances #-}      -- overloadedRecord-{-# LANGUAGE MultiParamTypeClasses #-}  -- overloadedRecord-{-# LANGUAGE TemplateHaskell #-}        -- overloadedRecord, labels-{-# LANGUAGE TypeFamilies #-}           -- overloadedRecord-module FooBar+-- Basic set of language extensions required when defining instances for+-- classes and type families from "Data.OverloadedRecords".+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- Following language extensions are required by code like this:++{-# LANGUAGE ConstraintKinds #-}+    -- Codomain of type family 'R' is a 'Constraint' kind.++{-# LANGUAGE FlexibleContexts #-}+    -- Required in example when field type (second argument of ':::') is a+    -- specific type instead of a polymorphic type.++{-# LANGUAGE TypeOperators #-}+    -- Required due to usage of ':::' type alias.++-- Following language extensions are available only in GHC >=8:++{-# LANGUAGE OverloadedLabels #-}+    -- Enables #label syntactic sugar.++module Example   where -import Data.Default.Class (Default(def))+import Data.Default (Default(def))+    -- Provided by one of these packages:+    --+    -- * data-default+    -- * data-default-extra +import Data.OverloadedRecords import Data.OverloadedRecords.TH (overloadedRecord)-import Data.OverloadedLabels.TH (label, labels)  -data Foo a = Foo-    { _x :: Int-    , _y :: a+data V3 a = V3+    { v3x :: !a+    , v3y :: !a+    , v3z :: !a     }+  deriving Show -overloadedRecord def ''Foo-labels ["x", "y"]+-- Following line derives instances for various type classes and type+-- families that are provided by the overloaded-records library.+--+-- However with def (default settings) this is done only for fields that+-- start with type name, data constructor name, or underscore. Prefix is+-- stripped. In example "v3x" is transformed in to "x" and so would be+-- "_x".+overloadedRecord def ''V3 -newtype Bar a = Bar {_bar :: a}+data V4 a = V4+    { v4x :: !a+    , v4y :: !a+    , v4z :: !a+    , v4t :: !a+    }+  deriving Show -overloadedRecord def ''Bar-label "bar"+overloadedRecord def ''V4++zeroV3+    :: (Num a, R ["x" ::: a, "y" ::: a, "z" ::: a] r)+    => r -> r+zeroV3 = set' #x 0 . set' #y 0 . set' #z 0 ``` +The following type signatures for `zeroV3` are equivalent: +```Haskell+zeroV3+    :: (Num a, R ["x" ::: a, "y" ::: a, "z" ::: a] r)+    => r -> r+```++```Haskell+zeroV3+    ::  ( Num a+        , ModifyField' "x" r a+        , ModifyField' "y" r a+        , ModifyField' "z" r a+        )+    => r -> r+```++One of the biggest features of *Overloaded Records* is the possibility to+define functions that do not depend on concrete data types, but on the "fields"+they provide. In example function `zeroV3` can be applied to anything that has+fields `"x"`, `"y"`, and `"z"` that reference values of some `Num` type:++```Haskell+λ> zeroV3 (V3 1 1 1 :: V3 Int)+V3 {_x = 0, _y = 0, _z = 0}+```++```Haskell+λ> zeroV3 (V4 1 1 1 1 :: V4 Int)+V4 {_x = 0, _y = 0, _z = 0, _t = 1}+```++Function `zeroV3` can be also defined using operators from+[lens][Hackage: lens] library:++```Haskell+zeroV3+    :: (Num a, R ["x" ::: a, "y" ::: a, "z" ::: a] r)+    => r -> r+zeroV3 r = r+    & #x .~ 0+    & #y .~ 0+    & #z .~ 0+```++ ## License  The BSD 3-Clause License, see [LICENSE][] file for details. This implementation@@ -103,6 +193,9 @@ [GHC Wiki: OverloadedRecordFields]:   https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields   "OverloadedRecordFields language extension on GHC Wiki"+[Hackage: lens]:+  https://hackage.haskell.org/package/lens+  "lens package on Hackage" [Hackage: overloaded-records]:   http://hackage.haskell.org/package/overloaded-records   "overloaded-records package on Hackage"

@@ -1,12 +1,12 @@ name:                   overloaded-records-version:                0.3.0.0+version:                0.4.0.0 synopsis:               Overloaded Records based on current GHC proposal. description:   Implementation of /Overloaded Record Fields/ based on current GHC proposal.   It is built on top of functionality that is included in GHC 8.0.1, but it   works on older GHC versions as well. Most importantly, this library provides   Template Haskell functions for automatic deriving of instancess for-  @HasField@ and @SetField@ type classes. With these instances overloaded+  @HasField@ and @ModifyField@ type classes. With these instances overloaded   fields can be used directly as getters and lenses.   .   See README for usage examples.@@ -44,11 +44,13 @@     , Data.OverloadedLabels.TH     , Data.OverloadedRecords     , Data.OverloadedRecords.TH+    , Data.OverloadedRecords.TH.Internal   -- other-modules:    default-language:     Haskell2010   other-extensions:-      CPP+      ConstraintKinds+    , CPP     , DataKinds     , DeriveDataTypeable     , DeriveGeneric@@ -93,6 +95,7 @@     , Data.OverloadedLabels.TH     , Data.OverloadedRecords     , Data.OverloadedRecords.TH+    , Data.OverloadedRecords.TH.Internal     , TestCase     , TestCase.Data.OverloadedRecords @@ -133,6 +136,14 @@       -- ^ Lower versions have more restrictive bounds on test-framework.     -- }}} Test-suite dependencies -------------------------------------------- +    , overloaded-records++  if impl(ghc <7.10)+    -- Identity functor is available in base bundled with GHC >=7.10, for older+    -- we need to get it elsewhere.+    build-depends:+      transformers >=0.2+   if impl(ghc >=8.0)     cpp-options:       -DHAVE_MONAD_FAIL@@ -152,4 +163,4 @@ source-repository this   type:                 git   location:             git://github.com/trskop/overloaded-records.git-  tag:                  0.3.0.0+  tag:                  0.4.0.0

@@ -15,8 +15,8 @@ -- Stability:    experimental -- Portability:  NoImplicitPrelude ----- This module defines the `IsLabel` class is used by the OverloadedLabels--- extension.  See the+-- This module defines the `IsLabel` class which is used by the OverloadedLabels+-- language extension.  See the -- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page> -- for more details. --@@ -26,22 +26,26 @@ -- > fromLabel (proxy# :: Proxy# "foo") :: alpha -- -- plus a wanted constraint @IsLabel "foo" alpha@.+--+-- On /GHC >=8.0.1/ we just reexport "GHC.OverloadedLabels" module. module Data.OverloadedLabels     (     -- * Oveloaded Labels+#ifdef HAVE_OVERLOADED_LABELS+      module GHC.OverloadedLabels+#else       IsLabel(..)+#endif     )   where  #ifdef HAVE_OVERLOADED_LABELS-import GHC.OverloadedLabels (IsLabel(fromLabel))+import GHC.OverloadedLabels #else import GHC.TypeLits (Symbol) import GHC.Exts (Proxy#)-#endif  -#ifndef HAVE_OVERLOADED_LABELS class IsLabel (l :: Symbol) a where     fromLabel :: Proxy# l -> a #endif

@@ -1,151 +1,1159 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module:       $HEADER$--- Description:  Magic classes for OverloadedRecordFields.--- Copyright:    (c) 2016, Peter Trško--- License:      BSD3------ Maintainer:   peter.trsko@gmail.com--- Stability:    experimental--- Portability:  DataKinds, FlexibleInstances, FunctionalDependencies,---               MagicHash, MultiParamTypeClasses, NoImplicitPrelude,---               TypeFamilies, UndecidableInstances------ Magic classes for OverloadedRecordFields.------ Implementation is based on:--- <https://github.com/adamgundry/records-prototype/blob/master/CoherentPrototype.hs>--- by Adam Gundry under MIT License.-module Data.OverloadedRecords-    (-    -- * Oveloaded Labels-      module Data.OverloadedLabels--    -- * Overloaded Record Fields-    ---    -- ** Getter-    , FieldType-    , HasField(..)--    -- ** Setter-    , UpdateType-    , SetField(..)-    , Setter-    , set--    -- ** IsLabel For Getter and Lens-    , FromArrow-    , IsFieldAccessor(..)-    )-  where--import Data.Bool (Bool(False, True))-import Data.Functor (Functor, (<$>))-import GHC.TypeLits (Symbol)-import GHC.Exts (Proxy#)--import Data.OverloadedLabels----- | When accessing field named @l :: Symbol@ of a record @s :: *@, then the--- type of the value in that field is @'FieldType' l s@.-type family FieldType (l :: Symbol) (s :: *) :: *---- | If field @l :: Symbol@ of a record @s :: *@ is set to new value which has--- type @a :: *@, then the modified record will have type @'UpdateType' l s a@.-type family UpdateType (l :: Symbol) (s :: *) (a :: *) :: *---- | Definition of this class is based on:--- <https://phabricator.haskell.org/D1687>-class HasField (l :: Symbol) s a | l s -> a where-    -- | Get value of a field.-    getField :: Proxy# l -> s -> a--class-    ( HasField l s b-    , FieldType l s ~ b-    ) => SetField l s b-  where-    -- | Set value of a field.-    setField :: Proxy# l -> s -> b -> UpdateType l s b---- | Returns 'True' if type @a@ is a function.-type family FromArrow (a :: *) :: Bool where-    FromArrow (x -> y) = 'True-    FromArrow t        = 'False---- | Distinguish between getter and lens.-class-    ( z ~ FromArrow x-    ) => IsFieldAccessor (l :: Symbol) x y (z :: Bool) | l y -> x-  where-    fieldAccessor :: Proxy# l -> x -> y--instance IsFieldAccessor l x y (FromArrow x) => IsLabel l (x -> y) where-    fromLabel = fieldAccessor---- | Overloaded lens:------ @--- 'Functor' f => 'Proxy#' l -> (a -> f b) -> s -> f t--- @-instance-    ( Functor f-    , HasField l s a-    , SetField l s b-    , FieldType l s ~ a-    , UpdateType l s b ~ t-    ) => IsFieldAccessor l (a -> f b) (s -> f t) 'True-  where-    fieldAccessor proxy f s = setField proxy s <$> f (getField proxy s)---- | Overloaded getter:------ @--- 'Proxy#' l -> r -> a--- @-instance-    ( HasField l s a-    , FieldType l s ~ a-    , FromArrow s ~ 'False-    ) => IsFieldAccessor l s a 'False-  where-    fieldAccessor = getField---- | Wrapper for a set function, lens naming convention is used for type--- variables. Its instance for 'IsLabel' forces overloaded label to behave as a--- setter.-newtype Setter s t b = Setter (s -> b -> t)---- | Extract set function from 'Setter'. Using 'Setter' instance for 'IsLabel'--- forces overloaded label to behave as a setter.------ Usage example:------ @--- newtype Bar a = Bar {_bar :: a}---   deriving Show------ overloadedRecord ''Bar--- @------ >>> set bar (Bar (Just False)) Nothing--- Bar {_bar = Nothing}-set :: Setter s t b -> s -> b -> t-set (Setter f) = f--instance-    ( SetField l s b-    , UpdateType l s b ~ t-    ) => IsLabel l (Setter s t b)-  where-    fromLabel _proxy = Setter (setField _proxy)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module:       $HEADER$+-- Description:  Magic classes for OverloadedRecordFields.+-- Copyright:    (c) 2016, Peter Trško+-- License:      BSD3+--+-- Maintainer:   peter.trsko@gmail.com+-- Stability:    experimental+-- Portability:  ConstraintKinds, DataKinds, DeriveDataTypeable, DeriveGeneric,+--               FlexibleInstances, FlexibleContexts, FunctionalDependencies,+--               LambdaCase MagicHash, MultiParamTypeClasses,+--               NoImplicitPrelude, RankNTypes, TypeFamilies, TypeOperators,+--               UndecidableInstances+--+-- Magic classes for OverloadedRecordFields.+--+-- Implementation is based on:+-- <https://github.com/adamgundry/records-prototype/blob/master/CoherentPrototype.hs>+-- by Adam Gundry under MIT License.+module Data.OverloadedRecords+    (+    -- * Usage Examples+    --+    -- $usageExamples++    -- * Oveloaded Labels+      module Data.OverloadedLabels++    -- * Overloaded Record Fields+    --+    -- ** Getter+    , FieldType+    , HasField(..)++    -- ** Setter and Modifier+    , UpdateType+    , ModifyField(..)+    , R+    , (:::)++    , Setting+    , setting++    , Setter+    , set++    , Modifier+    , modify++    -- ** Simple Setter and Modifier+    , ModifyField'+    , fieldLens'+    , modifyField'+    , setField'++    , Setter'+    , set'++    , Modifier'+    , modify'++    -- ** IsLabel For Getter and Lens+    , FromArrow+    , IsFieldAccessor(..)+    )+  where++import Data.Bool (Bool(False, True))+import Data.Function (const)+import Data.Functor (Functor, (<$>))+import Data.Maybe (Maybe(Just, Nothing))+import Data.Proxy (Proxy)+import Data.Typeable (Typeable)+import GHC.Exts (Constraint, Proxy#)+import GHC.Generics (Generic)+import GHC.TypeLits (Symbol)++import Data.OverloadedLabels+++-- | When accessing field named @l :: Symbol@ of a record @s :: *@, then the+-- type of the value in that field is @'FieldType' l s@.+type family FieldType (l :: Symbol) (s :: *) :: *++-- | If field @l :: Symbol@ of a record @s :: *@ is set to new value which has+-- type @a :: *@, then the modified record will have type @'UpdateType' l s a@.+type family UpdateType (l :: Symbol) (s :: *) (a :: *) :: *++-- | Definition of this class is based on:+-- <https://phabricator.haskell.org/D1687>+class HasField (l :: Symbol) s a | l s -> a where+    -- | Get value of a field.+    getField :: Proxy# l -> s -> a++-- | Represents overloaded record fields that can be modified, i.e. updated.+--+-- @+-- forall l a b s t.+--   'ModifyField' l s t a b => a /= b \<==\> s /= t+-- @+--+-- In other words, if field is modified and its type has changed, then the type+-- of the record has to change as well, and vice versa. Functional dependencies+-- enforce this rule.+--+-- /Since 0.4.0.0/+class (HasField l s a) => ModifyField (l :: Symbol) s t a b+    | l s -> a, l t -> b, l s b -> t, l t a -> s+  where+    {-# MINIMAL modifyField | setField #-}++    -- | Modify overloaded field @l :: 'Symbol'@ of record @s@ using pure+    -- function @a -> b@, and produce new record @t@.+    modifyField :: Proxy# l -> (a -> b) -> s -> t+    modifyField proxy f s = setField proxy s (f (getField proxy s))++    -- | Set overloaded field @l :: 'Symbol'@ of record @s@ to value of type+    -- @b@, and produce new record @t@. Please note that there is no mention of+    -- the type @a@, therefore the compiler may not be able to derive it in+    -- some cases.+    setField :: Proxy# l -> s -> b -> t+    setField proxy s b = modifyField proxy (const b) s++    -- | Lens for overloaded field @l :: 'Symbol'@ of record @s@.+    fieldLens :: Functor f => Proxy# l -> (a -> f b) -> s -> f t+    fieldLens proxy f s = setField proxy s <$> f (getField proxy s)++-- | Same as 'ModifyField', but type-changing assignment is prohibited.+--+-- /Since 0.4.0.0/+type ModifyField' l s a = ModifyField l s s a a++-- | Same as 'setFiend', but the field type can not be changed.+--+-- /Since 0.4.0.0/+setField' :: ModifyField' l s a => Proxy# l -> s -> a -> s+setField' = setField++-- | Same as 'modifyField', but the field type can not be changed.+--+-- /Since 0.4.0.0/+modifyField' :: ModifyField' l s a => Proxy# l -> (a -> a) -> s -> s+modifyField' = modifyField++-- | Same as 'modifyField', but the field type can not be changed.+--+-- /Since 0.4.0.0/+fieldLens'+    :: (Functor f, ModifyField' l s a)+    => Proxy# l+    -> (a -> f a)+    -> s -> f s+fieldLens' = fieldLens++-- | Returns 'True' if type @a :: \*@ is a function.+type family FromArrow (a :: *) :: Bool where+    FromArrow (x -> y) = 'True+    FromArrow t        = 'False++-- | Distinguish between getter and lens.+class+    ( z ~ FromArrow x+    ) => IsFieldAccessor (l :: Symbol) x y (z :: Bool) | l y -> x+  where+    fieldAccessor :: Proxy# l -> x -> y++-- | Overloaded lens:+--+-- @+-- 'Functor' f => 'Proxy#' l -> (a -> f b) -> s -> f t+-- @+instance+    ( Functor f+    , ModifyField l s t a b+    ) => IsFieldAccessor l (a -> f b) (s -> f t) 'True+  where+    fieldAccessor = fieldLens++-- | Overloaded getter:+--+-- @+-- 'Proxy#' l -> r -> a+-- @+instance+    ( HasField l s a+    , FromArrow s ~ 'False+    ) => IsFieldAccessor l s a 'False+  where+    fieldAccessor = getField++instance IsFieldAccessor l x y (FromArrow x) => IsLabel l (x -> y) where+    fromLabel = fieldAccessor++-- | Using this type family provides more compact type signatures for multiple+-- record fields.+--+-- @+-- data V3 a = V3+--     { _x :: a+--     , _y :: a+--     , _z :: a+--     }+--   deriving Show+--+-- 'Data.OverloadedRecords.TH.overloadedRecord' def ''V3+--+-- setV3+--     :: 'R' [\"x\" ':::' a, \"y\" ':::' a, \"z\" ':::' a] r+--     => a -> a -> a -> r -> r+-- setV3 x y z = 'set'' \#x x . 'set'' \#y y . 'set'' \#z z+-- @+--+-- >>> setV3 0 0 0 (V3 1 1 1 :: V3 Int)+-- V3 {_x = 0, _y = 0, _z = 0}+--+-- /Since 0.4.0.0/+type family R (ts :: [(Symbol, *)]) (r :: *) :: Constraint where+    R '[] r             = ()+    R ('(l, a) ': ts) r = (ModifyField' l r a, R ts r)++-- | This type alias is used for more readable type signatures when using 'R'+-- type family.+--+-- /Since 0.4.0.0/+type (:::) (l :: Symbol) (a :: *) = '(l, a)++-- {{{ Setter -----------------------------------------------------------------++-- | 'Setting' is just a form of a 'Modifier' that allows us to specify what+-- was the original type of the value we are changing.+--+-- See also 'Setter', 'Setter'', 'Modifier', and 'Modifier''.+--+-- /Since 0.4.0.0/+type Setting a s t b = Modifier s t a b++-- | Same as 'set', but allows us to use phantom type to restrict the type of a+-- value before it was changed.+--+-- @+-- newtype Bar a = Bar {_bar :: a}+--   deriving Show+--+-- overloadedRecord ''Bar+-- @+--+-- Now we can use 'setting' to change the value stored in @Bar@. The type+-- signature in following example is not required, it is what type checker+-- would infer.+--+-- @+-- 'setting' \#bar ('Proxy' @Int) False :: Bar Int -> Bar Bool+-- @+--+-- /Since 0.4.0.0/+setting :: Setting a s t b -> Proxy a -> b -> s -> t+setting x _proxy b = modify x (const b)++-- | Wrapper for a set function, lens naming convention is used for type+-- variables. Its instance for 'IsLabel' forces overloaded label to behave as a+-- setter. We could also define 'Setter' as:+--+-- @+-- type 'Setter' s t b = forall a. 'Setting' a s t b+-- @+--+-- Notice that the @forall a@ forbids us from stating what exactly it is,+-- therefore functional dependencies in 'ModifyField' type class have to be+-- able to uniquely identify it. If that is not possible, then we may have to+-- use explicit type signature.+--+-- See also 'Setting', 'Setter'', 'Modifier', and 'Modifier''.+--+-- /Definition changed in 0.4.0.0/+type Setter s t b = forall a. Modifier s t a b++-- | Extract set function from 'Setter'. Using 'Modifier' instance for+-- 'IsLabel' forces overloaded label to behave as a setter.+--+-- Usage example:+--+-- @+-- newtype Bar a = Bar {_bar :: a}+--   deriving Show+--+-- overloadedRecord ''Bar+-- @+--+-- >>> set #bar (Nothing :: Maybe Int) (Bar (Just False))+-- Bar {_bar = Nothing}+set :: Setter s t b -> b -> s -> t+set m b = modify m (const b)+{-# INLINE set #-}++-- | Simple 'Setter' which forbids changing the field type. It can be also+-- defined in terms of 'Setting':+--+-- @+-- type 'Setter'' s a = 'Setting' a s s a+-- @+--+-- See also 'Setting', 'Setter', 'Modifier', and 'Modifier''.+--+-- /Definition changed in 0.4.0.0/+type Setter' s a = Modifier' s a++-- | Same as 'set', but the field type can not be changed.+set' :: Setter' s a -> a -> s -> s+set' m a = modify' m (const a)+{-# INLINE set' #-}++-- }}} Setter -----------------------------------------------------------------++-- {{{ Modifier ---------------------------------------------------------------++-- | Wrapper for a modification function, lens naming convention is used for+-- type variables. Its instance for 'IsLabel' forces overloaded label to behave+-- as a modification function.+--+-- See also 'Modifier'', 'Setting', 'Setter', and 'Setter''.+--+-- /Since 0.4.0.0/+newtype Modifier s t a b = Modifier ((a -> b) -> s -> t)+  deriving (Generic, Typeable)++-- /Since 0.4.0.0/+instance (ModifyField l s t a b) => IsLabel l (Modifier s t a b) where+    fromLabel proxy = Modifier (modifyField proxy)++-- | Modify field value using provided function.+--+-- /Since 0.4.0.0/+modify :: Modifier s t a b -> (a -> b) -> s -> t+modify (Modifier f) = f++-- | Simple 'Modifier' which forbids changing the field type.+--+-- See also 'Modifier', 'Modifier'', 'Setting', 'Setter', and 'Setter''.+--+-- /Since 0.4.0.0/+type Modifier' s a = Modifier s s a a++-- | Same as 'modify', but the field type can not be changed.+--+-- /Since 0.4.0.0/+modify' :: Modifier' s a -> (a -> a) -> s -> s+modify' = modify++-- }}} Modifier ---------------------------------------------------------------++-- {{{ Instances --------------------------------------------------------------++-- {{{ Instances -- Tuples ----------------------------------------------------++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a, b) = a++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a, b) a' = (a', b)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a, b) = b++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a, b) b' = (a, b')++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a, b) -> c) = a -> b -> c++-- | /Since 0.4.0.0/+instance HasField "fst" (a, b) a where+    getField _proxy (a, _) = a++-- | /Since 0.4.0.0/+instance HasField "snd" (a, b) b where+    getField _proxy (_, b) = b++-- | /Since 0.4.0.0/+instance HasField "curry" ((a, b) -> c) (a -> b -> c) where+    getField _proxy f a b = f (a, b)++-- | /Since 0.4.0.0/+instance ModifyField "fst" (a, b) (a', b) a a' where+    modifyField _proxy f (a, b) = (f a, b)+    setField _proxy (_, b) a = (a, b)++-- | /Since 0.4.0.0/+instance ModifyField "snd" (a, b) (a, b') b b' where+    modifyField _proxy f (a, b) = (a, f b)+    setField _proxy (a, _) b = (a, b)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a, b, c) = a++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a, b, c) a' = (a', b, c)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a, b, c) = b++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a, b, c) b' = (a, b', c)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a, b, c) = c++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a, b, c) c' = (a, b, c')++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a, b, c) -> d) = a -> b -> c -> d++-- | /Since 0.4.0.0/+instance HasField "fst" (a, b, c) a where+    getField _proxy (a, _, _) = a++-- | /Since 0.4.0.0/+instance HasField "snd" (a, b, c) b where+    getField _proxy (_, b, _) = b++-- | /Since 0.4.0.0/+instance HasField "thd" (a, b, c) c where+    getField _proxy (_, _, c) = c++-- | /Since 0.4.0.0/+instance HasField "curry" ((a, b, c) -> d) (a -> b -> c -> d) where+    getField _proxy f a b c = f (a, b, c)++-- | /Since 0.4.0.0/+instance ModifyField "fst" (a, b, c) (a', b, c) a a' where+    modifyField _proxy f (a, b, c) = (f a, b, c)+    setField _proxy (_, b, c) a = (a, b, c)++-- | /Since 0.4.0.0/+instance ModifyField "snd" (a, b, c) (a, b', c) b b' where+    modifyField _proxy f (a, b, c) = (a, f b, c)+    setField _proxy (a, _, c) b = (a, b, c)++-- | /Since 0.4.0.0/+instance ModifyField "thd" (a, b, c) (a, b, c') c c' where+    modifyField _proxy f (a, b, c) = (a, b, f c)+    setField _proxy (a, b, _) c = (a, b, c)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4) a1' = (a1', a2, a3, a4)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4) a2' = (a1, a2', a3, a4)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4) a3' = (a1, a3', a3, a4)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4) -> r) =+    a1 -> a2 -> a3 -> a4 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4) a1 where+    getField _proxy (a1, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4) a2 where+    getField _proxy (_, a2, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4) a3 where+    getField _proxy (_, _, a3, _) = a3++-- | /Since 0.4.0.0/+instance ModifyField "fst" (a1, a2, a3, a4) (a1', a2, a3, a4) a1 a1' where+    modifyField _proxy f (a1, a2, a3, a4) = (f a1, a2, a3, a4)+    setField _proxy (_, a2, a3, a4) a1 = (a1, a2, a3, a4)++-- | /Since 0.4.0.0/+instance ModifyField "snd" (a1, a2, a3, a4) (a1, a2', a3, a4) a2 a2' where+    modifyField _proxy f (a1, a2, a3, a4) = (a1, f a2, a3, a4)+    setField _proxy (a1, _, a3, a4) a2 = (a1, a2, a3, a4)++-- | /Since 0.4.0.0/+instance ModifyField "thd" (a1, a2, a3, a4) (a1, a2, a3', a4) a3 a3' where+    modifyField _proxy f (a1, a2, a3, a4) = (a1, a2, f a3, a4)+    setField _proxy (a1, a2, _, a4) a3 = (a1, a2, a3, a4)++-- | /Since 0.4.0.0/+instance HasField "curry" ((a1, a2, a3, a4) -> r) (a1 -> a2 -> a3 -> a4 -> r)+  where+    getField _proxy f a1 a2 a3 a4 = f (a1, a2, a3, a4)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5) a1' = (a1', a2, a3, a4, a5)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5) a2' = (a1, a2', a3, a4, a5)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5) a3' = (a1, a2, a3', a4, a5)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4, a5) -> r) =+    a1 -> a2 -> a3 -> a4 -> a5 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5) a1 where+    getField _proxy (a1, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5) a2 where+    getField _proxy (_, a2, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5) a3 where+    getField _proxy (_, _, a3, _, _) = a3++-- | /Since 0.4.0.0/+instance ModifyField "fst" (a1, a2, a3, a4, a5) (a1', a2, a3, a4, a5) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5) = (f a1, a2, a3, a4, a5)+    setField _proxy (_, a2, a3, a4, a5) a1 = (a1, a2, a3, a4, a5)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5) (a1, a2', a3, a4, a5) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5) = (a1, f a2, a3, a4, a5)+    setField _proxy (a1, _, a3, a4, a5) a2 = (a1, a2, a3, a4, a5)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5) (a1, a2, a3', a4, a5) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5) = (a1, a2, f a3, a4, a5)+    setField _proxy (a1, a2, _, a4, a5) a3 = (a1, a2, a3, a4, a5)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 = f (a1, a2, a3, a4, a5)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5, a6) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5, a6) a1' =+    (a1', a2, a3, a4, a5, a6)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5, a6) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5, a6) a2' =+    (a1, a2', a3, a4, a5, a6)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5, a6) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5, a6) a3' =+    (a1, a2, a3', a4, a5, a6)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4, a5, a6) -> r) =+    a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5, a6) a1 where+    getField _proxy (a1, _, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5, a6) a2 where+    getField _proxy (_, a2, _, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5, a6) a3 where+    getField _proxy (_, _, a3, _, _, _) = a3++-- | /Since 0.4.0.0/+instance+    ModifyField "fst" (a1, a2, a3, a4, a5, a6) (a1', a2, a3, a4, a5, a6) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6) = (f a1, a2, a3, a4, a5, a6)+    setField _proxy (_, a2, a3, a4, a5, a6) a1 = (a1, a2, a3, a4, a5, a6)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5, a6) (a1, a2', a3, a4, a5, a6) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6) = (a1, f a2, a3, a4, a5, a6)+    setField _proxy (a1, _, a3, a4, a5, a6) a2 = (a1, a2, a3, a4, a5, a6)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5, a6) (a1, a2, a3', a4, a5, a6) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6) = (a1, a2, f a3, a4, a5, a6)+    setField _proxy (a1, a2, _, a4, a5, a6) a3 = (a1, a2, a3, a4, a5, a6)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5, a6) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 a6 = f (a1, a2, a3, a4, a5, a6)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5, a6, a7) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5, a6, a7) a1' =+    (a1', a2, a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5, a6, a7) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5, a6, a7) a2' =+    (a1, a2', a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5, a6, a7) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5, a6, a7) a3' =+    (a1, a2, a3', a4, a5, a6, a7)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4, a5, a6, a7) -> r) =+    a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5, a6, a7) a1 where+    getField _proxy (a1, _, _, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5, a6, a7) a2 where+    getField _proxy (_, a2, _, _, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5, a6, a7) a3 where+    getField _proxy (_, _, a3, _, _, _, _) = a3++-- | /Since 0.4.0.0/+instance+    ModifyField "fst" (a1, a2, a3, a4, a5, a6, a7)+        (a1', a2, a3, a4, a5, a6, a7) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7) =+        (f a1, a2, a3, a4, a5, a6, a7)+    setField _proxy (_, a2, a3, a4, a5, a6, a7) a1 =+        (a1, a2, a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5, a6, a7)+        (a1, a2', a3, a4, a5, a6, a7) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7) =+        (a1, f a2, a3, a4, a5, a6, a7)+    setField _proxy (a1, _, a3, a4, a5, a6, a7) a2 =+        (a1, a2, a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5, a6, a7)+        (a1, a2, a3', a4, a5, a6, a7) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7) =+        (a1, a2, f a3, a4, a5, a6, a7)+    setField _proxy (a1, a2, _, a4, a5, a6, a7) a3 =+        (a1, a2, a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5, a6, a7) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 a6 a7 = f (a1, a2, a3, a4, a5, a6, a7)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5, a6, a7, a8) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5, a6, a7, a8) a1' =+    (a1', a2, a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5, a6, a7, a8) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5, a6, a7, a8) a2' =+    (a1, a2', a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5, a6, a7, a8) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5, a6, a7, a8) a3' =+    (a1, a2, a3', a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4, a5, a6, a7, a8) -> r) =+    a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5, a6, a7, a8) a1 where+    getField _proxy (a1, _, _, _, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5, a6, a7, a8) a2 where+    getField _proxy (_, a2, _, _, _, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5, a6, a7, a8) a3 where+    getField _proxy (_, _, a3, _, _, _, _, _) = a3++-- | /Since 0.4.0.0/+instance+    ModifyField "fst" (a1, a2, a3, a4, a5, a6, a7, a8)+        (a1', a2, a3, a4, a5, a6, a7, a8) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8) =+        (f a1, a2, a3, a4, a5, a6, a7, a8)+    setField _proxy (_, a2, a3, a4, a5, a6, a7, a8) a1 =+        (a1, a2, a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5, a6, a7, a8)+        (a1, a2', a3, a4, a5, a6, a7, a8) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8) =+        (a1, f a2, a3, a4, a5, a6, a7, a8)+    setField _proxy (a1, _, a3, a4, a5, a6, a7, a8) a2 =+        (a1, a2, a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5, a6, a7, a8)+        (a1, a2, a3', a4, a5, a6, a7, a8) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8) =+        (a1, a2, f a3, a4, a5, a6, a7, a8)+    setField _proxy (a1, a2, _, a4, a5, a6, a7, a8) a3 =+        (a1, a2, a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5, a6, a7, a8) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 a6 a7 a8 =+        f (a1, a2, a3, a4, a5, a6, a7, a8)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a1' =+    (a1', a2, a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a2' =+    (a1, a2', a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a3' =+    (a1, a2, a3', a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+type instance FieldType "curry" ((a1, a2, a3, a4, a5, a6, a7, a8, a9) -> r) =+    a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a1 where+    getField _proxy (a1, _, _, _, _, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a2 where+    getField _proxy (_, a2, _, _, _, _, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9) a3 where+    getField _proxy (_, _, a3, _, _, _, _, _, _) = a3++-- | /Since 0.4.0.0/+instance+    ModifyField "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9)+        (a1', a2, a3, a4, a5, a6, a7, a8, a9) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9) =+        (f a1, a2, a3, a4, a5, a6, a7, a8, a9)+    setField _proxy (_, a2, a3, a4, a5, a6, a7, a8, a9) a1 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9)+        (a1, a2', a3, a4, a5, a6, a7, a8, a9) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9) =+        (a1, f a2, a3, a4, a5, a6, a7, a8, a9)+    setField _proxy (a1, _, a3, a4, a5, a6, a7, a8, a9) a2 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9)+        (a1, a2, a3', a4, a5, a6, a7, a8, a9) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9) =+        (a1, a2, f a3, a4, a5, a6, a7, a8, a9)+    setField _proxy (a1, a2, _, a4, a5, a6, a7, a8, a9) a3 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5, a6, a7, a8, a9) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 a6 a7 a8 a9 =+        f (a1, a2, a3, a4, a5, a6, a7, a8, a9)++-- | /Since 0.4.0.0/+type instance FieldType "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = a1++-- | /Since 0.4.0.0/+type instance UpdateType "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a1' =+    (a1', a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+type instance FieldType "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = a2++-- | /Since 0.4.0.0/+type instance UpdateType "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a2' =+    (a1, a2', a3, a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+type instance FieldType "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = a3++-- | /Since 0.4.0.0/+type instance UpdateType "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a3' =+    (a1, a2, a3', a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+type instance FieldType "curry"+    ((a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) -> r) =+        a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> r++-- | /Since 0.4.0.0/+instance HasField "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a1 where+    getField _proxy (a1, _, _, _, _, _, _, _, _, _) = a1++-- | /Since 0.4.0.0/+instance HasField "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a2 where+    getField _proxy (_, a2, _, _, _, _, _, _, _, _) = a2++-- | /Since 0.4.0.0/+instance HasField "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) a3 where+    getField _proxy (_, _, a3, _, _, _, _, _, _, _) = a3++-- | /Since 0.4.0.0/+instance+    ModifyField "fst" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+        (a1', a2, a3, a4, a5, a6, a7, a8, a9, a10) a1 a1'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) =+        (f a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+    setField _proxy (_, a2, a3, a4, a5, a6, a7, a8, a9, a10) a1 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+instance+    ModifyField "snd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+        (a1, a2', a3, a4, a5, a6, a7, a8, a9, a10) a2 a2'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) =+        (a1, f a2, a3, a4, a5, a6, a7, a8, a9, a10)+    setField _proxy (a1, _, a3, a4, a5, a6, a7, a8, a9, a10) a2 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+instance+    ModifyField "thd" (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+        (a1, a2, a3', a4, a5, a6, a7, a8, a9, a10) a3 a3'+  where+    modifyField _proxy f (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) =+        (a1, a2, f a3, a4, a5, a6, a7, a8, a9, a10)+    setField _proxy (a1, a2, _, a4, a5, a6, a7, a8, a9, a10) a3 =+        (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | /Since 0.4.0.0/+instance+    HasField "curry" ((a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) -> r)+        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> r)+  where+    getField _proxy f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 =+        f (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- }}} Instances -- Tuples ----------------------------------------------------++-- {{{ Instances -- Lists -----------------------------------------------------++-- | /Since 0.4.0.0/+type instance FieldType "head" [a] = Maybe a++-- | /Since 0.4.0.0/+type instance UpdateType "head" [a] (Maybe a) = [a]++-- |+-- >>> #head []+-- Nothing+--+-- >>> #head [1, 2, 3]+-- Just 1+--+-- /Since 0.4.0.0/+instance HasField "head" [a] (Maybe a) where+    getField _proxy []      = Nothing+    getField _proxy (a : _) = Just a++-- |+-- >>> set' #head [] Nothing :: [Int]+-- []+--+-- >>> set' #head [] (Just 1)+-- [1]+--+-- >>> set' #head [1, 2, 3] Nothing+-- [2, 3]+--+-- >>> set' #head [1, 2, 3] (Just 4)+-- [4, 2, 3]+--+-- /Since 0.4.0.0/+instance ModifyField "head" [a] [a] (Maybe a) (Maybe a) where+    modifyField _proxy f = \case+        [] -> case f Nothing of+            Nothing -> []+            Just a -> [a]+        a : as -> case f (Just a) of+            Nothing -> as+            Just a' -> a' : as++    setField _proxy = \case+        [] -> \case+            Nothing -> []+            Just a -> [a]+        _ : as -> \case+            Nothing -> as+            Just a -> a : as++-- | /Since 0.4.0.0/+type instance FieldType "tail" [a] = Maybe [a]+-- | /Since 0.4.0.0/+type instance UpdateType "tail" [a] (Maybe [a]) = [a]++-- |+-- >>> #tail []+-- Nothing+--+-- >>> #tail [1, 2, 3]+-- Just [2, 3]+--+-- /Since 0.4.0.0/+instance HasField "tail" [a] (Maybe [a]) where+    getField _proxy []       = Nothing+    getField _proxy (_ : as) = Just as++-- |+-- >>> set' #tail [] Nothing :: [Int]+-- []+--+-- >>> set' #tail [] (Just [2, 3])+-- [2, 3]+--+-- >>> set' #tail [1, 2, 3] Nothing+-- [1]+--+-- >>> set' #tail [1, 2, 3] (Just [4, 5, 6])+-- [1, 4, 5, 6]+--+-- /Since 0.4.0.0/+instance ModifyField "tail" [a] [a] (Maybe [a]) (Maybe [a]) where+    modifyField _proxy f = \case+        [] -> case f Nothing of+            Nothing -> []+            Just as -> as+        a : as -> case f (Just as) of+            Nothing -> [a]+            Just as' -> a : as'++    setField _proxy = \case+        [] -> \case+            Nothing -> []+            Just as -> as+        a : _ -> \case+            Nothing -> [a]+            Just as -> a : as++-- }}} Instances -- Lists -----------------------------------------------------++-- }}} Instances --------------------------------------------------------------++-- $usageExamples+--+-- @+-- -- Basic set of language extensions required when defining instances for+-- -- classes and type families from "Data.OverloadedRecords".+-- {-\# LANGUAGE DataKinds \#-}+-- {-\# LANGUAGE FlexibleInstances \#-}+-- {-\# LANGUAGE MultiParamTypeClasses \#-}+-- {-\# LANGUAGE TemplateHaskell \#-}+-- {-\# LANGUAGE TypeFamilies \#-}+--+-- -- Following language extensions are required by code like this:+--+-- {-\# LANGUAGE ConstraintKinds \#-}+--     -- Codomain of type family 'R' is a 'Constraint' kind.+--+-- {-\# LANGUAGE FlexibleContexts \#-}+--     -- Required in example when field type (second argument of ':::') is a+--     -- specific type instead of a polymorphic type.+--+-- {-\# LANGUAGE TypeOperators \#-}+--     -- Required due to usage of ':::' type alias.+--+-- -- Following language extensions are available only in GHC >=8:+--+-- {-\# LANGUAGE OverloadedLabels \#-}+--     -- Enables #label syntactic sugar.+--+-- module Example+--   where+--+-- import Data.Default (Default(def))+--     -- Provided by one of these packages:+--     --+--     -- * <https://hackage.haskell.org/package/data-default data-default>+--     -- * <https://hackage.haskell.org/package/data-default data-default-extra>+--+-- import "Data.OverloadedRecords"+-- import "Data.OverloadedRecords.TH" ('Data.OverloadedRecords.TH.overloadedRecord')+--+--+-- data V3 a = V3+--     { v3x :: !a+--     , v3y :: !a+--     , v3z :: !a+--     }+--   deriving Show+--+-- -- Following line derives instances for various type classes and type+-- -- families that are provided by the overloaded-records library.+-- --+-- -- However with def (default settings) this is done only for fields that+-- -- start with type name, data constructor name, or underscore. Prefix is+-- -- stripped. In example \"v3x\" is transformed in to \"x\" and so would be+-- -- \"_x\".+-- 'Data.OverloadedRecords.TH.overloadedRecord' def ''V3+--+-- data V4 a = V4+--     { v4x :: !a+--     , v4y :: !a+--     , v4z :: !a+--     , v4t :: !a+--     }+--   deriving Show+--+-- 'Data.OverloadedRecords.TH.overloadedRecord' def ''V4+--+-- zeroV3+--     :: (Num a, 'R' [\"x\" ':::' a, \"y\" ':::' a, \"z\" ':::' a] r)+--     => r -> r+-- zeroV3 = 'set'' \#x 0 . 'set'' \#y 0 . 'set'' \#z 0+-- @+--+-- The following type signatures for @zeroV3@ are equivalent:+--+-- @+-- zeroV3+--     :: (Num a, 'R' [\"x\" ':::' a, \"y\" ':::' a, \"z\" ':::' a] r)+--     => r -> r+-- @+--+-- @+-- zeroV3+--     ::  ( Num a+--         , 'ModifyField'' \"x\" r a+--         , 'ModifyField'' \"y\" r a+--         , 'ModifyField'' \"z\" r a+--         )+--     => r -> r+-- @+--+-- One of the biggest features of /Overloaded Records/ is the possibility to+-- define functions that do not depend on concrete data types, but on the+-- \"fields\" they provide. In example function @zeroV3@ can be applied to+-- anything that has fields @\"x\"@, @\"y\"@, and @\"z\"@ that reference values+-- of some @Num@ type:+--+-- >>> zeroV3 (V3 1 1 1 :: V3 Int)+-- V3 {_x = 0, _y = 0, _z = 0}+--+-- >>> zeroV3 (V4 1 1 1 1 :: V4 Int)+-- V4 {_x = 0, _y = 0, _z = 0, _t = 1}+--+-- Function @zeroV3@ can be also defined using operators from+-- <https://hackage.haskell.org/package/lens lens> library:+--+-- @+-- zeroV3+--     :: (Num a, 'R' [\"x\" ':::' a, \"y\" ':::' a, \"z\" ':::' a] r)+--     => r -> r+-- zeroV3 r = r+--     & \#x .~ 0+--     & \#y .~ 0+--     & \#z .~ 0+-- @

@@ -1,33 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--#ifndef HAVE_OVERLOADED_LABELS-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-#endif--#if 0-#if HAVE_MONAD_FAIL && MIN_VERSION_template_haskell(2,11,0)-#define _FAIL_IN_MONAD-#else-#define _FAIL_IN_MONAD , fail-#endif-#endif---- Package template-haskell 2.11 is missing MonadFail instance for Q.-#define _FAIL_IN_MONAD , fail- -- | -- Module:       $HEADER$ -- Description:  Derive magic instances for OverloadedRecordFields.@@ -36,11 +8,7 @@ -- -- Maintainer:   peter.trsko@gmail.com -- Stability:    experimental--- Portability:  CPP, DataKinds, DeriveDataTypeable, DeriveGeneric,---               FlexibleContexts (GHC <8), FlexibleInstances, LambdaCase,---               MagicHash (GHC <8), MultiParamTypeClasses, NoImplicitPrelude,---               RecordWildCards, TemplateHaskell, TupleSections, TypeFamilies,---               TypeSynonymInstances+-- Portability:  CPP, NoImplicitPrelude -- -- Derive magic instances for OverloadedRecordFields. module Data.OverloadedRecords.TH@@ -70,597 +38,22 @@     )   where -import Prelude (Num((-)), fromIntegral)--import Control.Applicative (Applicative((<*>)))-import Control.Monad (Monad((>>=) _FAIL_IN_MONAD, return), replicateM)-#if 0-#if HAVE_MONAD_FAIL && MIN_VERSION_template_haskell(2,11,0)-import Control.Monad.Fail (MonadFail(fail))-#endif-#endif-import Data.Bool (Bool(False), otherwise)-import qualified Data.Char as Char (toLower)-import Data.Foldable (concat, foldl)-import Data.Function ((.), ($))-import Data.Functor (Functor(fmap), (<$>))-import qualified Data.List as List-    ( drop-    , isPrefixOf-    , length-    , map-    , replicate-    , zip-    )-import Data.Maybe (Maybe(Just, Nothing), fromMaybe)-import Data.Monoid ((<>))-import Data.String (String)-import Data.Traversable (forM, mapM)-import Data.Typeable (Typeable)-import Data.Word (Word)-import GHC.Generics (Generic)-#ifndef HAVE_OVERLOADED_LABELS-import GHC.Exts (Proxy#, proxy#)-#endif-import Text.Show (Show(show))--import Language.Haskell.TH-    ( Con(ForallC, InfixC, NormalC, RecC)-    , Dec(DataD, NewtypeD)-    , DecsQ-    , ExpQ-    , Info(TyConI)-    , Name-    , Pat(ConP, VarP, WildP)-    , PatQ-    , Q-    , Strict-    , Type-    , TypeQ-    , TyVarBndr(KindedTV, PlainTV)-    , appE-    , appT-    , conE-    , conP-    , conT-    , lamE-    , litT-    , nameBase-    , newName-    , recUpdE-    , reify-    , strTyLit-    , varE-    , varP-    , varT-    , wildP-    )--import Data.Default.Class (Default(def))-+import Data.OverloadedRecords.TH.Internal+    ( DeriveOverloadedRecordsParams+    , FieldDerivation+    , OverloadedField(..)+    , defaultFieldDerivation+    , defaultMakeFieldName+    , field #ifndef HAVE_OVERLOADED_LABELS-import Data.OverloadedLabels (IsLabel(fromLabel))+    , fieldDerivation #endif-import Data.OverloadedRecords-    ( FieldType-    , HasField(getField)-    , SetField(setField)-    , UpdateType+    , fieldGetter+    , fieldSetter+    , overloadedRecord+    , overloadedRecordFor+    , overloadedRecords+    , overloadedRecordsFor+    , simpleField+    , simpleFieldSetter     )---#ifndef HAVE_OVERLOADED_LABELS--- | Overloaded label that can be used for accessing function of type--- 'FieldDerivation' from 'DeriveOverloadedRecordsParams'.------ This definition is available only if compiled with GHC <8.-fieldDerivation :: IsLabel "fieldDerivation" a => a-fieldDerivation = fromLabel (proxy# :: Proxy# "fieldDerivation")-#endif---- | Parameters for customization of deriving process. Use 'def' to get--- default behaviour.-data DeriveOverloadedRecordsParams = DeriveOverloadedRecordsParams-    { _strictFields :: Bool-    -- ^ Make setter and getter strict. **Currently unused.**-    , _fieldDerivation :: FieldDerivation-    -- ^ See 'FieldDerivation' for description.-    }-  deriving (Generic, Typeable)--type instance FieldType "fieldDerivation" DeriveOverloadedRecordsParams =-    FieldDerivation--instance-    HasField "fieldDerivation" DeriveOverloadedRecordsParams FieldDerivation-  where-    getField _proxy = _fieldDerivation--type instance-    UpdateType "fieldDerivation" DeriveOverloadedRecordsParams FieldDerivation =-        DeriveOverloadedRecordsParams--instance-    SetField "fieldDerivation" DeriveOverloadedRecordsParams FieldDerivation-  where-    setField _proxy s b = s{_fieldDerivation = b}---- | Describes what should be the name of overloaded record field, and can also--- provide custom implementation of getter and setter.-data OverloadedField-    = GetterOnlyField String (Maybe ExpQ)-    -- ^ Derive only getter instances. If second argument is 'Just', then it-    -- contains custom definition of getter function.-    | GetterAndSetterField String (Maybe (ExpQ, ExpQ))-    -- ^ Derive only getter instances. If second argument is 'Just', then it-    -- contains custom definitions of getter and setter functions,-    -- respectively.-  deriving (Generic, Typeable)---- | Type signature of a function that can customize the derivation of each--- individual overloaded record field.------ If field has an selector then the function will get its name or 'Nothing'--- otherwise.  Function has to return 'Nothing' in case when generating--- overloaded record field instances is not desired.-type FieldDerivation-    =  String-    -- ^ Name of the type, of which this field is part of.-    -> String-    -- ^ Name of the constructor, of which this field is part of.-    -> Word-    -- ^ Field position as an argument of the constructor it is part of.-    -- Indexing starts from zero.-    -> Maybe String-    -- ^ Name of the field (record) accessor; 'Nothing' means that there is no-    -- record accessor defined for it.-    -> Maybe OverloadedField-    -- ^ Describes how overloaded record field should be generated for this-    -- specific constructor field. 'Nothing' means that no overloaded record-    -- field should be derived. See also 'OverloadedField' for details.---- | Suppose we have a weird type definition as this:------ @--- data SomeType a b c = SomeConstructor---     { _fieldX :: a---     , someTypeFieldY :: b---     , someConstructorFieldZ :: c---     , anythingElse :: (a, b, c)---     }--- @------ Then for each of those fields, 'defaultMakeFieldName' will produce--- expected OverloadedLabel name:------ * @_fieldX --> fieldX@------ * @someTypeFieldY --> fieldY@------ * @someConstructorFieldZ --> fieldZ@------ * @anythingElse@ is ignored-defaultMakeFieldName-    :: String-    -- ^ Name of the type, of which this field is part of.-    -> String-    -- ^ Name of the constructor, of which this field is part of.-    -> Word-    -- ^ Field position as an argument of the constructor it is part of.-    -- Indexing starts from zero.-    -> Maybe String-    -- ^ Name of the field (record) accessor; 'Nothing' means that there is no-    -- record accessor defined for it.-    -> Maybe String-    -- ^ Overloaded record field name to be used for this specific constructor-    -- field; 'Nothing' means that there shouldn't be a label associated with-    -- it.-defaultMakeFieldName typeName constructorName _fieldPosition = \case-    Nothing -> Nothing-    Just fieldName-      | startsWith "_"        -> Just $ dropPrefix "_"        fieldName-      | startsWith typePrefix -> Just $ dropPrefix typePrefix fieldName-      | startsWith conPrefix  -> Just $ dropPrefix conPrefix  fieldName-      | otherwise             -> Nothing-      where-        startsWith :: String -> Bool-        startsWith = (`List.isPrefixOf` fieldName)--        dropPrefix :: String -> String -> String-        dropPrefix s = headToLower . List.drop (List.length s)--        headToLower :: String -> String-        headToLower "" = ""-        headToLower (x : xs) = Char.toLower x : xs--        typePrefix, conPrefix :: String-        typePrefix = headToLower typeName-        conPrefix = headToLower constructorName---- | Function used by default value of 'DeriveOverloadedRecordsParams'.-defaultFieldDerivation :: FieldDerivation-defaultFieldDerivation =-    (((fmap (`GetterAndSetterField` Nothing) .) .) .) . defaultMakeFieldName---- |--- @--- 'def' = 'DeriveOverloadedRecordsParams'---     { strictFields = 'False'---     , 'fieldDerivation' = 'defaultFieldDerivation'---     }--- @-instance Default DeriveOverloadedRecordsParams where-    def = DeriveOverloadedRecordsParams-        { _strictFields = False-        , _fieldDerivation = defaultFieldDerivation-        }---- | Derive magic OverloadedRecordFields instances for specified type.-overloadedRecord-    :: DeriveOverloadedRecordsParams-    -- ^ Parameters for customization of deriving process. Use 'def' to get-    -- default behaviour.-    -> Name-    -- ^ Name of the type for which magic instances should be derived.-    -> DecsQ-overloadedRecord params = withReified $ \name -> \case-    TyConI dec -> case dec of-        -- Not supporting DatatypeContexts, hence the [] required as the first-        -- argument to NewtypeD and DataD.-#if MIN_VERSION_template_haskell(2,11,0)-        NewtypeD [] typeName typeVars _kindSignature constructor _deriving ->-#else-        NewtypeD [] typeName typeVars constructor _deriving ->-#endif-            deriveForConstructor params typeName typeVars constructor-#if MIN_VERSION_template_haskell(2,11,0)-        DataD [] typeName typeVars _kindSignature constructors _deriving ->-#else-        DataD [] typeName typeVars constructors _deriving ->-#endif-            fmap concat . forM constructors-                $ deriveForConstructor params typeName typeVars-        x -> canNotDeriveError name x--    x -> canNotDeriveError name x-  where-    withReified :: (Name -> Info -> Q a) -> Name -> Q a-    withReified f t = (reify t >>= f t)--    canNotDeriveError :: Show a => Name -> a -> Q b-    canNotDeriveError = (fail .) . errMessage--    errMessage :: Show a => Name -> a -> String-    errMessage n x =-        "`" <> show n <> "' is neither newtype nor data type: " <> show x---- | Derive magic OverloadedRecordFields instances for specified types.-overloadedRecords-    :: DeriveOverloadedRecordsParams-    -- ^ Parameters for customization of deriving process. Use 'def' to get-    -- default behaviour.-    -> [Name]-    -- ^ Names of the types for which magic instances should be derived.-    -> DecsQ-overloadedRecords params = fmap concat . mapM (overloadedRecord params)---- | Derive magic OverloadedRecordFields instances for specified type.------ Similar to 'overloadedRecords', but instead of--- 'DeriveOverloadedRecordsParams' value it takes function which can modify its--- default value.------ @--- data Coordinates2D a---     { coordinateX :: a---     , coordinateY :: a---     }------ 'overloadedRecordsFor' ''Coordinates2D---     $ \#fieldDerivation .~ \\_ _ _ -> \\case---         Nothing -> Nothing---         Just field -> lookup field---            [ (\"coordinateX\", 'GetterOnlyField' \"x\" Nothing)---            , (\"coordinateY\", 'GetterOnlyField' \"y\" Nothing)---            ]--- @-overloadedRecordFor-    :: Name-    -- ^ Name of the type for which magic instances should be derived.-    -> (DeriveOverloadedRecordsParams -> DeriveOverloadedRecordsParams)-    -- ^ Function that modifies parameters for customization of deriving-    -- process.-    -> DecsQ-overloadedRecordFor typeName f = overloadedRecord (f def) typeName---- | Derive magic OverloadedRecordFields instances for specified types.-overloadedRecordsFor-    :: [Name]-    -- ^ Names of the types for which magic instances should be derived.-    -> (DeriveOverloadedRecordsParams -> DeriveOverloadedRecordsParams)-    -- ^ Function that modifies parameters for customization of deriving-    -- process.-    -> DecsQ-overloadedRecordsFor typeNames f = overloadedRecords (f def) typeNames---- | Derive magic instances for all fields of a specific data constructor of a--- specific type.-deriveForConstructor-    :: DeriveOverloadedRecordsParams-    -- ^ Parameters for customization of deriving process. Use 'def' to get-    -- default behaviour.-    -> Name-    -> [TyVarBndr]-    -> Con-    -> DecsQ-deriveForConstructor params name typeVars = \case-    NormalC constructorName args ->-        deriveFor constructorName args $ \(strict, argType) f ->-            f Nothing strict argType--    RecC constructorName args ->-        deriveFor constructorName args $ \(accessor, strict, argType) f ->-            f (Just accessor) strict argType--    InfixC arg0 constructorName arg1 ->-        deriveFor constructorName [arg0, arg1] $ \(strict, argType) f ->-            f Nothing strict argType--#if 0-#if MIN_VERSION_template_haskell(2,11,0)-    GadtC _ _ _ ->-    RecGadtC _ _ _ ->-#endif-#endif--    -- Existentials aren't supported.-    ForallC _typeVariables _context _constructor -> return []-  where-    deriveFor-        :: Name-        -> [a]-        -> (a -> (Maybe Name -> Strict -> Type -> DecsQ) -> DecsQ)-        -> DecsQ-    deriveFor constrName args f =-        fmap concat . forM (withIndexes args) $ \(idx, arg) ->-            f arg $ \accessor strict fieldType' ->-                deriveForField params DeriveFieldParams-                    { typeName = name-                    , typeVariables = List.map getTypeName typeVars-                    , constructorName = constrName-                    , numberOfArgs = fromIntegral $ List.length args-                    , currentIndex = idx-                    , accessorName = accessor-                    , strictness = strict-                    , fieldType = fieldType'-                    }-      where-        getTypeName :: TyVarBndr -> Name-        getTypeName = \case-            PlainTV n -> n-            KindedTV n _kind -> n--    withIndexes = List.zip [(0 :: Word) ..]---- | Parameters for 'deriveForField' function.-data DeriveFieldParams = DeriveFieldParams-    { typeName :: Name-    -- ^ Record name, i.e. type constructor name.-    , typeVariables :: [Name]-    -- ^ Free type variables of a type constructor.-    , constructorName :: Name-    -- ^ Data constructor name.-    , numberOfArgs :: Word-    -- ^ Number of arguments that data constructor takes.-    , currentIndex :: Word-    -- ^ Index of the current argument of a data constructor for which we are-    -- deriving overloaded record field instances. Indexing starts from zero.-    -- In other words 'currentIndex' is between zero (including) and-    -- 'numberOfArgs' (excluding).-    , accessorName :: Maybe Name-    -- ^ Record field accessor, if available, otherwise 'Nothing'.-    , strictness :: Strict-    -- ^ Strictness annotation of the current data constructor argument.-    , fieldType :: Type-    -- ^ Type of the current data constructor argument.-    }---- | Derive magic instances for a specific field of a specific type.-deriveForField-    :: DeriveOverloadedRecordsParams-    -- ^ Parameters for customization of deriving process. Use 'def' to get-    -- default behaviour.-    -> DeriveFieldParams-    -- ^ All the necessary information for derivation procedure.-    -> DecsQ-deriveForField params DeriveFieldParams{..} =-    case possiblyLabel of-        Nothing -> return []-        Just (GetterOnlyField label customGetterExpr) ->-            deriveGetter' (strTyLitT label)-                $ fromMaybe derivedGetterExpr customGetterExpr-        Just (GetterAndSetterField label customGetterAndSetterExpr) -> (<>)-            <$> deriveGetter' labelType getterExpr-            <*> deriveSetter' labelType setterExpr-          where-            labelType = strTyLitT label--            (getterExpr, setterExpr) =-                fromMaybe (derivedGetterExpr, derivedSetterExpr)-                    customGetterAndSetterExpr-  where-    possiblyLabel = _fieldDerivation params (nameBase typeName)-        (nameBase constructorName) currentIndex (fmap nameBase accessorName)--    deriveGetter' labelType =-        deriveGetter labelType recordType (return fieldType)--    deriveSetter' labelType =-        deriveSetter labelType recordType (return fieldType) newRecordType-            newFieldType--    recordType = foldl appT (conT typeName) $ List.map varT typeVariables--    -- TODO: When field type is polymorphic, then we should allow to change it.-    newFieldType = return fieldType-    newRecordType = recordType--    -- Number of variables, i.e. arguments of a constructor, to the right of-    -- the currently processed field.-    numVarsOnRight = numberOfArgs - currentIndex - 1--    inbetween :: (a -> [b]) -> a -> a -> b -> [b]-    inbetween f a1 a2 b = f a1 <> (b : f a2)--    derivedGetterExpr = case accessorName of-        Just name -> varE name-        Nothing -> do-            a <- newName "a"-            -- \(C _ _ ... _ a _ _ ... _) -> a-            lamE [return . ConP constructorName $ nthArg (VarP a)] (varE a)-      where-        nthArg :: Pat -> [Pat]-        nthArg = inbetween wildPs currentIndex numVarsOnRight--    derivedSetterExpr = case accessorName of-        Just name -> do-            s <- newName "s"-            b <- newName "b"-            lamE [varP s, varP b] $ recUpdE (varE s) [(name, ) <$> varE b]-        Nothing -> do-            varsBefore <- newNames currentIndex "a"-            b <- newName "b"-            varsAfter <- newNames numVarsOnRight "a"--            -- \(C a_0 a_1 ... a_(i - 1) _ a_(i + 1) a_(i + 2) ... a_(n)) b ->-            --     C a_0 a_1 ... a_(i - 1) b a_(i + 1) a_(i + 2) ... a_(n)-            lamE [constrPattern varsBefore varsAfter, varP b]-                $ constrExpression varsBefore (varE b) varsAfter-          where-            constrPattern before after =-                conP constructorName $ inbetween varPs before after wildP--            constrExpression before b after = foldl appE (conE constructorName)-                $ varEs before <> (b : varEs after)---- | Derive instances for overloaded record field, both getter and setter.-field-    :: String-    -- ^ Overloaded label name.-    -> TypeQ-    -- ^ Record type.-    -> TypeQ-    -- ^ Field type.-    -> TypeQ-    -- ^ Record type after update.-    -> TypeQ-    -- ^ Setter will set field to a value of this type.-    -> ExpQ-    -- ^ Getter function.-    -> ExpQ-    -- ^ Setter function.-    -> DecsQ-field label recType fldType newRecType newFldType getterExpr setterExpr = (<>)-    <$> deriveGetter labelType recType fldType getterExpr-    <*> deriveSetter labelType recType fldType newRecType newFldType setterExpr-  where-    labelType = strTyLitT label---- | Derive instances for overloaded record field, both getter and setter. Same--- as 'field', but record type is the same before and after update and so is--- the field type.-simpleField-    :: String-    -- ^ Overloaded label name.-    -> TypeQ-    -- ^ Record type.-    -> TypeQ-    -- ^ Field type.-    -> ExpQ-    -- ^ Getter function.-    -> ExpQ-    -- ^ Setter function.-    -> DecsQ-simpleField label recType fldType = field label recType fldType recType fldType---- | Derive instances for overloaded record field getter.-fieldGetter-    :: String-    -- ^ Overloaded label name.-    -> TypeQ-    -- ^ Record type.-    -> TypeQ-    -- ^ Field type-    -> ExpQ-    -- ^ Getter function.-    -> DecsQ-fieldGetter = deriveGetter . strTyLitT---- | Derive only getter related instances.-deriveGetter :: TypeQ -> TypeQ -> TypeQ -> ExpQ -> DecsQ-deriveGetter labelType recordType fieldType getter =-    [d| type instance FieldType $(labelType) $(recordType) = $(fieldType)--        instance HasField $(labelType) $(recordType) $(fieldType) where-            getField _proxy = $(getter)-    |]---- | Derive instances for overloaded record field setter. Same as--- 'fieldSetter', but record type is the same before and after update and so is--- the field type.-simpleFieldSetter-    :: String-    -- ^ Overloaded label name.-    -> TypeQ-    -- ^ Record type.-    -> TypeQ-    -- ^ Field type.-    -> ExpQ-    -- ^ Setter function.-    -> DecsQ-simpleFieldSetter label recordType fieldType =-    fieldSetter label recordType fieldType recordType fieldType---- | Derive instances for overloaded record field setter.-fieldSetter-    :: String-    -- ^ Overloaded label name.-    -> TypeQ-    -- ^ Record type.-    -> TypeQ-    -- ^ Field type.-    -> TypeQ-    -- ^ Record type after update.-    -> TypeQ-    -- ^ Setter will set field to a value of this type.-    -> ExpQ-    -- ^ Setter function.-    -> DecsQ-fieldSetter = deriveSetter . strTyLitT---- | Derive only setter related instances.-deriveSetter :: TypeQ -> TypeQ -> TypeQ -> TypeQ -> TypeQ -> ExpQ -> DecsQ-deriveSetter labelType recordType fieldType newRecordType newFieldType setter =-    [d| type instance UpdateType $(labelType) $(recordType) $(newFieldType) =-            $(newRecordType)--        instance SetField $(labelType) $(recordType) $(fieldType) where-            setField _proxy = $(setter)-    |]---- | Construct list of wildcard patterns ('WildP').-wildPs :: Word -> [Pat]-wildPs n = List.replicate (fromIntegral n) WildP---- | Construct list of new names usin 'newName'.-newNames :: Word -> String -> Q [Name]-newNames n s = fromIntegral n `replicateM` newName s--varPs :: [Name] -> [PatQ]-varPs = List.map varP--varEs :: [Name] -> [ExpQ]-varEs = List.map varE--strTyLitT :: String -> TypeQ-strTyLitT = litT . strTyLit

@@ -0,0 +1,689 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++#ifndef HAVE_OVERLOADED_LABELS+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+#endif++#if 0+#if HAVE_MONAD_FAIL && MIN_VERSION_template_haskell(2,11,0)+#define _FAIL_IN_MONAD+#else+#define _FAIL_IN_MONAD , fail+#endif+#endif++-- Package template-haskell 2.11 is missing MonadFail instance for Q.+#define _FAIL_IN_MONAD , fail++-- |+-- Module:       $HEADER$+-- Description:  Derive magic instances for OverloadedRecordFields.+-- Copyright:    (c) 2016, Peter Trško+-- License:      BSD3+--+-- Maintainer:   peter.trsko@gmail.com+-- Stability:    experimental+-- Portability:  CPP, DataKinds, DeriveDataTypeable, DeriveGeneric,+--               FlexibleContexts (GHC <8), FlexibleInstances, LambdaCase,+--               MagicHash (GHC <8), MultiParamTypeClasses, NoImplicitPrelude,+--               RecordWildCards, TemplateHaskell, TupleSections, TypeFamilies,+--               TypeSynonymInstances+--+-- Derive magic instances for OverloadedRecordFields.+module Data.OverloadedRecords.TH.Internal+    (+    -- * Derive OverloadedRecordFields instances+      overloadedRecord+    , overloadedRecords+    , overloadedRecordFor+    , overloadedRecordsFor++    -- ** Customize Derivation Process+    , DeriveOverloadedRecordsParams(..)+#ifndef HAVE_OVERLOADED_LABELS+    , fieldDerivation+#endif+    , FieldDerivation+    , OverloadedField(..)+    , defaultFieldDerivation+    , defaultMakeFieldName++    -- * Low-level Deriving Mechanism+    , field+    , simpleField+    , fieldGetter+    , fieldSetter+    , simpleFieldSetter++    -- * Internal Definitions+    , DeriveFieldParams(..)+    , deriveForConstructor+    , deriveForField++    -- ** Helper Functions+    , newNames+    , strTyLitT+    , varEs+    , varPs+    , wildPs+    )+  where++import Prelude (Num((-)), fromIntegral)++import Control.Applicative (Applicative((<*>)))+import Control.Monad (Monad((>>=) _FAIL_IN_MONAD, return), replicateM)+#if 0+#if HAVE_MONAD_FAIL && MIN_VERSION_template_haskell(2,11,0)+import Control.Monad.Fail (MonadFail(fail))+#endif+#endif+import Data.Bool (Bool(False), otherwise)+import qualified Data.Char as Char (toLower)+import Data.Foldable (concat, foldl)+import Data.Function ((.), ($))+import Data.Functor (Functor(fmap), (<$>))+import qualified Data.List as List+    ( drop+    , isPrefixOf+    , length+    , map+    , replicate+    , zip+    )+import Data.Maybe (Maybe(Just, Nothing), fromMaybe)+import Data.Monoid ((<>))+import Data.String (String)+import Data.Traversable (forM, mapM)+import Data.Typeable (Typeable)+import Data.Word (Word)+import GHC.Generics (Generic)+#ifndef HAVE_OVERLOADED_LABELS+import GHC.Exts (Proxy#, proxy#)+#endif+import Text.Show (Show(show))++import Language.Haskell.TH+    ( Con+        ( ForallC+        , InfixC+        , NormalC+        , RecC+#if MIN_VERSION_template_haskell(2,11,0)+        , GadtC+        , RecGadtC+#endif+        )+    , Dec(DataD, NewtypeD)+    , DecsQ+    , ExpQ+    , Info(TyConI)+    , Name+    , Pat(ConP, VarP, WildP)+    , PatQ+    , Q+    , Strict+    , Type+    , TypeQ+    , TyVarBndr(KindedTV, PlainTV)+    , appE+    , appT+    , conE+    , conP+    , conT+    , lamE+    , litT+    , nameBase+    , newName+    , recUpdE+    , reify+    , strTyLit+    , varE+    , varP+    , varT+    , wildP+    )++import Data.Default.Class (Default(def))++#ifndef HAVE_OVERLOADED_LABELS+import Data.OverloadedLabels (IsLabel(fromLabel))+#endif+import Data.OverloadedRecords+    ( FieldType+    , HasField(getField)+    , ModifyField(setField)+    , UpdateType+    )+++#ifndef HAVE_OVERLOADED_LABELS+-- | Overloaded label that can be used for accessing function of type+-- 'FieldDerivation' from 'DeriveOverloadedRecordsParams'.+--+-- This definition is available only if compiled with GHC <8.+fieldDerivation :: IsLabel "fieldDerivation" a => a+fieldDerivation = fromLabel (proxy# :: Proxy# "fieldDerivation")+#endif++-- | Parameters for customization of deriving process. Use 'def' to get+-- default behaviour.+data DeriveOverloadedRecordsParams = DeriveOverloadedRecordsParams+    { _strictFields :: Bool+    -- ^ Make setter and getter strict. __Currently unused.__+    , _fieldDerivation :: FieldDerivation+    -- ^ See 'FieldDerivation' for description.+    }+  deriving (Generic, Typeable)++type instance FieldType "fieldDerivation" DeriveOverloadedRecordsParams =+    FieldDerivation++instance+    HasField "fieldDerivation" DeriveOverloadedRecordsParams FieldDerivation+  where+    getField _proxy = _fieldDerivation++type instance+    UpdateType "fieldDerivation" DeriveOverloadedRecordsParams FieldDerivation =+        DeriveOverloadedRecordsParams++instance+    ModifyField "fieldDerivation" DeriveOverloadedRecordsParams+        DeriveOverloadedRecordsParams FieldDerivation FieldDerivation+  where+    setField _proxy s b = s{_fieldDerivation = b}++-- | Describes what should be the name of overloaded record field, and can also+-- provide custom implementation of getter and setter.+data OverloadedField+    = GetterOnlyField String (Maybe ExpQ)+    -- ^ Derive only getter instances. If second argument is 'Just', then it+    -- contains custom definition of getter function.+    | GetterAndSetterField String (Maybe (ExpQ, ExpQ))+    -- ^ Derive only getter instances. If second argument is 'Just', then it+    -- contains custom definitions of getter and setter functions,+    -- respectively.+  deriving (Generic, Typeable)++-- | Type signature of a function that can customize the derivation of each+-- individual overloaded record field.+--+-- If field has an selector then the function will get its name or 'Nothing'+-- otherwise.  Function has to return 'Nothing' in case when generating+-- overloaded record field instances is not desired.+type FieldDerivation+    =  String+    -- ^ Name of the type, of which this field is part of.+    -> String+    -- ^ Name of the constructor, of which this field is part of.+    -> Word+    -- ^ Field position as an argument of the constructor it is part of.+    -- Indexing starts from zero.+    -> Maybe String+    -- ^ Name of the field (record) accessor; 'Nothing' means that there is no+    -- record accessor defined for it.+    -> Maybe OverloadedField+    -- ^ Describes how overloaded record field should be generated for this+    -- specific constructor field. 'Nothing' means that no overloaded record+    -- field should be derived. See also 'OverloadedField' for details.++-- | Suppose we have a weird type definition as this:+--+-- @+-- data SomeType a b c = SomeConstructor+--     { _fieldX :: a+--     , someTypeFieldY :: b+--     , someConstructorFieldZ :: c+--     , anythingElse :: (a, b, c)+--     }+-- @+--+-- Then for each of those fields, 'defaultMakeFieldName' will produce+-- expected OverloadedLabel name:+--+-- * @_fieldX --> fieldX@+--+-- * @someTypeFieldY --> fieldY@+--+-- * @someConstructorFieldZ --> fieldZ@+--+-- * @anythingElse@ is ignored+defaultMakeFieldName+    :: String+    -- ^ Name of the type, of which this field is part of.+    -> String+    -- ^ Name of the constructor, of which this field is part of.+    -> Word+    -- ^ Field position as an argument of the constructor it is part of.+    -- Indexing starts from zero.+    -> Maybe String+    -- ^ Name of the field (record) accessor; 'Nothing' means that there is no+    -- record accessor defined for it.+    -> Maybe String+    -- ^ Overloaded record field name to be used for this specific constructor+    -- field; 'Nothing' means that there shouldn't be a label associated with+    -- it.+defaultMakeFieldName typeName constructorName _fieldPosition = \case+    Nothing -> Nothing+    Just fieldName+      | startsWith "_"        -> Just $ dropPrefix "_"        fieldName+      | startsWith typePrefix -> Just $ dropPrefix typePrefix fieldName+      | startsWith conPrefix  -> Just $ dropPrefix conPrefix  fieldName+      | otherwise             -> Nothing+      where+        startsWith :: String -> Bool+        startsWith = (`List.isPrefixOf` fieldName)++        dropPrefix :: String -> String -> String+        dropPrefix s = headToLower . List.drop (List.length s)++        headToLower :: String -> String+        headToLower "" = ""+        headToLower (x : xs) = Char.toLower x : xs++        typePrefix, conPrefix :: String+        typePrefix = headToLower typeName+        conPrefix = headToLower constructorName++-- | Function used by default value of 'DeriveOverloadedRecordsParams'.+defaultFieldDerivation :: FieldDerivation+defaultFieldDerivation =+    (((fmap (`GetterAndSetterField` Nothing) .) .) .) . defaultMakeFieldName++-- |+-- @+-- 'def' = 'DeriveOverloadedRecordsParams'+--     { strictFields = 'False'+--     , 'fieldDerivation' = 'defaultFieldDerivation'+--     }+-- @+instance Default DeriveOverloadedRecordsParams where+    def = DeriveOverloadedRecordsParams+        { _strictFields = False+        , _fieldDerivation = defaultFieldDerivation+        }++-- | Derive magic OverloadedRecordFields instances for specified type.+overloadedRecord+    :: DeriveOverloadedRecordsParams+    -- ^ Parameters for customization of deriving process. Use 'def' to get+    -- default behaviour.+    -> Name+    -- ^ Name of the type for which magic instances should be derived.+    -> DecsQ+overloadedRecord params = withReified $ \name -> \case+    TyConI dec -> case dec of+        -- Not supporting DatatypeContexts, hence the [] required as the first+        -- argument to NewtypeD and DataD.+#if MIN_VERSION_template_haskell(2,11,0)+        NewtypeD [] typeName typeVars _kindSignature constructor _deriving ->+#else+        NewtypeD [] typeName typeVars constructor _deriving ->+#endif+            deriveForConstructor params typeName typeVars constructor+#if MIN_VERSION_template_haskell(2,11,0)+        DataD [] typeName typeVars _kindSignature constructors _deriving ->+#else+        DataD [] typeName typeVars constructors _deriving ->+#endif+            fmap concat . forM constructors+                $ deriveForConstructor params typeName typeVars+        x -> canNotDeriveError name x++    x -> canNotDeriveError name x+  where+    withReified :: (Name -> Info -> Q a) -> Name -> Q a+    withReified f t = reify t >>= f t++    canNotDeriveError :: Show a => Name -> a -> Q b+    canNotDeriveError = (fail .) . errMessage++    errMessage :: Show a => Name -> a -> String+    errMessage n x =+        "`" <> show n <> "' is neither newtype nor data type: " <> show x++-- | Derive magic OverloadedRecordFields instances for specified types.+overloadedRecords+    :: DeriveOverloadedRecordsParams+    -- ^ Parameters for customization of deriving process. Use 'def' to get+    -- default behaviour.+    -> [Name]+    -- ^ Names of the types for which magic instances should be derived.+    -> DecsQ+overloadedRecords params = fmap concat . mapM (overloadedRecord params)++-- | Derive magic OverloadedRecordFields instances for specified type.+--+-- Similar to 'overloadedRecords', but instead of+-- 'DeriveOverloadedRecordsParams' value it takes function which can modify its+-- default value.+--+-- @+-- data Coordinates2D a+--     { coordinateX :: a+--     , coordinateY :: a+--     }+--+-- 'overloadedRecordsFor' ''Coordinates2D+--     $ \#fieldDerivation .~ \\_ _ _ -> \\case+--         Nothing -> Nothing+--         Just field -> lookup field+--            [ (\"coordinateX\", 'GetterOnlyField' \"x\" Nothing)+--            , (\"coordinateY\", 'GetterOnlyField' \"y\" Nothing)+--            ]+-- @+overloadedRecordFor+    :: Name+    -- ^ Name of the type for which magic instances should be derived.+    -> (DeriveOverloadedRecordsParams -> DeriveOverloadedRecordsParams)+    -- ^ Function that modifies parameters for customization of deriving+    -- process.+    -> DecsQ+overloadedRecordFor typeName f = overloadedRecord (f def) typeName++-- | Derive magic OverloadedRecordFields instances for specified types.+overloadedRecordsFor+    :: [Name]+    -- ^ Names of the types for which magic instances should be derived.+    -> (DeriveOverloadedRecordsParams -> DeriveOverloadedRecordsParams)+    -- ^ Function that modifies parameters for customization of deriving+    -- process.+    -> DecsQ+overloadedRecordsFor typeNames f = overloadedRecords (f def) typeNames++-- | Derive magic instances for all fields of a specific data constructor of a+-- specific type.+deriveForConstructor+    :: DeriveOverloadedRecordsParams+    -- ^ Parameters for customization of deriving process. Use 'def' to get+    -- default behaviour.+    -> Name+    -> [TyVarBndr]+    -> Con+    -> DecsQ+deriveForConstructor params name typeVars = \case+    NormalC constructorName args ->+        deriveFor constructorName args $ \(strict, argType) f ->+            f Nothing strict argType++    RecC constructorName args ->+        deriveFor constructorName args $ \(accessor, strict, argType) f ->+            f (Just accessor) strict argType++    InfixC arg0 constructorName arg1 ->+        deriveFor constructorName [arg0, arg1] $ \(strict, argType) f ->+            f Nothing strict argType++#if MIN_VERSION_template_haskell(2,11,0)+    GadtC _ _ _ -> fail "GADTs aren't yet supported."+    RecGadtC _ _ _ -> fail "GADTs aren't yet supported."+#endif++    -- Existentials aren't supported.+    ForallC _typeVariables _context _constructor -> return []+  where+    deriveFor+        :: Name+        -> [a]+        -> (a -> (Maybe Name -> Strict -> Type -> DecsQ) -> DecsQ)+        -> DecsQ+    deriveFor constrName args f =+        fmap concat . forM (withIndexes args) $ \(idx, arg) ->+            f arg $ \accessor strict fieldType' ->+                deriveForField params DeriveFieldParams+                    { typeName = name+                    , typeVariables = List.map getTypeName typeVars+                    , constructorName = constrName+                    , numberOfArgs = fromIntegral $ List.length args+                    , currentIndex = idx+                    , accessorName = accessor+                    , strictness = strict+                    , fieldType = fieldType'+                    }+      where+        getTypeName :: TyVarBndr -> Name+        getTypeName = \case+            PlainTV n -> n+            KindedTV n _kind -> n++    withIndexes = List.zip [(0 :: Word) ..]++-- | Parameters for 'deriveForField' function.+data DeriveFieldParams = DeriveFieldParams+    { typeName :: Name+    -- ^ Record name, i.e. type constructor name.+    , typeVariables :: [Name]+    -- ^ Free type variables of a type constructor.+    , constructorName :: Name+    -- ^ Data constructor name.+    , numberOfArgs :: Word+    -- ^ Number of arguments that data constructor takes.+    , currentIndex :: Word+    -- ^ Index of the current argument of a data constructor for which we are+    -- deriving overloaded record field instances. Indexing starts from zero.+    -- In other words 'currentIndex' is between zero (including) and+    -- 'numberOfArgs' (excluding).+    , accessorName :: Maybe Name+    -- ^ Record field accessor, if available, otherwise 'Nothing'.+    , strictness :: Strict+    -- ^ Strictness annotation of the current data constructor argument.+    , fieldType :: Type+    -- ^ Type of the current data constructor argument.+    }++-- | Derive magic instances for a specific field of a specific type.+deriveForField+    :: DeriveOverloadedRecordsParams+    -- ^ Parameters for customization of deriving process. Use 'def' to get+    -- default behaviour.+    -> DeriveFieldParams+    -- ^ All the necessary information for derivation procedure.+    -> DecsQ+deriveForField params DeriveFieldParams{..} =+    case possiblyLabel of+        Nothing -> return []+        Just (GetterOnlyField label customGetterExpr) ->+            deriveGetter' (strTyLitT label)+                $ fromMaybe derivedGetterExpr customGetterExpr+        Just (GetterAndSetterField label customGetterAndSetterExpr) -> (<>)+            <$> deriveGetter' labelType getterExpr+            <*> deriveSetter' labelType setterExpr+          where+            labelType = strTyLitT label++            (getterExpr, setterExpr) =+                fromMaybe (derivedGetterExpr, derivedSetterExpr)+                    customGetterAndSetterExpr+  where+    possiblyLabel = _fieldDerivation params (nameBase typeName)+        (nameBase constructorName) currentIndex (fmap nameBase accessorName)++    deriveGetter' labelType =+        deriveGetter labelType recordType (return fieldType)++    deriveSetter' labelType =+        deriveSetter labelType recordType (return fieldType) newRecordType+            newFieldType++    recordType = foldl appT (conT typeName) $ List.map varT typeVariables++    -- TODO: When field type is polymorphic, then we should allow to change it.+    newFieldType = return fieldType+    newRecordType = recordType++    -- Number of variables, i.e. arguments of a constructor, to the right of+    -- the currently processed field.+    numVarsOnRight = numberOfArgs - currentIndex - 1++    inbetween :: (a -> [b]) -> a -> a -> b -> [b]+    inbetween f a1 a2 b = f a1 <> (b : f a2)++    derivedGetterExpr = case accessorName of+        Just name -> varE name+        Nothing -> do+            a <- newName "a"+            -- \(C _ _ ... _ a _ _ ... _) -> a+            lamE [return . ConP constructorName $ nthArg (VarP a)] (varE a)+      where+        nthArg :: Pat -> [Pat]+        nthArg = inbetween wildPs currentIndex numVarsOnRight++    derivedSetterExpr = case accessorName of+        Just name -> do+            s <- newName "s"+            b <- newName "b"+            lamE [varP s, varP b] $ recUpdE (varE s) [(name, ) <$> varE b]+        Nothing -> do+            varsBefore <- newNames currentIndex "a"+            b <- newName "b"+            varsAfter <- newNames numVarsOnRight "a"++            -- \(C a_0 a_1 ... a_(i - 1) _ a_(i + 1) a_(i + 2) ... a_(n)) b ->+            --     C a_0 a_1 ... a_(i - 1) b a_(i + 1) a_(i + 2) ... a_(n)+            lamE [constrPattern varsBefore varsAfter, varP b]+                $ constrExpression varsBefore (varE b) varsAfter+          where+            constrPattern before after =+                conP constructorName $ inbetween varPs before after wildP++            constrExpression before b after = foldl appE (conE constructorName)+                $ varEs before <> (b : varEs after)++-- | Derive instances for overloaded record field, both getter and setter.+field+    :: String+    -- ^ Overloaded label name.+    -> TypeQ+    -- ^ Record type.+    -> TypeQ+    -- ^ Field type.+    -> TypeQ+    -- ^ Record type after update.+    -> TypeQ+    -- ^ Setter will set field to a value of this type.+    -> ExpQ+    -- ^ Getter function.+    -> ExpQ+    -- ^ Setter function.+    -> DecsQ+field label recType fldType newRecType newFldType getterExpr setterExpr = (<>)+    <$> deriveGetter labelType recType fldType getterExpr+    <*> deriveSetter labelType recType fldType newRecType newFldType setterExpr+  where+    labelType = strTyLitT label++-- | Derive instances for overloaded record field, both getter and setter. Same+-- as 'field', but record type is the same before and after update and so is+-- the field type.+simpleField+    :: String+    -- ^ Overloaded label name.+    -> TypeQ+    -- ^ Record type.+    -> TypeQ+    -- ^ Field type.+    -> ExpQ+    -- ^ Getter function.+    -> ExpQ+    -- ^ Setter function.+    -> DecsQ+simpleField label recType fldType = field label recType fldType recType fldType++-- | Derive instances for overloaded record field getter.+fieldGetter+    :: String+    -- ^ Overloaded label name.+    -> TypeQ+    -- ^ Record type.+    -> TypeQ+    -- ^ Field type+    -> ExpQ+    -- ^ Getter function.+    -> DecsQ+fieldGetter = deriveGetter . strTyLitT++-- | Derive only getter related instances.+deriveGetter :: TypeQ -> TypeQ -> TypeQ -> ExpQ -> DecsQ+deriveGetter labelType recordType fieldType getter =+    [d| type instance FieldType $(labelType) $(recordType) = $(fieldType)++        instance HasField $(labelType) $(recordType) $(fieldType) where+            getField _proxy = $(getter)+    |]++-- | Derive instances for overloaded record field setter. Same as+-- 'fieldSetter', but record type is the same before and after update and so is+-- the field type.+simpleFieldSetter+    :: String+    -- ^ Overloaded label name.+    -> TypeQ+    -- ^ Record type.+    -> TypeQ+    -- ^ Field type.+    -> ExpQ+    -- ^ Setter function.+    -> DecsQ+simpleFieldSetter label recordType fieldType =+    fieldSetter label recordType fieldType recordType fieldType++-- | Derive instances for overloaded record field setter.+fieldSetter+    :: String+    -- ^ Overloaded label name.+    -> TypeQ+    -- ^ Record type.+    -> TypeQ+    -- ^ Field type.+    -> TypeQ+    -- ^ Record type after update.+    -> TypeQ+    -- ^ Setter will set field to a value of this type.+    -> ExpQ+    -- ^ Setter function.+    -> DecsQ+fieldSetter = deriveSetter . strTyLitT++-- | Derive only setter related instances.+deriveSetter :: TypeQ -> TypeQ -> TypeQ -> TypeQ -> TypeQ -> ExpQ -> DecsQ+deriveSetter labelType recordType fieldType newRecordType newFieldType setter =+    [d| type instance UpdateType $(labelType) $(recordType) $(newFieldType) =+            $(newRecordType)++        instance+            ModifyField $(labelType) $(recordType) $(newRecordType)+                $(fieldType) $(newFieldType)+          where+            setField _proxy = $(setter)+    |]++-- | Construct list of wildcard patterns ('WildP').+wildPs :: Word -> [Pat]+wildPs n = List.replicate (fromIntegral n) WildP++-- | Construct list of new names usin 'newName'.+newNames :: Word -> String -> Q [Name]+newNames n s = fromIntegral n `replicateM` newName s++varPs :: [Name] -> [PatQ]+varPs = List.map varP++varEs :: [Name] -> [ExpQ]+varEs = List.map varE++strTyLitT :: String -> TypeQ+strTyLitT = litT . strTyLit

@@ -16,9 +16,11 @@ module TestCase.Data.OverloadedRecords (tests)   where +import Prelude (Num((+)))+ import Data.Bool (Bool(False, True)) import Data.Eq (Eq)-import Data.Function (($), (&), (.), const)+import Data.Function (($), (.), const, flip, id) import Data.Functor.Identity (Identity(Identity, runIdentity)) import Data.Int (Int) import Data.List (map)@@ -33,6 +35,7 @@ import Test.HUnit ((@?=))  import Data.OverloadedLabels.TH (label, labels)+import Data.OverloadedRecords (HasField(getField), ModifyField(setField), set') import Data.OverloadedRecords.TH (defaultMakeFieldName, overloadedRecord)  @@ -51,6 +54,33 @@ overloadedRecord def ''Bar label "bar" +-- Type isomorphic to (a, b), the reason for not using (a, b) directly is to+-- prevent any possible instance declaration clashes in the future.+data Pair a b = Pair a b+  deriving (Eq, Show)++{-+type instance FieldType "fst" (Pair a b) = a+type instance FieldType "snd" (Pair a b) = b++type instance UpdateType "fst" (Pair a b) a' = Pair a' b+type instance UpdateType "snd" (Pair a b) b' = Pair a  b'+-}++instance HasField "fst" (Pair a b) a where+    getField _proxy (Pair a _) = a++instance HasField "snd" (Pair a b) b where+    getField _proxy (Pair _ b) = b++instance ModifyField "fst" (Pair a b) (Pair a' b) a a' where+    setField _proxy (Pair _ b) a' = Pair a' b++instance ModifyField "snd" (Pair a b) (Pair a b') b b' where+    setField _proxy (Pair a _) b' = Pair a b'++labels ["fst", "snd", "head", "tail"]+ tests :: [Test] tests =     [ testGroup "defaultMakeFieldName" $ map test_defaultMakeField@@ -72,9 +102,80 @@             $ (Foo 1 False & x .~ 2) @?= Foo 2 False         , testCase "Foo 1 False & y .~ True = Foo 1 True"             $ (Foo 1 False & y .~ True) @?= Foo 1 True-        , testCase "Bar (Just True) & bar .~ Nothing = Bar Nothing"-            $ (Bar (Just True) & bar .~ Nothing) @?= Bar Nothing+        , testCase "Bar (Just True) & bar .~ Nothing =\+            \ Bar (Nothing :: Maybe Bool)"+            $ (Bar (Just True) & bar .~ Nothing)+                @?= Bar (Nothing :: Maybe Bool)+        , testCase "Bar (Just True) & bar .~ Nothing =\+            \ Bar (Nothing :: Maybe Bool)"+            $ (Bar (Just True) & bar .~ Nothing)+                @?= Bar (Nothing :: Maybe Bool)+        , testCase "Bar (Just True) & simple . bar .~ Nothing = Bar Nothing"+            $ (Bar (Just True) & simple . bar .~ Nothing) @?= Bar Nothing+        , testCase "fst (Pair (1 :: Int) False) = 1"+            $ fst (Pair (1 :: Int) False) @?= 1+        , testCase "snd (Pair (1 :: Int) False) = False"+            $ snd (Pair (1 :: Int) False) @?= False+        , testCase "Pair (1 :: Int) False & fst .~ True = Pair True False"+            $ (Pair (1 :: Int) False & fst .~ True) @?= Pair True False+        , testCase "Pair (1 :: Int) False & fst .~ Just True =\+            \ Pair 1 (Just True)"+            $ (Pair (1 :: Int) False & snd .~ Just True) @?= Pair 1 (Just True)+        , testCase "Pair (1 :: Int) False & fst %~ (+1) = Pair 2 False"+            $ (Pair (1 :: Int) False & fst %~ (+1)) @?= Pair 2 False+        , testCase "Pair (1 :: Int) False & fst %~ show = Pair \"1\" False"+            $ (Pair (1 :: Int) False & fst %~ show) @?= Pair "1" False         ]+    , testGroup "#head for [a]"+        [ testCase "#head ([] :: Int) = Nothing"+            $ head ([] :: [Int]) @?= Nothing+        , testCase "#head [1, 2, 3] = Just 1"+            $ head [1, 2, 3 :: Int] @?= Just 1+            -- Type signature is here just to suppress defaulting warnings.+        ]+    , testGroup "#head for [a]"+        [ testCase "set' #head Nothing [] = []"+            $ set' head Nothing [] @?= ([] :: [Int])+        , testCase "[] & simple . #head .~ Nothing = []"+            $ ([] & simple . head .~ Nothing) @?= ([] :: [Int])+        , testCase "set' #head (Just 1) [] = [1]"+            $ set' head (Just 1) [] @?= [1 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[] & simple . #head .~ Just 1 = [1 :: Int]"+            $ ([] & simple . head .~ Just 1) @?= [1 :: Int]+        , testCase "set #head Nothing [1, 2, 3] = [2, 3]"+            $ set' head Nothing [1, 2, 3] @?= [2, 3 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[1, 2, 3] & simple . #head .~ Nothing = [2, 3]"+            $ ([1, 2, 3] & simple . head .~ Nothing) @?= [2, 3 :: Int]+        , testCase "set #head (Just 4) [1, 2, 3] = [4, 2, 3]"+            $ set' head (Just 4) [1, 2, 3] @?= [4, 2, 3 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[1, 2, 3] & simple . #head .~ Just 4 = [4, 2, 3]"+            $ ([1, 2, 3] & simple . head .~ Just 4) @?= [4, 2, 3 :: Int]+        ]+    , testGroup "#tail for [a]"+        [ testCase "set' #tail Nothing [] = []"+            $ set' tail Nothing [] @?= ([] :: [Int])+        , testCase "[] & simple . #tail .~ Nothing = []"+            $ ([] & simple . tail .~ Nothing) @?= ([] :: [Int])+        , testCase "set' #tail (Just [1, 2]) [] = [1, 2]"+            $ set' tail (Just [1, 2]) [] @?= [1, 2 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[] & simple . #tail .~ Just [1, 2] = [1, 2]"+            $ ([] & simple . tail .~ Just [1, 2]) @?= [1, 2 :: Int]+        , testCase "set' #tail Nothing [1, 2, 3] = [1]"+            $ set' tail Nothing [1, 2, 3] @?= [1 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[1, 2, 3] & simple . #tail .~ Nothing = [1 :: Int]"+            $ ([1, 2, 3] & simple . tail .~ Nothing) @?= [1 :: Int]+        , testCase "set' #tail (Just [4, 5, 6]) [1, 2, 3] = [1, 4, 5, 6]"+            $ set' tail (Just [4, 5, 6]) [1, 2, 3] @?= [1, 4, 5, 6 :: Int]+            -- Type signature is here just to suppress defaulting warnings.+        , testCase "[1, 2, 3] & simple . #tail .~ Just [4, 5, 6] = [1, 4, 5, 6]"+            $ ([1, 2, 3] & simple . tail .~ Just [4, 5, 6])+                @?= [1, 4, 5, 6 :: Int]+        ]     ]   where     test_defaultMakeField (input, output) =@@ -85,4 +186,18 @@         cn = "ConstructorName"      (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t-    (.~) l b = runIdentity . l (const $ Identity b)+    l .~ b = runIdentity . l (const $ Identity b)+    infixr 4 .~++    (%~) :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t+    l %~ f = runIdentity . l (Identity . f)+    infixr 4 %~++    -- Data.Function constains (&) since base 4.8.0.0, which was bundled with+    -- GHC 7.10, but we are supporting also GHC 7.8.+    (&) :: a -> (a -> b) -> b+    (&) = flip ($)+    infixl 1 &++    simple :: p a (f a) -> p a (f a)+    simple = id