cassava-th (empty) → 0.1.0.0
raw patch · 8 files changed
+653/−0 lines, 8 filesdep +basedep +bytestringdep +cassavasetup-changed
Dependencies added: base, bytestring, cassava, cassava-th, hspec, template-haskell, text, vector
Files
- CHANGELOG.md +11/−0
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- cassava-th.cabal +137/−0
- src/Data/Csv/TH.hs +391/−0
- test/Data/Csv/THSpec.hs +70/−0
- test/Spec.hs +9/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+# `cassava-th`++This package is designed to provide a `TemplateHaskell` based deriving mechanism for the classes in `Cassava`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cassava-th.cabal view
@@ -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 <https://github.com/MercuryTechnologies/cassava-th#readme>+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
+ src/Data/Csv/TH.hs view
@@ -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+
+ test/Data/Csv/THSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -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