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/pure-sum-aeson.cabal b/pure-sum-aeson.cabal new file mode 100644 --- /dev/null +++ b/pure-sum-aeson.cabal @@ -0,0 +1,91 @@ +cabal-version: 3.0 +name: pure-sum-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: Derive fromString/toString-like for pure sum types (aeson instances) +description: Derive fromString/toString-like for pure sum types (aeson instances). +Homepage: http://github.com/blackheaven/pure-sum/pure-sum-aeson +tested-with: GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7 + +library + default-language: Haskell2010 + build-depends: + base == 4.* + , pure-sum + , aeson == 2.* + , text == 2.* + hs-source-dirs: src + exposed-modules: + Data.Sum.Pure.Aeson + other-modules: + Paths_pure_sum_aeson + autogen-modules: + Paths_pure_sum_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 spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Data.Sum.Pure.AesonSpec + Paths_pure_sum_aeson + autogen-modules: + Paths_pure_sum_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 + , pure-sum-aeson + , aeson + , containers + , hspec + , hspec-core + , hspec-discover + default-language: Haskell2010 diff --git a/src/Data/Sum/Pure/Aeson.hs b/src/Data/Sum/Pure/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sum/Pure/Aeson.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Data.Sum.Pure.Aeson +-- Copyright : Gautier DI FOLCO +-- License : BSD2 +-- +-- Maintainer : Gautier DI FOLCO +-- Stability : Unstable +-- Portability : GHC +-- +-- Derive fromText/toText-like for pure sum types (aeson instances). +module Data.Sum.Pure.Aeson + ( -- * Base type + FromJSON (..), + FromJSONKey (..), + ToJSON (..), + ToJSONKey (..), + + -- * Reexport + module X, + ) +where + +import Data.Aeson.Types +import Data.Proxy +import Data.Sum.Pure as X +import qualified Data.Text as T +import GHC.Generics +import GHC.TypeLits + +-- -- * Base interface +-- +-- -- | Wrapper for derivation. +-- -- @transformation@ is a @Transformation@ applied during derivations +-- newtype PureSumWith transformation a = PureSumWith {unPureSumWith :: a} +-- deriving stock (Eq, Ord, Show) +-- +-- -- | Basic sum derivation +-- type PureSum = PureSumWith IdTransformation +-- +-- class ToSumText a where +-- toSumText :: a -> T.Text +-- +-- class FromSumText a where +-- fromSumText :: T.Text -> Maybe a + +instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSON (PureSumWith transformation a) where + parseJSON = withText (unConstructionName $ (to @a) <$> gConstructorName) pureSumWithParser + +instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSONKey (PureSumWith transformation a) where + fromJSONKey = FromJSONKeyTextParser pureSumWithParser + +pureSumWithParser :: (FromSumText a) => T.Text -> Parser (PureSumWith transformation a) +pureSumWithParser x = + maybe (fail $ "unknown value: " <> show x) (pure . PureSumWith) $ + fromSumText x + +newtype ConstructorName x = ConstructorName {unConstructionName :: String} + +instance Functor ConstructorName where + fmap _ (ConstructorName x) = ConstructorName x + +class GConstructorName f where + gConstructorName :: ConstructorName (f a) + +instance (KnownSymbol typeName) => GConstructorName (M1 D ('MetaData typeName c i b) a) where -- base type + gConstructorName = ConstructorName $ symbolVal (Proxy @typeName) + +instance (ToSumText a) => ToJSON (PureSumWith transformation a) where + toJSON = toJSON . toSumText . unPureSumWith + toEncoding = toEncoding . toSumText . unPureSumWith + +instance (ToSumText a) => ToJSONKey (PureSumWith transformation a) where + toJSONKey = toJSONKeyText (toSumText . unPureSumWith) diff --git a/test/Data/Sum/Pure/AesonSpec.hs b/test/Data/Sum/Pure/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sum/Pure/AesonSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Data.Sum.Pure.AesonSpec + ( main, + spec, + ) +where + +import Data.Aeson +import qualified Data.Map as Map +import Data.Sum.Pure.Aeson +import GHC.Generics +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + it "encoding regular derivation is broken" $ + encode (Map.singleton RSunday ("Happy day" :: String)) `shouldBe` "[[\"RSunday\",\"Happy day\"]]" + it "encoding pure sum derivation is working" $ + encode (Map.singleton BSunday ("Happy day" :: String)) `shouldBe` "{\"BSunday\":\"Happy day\"}" + it "decoding pure sum derivation is working" $ + eitherDecode "{\"BSunday\":\"Happy day\"}" `shouldBe` Right (Map.singleton BSunday ("Happy day" :: String)) + it "decoding unknown pure sum derivation is working" $ + eitherDecode @(Map.Map BetterWeekend String) "{\"Sunday\":\"Happy day\"}" `shouldBe` Left "Error in $.Sunday: unknown value: \"Sunday\"" + +data RegularWeekend = RSaturday | RSunday + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (FromJSON, FromJSONKey, ToJSON, ToJSONKey) + +data BetterWeekend = BSaturday | BSunday + deriving stock (Eq, Ord, Show, Generic) + deriving (ToSumText, FromSumText, FromJSON, FromJSONKey, ToJSON, ToJSONKey) via (PureSum BetterWeekend) 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 #-}