diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,14 @@ +# ChangeLog / ReleaseNotes + + +## Version 0.1.0.0 + +* First public release. +* Uploaded to [Hackage][]: + + + + +[Hackage]: + http://hackage.haskell.org/ + "HackageDB (or just Hackage) is a collection of releases of Haskell packages." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +# Overloaded Records + +[![Hackage](http://img.shields.io/hackage/v/overloaded-records.svg)][Hackage: overloaded-records] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/overloaded-records.svg)](http://packdeps.haskellers.com/reverse/overloaded-records) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] + +[![Build](https://travis-ci.org/trskop/overloaded-records.svg)](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)" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/overloaded-records.cabal b/overloaded-records.cabal new file mode 100644 --- /dev/null +++ b/overloaded-records.cabal @@ -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: + . + . + 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 diff --git a/src/Data/OverloadedLabels.hs b/src/Data/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/src/Data/OverloadedLabels.hs @@ -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 +-- +-- 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 diff --git a/src/Data/OverloadedLabels/TH.hs b/src/Data/OverloadedLabels/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/OverloadedLabels/TH.hs @@ -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: +-- +-- @ +-- \ :: 'IsLabel' \"\\" a => a +-- \ = 'fromLabel' ('proxy#' :: 'Proxy#' \"\\") +-- @ +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: +-- +-- @ +-- \ = 'fromLabel' ('proxy#' :: 'Proxy#' \"\\") +-- @ +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 diff --git a/src/Data/OverloadedRecords.hs b/src/Data/OverloadedRecords.hs new file mode 100644 --- /dev/null +++ b/src/Data/OverloadedRecords.hs @@ -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: +-- +-- 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: +-- +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) diff --git a/src/Data/OverloadedRecords/TH.hs b/src/Data/OverloadedRecords/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/OverloadedRecords/TH.hs @@ -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