derive-has-field (empty) → 0.0.1.0

raw patch · 7 files changed

+233/−0 lines, 7 filesdep +basedep +derive-has-fielddep +hspec

Dependencies added: base, derive-has-field, hspec, template-haskell, th-abstraction

Files

• LICENSE +19/−0
• README.md +37/−0
• derive-has-field.cabal +68/−0
• src/DeriveHasField.hs +65/−0
• test/DeriveHasFieldSpec.hs +36/−0
• test/Import.hs +7/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,19 @@+Copyright (c) 2023 Barry Moore <chiroptical@gmail.com>++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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}