roundtrip-aeson (empty) → 0.2.0.0

raw patch · 11 files changed

+561/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, lens, lens-aeson, roundtrip, roundtrip-aeson, scientific, text, unordered-containers, vector

Files

.travis.yml +45/−0
HLint.hs +7/−0
LICENSE +30/−0
README.md +61/−0
Setup.hs +2/−0
lib/Data/Aeson/Roundtrip.hs +251/−0
roundtrip-aeson.cabal +59/−0
stack-2.14.yaml +6/−0
stack-2.18.yaml +6/−0
stack-2.20.yaml +6/−0
tests/demo.hs +88/−0

+ .travis.yml view

@@ -0,0 +1,45 @@+# Use the docker infrastructure.+sudo: false++# for cabal+language: haskell+ghc: 7.8++cache:+  directories:+    - $HOME/.stack++notifications:+  email:+    on_success: change+    on_failure: change++env:+  matrix:+    - STACK_YAML=stack-2.14.yaml+    - STACK_YAML=stack-2.18.yaml+    - STACK_YAML=stack-2.20.yaml++install:+ - travis_retry wget https://github.com/commercialhaskell/stack/releases/download/v0.1.2.0/stack-0.1.2.0-x86_64-linux.gz+ - gunzip stack-0.1.2.0-x86_64-linux.gz+ - mv stack-0.1.2.0-x86_64-linux stack+ - chmod +x stack++# Here starts the actual work to be performed for the package under test; any+# command which exits with a non-zero exit code causes the build to fail.+script:+ - cabal check+ - cabal sdist+ - export SRC=$(cabal info . | awk '{print $2;exit}')+ - tar -xzf "dist/$SRC.tar.gz"+ - cd "$SRC"+ - cp ../$STACK_YAML .+ - cp ../stack .+ - travis_retry ./stack setup+ - travis_retry ./stack install --only-snapshot -j4 --verbosity info+ - ./stack build+ - ./stack test+ - ./stack haddock --no-haddock-deps+ - export DIST_DIR=$(./stack path --dist-dir --stack-yaml $STACK_YAML)+ - echo $DIST_DIR

+ HLint.hs view

@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+module HLint.HLint where++import           "hint" HLint.Builtin.All+import           "hint" HLint.Default+import           "hint" HLint.Dollar+import           "hint" HLint.Generalise

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright © 2014 Anchor Systems, Pty Ltd++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 Thomas Sutton 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

@@ -0,0 +1,61 @@+Roundtrip Aeson+===============++[![Build Status][6]][7]++[roundtrip][1] allows you to write [invertible syntax descriptions][2] -- or,+to put it another way, a parser and pretty printer combined -- for String or+XML data. This package extends this to support constructing and destructing+JSON documents.++Example+-------++Using `roundtrip-aeson` is relatively straightforward:++1. Define your data type;++2. Define [partial isomorphisms][3] for the constructors (probably using the+[template haskell][4]);++2. Describe the syntax of its JSON representation; and++3. Use that representation to build and parse JSON.++````{.haskell}+import Data.Aeson.RoundTrip++data Invoice+    = Unpaid Bool Integer Bool+    | Paid Double+  deriving (Show)++defineIsomorphisms ''Invoice++invoiceSyntax :: JsonSyntax s => s Invoice+invoiceSyntax =+    unpaid+        <$> jsonField "overdue" jsonBool+        <*> jsonField "total"   jsonIntegral+        <*> jsonField "warned"  jsonBool+    <|> paid+        <$> jsonField "total"   jsonRealFrac++main :: IO ()+main = do+    -- Build a JSON representation.+    let Right x = runBuilder invoiceSyntax $ Unpaid False 40 [False]+    L.putStrLn $ encode x+    -- Parse a JSON representation.+    print $ runParser invoiceSyntax x+````++See [tests/demo.hs][5] for the complete source of this example.++[1]: https://hackage.haskell.org/package/roundtrip+[2]: http://scholar.google.com/scholar?cluster=14145973580303258649+[3]: https://hackage.haskell.org/package/roundtrip/docs/Control-Isomorphism-Partial-Iso.html+[4]: https://hackage.haskell.org/package/roundtrip/docs/Control-Isomorphism-Partial-TH.html+[5]: https://github.com/anchor/roundtrip-aeson/blob/master/tests/demo.hs+[6]: https://travis-ci.org/anchor/roundtrip-aeson.svg?branch=master+[7]: https://travis-ci.org/anchor/roundtrip-aeson

+ Setup.hs view

@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain

+ lib/Data/Aeson/Roundtrip.hs view

@@ -0,0 +1,251 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++-- TH does not generate signatures+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Data.Aeson.Roundtrip+(+    -- * Parser/Builder+    JsonParser(..),+    JsonBuilder(..),+    -- * Combinators+    is,+    wat,+    -- * Syntaxes+    jsonField,+    jsonString,+    jsonBool,+    jsonNumber,+    jsonIntegral,+    jsonRealFloat,+    -- * Lenses, Prisms, and Isomorphisms.+    demote,+    demoteLR,+    demoteL,+    demoteR,+    -- * JSON Syntax+    JsonSyntax (..)+)+where++import           Control.Category            ((.))+import           Control.Isomorphism.Partial+import           Control.Lens                hiding (Iso)+import qualified Control.Lens                as L+import           Control.Monad               (guard, liftM2, mplus, (>=>))+import           Data.Aeson+import           Data.Aeson.Lens+import           Data.HashMap.Strict         (union)+import           Data.Monoid+import           Data.Scientific+import           Data.Text                   (Text)+import           Data.Vector                 ((!?))+import qualified Data.Vector                 as V+import           Prelude                     hiding ((.))+import           Text.Roundtrip.Classes+++-- | Demote a lens 'Prism' to a partial 'Iso'.+--+-- This involves strapping a _Just onto the review as a prism is slightly+-- "stronger" than an Iso anyway. Bear in mind that this is not a lens iso but+-- a RoundTrip iso.+--+-- This also works on lens isos, you can imagine this as :+--+--   demote :: L.Iso' a b -> Iso a b+--+demote :: String -> Prism' a b -> Iso a b+demote name p = unsafeMakeNamedIso name (preview p) (review (_Just . p))++-- | Demote something with show instances for better messages.+demoteLR :: (Show a, Show b) => String -> Prism' a b -> Iso a b+demoteLR name p = unsafeMakeNamedIsoLR name (preview p) (review (_Just . p))++demoteL :: Show a => String -> Prism' a b -> Iso a b+demoteL name p = unsafeMakeNamedIsoL name (preview p) (review (_Just . p))++demoteR :: Show b => String -> Prism' a b -> Iso a b+demoteR name p = unsafeMakeNamedIsoR name (preview p) (review (_Just . p))++-- | Parse and unparse JSON values.+class Syntax s => JsonSyntax s where++    -- | Run a parser over some other parser.+    --+    -- This can be used to, e.g., traverse the fields of an 'Object'+    -- constructor and parse the result.+    runSub :: s v -> s Value -> s v++    -- | Parse any JSON value.+    value :: s Value++-- | Ensure that a value 'a' is "produced" or "consumed".+--+-- This is intended to be used infix in conjunction with *> and <*+is :: (JsonSyntax s, Eq a) => s a -> a -> s ()+is s a = demoteR "is" (prism' (const a) (guard . (a ==))) <$> s++-- | With Arbitrary Thing: Given a thing, ensure that it is always included on+-- the way "back" from JSON, but never ends up in the JSON document.+--+-- This is almost like pure, going one way.+wat :: JsonSyntax s => a -> s a+wat a = demoteL "wat"+                (prism' (const $ Object mempty) (const $ Just a)) <$> value++-- | Un-/parse from within a field in a JSON object.+jsonField+    :: JsonSyntax s+    => Text+    -- ^ Key to lookup/insert+    -> s v+    -- ^ Sub-parser+    -> s v+jsonField k syntax = runSub syntax (keyIso <$> value)+  where+    -- Only valid if we assume that isomorphism is viewed from the non-JSON end+    -- of things. This forgets any context.+    keyIso = demoteLR ("key " <> show k) $ prism' (\part -> Object [(k,part)]) (^? key k)++-- | Un-/parse a boolean JSON value.+jsonBool :: JsonSyntax s => s Bool+jsonBool = demoteLR "jsonBool" _Bool <$> value++-- | Un-/parse a number JSON value.+jsonNumber :: JsonSyntax s => s Scientific+jsonNumber = demoteLR "jsonNumber" _Number <$> value++-- | Un-/parse an integral number JSON value.+jsonIntegral :: (Integral a, JsonSyntax s) => s a+jsonIntegral = demoteL "jsonIntegral" _Integral <$> value++-- | Un-/parse a floating number JSON value.+jsonRealFloat :: (RealFloat a, JsonSyntax s) => s a+jsonRealFloat = i . demoteL "jsonRealFloat (number)" _Number <$> value+  where+    i = demoteL "jsonRealFloat (toRealFloat)" $+            L.iso toRealFloat (fromRational . toRational)++-- | Un-/parse a string JSON value.+jsonString :: JsonSyntax s => s Text+jsonString = demoteLR "String" _String <$> value++-- | Try to apply an iso, provide message on failure+tryLR :: Iso a b -> a -> Either String b+tryLR i a =+    case isoLR i a of+        Just x -> Right x+        Nothing -> Left $ isoFailedErrorMessageL i a++-- | Try to unapply an iso, provide message on failure+tryRL :: Iso a b -> b -> Either String a+tryRL i b =+    case isoRL i b of+        Just x -> Right x+        Nothing -> Left $ isoFailedErrorMessageR i b++-- | An implementation of 'JsonSyntax' which constructs JSON values.+newtype JsonBuilder a = JsonBuilder+    { runBuilder :: a -> Either String Value }++instance IsoFunctor JsonBuilder where+    -- When going from a to 'Value' we simply want to compose the possible iso+    -- failures in the 'unapply' direction.+    i <$> JsonBuilder b = JsonBuilder $ tryRL i >=> b++instance ProductFunctor JsonBuilder where+    -- When building a 'Value' we want to decompose our church pair list tupled+    -- builders and merge the results together.+    --+    -- Note that the second argument is not pattern matched, this is to ensure+    -- that it is not eagerly constructed and does not diverge in things like+    -- many.+    JsonBuilder p <*> JsonBuilder q = JsonBuilder $ \(a,b) -> do+        a' <- p a+        b' <- q b+        merge a' b'+      where+        -- Merging of two objects is simply a union, this rule fires when you+        -- do things like:+        --+        -- jsonField "a" p <*> jsonField "b" p+        merge (Object a) (Object b) = Right . Object $ a `union` b+        -- merge Null (Object b) = Object b+        -- Merging of head and tail of arrays, this rule fires when using+        -- things like the many combinator to create a JSON array+        merge a (Array b) = Right . Array $ V.cons a b+        merge x Null = Right x+        merge Null x = Right x+        merge x y = Left $+            "Don't know how to merge: " <> show x <> " <*> " <> show y++instance Alternative JsonBuilder where+    -- Try the left first, then right.+    JsonBuilder p <||> JsonBuilder q = JsonBuilder $ \a -> p a `mplus` q a++    -- Always Left+    empty = JsonBuilder . const $ Left "empty"++instance Syntax JsonBuilder where+    -- | Have to rewrite Null as [] as pure () is will make a Null as it+    -- terminates the list.+    --+    -- This is so that pure can make nulls, which is "nicer" for things like+    -- optional.+    rule "many" _ (JsonBuilder b) =+        JsonBuilder $ b >=> (\case Null -> Right $ Array mempty+                                   x    -> Right x)+    rule _ _ x = x++    pure x = JsonBuilder $ \y ->+        if x == y+            then Right Null+            else Left "pure, x /= y"++instance JsonSyntax JsonBuilder where+    -- | To roduces a 'Value', we simply need to pass it through.+    value = JsonBuilder Right++    -- Run a sub-parser. Just composition, really.+    runSub (JsonBuilder a) (JsonBuilder b) =+        JsonBuilder $ a >=> b+++-- | An implementation of 'JsonSyntax' which deconstructs JSON values.+newtype JsonParser a = JsonParser+    { runParser :: Value -> Either String a }++instance IsoFunctor JsonParser where+    -- The opposite of a JsonParser in both order of composition and direction+    -- of iso+    i <$> JsonParser p = JsonParser $ p >=> tryLR i++instance ProductFunctor JsonParser where+    -- When coming from a 'Value' we either want to tuple things up, or, in+    -- the special case of a list, consume the head and pass the tail on. This+    -- is a simple way of getting the many combinator to work on JSON.+    JsonParser p <*> JsonParser q = JsonParser f+      where+        f v | Array x <- v, Just y <- x !? 0+            = liftM2 (,) (p y) (q . Array $ V.tail x)+            | Array _ <- v+            = Left "Empty array"+            | otherwise+            = liftM2 (,) (p v) (q v)++instance Alternative JsonParser where+    JsonParser p <||> JsonParser q = JsonParser $ \v -> p v `mplus` q v++    empty = JsonParser . const $ Left "empty"++instance Syntax JsonParser where+    pure = JsonParser . const . Right++instance JsonSyntax JsonParser where+    value = JsonParser Right++    runSub (JsonParser a) (JsonParser b) = JsonParser $ b >=> a

+ roundtrip-aeson.cabal view

@@ -0,0 +1,59 @@+name:                roundtrip-aeson+version:             0.2.0.0+synopsis:            Un-/parse JSON with roundtrip invertible syntax definitions.+description:         Un-/parse JSON with roundtrip invertible syntax definitions.+homepage:            https://github.com/anchor/roundtrip-aeson+license:             BSD3+license-file:        LICENSE+author:              Thomas Sutton <me@thomas-sutton.id.au>, Christian Marie <christian@ponies.io>+maintainer:          Anchor Engineering <engineering@anchor.net.au>+copyright:           Copyright 2014-2015 Anchor Systems and others.+category:            Data+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:+  HLint.hs+  README.md+  stack-2.14.yaml+  stack-2.18.yaml+  stack-2.20.yaml+  .travis.yml++source-repository HEAD+  type: git+  location: https://github.com/anchor/roundtrip-aeson++source-repository this+  type: git+  location: https://github.com/anchor/roundtrip-aeson+  tag: release-0.2.0.0++library+  default-language:    Haskell2010+  hs-source-dirs:      lib+  exposed-modules:     Data.Aeson.Roundtrip+  build-depends:       base >=4.7 && <4.8+                     , aeson+                     , bytestring+                     , containers >=0.5 && <0.6+                     , lens+                     , lens-aeson+                     , roundtrip >= 0.2 && < 0.3+                     , scientific+                     , text >=1.2 && <1.3+                     , unordered-containers+                     , vector++test-suite demo+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      tests+  main-is:             demo.hs+  build-depends:       base >=4.7 && <4.8+                     , aeson+                     , bytestring+                     , lens-aeson+                     , roundtrip+                     , roundtrip-aeson+                     , text+                     , vector

+ stack-2.14.yaml view

@@ -0,0 +1,6 @@+flags: {}+packages:+- '.'+extra-deps:+- roundtrip-0.2.0.3+resolver: lts-2.20

+ stack-2.18.yaml view

@@ -0,0 +1,6 @@+flags: {}+packages:+- '.'+extra-deps:+- roundtrip-0.2.0.3+resolver: lts-2.20

+ stack-2.20.yaml view

@@ -0,0 +1,6 @@+flags: {}+packages:+- '.'+extra-deps:+- roundtrip-0.2.0.3+resolver: lts-2.20

+ tests/demo.hs view

@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- TH does not generate signatures+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Main where++import           Control.Isomorphism.Partial+import           Data.Aeson+import qualified Data.ByteString.Lazy.Char8  as L+import           Data.Monoid+import           Data.Text                   (Text)+import           Text.Roundtrip.Classes+import           Text.Roundtrip.Combinators++import           Data.Aeson.Roundtrip++-- | A silly example+data Invoice+    = Unpaid Integer [Bool]+    | Paid Double+  deriving (Show)++defineIsomorphisms ''Invoice++-- | An example of nesting syntaxes+data Account = Account Text [Invoice]+  deriving Show++defineIsomorphisms ''Account++-- | A syntax is an abstract representation of the structure of a document.+--+-- It is built up by composing partial isomorphisms which have been+-- 'IsoFunctor' fmapped onto the 'JsonSyntax' value primitive.+invoiceSyntax :: JsonSyntax s => s Invoice+invoiceSyntax =+    -- unpaid is an iso from Invoice to (Integer, [Bool])+    unpaid+        -- Ignore "paid", but make sure it's set to False+        <$> jsonField "paid" (jsonBool `is` False)+         *> jsonField "bar" jsonIntegral+        <*> jsonField "baz" (many jsonBool)+    -- If the s Invoice above failed, try the one for paid+    <|> paid+        <$> jsonField "paid" (jsonBool `is` True)+         *> jsonField "bar" jsonRealFloat++-- | An example of nesting syntax definitions+accountSyntax :: JsonSyntax s => s Account+accountSyntax = account+    <$> jsonField "name" jsonString+    <*> jsonField "invoices" (many invoiceSyntax)++-- | A really bad acceptance test+main :: IO ()+main = do+    putStrLn "FIELDS"+    putStrLn "\tUNPARSE"++    let Right x = runBuilder invoiceSyntax $ Unpaid 40 [False, True, False]+    let Right y = runBuilder invoiceSyntax $ Paid 42++    L.putStrLn $ "\t" <> encode x+    L.putStrLn $ "\t" <> encode y++    putStrLn "\n\tPARSE"++    putStrLn $ "\t" <> show (runParser invoiceSyntax x)+    putStrLn $ "\t" <> show (runParser invoiceSyntax y)++    putStrLn "\n\nLISTS"+    putStrLn "\tUNPARSE"++    let Right z1 = runBuilder accountSyntax $ Account "Foo"+            [ Unpaid 44 [True]+            , Paid 46+            ]+    L.putStrLn $ "\t" <> encode z1++    let Right z2 = runBuilder accountSyntax $ Account "Bar" []+    L.putStrLn $ "\t" <> encode z2++    putStrLn "\n\tPARSE"++    putStrLn $ "\t" <> show (runParser accountSyntax z1)+    putStrLn $ "\t" <> show (runParser accountSyntax z2)