diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `cassava-th` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2023-12-07 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# `cassava-th` + +This package is designed to provide a `TemplateHaskell` based deriving mechanism for the classes in `Cassava`. 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/cassava-th.cabal b/cassava-th.cabal new file mode 100644 --- /dev/null +++ b/cassava-th.cabal @@ -0,0 +1,137 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: cassava-th +version: 0.1.0.0 +synopsis: `TemplateHaskell` helpers for `cassava` +description: Please see the README on GitHub at +category: System +homepage: https://github.com/MercuryTechnologies/cassava-th#readme +bug-reports: https://github.com/MercuryTechnologies/cassava-th/issues +author: Matt von Hagen +maintainer: mattp@mercury.com +copyright: 2023 Mercury Technologies +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/MercuryTechnologies/cassava-th + +library + exposed-modules: + Data.Csv.TH + other-modules: + Paths_cassava_th + autogen-modules: + Paths_cassava_th + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + UndecidableInstances + ViewPatterns + TypeOperators + NoForeignFunctionInterface + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.14 && <5 + , bytestring + , cassava + , template-haskell + , text + , vector + default-language: Haskell2010 + +test-suite cassava-th-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Data.Csv.THSpec + Paths_cassava_th + autogen-modules: + Paths_cassava_th + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + UndecidableInstances + ViewPatterns + TypeOperators + NoForeignFunctionInterface + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.14 && <5 + , bytestring + , cassava + , cassava-th + , hspec + , template-haskell + , text + , vector + default-language: Haskell2010 diff --git a/src/Data/Csv/TH.hs b/src/Data/Csv/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Csv/TH.hs @@ -0,0 +1,391 @@ +{-# language TemplateHaskell #-} + +-- | This module provides @TemplateHaskell@ support for the @cassava@ +-- library, so you can avoid deriving 'Generic' and the compilation +-- overhead that brings. +module Data.Csv.TH + ( deriveToNamedRecord, + deriveToRecord, + deriveDefaultOrdered, + deriveNamedRecord, + deriveFromNamedRecord, + deriveFromRecord, + deriveToAndFromRecord, + deriveToNamedRecordAndDefaultOrdered, + deriveToAndFromNamedRecordAndDefaultOrdered, + CsvOptions, + csvDefaultOptions, + ) +where + +import Data.Traversable +import Control.Monad +import Control.Monad.Fail +import Data.Csv qualified as Csv +import Data.Vector qualified as V +import Language.Haskell.TH + +-- | Cassava uses the same name as Aeson, which is used much more frequently. +-- This alias makes it a bit easier to refer to it. +type CsvOptions = Csv.Options + +-- | Cassava uses the same name as Aeson, which is used more frequently. To +-- avoid qualified names and lots of clashes, we export an alias here. +csvDefaultOptions :: Csv.Options +csvDefaultOptions = Csv.defaultOptions + +-- | A helper for the common case of deriving both 'Csv.ToNamedRecord' and +-- 'Csv.DefaultOrdered', sharing the same options. +deriveToNamedRecordAndDefaultOrdered :: Csv.Options -> Name -> DecsQ +deriveToNamedRecordAndDefaultOrdered opts name = + deriveToNamedRecord opts name <> deriveDefaultOrdered opts name + +-- | A helper for the common case of deriving 'Csv.ToNamedRecord', +-- 'Csv.FromNamedRecord', and 'Csv.DefaultOrdered', sharing the same options. +deriveToAndFromNamedRecordAndDefaultOrdered :: Csv.Options -> Name -> DecsQ +deriveToAndFromNamedRecordAndDefaultOrdered opts name = + deriveToNamedRecord opts name + <> deriveDefaultOrdered opts name + <> deriveFromNamedRecord opts name + +-- | Derives a 'Csv.ToNamedRecord' instance for a given type. +deriveToNamedRecord :: Csv.Options -> Name -> DecsQ +deriveToNamedRecord opts typName = do + info <- reify typName + con <- + case info of + TyConI dec -> + case dec of + NewtypeD _cxt _name _tyvars _mkind con _derivs -> + pure con + DataD _cxt _name _tyvars _mkind cons _derivs -> + case cons of + [con] -> + pure con + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected" + , show typName + , " to be a type name of a single record constructor." + ] + (constrPatternMatch, matchedVariables) <- + case con of + RecC constrName fields -> do + namesWithPatterns <- for fields \(fieldName, _, _) -> do + FieldName fieldName <$> newName (nameBase fieldName) + + pure (ConP constrName [] (map (VarP . fieldPatternVariable) namesWithPatterns), namesWithPatterns) + _ -> + fail $ + concat + [ "Expected " + , show typName + , "to be a record with a single constructor." + ] + + let fieldExpr fieldName = do + let modifiedFieldName = + Csv.fieldLabelModifier opts (nameBase $ fieldOriginalName fieldName) + + [e| + ( $(litE $ StringL modifiedFieldName) + , Csv.toField $(varE (fieldPatternVariable fieldName)) + ) + |] + + listExpr <- + ListE <$> for matchedVariables \fieldName -> + fieldExpr fieldName + [d| + instance Csv.ToNamedRecord $(conT typName) where + toNamedRecord val = + case val of + $(pure constrPatternMatch) -> + Csv.namedRecord $(pure listExpr) + |] + +data FieldName = FieldName + { fieldOriginalName :: Name + , fieldPatternVariable :: Name + } + +-- | Derive an instance of the 'Csv.ToRecord' type class. This only works for +-- non-record types. +deriveToRecord :: Name -> DecsQ +deriveToRecord typName = do + info <- reify typName + cons <- + case info of + TyConI dec -> + case dec of + NewtypeD _cxt _name _tyvars _mkind con _derivs -> + pure [con] + DataD _cxt _name _tyvars _mkind cons _derivs -> + pure cons + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a datatype." + ] + _ -> + fail $ + concat + [ "Expected" + , show typName + , " to be a type name of a datatype." + ] + + cases <- + for cons \case + NormalC constrName bangTypes -> do + names <- for bangTypes \_ -> newName "p" + exprBody <- + AppE (VarE 'V.fromList) . ListE <$> do + for names \name -> + [e|Csv.toField $(varE name)|] + let constrPattern = + ConP constrName [] (map VarP names) + pure $ Match constrPattern (NormalB exprBody) [] + RecC constrName varBangTypes -> do + names <- for varBangTypes \(name, _, _) -> newName (nameBase name) + exprBody <- + AppE (VarE 'V.fromList) . ListE <$> do + for names \name -> + [e|Csv.toField $(varE name)|] + let constrPattern = + ConP constrName [] (map VarP names) + pure $ Match constrPattern (NormalB exprBody) [] + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to have regular constructors" + ] + + [d| + instance Csv.ToRecord $(conT typName) where + toRecord = + $(pure $ LamCaseE cases) + |] + +-- | Derive an instance of 'Csv.DefaultOrdered' for the type. +deriveDefaultOrdered :: CsvOptions -> Name -> DecsQ +deriveDefaultOrdered opts typName = do + info <- reify typName + con <- + case info of + TyConI dec -> + case dec of + NewtypeD _cxt _name _tyvars _mkind con _derivs -> + pure con + DataD _cxt _name _tyvars _mkind cons _derivs -> + case cons of + [con] -> + pure con + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected" + , show typName + , " to be a type name of a single record constructor." + ] + body <- + case con of + RecC _constrName varBangTypes -> do + ListE <$> for varBangTypes \(fieldName, _, _) -> do + let modifiedFieldName = + Csv.fieldLabelModifier opts (nameBase fieldName) + [e|$(litE $ StringL modifiedFieldName)|] + _ -> + fail $ + concat + [ "Expected " + , show typName + , "to be a record with a single constructor." + ] + + [d| + instance Csv.DefaultOrdered $(conT typName) where + headerOrder _ = V.fromList $(pure body) + |] + +-- | Derive an instance of both 'Csv.ToNamedRecord' and 'Csv.FromNamedRecord' +-- for a record type. +deriveNamedRecord :: CsvOptions -> Name -> DecsQ +deriveNamedRecord opts typName = + deriveToNamedRecord opts typName <> deriveFromNamedRecord opts typName + +-- | Derive an instance of 'Csv.FromNamedRecord' for record types. +deriveFromNamedRecord :: CsvOptions -> Name -> DecsQ +deriveFromNamedRecord opts typName = do + info <- reify typName + con <- + case info of + TyConI dec -> + case dec of + NewtypeD _cxt _name _tyvars _mkind con _derivs -> + pure con + DataD _cxt _name _tyvars _mkind cons _derivs -> + case cons of + [con] -> + pure con + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected" + , show typName + , " to be a type name of a single record constructor." + ] + (constrName, fieldNames) <- + case con of + RecC constrName fields -> do + namesWithPatterns <- for fields \(fieldName, _, _) -> do + pure fieldName + + pure (constrName, namesWithPatterns) + _ -> + fail $ + concat + [ "Expected " + , show typName + , "to be a record with a single constructor." + ] + + lamExpr <- do + arg <- newName "namedRecord" + + let getFieldExpr fieldName = do + let modifiedFieldName = + Csv.fieldLabelModifier opts (nameBase fieldName) + + [e|$(varE arg) Csv..: $(litE $ StringL modifiedFieldName)|] + body <- do + foldM + (\acc fieldName -> [e|$(pure acc) <*> $(getFieldExpr fieldName)|]) + (VarE 'pure `AppE` ConE constrName) + fieldNames + pure $ LamE [VarP arg] body + + [d| + instance Csv.FromNamedRecord $(conT typName) where + parseNamedRecord = $(pure lamExpr) + |] + +-- | Derive 'Csv.FromRecord' for a type. This ignores the record fields and uses +-- the position of the fields to determine how to parse the record. +deriveFromRecord :: Name -> DecsQ +deriveFromRecord typName = do + info <- reify typName + con <- + case info of + TyConI dec -> + case dec of + NewtypeD _cxt _name _tyvars _mkind con _derivs -> + pure con + DataD _cxt _name _tyvars _mkind cons _derivs -> + case cons of + [con] -> + pure con + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected " + , show typName + , " to be a record with a single constructor." + ] + _ -> + fail $ + concat + [ "Expected" + , show typName + , " to be a type name of a single record constructor." + ] + (constrName, fieldCount) <- + case con of + RecC constrName fields -> do + pure (constrName, length fields) + NormalC constrName fields -> + pure (constrName, length fields) + _ -> + fail $ + concat + [ "Expected " + , show typName + , "to be a record with a single constructor." + ] + + lamExpr <- do + arg <- newName "record" + + let getFieldExpr idx = do + [e|$(varE arg) Csv..! idx|] + + body <- do + foldM + (\acc fieldIndex -> [e|$(pure acc) <*> $(getFieldExpr fieldIndex)|]) + (VarE 'pure `AppE` ConE constrName) + [0 .. fieldCount - 1] + pure $ LamE [VarP arg] body + + [d| + instance Csv.FromRecord $(conT typName) where + parseRecord = $(pure lamExpr) + |] + +deriveToAndFromRecord :: Name -> DecsQ +deriveToAndFromRecord name = + deriveToRecord name <> deriveFromRecord name + diff --git a/test/Data/Csv/THSpec.hs b/test/Data/Csv/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Csv/THSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Data.Csv.THSpec where + +import Data.Csv hiding (record) +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Csv.TH +import GHC.Generics +import Test.Hspec + +data Foo = Foo + { fooName :: Text + , fooAge :: Int + } + deriving stock (Show, Eq, Generic) + +$(deriveNamedRecord csvDefaultOptions ''Foo) +$(deriveToAndFromRecord ''Foo) + +newtype GenericCsv a = GenericCsv a + deriving stock (Show, Eq) + +instance (Generic a, GToRecord (Rep a) (ByteString, ByteString)) => ToNamedRecord (GenericCsv a) where + toNamedRecord (GenericCsv a) = genericToNamedRecord defaultOptions a + +instance (Generic a, GToRecord (Rep a) ByteString) => ToRecord (GenericCsv a) where + toRecord (GenericCsv a) = genericToRecord defaultOptions a + +instance (Generic a, GFromNamedRecord (Rep a)) => FromNamedRecord (GenericCsv a) where + parseNamedRecord rec = GenericCsv <$> genericParseNamedRecord defaultOptions rec + +instance (Generic a, GFromRecord (Rep a)) => FromRecord (GenericCsv a) where + parseRecord rec = GenericCsv <$> genericParseRecord defaultOptions rec + +spec :: Spec +spec = do + let foo = Foo "hello" 50 + describe "deriveToNamedRecord" do + it "is equivalent to the generic" do + toNamedRecord foo + `shouldBe` toNamedRecord (GenericCsv foo) + describe "deriveToRecord" do + it "is equivalent to the generic" do + toRecord foo + `shouldBe` toRecord (GenericCsv foo) + describe "deriveFromNamedRecord" do + it "is equivalent to the generic" do + let record = toNamedRecord foo + recordG = toNamedRecord (GenericCsv foo) + runParser (parseNamedRecord record) + `shouldBe` pure foo + runParser (parseNamedRecord recordG) + `shouldBe` pure foo + runParser (parseNamedRecord record) + `shouldBe` pure (GenericCsv foo) + runParser (parseNamedRecord recordG) + `shouldBe` pure (GenericCsv foo) + describe "deriveFromRecord" do + it "is equivalent to the Generic" do + let record = toRecord foo + recordG = toRecord (GenericCsv foo) + runParser (parseRecord record) + `shouldBe` Right foo + runParser (parseRecord record) + `shouldBe` Right (GenericCsv foo) + runParser (parseRecord recordG) + `shouldBe` Right foo + runParser (parseRecord recordG) + `shouldBe` pure (GenericCsv foo) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,9 @@ +module Main where + +import Data.Csv.THSpec qualified as Data.Csv.TH +import Test.Hspec + +main :: IO () +main = do + hspec do + describe "Data.Csv.TH" Data.Csv.TH.spec