diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,15 @@ +ISC License + +Copyright (c) 2022 Gautier DI FOLCO + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/nonempty-wrapper-aeson.cabal b/nonempty-wrapper-aeson.cabal new file mode 100644 --- /dev/null +++ b/nonempty-wrapper-aeson.cabal @@ -0,0 +1,91 @@ +cabal-version: 3.0 +name: nonempty-wrapper-aeson +version: 0.1.0.0 +author: Gautier DI FOLCO +maintainer: gautier.difolco@gmail.com +category: Data +build-type: Simple +license: ISC +license-file: LICENSE +synopsis: aeson instances for 'NonEmpty' +description: aeson instances for 'NonEmpty'. +Homepage: http://github.com/blackheaven/nonempty-wrapper/nonempty-wrapper-aeson +tested-with: GHC==9.2.2, GHC==9.0.2, GHC==8.10.7 + +library + default-language: Haskell2010 + build-depends: + base == 4.* + , aeson == 2.* + , nonempty-wrapper >= 0.1.0.0 && < 1 + hs-source-dirs: src + exposed-modules: + Data.Aeson.Types.Instances.NonEmpty + other-modules: + Paths_nonempty_wrapper_aeson + autogen-modules: + Paths_nonempty_wrapper_aeson + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + OverloadedLists + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +test-suite nonempty-wrapper-aeson-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Data.Aeson.Types.Instances.NonEmptySpec + Paths_nonempty_wrapper_aeson + autogen-modules: + Paths_nonempty_wrapper_aeson + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + OverloadedLists + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base + , nonempty-wrapper + , nonempty-wrapper-aeson + , aeson + , containers >= 0.5 && < 1 + , hspec + , hspec-core + , hspec-discover + default-language: Haskell2010 diff --git a/src/Data/Aeson/Types/Instances/NonEmpty.hs b/src/Data/Aeson/Types/Instances/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Types/Instances/NonEmpty.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.QuickCheck.Instances.NonEmpty +-- Copyright : Gautier DI FOLCO +-- License : BSD2 +-- +-- Maintainer : Gautier DI FOLCO +-- Stability : Unstable +-- Portability : GHC +-- +-- aeson instances for 'NonEmpty' +module Data.Aeson.Types.Instances.NonEmpty + ( FromJSON (..), + ToJSON (..), + FromJSONKey (..), + ToJSONKey (..), + ) +where + +import Control.Monad ((>=>)) +import Data.Aeson +import Data.Aeson.Types +import Data.Coerce +import Data.NonEmpty + +instance + ( FromJSON a, + Semigroup a, + NonEmptySingleton a, + NonEmptyFromContainer a, + FromJSON (NonEmptySingletonElement a) + ) => + FromJSON (NonEmpty a) + where + parseJSON x = do + raw <- parseJSON x + case nonEmpty raw of + Just y -> pure y + Nothing -> fail "parsing NonEmpty failed, unexpected empty container" + +instance + ( FromJSON a, + NonEmptySingleton a, + NonEmptyFromContainer a, + FromJSON (NonEmptySingletonElement a), + FromJSONKey (NonEmptySingletonElement a), + FromJSONKey a, + Semigroup a + ) => + FromJSONKey (NonEmpty a) + where + fromJSONKey = + case fromJSONKey @a of + FromJSONKeyCoerce -> FromJSONKeyTextParser (run . coerce) + FromJSONKeyText f -> FromJSONKeyTextParser (run . f) + FromJSONKeyTextParser f -> FromJSONKeyTextParser (f >=> run) + FromJSONKeyValue f -> FromJSONKeyValue (f >=> run) + where + run :: a -> Parser (NonEmpty a) + run x = + case nonEmpty x of + Just y -> pure y + Nothing -> fail "parsing NonEmpty failed, unexpected empty container" + +instance (ToJSON a) => ToJSON (NonEmpty a) where + toJSON = toJSON . getNonEmpty + toEncoding = toEncoding . getNonEmpty + toJSONList = toJSONList . map getNonEmpty + toEncodingList = toEncodingList . map getNonEmpty + +instance (ToJSONKey a) => ToJSONKey (NonEmpty a) where + toJSONKey = contramapToJSONKeyFunction getNonEmpty toJSONKey + toJSONKeyList = contramapToJSONKeyFunction (map getNonEmpty) toJSONKeyList diff --git a/test/Data/Aeson/Types/Instances/NonEmptySpec.hs b/test/Data/Aeson/Types/Instances/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Aeson/Types/Instances/NonEmptySpec.hs @@ -0,0 +1,35 @@ +module Data.Aeson.Types.Instances.NonEmptySpec + ( main, + spec, + ) +where + +import Data.Aeson +import Data.Aeson.Types.Instances.NonEmpty () +import qualified Data.Map.Strict as M +import Data.NonEmpty +import Data.Proxy +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "decode" $ do + describe "regular element" $ do + it "valid case should parse" $ + decode "[42]" `shouldBe` Just (singleton (Proxy @[Int]) 42) + it "empty case should fail" $ + decode "[]" `shouldBe` Nothing @(NonEmpty String) + describe "key" $ do + it "valid case should parse" $ + decode "{\"a\":42}" `shouldBe` Just (M.singleton (singleton (Proxy @String) 'a') (42 :: Int)) + it "empty case should fail" $ + decode "{\"\":42}" `shouldBe` Nothing @(M.Map (NonEmpty String) Int) + + describe "encode" $ do + it "list of Int" $ + encode (singleton (Proxy @[Int]) 42) `shouldBe` "[42]" + it "keymap" $ + encode (M.singleton (singleton (Proxy @String) 'a') (42 :: Int)) `shouldBe` "{\"a\":42}" 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 #-}