diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2023 Barry Moore + +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,37 @@ +Derive HasField instances +=== + +The [`OverloadedRecordDot`][overloaded-record-dot] syntax is surprisingly nice. +I really enjoy writing code with this extension and I was originally hesistant. + +[Persistent][persistent] has a really nice feature where it will automatically remove +prefixes from models. Given a model like, + +``` +BankAccount + accountNumber String +``` + +You would normally reference this field as `bankAccountAccountNumber`. However, +with overloaded record dot you can write `bankAccount.accountNumber` which is +much nicer. + +At work, I really wanted this for **every** record. With this library, I can +write, + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +import DeriveHasField + +data BankAccount = + BankAccount + { bankAccountAccountNumber :: String + } + +deriveHasFieldWith (dropPrefix "bankAccount") ''BankAccount +``` + +[overloaded-record-dot]: https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_record_dot.html +[persistent]: https://github.com/yesodweb/persistent diff --git a/derive-has-field.cabal b/derive-has-field.cabal new file mode 100644 --- /dev/null +++ b/derive-has-field.cabal @@ -0,0 +1,68 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: derive-has-field +version: 0.0.1.0 +synopsis: Derive HasField instances with Template Haskell +description: A Template Haskell function to derive HasField instances to utilize OverloadedRecordDot more effectively. +homepage: https://github.com/chiroptical/snail#readme +bug-reports: https://github.com/chiroptical/snail/issues +author: Barry Moore II +maintainer: chiroptical@gmail.com +copyright: Barry Moore II +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/chiroptical/snail + +library + exposed-modules: + DeriveHasField + other-modules: + Paths_derive_has_field + hs-source-dirs: + src + default-extensions: + DeriveGeneric + ImportQualifiedPost + LambdaCase + OverloadedStrings + RecordWildCards + TypeApplications + build-depends: + base >=4.7 && <5 + , template-haskell + , th-abstraction >0.4 && <0.7 + default-language: Haskell2010 + +test-suite derive-has-field-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + DeriveHasFieldSpec + Import + Paths_derive_has_field + hs-source-dirs: + test + default-extensions: + DeriveGeneric + ImportQualifiedPost + LambdaCase + OverloadedStrings + RecordWildCards + TypeApplications + build-depends: + base >=4.7 && <5 + , derive-has-field + , hspec >=2.10.10 && <2.11 + , template-haskell + , th-abstraction >0.4 && <0.7 + default-language: Haskell2010 diff --git a/src/DeriveHasField.hs b/src/DeriveHasField.hs new file mode 100644 --- /dev/null +++ b/src/DeriveHasField.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module DeriveHasField ( + module GHC.Records, + deriveHasFieldWith, +) +where + +import Control.Monad +import Data.Char (toLower) +import Data.Foldable as Foldable +import Data.Traversable (for) +import GHC.Records +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +deriveHasFieldWith :: (String -> String) -> Name -> DecsQ +deriveHasFieldWith fieldModifier = makeDeriveHasField fieldModifier <=< reifyDatatype + +makeDeriveHasField :: (String -> String) -> DatatypeInfo -> DecsQ +makeDeriveHasField fieldModifier datatypeInfo = do + -- We do not support sum of product types + constructorInfo <- case datatypeInfo.datatypeCons of + [info] -> pure info + _ -> fail "deriveHasField: only supports product types with a single data constructor" + + -- We only support data and newtype declarations + when (datatypeInfo.datatypeVariant `Foldable.notElem` [Datatype, Newtype]) $ + fail "deriveHasField: only supports data and newtype" + + -- We only support data types with field names and concrete types + let isConcreteType = \case + ConT _ -> True + AppT _ _ -> True + _ -> False + recordConstructorNames <- case constructorInfo.constructorVariant of + RecordConstructor names -> pure names + _ -> fail "deriveHasField: only supports constructors with field names" + unless (Foldable.all isConcreteType constructorInfo.constructorFields) $ + fail "deriveHasField: only supports concrete field types" + + -- Build the instances + let constructorNamesAndTypes :: [(Name, Type)] + constructorNamesAndTypes = zip recordConstructorNames constructorInfo.constructorFields + decs <- for constructorNamesAndTypes $ \(name, ty) -> + let currentFieldName = nameBase name + wantedFieldName = lowerFirst $ fieldModifier currentFieldName + litTCurrentField = litT $ strTyLit currentFieldName + litTFieldWanted = litT $ strTyLit wantedFieldName + parentTypeConstructor = conT datatypeInfo.datatypeName + in if currentFieldName == wantedFieldName + then fail "deriveHasField: after applying fieldModifier, field didn't change" + else + [d| + instance HasField $litTFieldWanted $parentTypeConstructor $(pure ty) where + getField = $(appTypeE (varE $ mkName "getField") litTCurrentField) + |] + pure $ Foldable.concat decs + +lowerFirst :: String -> String +lowerFirst = \case + [] -> [] + (x : xs) -> toLower x : xs diff --git a/test/DeriveHasFieldSpec.hs b/test/DeriveHasFieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeriveHasFieldSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module DeriveHasFieldSpec where + +import DeriveHasField +import Import +import Test.Hspec + +data SomeType = SomeType + { someTypeSomeField :: String + , someTypeSomeOtherField :: Int + , someTypeSomeMaybeField :: Maybe Int + , someTypeSomeEitherField :: Either String Int + } + +deriveHasFieldWith (dropPrefix "someType") ''SomeType + +someType :: SomeType +someType = + SomeType + { someTypeSomeField = "hello" + , someTypeSomeOtherField = 0 + , someTypeSomeMaybeField = Just 0 + , someTypeSomeEitherField = Right 0 + } + +spec :: Spec +spec = do + describe "deriveHasField" $ do + it "compiles and gets the right field" $ do + someType.someField `shouldBe` "hello" + someType.someOtherField `shouldBe` 0 + someType.someMaybeField `shouldBe` Just 0 + someType.someEitherField `shouldBe` Right 0 diff --git a/test/Import.hs b/test/Import.hs new file mode 100644 --- /dev/null +++ b/test/Import.hs @@ -0,0 +1,7 @@ +module Import where + +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) + +dropPrefix :: String -> String -> String +dropPrefix prefix input = fromMaybe input $ stripPrefix prefix input diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}