diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,21 @@ # ChangeLog / ReleaseNotes +## Version 0.2.0.0 + +* Function `overloadedRecords` renamed to `overloadedRecord`. There is also new + `overloadedRecords` function, that behaves as `overloadedRecord`, but for + multiple types at once. (**breaking change**) +* It is now possible to customize overloadedRecord\* family of functions with + custom getter and setter implementation. (**new**) +* Types and functions follow, hopefully, better naming conventions. (**change**) +* More low-level template haskell functions for those cases when it is + necessary to build your own higher-level ones, or when you need much more + control over the result. (**new**) +* Uploaded to [Hackage][]: + + + ## Version 0.1.0.0 * First public release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,8 +10,45 @@ ## Description -Implementation of /Overloaded Records/ based on current GHC proposal. +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 fields can be used +directly as getters and lenses. +```Haskell +import Data.OverloadedRecords.TH (overloadedRecord) + +newtype Bar a = Bar {_bar :: a} + +overloadedRecord def ''Bar +``` + +On GHC 8.0.1 it is possible to just write: + +```Haskell +{-# LANGUAGE OverloadedLabels #-} + +import Control.Lens ((+~)) + +add :: Int -> Bar Int -> Bar Int +add n = #bar +~ n +``` + +For older GHC versions there is a family of Template Haskell functions that +will derive overloaded labels in form of standard haskell definitions: + +```Haskell +import Control.Lens ((+~)) +import Data.OverloadedLabels.TH (label) + +label "bar" + +add :: Int -> Bar Int -> Bar Int +add n = bar +~ n +``` + This implementation is highly experimental and may change rapidly. More about the current status of OverloadedRecordFields language extension can @@ -21,18 +58,18 @@ ## Usage Example ```Haskell -{-# LANGUAGE DataKinds #-} -- overloadedRecords, labels +{-# LANGUAGE DataKinds #-} -- overloadedRecord, labels {-# LANGUAGE FlexibleContexts #-} -- labels -{-# LANGUAGE FlexibleInstances #-} -- overloadedRecords -{-# LANGUAGE MultiParamTypeClasses #-} -- overloadedRecords -{-# LANGUAGE TemplateHaskell #-} -- overloadedRecords, labels -{-# LANGUAGE TypeFamilies #-} -- overloadedRecords +{-# LANGUAGE FlexibleInstances #-} -- overloadedRecord +{-# LANGUAGE MultiParamTypeClasses #-} -- overloadedRecord +{-# LANGUAGE TemplateHaskell #-} -- overloadedRecord, labels +{-# LANGUAGE TypeFamilies #-} -- overloadedRecord module FooBar where import Data.Default.Class (Default(def)) -import Data.OverloadedRecords.TH (overloadedRecords) +import Data.OverloadedRecords.TH (overloadedRecord) import Data.OverloadedLabels.TH (label, labels) @@ -41,12 +78,12 @@ , _y :: a } -overloadedRecords def ''Foo +overloadedRecord def ''Foo labels ["x", "y"] newtype Bar a = Bar {_bar :: a} -overloadedRecords def ''Bar +overloadedRecord def ''Bar label "bar" ``` diff --git a/overloaded-records.cabal b/overloaded-records.cabal --- a/overloaded-records.cabal +++ b/overloaded-records.cabal @@ -1,16 +1,21 @@ name: overloaded-records -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Overloaded Records based on current GHC proposal. description: - Implementation of /Overloaded Records/ based on current GHC proposal. + 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 + fields can be used directly as getters and lenses. . + See README for usage examples. + . 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 @@ -84,4 +89,4 @@ source-repository this type: git location: git://github.com/trskop/overloaded-records.git - tag: 0.1.0.0 + tag: 0.2.0.0 diff --git a/src/Data/OverloadedRecords/TH.hs b/src/Data/OverloadedRecords/TH.hs --- a/src/Data/OverloadedRecords/TH.hs +++ b/src/Data/OverloadedRecords/TH.hs @@ -1,12 +1,22 @@ {-# 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 @@ -26,19 +36,37 @@ -- -- Maintainer: peter.trsko@gmail.com -- Stability: experimental --- Portability: CPP, DeriveDataTypeable, DeriveGeneric, LambdaCase, --- NoImplicitPrelude, RecordWildCards, TemplateHaskell, --- TupleSections +-- 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 ( -- * Derive OverloadedRecordFields instances - overloadedRecords + overloadedRecord + , overloadedRecords + , overloadedRecordFor + , overloadedRecordsFor + + -- ** Customize Derivation Process , DeriveOverloadedRecordsParams - , MakeAccessorName - , makeAccessorName - , defaultMakeAccessorName +#ifndef HAVE_OVERLOADED_LABELS + , fieldDerivation +#endif + , FieldDerivation + , OverloadedField(..) + , defaultFieldDerivation + , defaultMakeFieldName + + -- * Low-level Deriving Mechanism + , field + , simpleField + , fieldGetter + , fieldSetter + , simpleFieldSetter ) where @@ -64,13 +92,16 @@ , replicate , zip ) -import Data.Maybe (Maybe(Just, Nothing)) +import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.Monoid ((<>)) import Data.String (String) -import Data.Traversable (forM) +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 @@ -107,6 +138,9 @@ import Data.Default.Class (Default(def)) +#ifndef HAVE_OVERLOADED_LABELS +import Data.OverloadedLabels (IsLabel(fromLabel)) +#endif import Data.OverloadedRecords ( FieldType , HasField(getField) @@ -115,54 +149,86 @@ ) --- Parameters for customization of deriving process. Use 'def' to get +#ifndef HAVE_OVERLOADED_LABELS +-- | Overloaded label that can be used for accessing function of type +-- 'FieldDerivation' from 'DeriveOverloadedRecordsParams'. +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 - { _strictAccessors :: Bool + { _strictFields :: Bool -- ^ Make setter and getter strict. **Currently unused.** - , _makeAccessorName :: MakeAccessorName - -- ^ See 'MakeAccessorName' for description. + , _fieldDerivation :: FieldDerivation + -- ^ See 'FieldDerivation' for description. } deriving (Generic, Typeable) --- | Pseudo type definition: --- --- @ --- :: TypeName --- -> ConstructorName --- -> FieldIndex --- -> Maybe AccessorName --- -> Maybe OverloadedLabelName --- @ +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 accessor then the function will get its name or 'Nothing' +-- 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. --- --- @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 +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 = SomeConstructor +-- data SomeType a b c = SomeConstructor -- { _fieldX :: a -- , someTypeFieldY :: b -- , someConstructorFieldZ :: c +-- , anythingElse :: (a, b, c) -- } -- @ -- --- Then for each of those fields, 'defaultMakeAccessorName' will produce +-- Then for each of those fields, 'defaultMakeFieldName' will produce -- expected OverloadedLabel name: -- -- * @_fieldX --> fieldX@ @@ -171,27 +237,29 @@ -- -- * @someConstructorFieldZ --> fieldZ@ -- --- Any other field name is kept unchanged. -defaultMakeAccessorName +-- * @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 label name for the field; 'Nothing' means that there - -- shouldn't be a label associated with it. -defaultMakeAccessorName typeName constructorName _fieldPosition = \case + -- ^ 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 constructorPrefix -> Just $ dropPrefix typePrefix fieldName - | otherwise -> Just fieldName + | otherwise -> Nothing where startsWith :: String -> Bool startsWith = (`List.isPrefixOf` fieldName) @@ -205,28 +273,33 @@ typePrefix = headToLower typeName constructorPrefix = headToLower constructorName +-- | Function used by default value of 'DeriveOverloadedRecordsParams'. +defaultFieldDerivation :: FieldDerivation +defaultFieldDerivation = + (((fmap (`GetterAndSetterField` Nothing) .) .) .) . defaultMakeFieldName + -- | -- @ -- 'def' = 'DeriveOverloadedRecordsParams' --- { strictAccessors = 'False' --- , 'makeAccessorName' = 'defaultMakeAccessorName' +-- { strictFields = 'False' +-- , 'fieldDerivation' = 'defaultFieldDerivation' -- } -- @ instance Default DeriveOverloadedRecordsParams where def = DeriveOverloadedRecordsParams - { _strictAccessors = False - , _makeAccessorName = defaultMakeAccessorName + { _strictFields = False + , _fieldDerivation = defaultFieldDerivation } --- | Derive magic OverloadedRecordFields instances for specified type name. -overloadedRecords +-- | 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 -overloadedRecords params = withReified $ \name -> \case +overloadedRecord params = withReified $ \name -> \case TyConI dec -> case dec of -- Not supporting DatatypeContexts, hence the [] required as the first -- argument to NewtypeD and DataD. @@ -257,6 +330,55 @@ 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 @@ -280,6 +402,13 @@ 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 @@ -343,16 +472,29 @@ deriveForField params DeriveFieldParams{..} = case possiblyLabel of Nothing -> return [] - Just label -> (<>) - <$> deriveGetter labelType recordType (return fieldType) getterExpr - <*> deriveSetter labelType recordType (return fieldType) newRecordType - newFieldType setterExpr + 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 = _makeAccessorName params (nameBase typeName) + 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. @@ -366,7 +508,7 @@ inbetween :: (a -> [b]) -> a -> a -> b -> [b] inbetween f a1 a2 b = f a1 <> (b : f a2) - getterExpr = case accessorName of + derivedGetterExpr = case accessorName of Just name -> varE name Nothing -> do a <- newName "a" @@ -376,7 +518,7 @@ nthArg :: Pat -> [Pat] nthArg = inbetween wildPs currentIndex numVarsOnRight - setterExpr = case accessorName of + derivedSetterExpr = case accessorName of Just name -> do s <- newName "s" b <- newName "b" @@ -397,6 +539,59 @@ 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 = @@ -405,6 +600,39 @@ 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