packages feed

aeson-flat (empty) → 0.1.0.0

raw patch · 6 files changed

+250/−0 lines, 6 filesdep +aesondep +aeson-flatdep +basesetup-changed

Dependencies added: aeson, aeson-flat, base, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sean Hess (c) 2017++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 Sean Hess 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-flat.cabal view
@@ -0,0 +1,38 @@+name:                aeson-flat+version:             0.1.0.0+synopsis:            Tools for creating flat JSON serializations+description:         Tools for creating flat JSON serializations+homepage:            https://github.com/seanhess/aeson-flat#readme+license:             BSD3+license-file:        LICENSE+author:              Sean Hess+maintainer:          seanhess@gmail.com+copyright:           Sean Hess+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Data.Aeson.Flat+  build-depends:+      base >= 4.7 && < 5+    , aeson >= 0.8+    , text+    , vector+    , unordered-containers+  default-language:    Haskell2010++test-suite aeson-flat-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , aeson-flat+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/seanhess/aeson-flat
+ src/Data/Aeson/Flat.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Aeson.Flat where++-- import Debug.Trace (trace)+import Control.Applicative ((<|>))+import Data.Aeson (Value(..))+import Data.Aeson.Types (genericToJSON, genericParseJSON, defaultOptions, GToJSON, GFromJSON, Parser, typeMismatch)+import Data.Text (Text, unpack)+import qualified Data.Vector as V+import Data.Monoid ((<>))+import qualified Data.HashMap.Strict as HM+import GHC.Generics (Generic, Rep)+-- import qualified Data.ByteString.Lazy.Char8 as BSL++++-- | Merge values together. Useful for creating compound JSON structures that should be parsed as one object+--+-- > data A = A { one :: String, two :: String } deriving (Show, Eq, Generic)+-- > instance ToJSON A+-- > instance FromJSON A+-- >+-- > data B = B { three :: String } deriving (Show, Eq, Generic)+-- > instance ToJSON B+-- > instance FromJSON B+-- >+-- > data AB = AB A B deriving (Show, Eq)+-- >+-- > instance ToJSON AB where+-- >   toJSON (AB a b) = merge [toJSON a, toJSON b]+-- >+-- > instance FromJSON AB where+-- >   parseJSON o = do+-- >     a <- parseJSON o+-- >     b <- parseJSON o+-- >     return $ AB a b++merge :: [Value] -> Value+merge [] = Null+merge (v:vs) = foldl append v vs+  where+    append (Object a) (Object b) =+      Object $ a <> b+    append (Array a) (Array b) =+      Array $ a <> b+    append (String a) (String b) =+      String $ a <> b+    append (Number a) (Number b) =+      Number $ a + b+    append (Bool a) (Bool b) =+      Bool $ a && b+    append _ _ = Null+++-- | Serialize a sumtype to a flat object, rather than to "tag" and "contents"+--+-- > data C = CA A | CB B deriving (Show, Eq, Generic)+-- >+-- > instance ToJSON C where+-- >   toJSON x = flatToJSON "c" x+--+-- {"c": "CA", "one": "value", "two": "value"}+-- {"c": "CB", "three": "value"}++flatToJSON :: (Generic a, GToJSON (Rep a)) => Text -> a -> Value+flatToJSON n a =+  flatten n $ genericToJSON defaultOptions a+  where+  flatten n' (Object o) =+    let t = sumTag o+        c = sumContents o+    in Object $ HM.insert n' (String t) c+  flatten _ v = v++  sumTag o =+    case HM.lookup "tag" o of+      Just (String t) ->+        t+      _ ->+        ""++  sumContents o =+    case HM.lookup "contents" o of+      Just (Object c) ->+        c+      Just (Array v) ->+        V.foldl allObjects HM.empty v+      _ ->+        HM.empty++  allObjects m (Object o) = HM.union m o+  allObjects m _ = m+++-- | Deserialize a sumtype from a flat object+-- >+-- > instance FromJSON C where+-- >   parseJSON x = flatParseJSON "c" x++flatParseJSON :: (Generic a, GFromJSON (Rep a)) => Text -> Value -> Parser a+flatParseJSON n (Object o) =+  case HM.lookup n o of+    Just (String t) ->+      let o' = HM.fromList [("tag", String t), ("contents", Object o)]+          u' = HM.fromList [("tag", String t), ("contents", Array V.empty)]+      in parse o' <|> parse u'+    _ -> typeMismatch ("field: " ++ unpack n) (Object o)+  where+    parse o' = genericParseJSON defaultOptions (Object o')+flatParseJSON _ v = typeMismatch "Object" v++++fieldToJSON :: (Generic a, GToJSON (Rep a)) => Text -> a -> Value+fieldToJSON n a =+  flatten n $ genericToJSON defaultOptions a+  where+  flatten n' v =+    Object $ HM.fromList [(n', v)]+++fieldParseJSON :: (Generic a, GFromJSON (Rep a)) => Text -> Value -> Parser a+fieldParseJSON n (Object o) =+  -- construct what it is expecting: tag, and contents+  case HM.lookup n o of+    Just v ->+      genericParseJSON defaultOptions v+    _ -> typeMismatch ("field: " ++ unpack n) (Object o)+fieldParseJSON _ v = typeMismatch "Object" v+++-- | Example of how to use the above for a parent record+--+-- > data Example = Example+-- >   { exa :: String+-- >   , exb :: Int+-- >   , exc :: C+-- >   } deriving (Show, Eq, Generic)+-- >+-- > instance ToJSON Example where+-- >   toJSON ex =+-- >     merge+-- >       [ object [ "a" .= toJSON (exa ex)+-- >                , "b" .= toJSON (exb ex)+-- >                ]+-- >       , toJSON (exc ex)+-- >       ]+-- >+-- > instance FromJSON Example where+-- >   parseJSON (Object o) = do+-- >     a <- o .: "a"+-- >     b <- o .: "b"+-- >     c <- parseJSON (Object o)+-- >     return $ Example a b c++++-- test :: IO ()+-- test = do+--+--   let a = A { one = "one", two = "two" }+--       b = B { three = "three" }+--       ab = AB a b+--       c' = CB b+--       ex = Example "a" 1 c'+--+--   -- BSL.putStrLn $ Aeson.encode ab+--   -- print $ (Aeson.eitherDecode $ Aeson.encode ab :: Either String AB)+--+--   BSL.putStrLn $ Aeson.encode c'+--   print $ (Aeson.eitherDecode $ Aeson.encode c' :: Either String C)+--+--   BSL.putStrLn $ Aeson.encode ex+--   print $ (Aeson.eitherDecode $ Aeson.encode ex :: Either String Example)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"