diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,17 @@ +# Changelog for cassava-generics + +# Version 0.1.0, July 30th, 2020 + +* First public release to Hackage. + +# Version 0.0.2, June 2020 + +* Added generic instances for Identity functor. + +# Version 0.0.1, April 2020 + +* Generic instances for Either and Maybe + +## Unreleased changes + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michał J. Gajda (c) 2020 + +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 Michał J. Gajda 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,12 @@ +# cassava-generics + +Cassava `ToNamedField` instances for standard functors and datatypes. +They depend on both `ToNamedField` and `DefaultHeaderOrder` instances for `a`: + +* `Either String a` +* `Maybe a` + +Also for convenience instances for common types: +* [Text] -- tag list +* [(Text,Text)] -- assoc list + 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-generic.cabal b/cassava-generic.cabal new file mode 100644 --- /dev/null +++ b/cassava-generic.cabal @@ -0,0 +1,47 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b4f6db6bae8ab8a4834c5ec3bd12d71c696a73772a59b0be938655b6856b11d7 + +name: cassava-generic +version: 0.1.0.0 +synopsis: Cassave instances for functor-like datatypes like `Either String a`. +description: Please see the README on GitHub at +category: Data +homepage: https://github.com/mjgajda/cassava-generic#readme +bug-reports: https://github.com/mjgajda/cassava-generic/issues +author: Michał J. Gajda +maintainer: mjgajda@migamake.com +copyright: Migamake '2020 +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/mjgajda/cassava-generic + +library + exposed-modules: + Data.Csv.GenericInstances + Data.Functor.Identity.Default + other-modules: + Paths_cassava_generic + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , cassava + , data-default + , text + , unordered-containers + , vector + default-language: Haskell2010 diff --git a/src/Data/Csv/GenericInstances.hs b/src/Data/Csv/GenericInstances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Csv/GenericInstances.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Generic instances of Csv.ToNamedRecord, +-- and Csv.DefaultOrdered. +-- +-- Allow modular treatment of nested records when writing with Cassava. +module Data.Csv.GenericInstances + ( -- Instances only + ) +where + +import GHC.Generics +import Data.Typeable +import Data.Aeson +import Data.List (sort) +import Data.Aeson.Types (prependFailure) +import Control.Applicative +import Data.Text as Text +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text.Encoding as Text +import Data.Vector +import qualified Data.Foldable as F +import Data.Functor.Identity +import qualified Data.HashMap.Strict as Map +import Data.Default +import Data.Functor.Classes +import qualified Data.Csv as Csv + +-- * Missing instances of `Data.Csv.ToField class` +instance Csv.ToField [Text] where + toField = Text.encodeUtf8 . Text.intercalate " " + +instance Csv.ToField Bool where + toField True = "yes" + toField False = "no" + +instance Csv.ToField [String] where + toField aList = " " `BS.intercalate` (BS.pack <$> aList) + +-- * Assoc list: +instance Csv.ToField [(Text, Text)] where + toField ttList = " " `BS.intercalate` Prelude.map ( + \(a, b) -> + Text.encodeUtf8 $ "=" `Text.intercalate` [a, b]) ttList + +instance {-# OVERLAPPABLE #-} Show a => Csv.ToField a where + toField = BS.pack . show + +-- * These instances assume that we use argument for `headerOrder` like `Proxy` +-- (so do not need value at all). +-- Generic Either instance for ToNamedRecord +instance (Csv.DefaultOrdered a + ,Csv.ToNamedRecord a) + => Csv.ToNamedRecord (Either String a) where + toNamedRecord (arg :: Either String a) = case arg of + Left msg -> Csv.namedRecord (F.foldMap emptyField subHeader) + <> errorField msg + Right r -> Csv.toNamedRecord r + <> errorField (""::String) + where + subHeader :: Csv.Header + subHeader = Csv.headerOrder (error "fails in ToNamedRecord (Either String a)" :: a) + errorField errorMessage = Csv.namedRecord + [(Data.Vector.head subHeader<>"_error") Csv..= errorMessage] + +-- Generic Either instance for ToNamedRecord +instance (Csv.DefaultOrdered a + ,Csv.ToNamedRecord a) + => Csv.DefaultOrdered (Either String a) where + headerOrder (_ :: Either String a) = Csv.header [Data.Vector.head subHeader<>"_error"] + <> subHeader + where + subHeader :: Csv.Header + subHeader = Csv.headerOrder (error "fails in DefaultOrdered (Either String a)" :: a) + +-- Generic Maybe instance for ToNamedRecord +instance (Csv.DefaultOrdered a + ,Csv.ToNamedRecord a) + => Csv.ToNamedRecord (Maybe a) where + toNamedRecord (arg :: Maybe a) = case arg of + Nothing -> Csv.namedRecord (F.foldMap emptyField subHeader) + Just r -> Csv.toNamedRecord r + where + subHeader :: Csv.Header + subHeader = Csv.headerOrder (error "fails in ToNamedRecord (Maybe a)" :: a) + +-- | Generic Identity instance for ToNamedRecord +instance Csv.ToNamedRecord a + => Csv.ToNamedRecord (Identity a) where + toNamedRecord (Identity a) = Csv.toNamedRecord a + +-- | Empty field for generic instances +emptyField name = [name Csv..= ("" :: String)] + +instance (Csv.DefaultOrdered a + ,Csv.ToNamedRecord a) + => Csv.DefaultOrdered (Maybe a) where + headerOrder (_ :: Maybe a) = subHeader + where + subHeader :: Csv.Header + subHeader = Csv.headerOrder (error "fails in DefaultOrdered (Maybe a)" :: a) + +-- | Generic Identity instance for DefaultOrdered +instance Csv.DefaultOrdered a + => Csv.DefaultOrdered (Identity a) where + headerOrder _ = Csv.headerOrder (undefined :: a) diff --git a/src/Data/Functor/Identity/Default.hs b/src/Data/Functor/Identity/Default.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Identity/Default.hs @@ -0,0 +1,11 @@ +module Data.Functor.Identity.Default( + -- instances only + ) where + +import Data.Default +import Data.Functor.Identity + +-- * Missing instances of `Data.Default.Default class` +instance Default a => Default (Identity a) where + def = Identity def +