overloaded-records (empty) → 0.1.0.0
raw patch · 9 files changed
+919/−0 lines, 9 filesdep +basedep +data-default-classdep +template-haskellsetup-changed
Dependencies added: base, data-default-class, template-haskell
Files
- ChangeLog.md +14/−0
- LICENSE +61/−0
- README.md +80/−0
- Setup.hs +2/−0
- overloaded-records.cabal +87/−0
- src/Data/OverloadedLabels.hs +47/−0
- src/Data/OverloadedLabels/TH.hs +76/−0
- src/Data/OverloadedRecords.hs +118/−0
- src/Data/OverloadedRecords/TH.hs +434/−0
+ ChangeLog.md view
@@ -0,0 +1,14 @@+# ChangeLog / ReleaseNotes+++## Version 0.1.0.0++* First public release.+* Uploaded to [Hackage][]:+ <http://hackage.haskell.org/package/overloaded-records-0.1.0.0>++++[Hackage]:+ http://hackage.haskell.org/+ "HackageDB (or just Hackage) is a collection of releases of Haskell packages."
+ LICENSE view
@@ -0,0 +1,61 @@+Copyright (c) 2016, Peter Trško++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Peter Trško nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++*******************************************************************************++LICENSE of a prototype implementation of overloaded record fields for GHC++Repository URL:+ https://github.com/adamgundry/records-prototype++Original LICENSE URL:+ https://github.com/adamgundry/records-prototype/blob/master/LICENSE++The MIT License (MIT)++Copyright (c) 2013 Adam Gundry++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,80 @@+# Overloaded Records++[][Hackage: overloaded-records]+[](http://packdeps.haskellers.com/reverse/overloaded-records)+[][Haskell.org]+[][tl;dr Legal: BSD3]++[](https://travis-ci.org/trskop/overloaded-records)+++## Description++Implementation of /Overloaded Records/ based on current GHC proposal.++This implementation is highly experimental and may change rapidly.++More about the current status of OverloadedRecordFields language extension can+be found on [GHC Wiki: OverloadedRecordFields][].+++## Usage Example++```Haskell+{-# LANGUAGE DataKinds #-} -- overloadedRecords, labels+{-# LANGUAGE FlexibleContexts #-} -- labels+{-# LANGUAGE FlexibleInstances #-} -- overloadedRecords+{-# LANGUAGE MultiParamTypeClasses #-} -- overloadedRecords+{-# LANGUAGE TemplateHaskell #-} -- overloadedRecords, labels+{-# LANGUAGE TypeFamilies #-} -- overloadedRecords+module FooBar+ where++import Data.Default.Class (Default(def))++import Data.OverloadedRecords.TH (overloadedRecords)+import Data.OverloadedLabels.TH (label, labels)+++data Foo a = Foo+ { _x :: Int+ , _y :: a+ }++overloadedRecords def ''Foo+labels ["x", "y"]++newtype Bar a = Bar {_bar :: a}++overloadedRecords def ''Bar+label "bar"+```+++## License++The BSD 3-Clause License, see [LICENSE][] file for details. This implementation+is based on original prototype, which is under MIT License.+++## Contributions++Contributions, pull requests and bug reports are welcome! Please don't be+afraid to contact author using GitHub or by e-mail.+++[GHC Wiki: OverloadedRecordFields]:+ https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields+ "OverloadedRecordFields language extension on GHC Wiki"+[Hackage: overloaded-records]:+ http://hackage.haskell.org/package/overloaded-records+ "overloaded-records package on Hackage"+[Haskell.org]:+ http://www.haskell.org+ "The Haskell Programming Language"+[LICENSE]:+ https://github.com/trskop/overloaded-records/blob/master/LICENSE+ "License of overloaded-records package."+[tl;dr Legal: BSD3]:+ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29+ "BSD 3-Clause License (Revised)"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ overloaded-records.cabal view
@@ -0,0 +1,87 @@+name: overloaded-records+version: 0.1.0.0+synopsis: Overloaded Records based on current GHC proposal.+description:+ Implementation of /Overloaded Records/ based on current GHC proposal.+ .+ This implementation is highly experimental and may change rapidly.+ .+ More about the current status of OverloadedRecordFields language extension+ can be found on:+ <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields GHC Wiki: OverloadedRecordFields>.+ .+ See README for usage example.++homepage: https://github.com/trskop/overloaded-records+bug-reports: https://github.com/trskop/overloaded-records/issues+license: BSD3+license-file: LICENSE+author: Peter Trško+maintainer: peter.trsko@gmail.com+copyright: (c) 2016, Peter Trško+category: Data+build-type: Simple+cabal-version: >=1.10++extra-source-files:+ ChangeLog.md+ , README.md++flag pedantic+ description: Pass additional warning flags to GHC.+ default: False+ manual: True++library+ hs-source-dirs: src+ exposed-modules:+ Data.OverloadedLabels+ , Data.OverloadedLabels.TH+ , Data.OverloadedRecords+ , Data.OverloadedRecords.TH+ -- other-modules:++ default-language: Haskell2010+ other-extensions:+ CPP+ , DataKinds+ , DeriveDataTypeable+ , DeriveGeneric+ , ExplicitForAll+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , KindSignatures+ , LambdaCase+ , MagicHash+ , MultiParamTypeClasses+ , NoImplicitPrelude+ , RecordWildCards+ , TemplateHaskell+ , TupleSections+ , TypeFamilies+ , UndecidableInstances++ build-depends:+ base >=4.7 && <5+ , data-default-class ==0.0.*+ , template-haskell >=2.9 && <2.12++ if impl(ghc >=8.0)+ cpp-options: -DHAVE_MONAD_FAIL++ ghc-options: -Wall+ if flag(pedantic)+ ghc-options:+ -fwarn-tabs+ -fwarn-implicit-prelude+-- -Werror++source-repository head+ type: git+ location: git://github.com/trskop/overloaded-records.git++source-repository this+ type: git+ location: git://github.com/trskop/overloaded-records.git+ tag: 0.1.0.0
+ src/Data/OverloadedLabels.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module: $HEADER$+-- Description: Magic class for OverloadedLabels.+-- Copyright: (c) 2016, Peter Trško+-- License: BSD3+--+-- Maintainer: peter.trsko@gmail.com+-- Stability: experimental+-- Portability: NoImplicitPrelude+--+-- This module defines the `IsLabel` class is used by the OverloadedLabels+-- extension. See the+-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page>+-- for more details.+--+-- The key idea is that when GHC sees an occurrence of the new+-- overloaded label syntax @#foo@, it is replaced with+--+-- > fromLabel (proxy# :: Proxy# "foo") :: alpha+--+-- plus a wanted constraint @IsLabel "foo" alpha@.+module Data.OverloadedLabels+ (+ -- * Oveloaded Labels+ IsLabel(..)+ )+ where++#ifdef HAVE_OVERLOADED_LABELS+import GHC.OverloadedLabels (IsLabel(fromLabel))+#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
+ src/Data/OverloadedLabels/TH.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module: $HEADER$+-- Description: Derive instances of IsLabel magic class for OverloadedLabels.+-- Copyright: (c) 2016, Peter Trško+-- License: BSD3+--+-- Maintainer: peter.trsko@gmail.com+-- Stability: experimental+-- Portability: NoImplicitPrelude+--+-- Derive instances of 'IsLabel' magic class for OverloadedLabels.+--+-- If you are using GHC, then you should use OverloadedLabels language+-- extension and not this module.+module Data.OverloadedLabels.TH+ ( label+ , labelNoSig+ , labels+ , labelsNoSig+ )+ where++import Control.Applicative (Applicative((<*>)))+import Data.Foldable (concat)+import Data.Function ((.), ($))+import Data.Functor (Functor(fmap), (<$>))+import Data.String (String)+import Data.Traversable (mapM, sequenceA)+import GHC.Exts (Proxy#, proxy#)++import Language.Haskell.TH+ ( DecsQ+ , litT+ , mkName+ , normalB+ , sigD+ , strTyLit+ , valD+ , varP+ )++import Data.OverloadedLabels (IsLabel(fromLabel))+++-- | Define overloaded label:+--+-- @+-- \<label-name\> :: 'IsLabel' \"\<label-name\>\" a => a+-- \<label-name\> = 'fromLabel' ('proxy#' :: 'Proxy#' \"\<label-name\>\")+-- @+label :: String -> DecsQ+label l = (:) <$> sig <*> labelNoSig l+ where+ sig = mkName l `sigD` [t|forall a. IsLabel $(litT $ strTyLit l) a => a|]++-- | Define overloaded label, but without a type signature:+--+-- @+-- \<label-name\> = 'fromLabel' ('proxy#' :: 'Proxy#' \"\<label-name\>\")+-- @+labelNoSig :: String -> DecsQ+labelNoSig l = sequenceA [varP (mkName l) `valD` normalB body $ []]+ where+ body = [| fromLabel (proxy# :: Proxy# $(litT $ strTyLit l)) |]++-- | Same as 'label', but defines multiple overloaded labels at once.+labels :: [String] -> DecsQ+labels = fmap concat . mapM label++-- | Same as 'labelsNoSig', but defines multiple overloaded labels at once.+labelsNoSig :: [String] -> DecsQ+labelsNoSig = fmap concat . mapM labelNoSig
+ src/Data/OverloadedRecords.hs view
@@ -0,0 +1,118 @@+{-# 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+ , FieldType+ , HasField(..)++ , UpdateType+ , SetField(..)+ , Setter+ , set+ )+ 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++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++-- | @'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)++-- | @'Proxy#' l -> r -> a@+instance+ ( HasField l s a+ , FieldType l s ~ a+ , FromArrow s ~ 'False+ ) => IsFieldAccessor l s a 'False+ where+ fieldAccessor = getField++newtype Setter s t b = Setter (s -> b -> t)++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)
+ src/Data/OverloadedRecords/TH.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++#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, DeriveDataTypeable, DeriveGeneric, LambdaCase,+-- NoImplicitPrelude, RecordWildCards, TemplateHaskell,+-- TupleSections+--+-- Derive magic instances for OverloadedRecordFields.+module Data.OverloadedRecords.TH+ (+ -- * Derive OverloadedRecordFields instances+ overloadedRecords+ , DeriveOverloadedRecordsParams+ , MakeAccessorName+ , makeAccessorName+ , defaultMakeAccessorName+ )+ 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))+import Data.Monoid ((<>))+import Data.String (String)+import Data.Traversable (forM)+import Data.Typeable (Typeable)+import Data.Word (Word)+import GHC.Generics (Generic)+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+ ( FieldType+ , HasField(getField)+ , SetField(setField)+ , UpdateType+ )+++-- Parameters for customization of deriving process. Use 'def' to get+-- default behaviour.+data DeriveOverloadedRecordsParams = DeriveOverloadedRecordsParams+ { _strictAccessors :: Bool+ -- ^ Make setter and getter strict. **Currently unused.**+ , _makeAccessorName :: MakeAccessorName+ -- ^ See 'MakeAccessorName' for description.+ }+ deriving (Generic, Typeable)++-- | Pseudo type definition:+--+-- @+-- :: TypeName+-- -> ConstructorName+-- -> FieldIndex+-- -> Maybe AccessorName+-- -> Maybe OverloadedLabelName+-- @+--+-- If field has an accessor 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.+--+-- @FieldIndex@ is starting from zero.+type MakeAccessorName =+ String -> String -> Word -> Maybe String -> Maybe String++-- | Lens for accessing function that specifies what magic instances will be+-- defined and what will be the names of overloaded record fields.+makeAccessorName+ :: Functor f+ => (MakeAccessorName -> f MakeAccessorName)+ -> DeriveOverloadedRecordsParams -> f DeriveOverloadedRecordsParams+makeAccessorName f s@DeriveOverloadedRecordsParams{_makeAccessorName = a} =+ (\b -> s{_makeAccessorName = b}) <$> f a++-- | Suppose we have a weird type definition as this:+--+-- @+-- data SomeType = SomeConstructor+-- { _fieldX :: a+-- , someTypeFieldY :: b+-- , someConstructorFieldZ :: c+-- }+-- @+--+-- Then for each of those fields, 'defaultMakeAccessorName' will produce+-- expected OverloadedLabel name:+--+-- * @_fieldX --> fieldX@+--+-- * @someTypeFieldY --> fieldY@+--+-- * @someConstructorFieldZ --> fieldZ@+--+-- Any other field name is kept unchanged.+defaultMakeAccessorName+ :: 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.+ -> Maybe String+ -- ^ Name of the field (record) accessor; 'Nothing' means that there is no+ -- record accessor defined for it.+ -> Maybe String+ -- ^ Overloaded label name for the field; 'Nothing' means that there+ -- shouldn't be a label associated with it.+defaultMakeAccessorName typeName constructorName _fieldPosition = \case+ Nothing -> Nothing+ Just fieldName+ | startsWith "_" -> Just $ dropPrefix "_" fieldName+ | startsWith typePrefix -> Just $ dropPrefix typePrefix fieldName+ | startsWith constructorPrefix -> Just $ dropPrefix typePrefix fieldName+ | otherwise -> Just fieldName+ where+ startsWith :: String -> Bool+ startsWith = (`List.isPrefixOf` fieldName)++ dropPrefix :: String -> String -> String+ dropPrefix s = List.drop (List.length s)++ headToLower "" = ""+ headToLower (x : xs) = Char.toLower x : xs++ typePrefix = headToLower typeName+ constructorPrefix = headToLower constructorName++-- |+-- @+-- 'def' = 'DeriveOverloadedRecordsParams'+-- { strictAccessors = 'False'+-- , 'makeAccessorName' = 'defaultMakeAccessorName'+-- }+-- @+instance Default DeriveOverloadedRecordsParams where+ def = DeriveOverloadedRecordsParams+ { _strictAccessors = False+ , _makeAccessorName = defaultMakeAccessorName+ }++-- | Derive magic OverloadedRecordFields instances for specified type name.+overloadedRecords+ :: 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+overloadedRecords 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 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++ -- 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 label -> (<>)+ <$> deriveGetter labelType recordType (return fieldType) getterExpr+ <*> deriveSetter labelType recordType (return fieldType) newRecordType+ newFieldType setterExpr+ where+ labelType = strTyLitT label+ where+ possiblyLabel = _makeAccessorName params (nameBase typeName)+ (nameBase constructorName) currentIndex (fmap nameBase accessorName)++ 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)++ getterExpr = 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++ setterExpr = 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 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 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