diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/HLint.hs b/HLint.hs new file mode 100644 --- /dev/null +++ b/HLint.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/Data/Aeson/Roundtrip.hs b/lib/Data/Aeson/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Aeson/Roundtrip.hs @@ -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 diff --git a/roundtrip-aeson.cabal b/roundtrip-aeson.cabal new file mode 100644 --- /dev/null +++ b/roundtrip-aeson.cabal @@ -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 , Christian Marie +maintainer: Anchor Engineering +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 diff --git a/stack-2.14.yaml b/stack-2.14.yaml new file mode 100644 --- /dev/null +++ b/stack-2.14.yaml @@ -0,0 +1,6 @@ +flags: {} +packages: +- '.' +extra-deps: +- roundtrip-0.2.0.3 +resolver: lts-2.20 diff --git a/stack-2.18.yaml b/stack-2.18.yaml new file mode 100644 --- /dev/null +++ b/stack-2.18.yaml @@ -0,0 +1,6 @@ +flags: {} +packages: +- '.' +extra-deps: +- roundtrip-0.2.0.3 +resolver: lts-2.20 diff --git a/stack-2.20.yaml b/stack-2.20.yaml new file mode 100644 --- /dev/null +++ b/stack-2.20.yaml @@ -0,0 +1,6 @@ +flags: {} +packages: +- '.' +extra-deps: +- roundtrip-0.2.0.3 +resolver: lts-2.20 diff --git a/tests/demo.hs b/tests/demo.hs new file mode 100644 --- /dev/null +++ b/tests/demo.hs @@ -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)