packages feed

aeson-possible (empty) → 0.1.0.0

raw patch · 5 files changed

+294/−0 lines, 5 filesdep +QuickCheckdep +aesondep +aeson-possible

Dependencies added: QuickCheck, aeson, aeson-possible, base, tasty, tasty-hunit, tasty-quickcheck, tasty-quickcheck-laws

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for aeson-possible++## 0.1.0.0 -- 2024-01-23++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2023, Jonathan Jouty++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.
+ aeson-possible.cabal view
@@ -0,0 +1,60 @@+cabal-version:      3.0+name:               aeson-possible+version:            0.1.0.0+synopsis:           Possible values for aeson+description:        Three-valued possible types for use with aeson.+                    Useful for use in PATCH endpoints.+homepage:           https://github.com/jonathanjouty/aeson-possible+license:            BSD-3-Clause+license-file:       LICENSE+author:             Jonathan Jouty+maintainer:         me@jonathanjouty.com+category:           Data+build-type:         Simple+extra-doc-files:    CHANGELOG.md+tested-with:+  GHC == 9.4+   || == 9.6+   || == 9.8++common extensions+    default-extensions:+      DeriveFunctor+      DeriveGeneric+      DerivingVia+      GeneralizedNewtypeDeriving+      OverloadedStrings++common warnings+    ghc-options: -Wall++library+    import:           extensions+    import:           warnings+    exposed-modules:  Data.Aeson.Possible+    build-depends:+        base >= 4.17 && < 5,+        aeson == 2.2.*,+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite aeson-possible-test+    import:           extensions+    import:           warnings+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:+        base >= 4.17 && < 5,+        aeson-possible,+        aeson,+        tasty == 1.*,+        QuickCheck,+        tasty-hunit,+        tasty-quickcheck,+        tasty-quickcheck-laws,++source-repository head+  type:     git+  location: git@github.com:jonathanjouty/aeson-possible.git
+ src/Data/Aeson/Possible.hs view
@@ -0,0 +1,89 @@+{- |+Three-valued possible types for use with `aeson`.++Useful for use in PATCH endpoints: use in records which have 'ToJSON' and+'FromJSON' instances.++See the README for suggested usage.++The 'Alternative' instance can be used to update a record (with PATCH data) as+the LHS data is kept unless it is missing:++@+-- PATCH uses new data+'HaveData' new \<|\> old == 'HaveData' new++-- PATCH sets null+'HaveNull' \<|\> old == 'HaveNull'++-- PATCH did not change data+'Missing' \<|\> old == old+@+-}+module Data.Aeson.Possible (+    Possible (..),+    toMaybe,+    fromMaybeMaybe,+) where++import Control.Applicative+import Data.Aeson+import GHC.Generics (Generic)++data Possible a = Missing | HaveNull | HaveData a+    deriving stock (Show, Generic, Functor)++instance (Eq a) => Eq (Possible a) where+    Missing == Missing = True+    Missing == _ = False+    HaveNull == HaveNull = True+    HaveNull == _ = False+    HaveData a == HaveData b = a == b+    HaveData _ == _ = False++instance Applicative Possible where+    pure = HaveData+    (HaveData f) <*> (HaveData x) = HaveData (f x)+    HaveNull <*> _ = HaveNull+    _ <*> HaveNull = HaveNull+    Missing <*> _ = Missing+    _ <*> Missing = Missing++{- | Similar to the @Alternative Maybe@ instance, picks the leftmost 'HaveData'+value.+-}+instance Alternative Possible where+    empty = Missing+    HaveNull <|> _ = HaveNull+    Missing <|> r = r+    l@(HaveData _) <|> _ = l++{- | Uses 'toMaybe' to implement `toJSON` and `toEncoding`, and `aeson`'s+'omitField' to specify when the field should be left out.++/Note/ that unless the 'Possible' value is encoded as an object field it+will be `null` even when you have a 'Missing' value.+_e.g._ `[Missing, HaveNull, HaveData 42]` will be encoded as `[null,null,42]`+-}+instance (ToJSON a) => ToJSON (Possible a) where+    toJSON = toJSON . toMaybe+    toEncoding = toEncoding . toMaybe+    omitField Missing = True+    omitField HaveNull = False+    omitField (HaveData _) = False++-- | Uses `omittedField` to default to 'Missing'+instance (FromJSON a) => FromJSON (Possible a) where+    parseJSON Null = pure HaveNull+    parseJSON v = fmap pure . parseJSON $ v+    omittedField = Just Missing++toMaybe :: Possible a -> Maybe a+toMaybe Missing = Nothing+toMaybe HaveNull = Nothing+toMaybe (HaveData a) = Just a++fromMaybeMaybe :: Maybe (Maybe a) -> Possible a+fromMaybeMaybe Nothing = Missing+fromMaybeMaybe (Just Nothing) = HaveNull+fromMaybeMaybe (Just (Just a)) = HaveData a
+ test/Main.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Test.QuickCheck.Gen as Gen+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC+import Test.Tasty.QuickCheck.Laws++import Control.Applicative+import Data.Aeson+import Data.Aeson.Possible+import Data.Typeable+import GHC.Generics (Generic)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [laws, unitTests]++newtype A_Possible a = A_Possible {unwrap :: Possible a}+    deriving stock (Show, Generic, Functor)+    deriving newtype (Eq, Applicative, Alternative)++instance (Arbitrary a) => Arbitrary (A_Possible a) where+    arbitrary =+        A_Possible+            <$> Gen.oneof+                [pure Missing, pure HaveNull, HaveData <$> arbitrary]+    shrink (A_Possible v) = A_Possible <$> genericShrink v++laws :: TestTree+laws =+    testGroup+        "Laws"+        [ testEqLaws (Proxy :: Proxy (A_Possible Bool))+        , testFunctorLaws+            (Proxy :: Proxy (A_Possible))+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (\_ fu1 fu2 -> fu1 == fu2)+        , testApplicativeLaws+            (Proxy :: Proxy (A_Possible))+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (Proxy :: Proxy Int)+            (\_ fu1 fu2 -> fu1 == fu2)+        , testGroup+            "Alternative is as documented"+            -- Should not need testing as it is quite simple, but just to be sure+            -- and guard against regressions+            [ QC.testProperty "PATCH new data" $ \(new :: Int) (old :: A_Possible Int) ->+                let newP = A_Possible (HaveData new)+                 in (newP <|> old) === newP+            , QC.testProperty "PATCH sets null" $ \(old :: A_Possible Bool) ->+                let aNull = A_Possible HaveNull+                 in (aNull <|> old) === aNull+            , QC.testProperty "PATCH did not change data" $ \(old :: A_Possible Bool) ->+                (A_Possible Missing <|> old) === old+            ]+        ]++data TestData = TestData+    { a :: Possible Bool+    , b :: Possible Bool+    , c :: Possible Bool+    }+    deriving stock (Show, Generic, Eq)++instance FromJSON TestData where+    parseJSON = genericParseJSON $ defaultOptions{omitNothingFields = True}++instance ToJSON TestData where+    toJSON = genericToJSON $ defaultOptions{omitNothingFields = True}++unitTests :: TestTree+unitTests =+    testGroup+        "Unit Tests"+        [ let+            objJson = "{\"b\":null,\"c\":true}"+            objValue = TestData{a = Missing, b = HaveNull, c = HaveData True}+           in+            testGroup+                "Object encoding and decoding"+                [ testCase "Decoding works as expected" $+                    eitherDecode objJson @?= Right objValue+                , testCase "Encoding works as expected" $+                    encode objValue @?= objJson+                ]+        , -- Encoding in non-objects leads to "null" as it must encode to something!+          -- Encoding other constructors are covered by object tests+          testGroup+            "Encoding not in an object"+            [ testCase "Bare `Missing`" $+                encode (Missing :: Possible Int) @?= "null"+            , testCase "List of Possible values" $+                encode ([HaveNull, Missing, HaveData True]) @?= "[null,null,true]"+            ]+        , testGroup+            "Bare decoding"+            [ testCase "Decode null" $+                eitherDecode "null" @?= Right (HaveNull :: Possible Bool)+            , testCase "Decode value" $+                eitherDecode "true" @?= Right (HaveData True)+            ]+        ]