diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Gracjan Polak + +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 Gracjan Polak 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/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/src/Data/Unjson.hs b/src/Data/Unjson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unjson.hs @@ -0,0 +1,1597 @@ +{-# LANGUAGE CPP #-} + +-- | @Unjson@: bidirectional JSON (de)serialization with strong error +-- reporting capabilities and automatic documentation generation. +-- +-- @Data.Unjson@ offers: +-- +-- * single definition for serialization and deserialization +-- +-- * parse and update mode +-- +-- * exact error reporting +-- +-- * required, optional and fields with default values +-- +-- * first class object, array and tuple support +-- +-- * lifting of Aeson instances +-- +-- * automatic documentation generation +-- +-- Example: +-- +-- > data Example = Example +-- > { exampleName :: Text.Text, +-- > exampleArray :: [Int], +-- > exampleOptional :: Maybe Bool } +-- > +-- > unjsonExample :: UnjsonDef Example +-- > unjsonExample = objectOf $ pure Example +-- > <*> field "name" +-- > exampleName +-- > "Name used for example" +-- > <*> fieldDefBy "array_of_ints" [] +-- > exampleArray +-- > "Array of integers, optional, defaults to empty list" +-- > arrayOf +-- > <*> fieldOpt "optional_bool" +-- > exampleOptional +-- > "Optional boolean" +-- +-- Rendered documentation: +-- +-- > name (req): +-- > Name used for example +-- > Text +-- > array_of_ints (def): +-- > Array of integers, optional, defaults to empty list +-- > array of: +-- > Int +-- > optional_bool (opt): +-- > Optional boolean +-- > Bool +-- +-- Documentation has some colors that could not be reproduced in +-- haddock. +-- +-- Parsing: +-- +-- > let Result val iss = parse unjsonExample (Anchored mempty $ +-- > object [ "name" .= 123, +-- > "array_of_ints" .= [toJSON 123, toJSON "abc"], +-- > "optional_bool" .= True ]) +-- +-- Error reporting: +-- +-- > mapM_ print iss +-- > > name: "when expecting a Text, encountered Number instead" +-- > > array_of_ints[1]: "when expecting a Integral, encountered String instead" +-- +-- Partial results: +-- +-- > print (exampleOptional val) +-- > > Just True +-- +-- Bottom errors in partial results: +-- +-- > print (exampleName val) +-- > > "*** Exception: name: "when expecting a Text, encountered Number instead" +-- +-- Note: if list of issues is empty then there are not bottoms, guaranteed. +-- +-- For more examples have a look at 'Unjson', 'parse', 'update', +-- 'unjsonToJSON', 'unjsonToByteStringLazy', +-- 'unjsonToByteStringBuilder' and 'render'. +module Data.Unjson +( +-- * Serialization to JSON + unjsonToJSON +, unjsonToJSON' +, unjsonToByteStringLazy +, unjsonToByteStringLazy' +, unjsonToByteStringBuilder +, unjsonToByteStringBuilder' +, unjsonToByteStringBuilder'' +, Options(..) + +-- * Data definitions +, Unjson(..) +, UnjsonDef(..) + +-- ** Objects +, objectOf +, field +, fieldBy +, fieldOpt +, fieldOptBy +, fieldDef +, fieldDefBy +, fieldReadonly +, fieldReadonlyBy +, FieldDef(..) +-- ** Arrays +, arrayOf +, arrayWithModeOf +, arrayWithPrimaryKeyOf +, arrayWithModeAndPrimaryKeyOf +, ArrayMode(..) +-- ** Maps, enums, sums +, mapOf +, enumOf +, disjointUnionOf +, unionOf +-- ** Helpers +, unjsonAeson +, unjsonAesonWithDoc + +-- * Documentation rendering +, render +, renderForPath +, renderDoc +, renderDocForPath + +-- * Parsing and updating +, parse +, update +, Result(..) +, Anchored(..) +, Problem +, Problems +, Path(..) +, PathElem(..) + +, unjsonInvmapR +, unjsonIsConstrByName +, unjsonIPv4AsWord32 +) +where + +import qualified Data.Aeson as Aeson hiding (encode) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson.Encode as Aeson +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Builder as Builder +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable +import qualified Data.Vector.Unboxed +import qualified Data.Vector.Primitive +import qualified Data.Vector.Generic +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.HashSet as HashSet +import Data.Typeable +import Data.Data +import Data.Monoid +import Data.Maybe +import Data.Primitive.Types +import Data.Hashable +import Data.Scientific +#ifdef MIN_VERSION_attoparsec +#if MIN_VERSION_attoparsec(0,14,0) + -- do nothing +#else +import Data.Attoparsec.Number +#endif +#endif +import Data.Time.LocalTime +import Data.Time.Clock +import Data.Fixed +import Data.Tree +import Foreign.Storable +import Control.Applicative +import Control.Applicative.Free +import Data.Functor.Invariant +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Lazy as LazyHashMap +import Control.Exception +import Data.Traversable + +import Data.Bits +import Data.Word +import Data.Int +import Data.Ratio +import Data.List +import qualified Text.ParserCombinators.ReadP as ReadP +import Data.Char +import Control.Monad + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +import qualified Text.PrettyPrint.HughesPJ as P + +-- | Describe a path from root JSON element to a specific +-- position. JSON has only two types of containers: objects and +-- arrays, so there are only two types of keys needed to index into +-- those containers: 'Int' and 'Text.Text'. See 'Path'. +data PathElem = PathElemKey Text.Text + | PathElemIndex Int + deriving (Typeable, Eq, Ord, Show) + +-- | 'Path's are rendered in a nice way. For example: @key.key2[34]@ +-- indexes into \"key\", then into \"key2\" then into index 34 of an +-- array. +newtype Path = Path [PathElem] + deriving (Eq, Ord, Typeable, Monoid) + +instance Show Path where + show (Path p) = Text.unpack (showPath True p) + +showPath :: Bool -> [PathElem] -> Text.Text +showPath _ [] = "" +showPath True (PathElemKey key : rest) = key <> showPath False rest +showPath False (PathElemKey key : rest) = "." <> key <> showPath False rest +showPath _ (PathElemIndex key : rest) = "[" <> Text.pack (show key) <> "]" <> showPath False rest + +-- | A value at a specific position in JSON object. +data Anchored a = Anchored Path a + deriving (Typeable, Functor, Eq, Ord) + +instance (Show a) => Show (Anchored a) where + show (Anchored (Path path) value) = Text.unpack (showPath True path) ++ ": " ++ show value + +instance (Typeable a, Show a) => Exception (Anchored a) + +-- | Problem information is represented as a 'Text.Text' attached to a +-- specific point in the JSON represenation tree. +type Problem = Anchored Text.Text + +-- | In general JSON deserialization may result in many +-- problems. Unjson reports all the problems at once. +type Problems = [Problem] + +-- | Parsing result. The value 'a' is only reliable when 'Problems' is +-- an empty list. +-- +-- 'Problems' is list of issues encountered while parsing. 'Unjson' +-- parsers continue forward and are able to find many problems at +-- once. +-- +-- Note that problems are anchored to specific elements of JSON so it +-- should be easy to find and spot an error. +-- +-- Even if list of problems is not empty, the returned value may be +-- partially usable. +-- +-- Examples of list of problems: +-- +-- > [Anchored [PathElemKey "credentials",PathElemKey "password"] "missing key", +-- > Anchored [PathElemKey "tuple"] "cannot parse array of length 3 into tuple of size 4", +-- > Anchored [PathElemKey "text_array",PathElemIndex 0.PathElemKey "value"] +-- > "when expecting a Text, encountered Boolean instead"] +-- +-- conveniently rendered as: +-- +-- > "credentials.password": "missing key" +-- > "tuple": "cannot parse array of length 3 into tuple of size 4" +-- > "text_array[0].value": "when expecting a Text, encountered Boolean instead" + +data Result a = Result a Problems + deriving (Functor, Show, Ord, Eq) + +instance Applicative Result where + pure a = Result a [] + Result a pa <*> Result b pb = Result (a b) (pa ++ pb) + +instance Monad Result where + return = pure + Result a pa >>= m = Result ma (pa ++ pma) + where Result ma pma = m a + fail str = Result (throw anchoredMessage) [anchoredMessage] + where anchoredMessage = Anchored mempty (Text.pack str) + +-- | 'Unjson' typeclass describes all types that can be parsed from +-- JSON and JSON generated from their values. +-- +-- Example declaration: +-- +-- > instance Unjson Thing where +-- > unjsonDef = objectOf $ pure Thing +-- > <*> field "key1" +-- > thingField1 +-- > "Required field of type with Unjson instance" +-- > <*> fieldBy "key2" +-- > thingField2 +-- > "Required field with parser given below" +-- > unjsonForKey2 +-- > <*> fieldOpt "key4" +-- > thingField4 +-- > "Optional field of type with Unjson instance" +-- > <*> fieldOptBy "key5" +-- > thingField5 +-- > "Optional field with parser given below" +-- > unjsonForKey5 +-- > <*> fieldDef "key7" +-- > thingField7 +-- > "Optional field with default of type with Unjson instance" +-- > <*> fieldDefBy "key8" +-- > thingField8 +-- > "Optional field with default with parser given below" +-- > unjsonForKey8 +class Unjson a where + -- | Definition of a bidirectional parser for a type 'a'. See + -- 'parse', 'update', 'serialize' and 'render' to see how to use + -- 'UnjsonDef'. + unjsonDef :: UnjsonDef a + +instance (Unjson a) => Unjson [a] where + unjsonDef = arrayOf unjsonDef + +instance Unjson String where + unjsonDef = unjsonAesonWithDoc "String" + +instance Unjson Bool where unjsonDef = unjsonAeson +instance Unjson Char where unjsonDef = unjsonAeson +instance Unjson Double where unjsonDef = unjsonAeson +instance Unjson Float where unjsonDef = unjsonAeson +instance Unjson Int where unjsonDef = unjsonAeson +instance Unjson Int8 where unjsonDef = unjsonAeson +instance Unjson Int16 where unjsonDef = unjsonAeson +instance Unjson Int32 where unjsonDef = unjsonAeson +instance Unjson Int64 where unjsonDef = unjsonAeson +instance Unjson Integer where unjsonDef = unjsonAeson +instance Unjson Word where unjsonDef = unjsonAeson +instance Unjson Word8 where unjsonDef = unjsonAeson +instance Unjson Word16 where unjsonDef = unjsonAeson +instance Unjson Word32 where unjsonDef = unjsonAeson +instance Unjson Word64 where unjsonDef = unjsonAeson +instance Unjson () where unjsonDef = unjsonAeson +instance Unjson Text.Text where unjsonDef = unjsonAeson +#ifdef MIN_VERSION_attoparsec +#if MIN_VERSION_attoparsec(0,14,0) + -- do nothing +#else +instance Unjson Number where unjsonDef = unjsonAeson +#endif +#endif +instance Unjson IntSet.IntSet where unjsonDef = unjsonAeson +#ifdef MIN_VERSION_aeson +#if MIN_VERSION_aeson(0,7,0) +instance Unjson Scientific where unjsonDef = unjsonAeson +#endif +#endif +instance Unjson LazyText.Text where unjsonDef = unjsonAeson +instance Unjson ZonedTime where unjsonDef = unjsonAeson +instance Unjson UTCTime where unjsonDef = unjsonAeson +instance Unjson Aeson.DotNetTime where unjsonDef = unjsonAeson +instance Unjson Aeson.Value where unjsonDef = unjsonAeson +instance Unjson (Ratio Integer) where unjsonDef = unjsonAeson +instance (HasResolution a, Typeable a, Aeson.FromJSON a, Aeson.ToJSON a) => Unjson (Fixed a) where unjsonDef = unjsonAeson +instance Unjson a => Unjson (Dual a) where unjsonDef = invmap Dual getDual unjsonDef +{- + +-- these work only when 'Maybe a' and 'a' instances are conflated. we do not want this really, do we? +-- First and Last are Monoids here, not sure if/how Unjson should be a monoid or something +instance Unjson a => Unjson (First a) where unjsonDef = invmap First getFirst unjsonDef +instance Unjson a => Unjson (Last a) where unjsonDef = unjsonAeson + +-- Tree instance creates array of the form ["rootname", [trees]]. We could parse this nicely. +instance Unjson v => Unjson (Tree v) where unjsonDef = unjsonAeson + +-- disjoint unions require special setup +instance (Unjson a, Unjson b) => Unjson (Either a b) where unjsonDef = unjsonAeson +-} + +instance Unjson a => Unjson (IntMap.IntMap a) + where unjsonDef = invmap IntMap.fromList IntMap.toList unjsonDef +instance (Ord a, Unjson a) => Unjson (Set.Set a) + where unjsonDef = invmap Set.fromList Set.toList unjsonDef +instance (Eq a, Hashable a, Unjson a) => Unjson (HashSet.HashSet a) + where unjsonDef = invmap HashSet.fromList HashSet.toList unjsonDef +instance Unjson a => Unjson (Vector.Vector a) + where unjsonDef = invmap Vector.fromList Vector.toList unjsonDef +instance (Data.Vector.Generic.Vector Data.Vector.Unboxed.Vector a, Unjson a, Data.Vector.Unboxed.Unbox a) => Unjson (Data.Vector.Unboxed.Vector a) + where unjsonDef = invmap Data.Vector.Unboxed.fromList Data.Vector.Unboxed.toList unjsonDef +instance (Storable a, Unjson a) => Unjson (Data.Vector.Storable.Vector a) + where unjsonDef = invmap Data.Vector.Storable.fromList Data.Vector.Storable.toList unjsonDef +instance (Prim a, Unjson a) => Unjson (Data.Vector.Primitive.Vector a) + where unjsonDef = invmap Data.Vector.Primitive.fromList Data.Vector.Primitive.toList unjsonDef + + +mapFst :: (a -> c) -> (a,b) -> (c,b) +mapFst f (a,b) = (f a, b) + +instance Unjson v => Unjson (Map.Map String v) + where unjsonDef = invmap (Map.fromList . map (mapFst Text.unpack) . HashMap.toList) + (HashMap.fromList . map (mapFst Text.pack) . Map.toList) + unjsonDef +instance Unjson v => Unjson (Map.Map Text.Text v) + where unjsonDef = invmap (Map.fromList . HashMap.toList) + (HashMap.fromList . Map.toList) + unjsonDef +instance Unjson v => Unjson (Map.Map LazyText.Text v) + where unjsonDef = invmap (Map.fromList . map (mapFst LazyText.fromStrict) . HashMap.toList) + (HashMap.fromList . map (mapFst LazyText.toStrict) . Map.toList) + unjsonDef +instance Unjson v => Unjson (HashMap.HashMap String v) + where unjsonDef = invmap (HashMap.fromList . map (mapFst Text.unpack) . HashMap.toList) + (HashMap.fromList . map (mapFst Text.pack) . HashMap.toList) + unjsonDef +instance Unjson v => Unjson (HashMap.HashMap Text.Text v) + where unjsonDef = MapUnjsonDef unjsonDef pure id +instance Unjson v => Unjson (HashMap.HashMap LazyText.Text v) + where unjsonDef = invmap (HashMap.fromList . map (mapFst LazyText.fromStrict) . HashMap.toList) + (HashMap.fromList . map (mapFst LazyText.toStrict) . HashMap.toList) + unjsonDef + +instance (Unjson a,Unjson b) => Unjson (a,b) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,) + <*> liftAp (TupleFieldDef 0 (\(p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c) => Unjson (a,b,c) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d) => Unjson (a,b,c,d) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e) => Unjson (a,b,c,d + ,e) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f) + => Unjson (a,b,c,d + ,e,f) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g) + => Unjson (a,b,c,d + ,e,f,g) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g,Unjson h) + => Unjson (a,b,c,d + ,e,f,g,h) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 7 (\(_,_,_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g,Unjson h + ,Unjson i) + => Unjson (a,b,c,d + ,e,f,g,h + ,i) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 7 (\(_,_,_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 8 (\(_,_,_,_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g,Unjson h + ,Unjson i,Unjson j) + => Unjson (a,b,c,d + ,e,f,g,h + ,i,j) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 7 (\(_,_,_,_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 8 (\(_,_,_,_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 9 (\(_,_,_,_,_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g,Unjson h + ,Unjson i,Unjson j,Unjson k) + => Unjson (a,b,c,d + ,e,f,g,h + ,i,j,k) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 7 (\(_,_,_,_,_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 8 (\(_,_,_,_,_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 9 (\(_,_,_,_,_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 10 (\(_,_,_,_,_,_,_,_,_,_,p) -> p) unjsonDef) + +instance (Unjson a,Unjson b,Unjson c,Unjson d + ,Unjson e,Unjson f,Unjson g,Unjson h + ,Unjson i,Unjson j,Unjson k,Unjson l) + => Unjson (a,b,c,d + ,e,f,g,h + ,i,j,k,l) where + unjsonDef = TupleUnjsonDef $ fmap pure + $ pure (,,,,,,,,,,,) + <*> liftAp (TupleFieldDef 0 (\(p,_,_,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 1 (\(_,p,_,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 2 (\(_,_,p,_,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 3 (\(_,_,_,p,_,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 4 (\(_,_,_,_,p,_,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 5 (\(_,_,_,_,_,p,_,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 6 (\(_,_,_,_,_,_,p,_,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 7 (\(_,_,_,_,_,_,_,p,_,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 8 (\(_,_,_,_,_,_,_,_,p,_,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 9 (\(_,_,_,_,_,_,_,_,_,p,_,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 10 (\(_,_,_,_,_,_,_,_,_,_,p,_) -> p) unjsonDef) + <*> liftAp (TupleFieldDef 11 (\(_,_,_,_,_,_,_,_,_,_,_,p) -> p) unjsonDef) + +-- | Specify how arrays should be handled. Default is +-- 'ArrayModeStrict' that does not do anything special with +-- arrays. +-- +-- 'ArrayMode' is used in 'arrayWithModeAndPrimaryKeyOf' and +-- 'arrayWithModeOf'. +data ArrayMode + -- | Require JSON array. On output always output array. + = ArrayModeStrict + + -- | Allow non-array element, in that case it will be treated as a + -- single element array. On output always output array. + | ArrayModeParseSingle + + -- | Allow non-array element, in that case it will be treated as a + -- single element array. On output output single element if array + -- has one element. + | ArrayModeParseAndOutputSingle + deriving (Eq, Ord, Show, Typeable) + +-- | 'PrimaryKeyExtraction' is needed to keep 'Ord pk' constraint +-- attached. Elements of array may be matched based on a primary +-- key. A primary key has to be extracted both from existing array +-- structure and from JSON array elements. Then a 'Set' is constructed +-- so that lookups are efficient. Then for each element in JSON a +-- corresponding element in old object is looked for. If found the +-- element is updated, if not found it is parsed fresh. +data PrimaryKeyExtraction k = forall pk . (Ord pk) => PrimaryKeyExtraction (k -> pk) (UnjsonDef pk) + +-- | Opaque 'UnjsonDef' defines a bidirectional JSON parser. +data UnjsonDef a where + SimpleUnjsonDef :: Text.Text -> (Aeson.Value -> Result k) -> (k -> Aeson.Value) -> UnjsonDef k + ArrayUnjsonDef :: Maybe (PrimaryKeyExtraction k) -> ArrayMode -> ([k] -> Result v) -> (v -> [k]) -> UnjsonDef k -> UnjsonDef v + ObjectUnjsonDef :: Ap (FieldDef k) (Result k) -> UnjsonDef k + TupleUnjsonDef :: Ap (TupleFieldDef k) (Result k) -> UnjsonDef k + DisjointUnjsonDef :: Text.Text -> [(Text.Text, k -> Bool, Ap (FieldDef k) (Result k))] -> UnjsonDef k + UnionUnjsonDef :: [(k -> Bool, Ap (FieldDef k) (Result k))] -> UnjsonDef k + MapUnjsonDef :: UnjsonDef k -> (HashMap.HashMap Text.Text k -> Result v) -> (v -> HashMap.HashMap Text.Text k) -> UnjsonDef v + +instance Invariant UnjsonDef where + invmap f g (SimpleUnjsonDef name p s) = SimpleUnjsonDef name (fmap f . p) (s . g) + invmap f g (ArrayUnjsonDef mpk am n k d) = ArrayUnjsonDef mpk am (fmap f . n) (k . g) d + invmap f g (MapUnjsonDef d n k) = MapUnjsonDef d (fmap f . n) (k . g) + invmap f g (ObjectUnjsonDef fd) = ObjectUnjsonDef (fmap (fmap f) (hoistAp (contramapFieldDef g) fd)) + invmap f g (TupleUnjsonDef td) = TupleUnjsonDef (fmap (fmap f) (hoistAp (contramapTupleFieldDef g) td)) + invmap f g (DisjointUnjsonDef d l) = DisjointUnjsonDef d (map (\(a,b,c) -> (a,b . g,fmap (fmap f) (hoistAp (contramapFieldDef g) c))) l) + invmap f g (UnionUnjsonDef l) = UnionUnjsonDef (map (\(b,c) -> (b . g,fmap (fmap f) (hoistAp (contramapFieldDef g) c))) l) + +unjsonInvmapR :: (a -> Result b) -> (b -> a) -> UnjsonDef a -> UnjsonDef b +unjsonInvmapR f g (SimpleUnjsonDef name p s) = SimpleUnjsonDef name (join . fmap f . p) (s . g) +unjsonInvmapR f g (ArrayUnjsonDef mpk am n k d) = ArrayUnjsonDef mpk am (join . fmap f . n) (k . g) d +unjsonInvmapR f g (MapUnjsonDef d n k) = MapUnjsonDef d (join . fmap f . n) (k . g) +unjsonInvmapR f g (ObjectUnjsonDef fd) = ObjectUnjsonDef (fmap (join . fmap f) (hoistAp (contramapFieldDef g) fd)) +unjsonInvmapR f g (TupleUnjsonDef td) = TupleUnjsonDef (fmap (join . fmap f) (hoistAp (contramapTupleFieldDef g) td)) +unjsonInvmapR f g (DisjointUnjsonDef d l) = DisjointUnjsonDef d (map (\(a,b,c) -> (a,b . g,fmap (join . fmap f) (hoistAp (contramapFieldDef g) c))) l) +unjsonInvmapR f g (UnionUnjsonDef l) = UnionUnjsonDef (map (\(b,c) -> (b . g,fmap (join . fmap f) (hoistAp (contramapFieldDef g) c))) l) + +-- Note: contramapFieldDef and contramapTupleFieldDef are basically +-- Contravariant, but due to type parameters in wrong order we would +-- need to do some type shuffling to get it right. Easier to just +-- write it here as it is. +contramapFieldDef :: (b -> a) -> FieldDef a x -> FieldDef b x +contramapFieldDef f (FieldReqDef name doc ext d) = FieldReqDef name doc (ext . f) d +contramapFieldDef f (FieldOptDef name doc ext d) = FieldOptDef name doc (ext . f) d +contramapFieldDef f (FieldDefDef name doc def ext d) = FieldDefDef name doc def (ext . f) d +contramapFieldDef f (FieldRODef name doc ext d) = FieldRODef name doc (ext . f) d + +contramapTupleFieldDef :: (b -> a) -> TupleFieldDef a x -> TupleFieldDef b x +contramapTupleFieldDef f (TupleFieldDef i e d) = TupleFieldDef i (e . f) d + +-- | Define a relation between a field of an object in JSON and a +-- field in a Haskell record structure. 'FieldDef' holds information +-- about a documentation string, key name, Haskell data accessor and +-- parsing definition. 'FieldDef' has three cases for fields that are +-- required, optional (via 'Maybe') or jave default value. +data FieldDef s a where + FieldReqDef :: Text.Text -> Text.Text -> (s -> a) -> UnjsonDef a -> FieldDef s a + FieldOptDef :: Text.Text -> Text.Text -> (s -> Maybe a) -> UnjsonDef a -> FieldDef s (Maybe a) + FieldDefDef :: Text.Text -> Text.Text -> a -> (s -> a) -> UnjsonDef a -> FieldDef s a + FieldRODef :: Text.Text -> Text.Text -> (s -> a) -> UnjsonDef a -> FieldDef s () + +-- | Define a tuple element. 'TupleFieldDef' holds information about +-- index, accessor function and a parser definition. +data TupleFieldDef s a where + TupleFieldDef :: Int -> (s -> a) -> UnjsonDef a -> TupleFieldDef s a + +tupleDefToArray :: (forall b . UnjsonDef b -> b -> v) -> s -> Ap (TupleFieldDef s) a -> [v] +tupleDefToArray sx _ (Pure _) = [] +tupleDefToArray sx s (Ap (TupleFieldDef _ f d) r) = (sx d (f s)) : tupleDefToArray sx s r + + +objectDefToArray :: Bool -> (forall b . UnjsonDef b -> b -> v) -> s -> Ap (FieldDef s) a -> [(Text.Text,v)] +objectDefToArray _ sx _ (Pure _) = [] +objectDefToArray explicitNulls sx s (Ap (FieldReqDef key _ f d) r) = (key,sx d (f s)) : objectDefToArray explicitNulls sx s r +objectDefToArray explicitNulls sx s (Ap (FieldOptDef key _ f d) r) = + case f s of + Nothing -> (if explicitNulls then [(key,sx unjsonDef Aeson.Null)] else []) ++ objectDefToArray explicitNulls sx s r + Just g -> (key,sx d g) : objectDefToArray explicitNulls sx s r +objectDefToArray explicitNulls sx s (Ap (FieldDefDef key _ _ f d) r) = (key,sx d (f s)) : objectDefToArray explicitNulls sx s r +objectDefToArray explicitNulls sx s (Ap (FieldRODef key _ f d) r) = (key,sx d (f s)) : objectDefToArray explicitNulls sx s r + +-- | Formatting options when serializing to JSON. Used in +-- 'unjsonToJSON'', 'unjsonToByteStringLazy'' and +-- 'unjsonToByteStringBuilder''. +data Options = Options + { pretty :: Bool -- ^ Pretty format. Use spaces and newlines. + , indent :: Int -- ^ Amount of spaces for indent. 4 looks good. + , nulls :: Bool -- ^ Output explicit nulls for absent optional fields. + } + deriving (Eq, Ord, Show) + +-- | Given a definition of a value and a value produce a +-- 'Aeson.Value'. +-- +-- Example: +-- +-- > let v = Thing { ... } +-- > let json = unjsonToJSON unjsonThing v +-- +unjsonToJSON :: UnjsonDef a -> a -> Aeson.Value +unjsonToJSON = unjsonToJSON' (Options { pretty = False, indent = 4, nulls = False }) + +-- | Given a definition of a value and a value produce a +-- 'Aeson.Value'. Takes 'Options'. +-- +-- Example: +-- +-- > let v = Thing { ... } +-- > let json = unjsonToJSON' options unjsonThing v +-- +unjsonToJSON' :: Options -> UnjsonDef a -> a -> Aeson.Value +unjsonToJSON' _ (SimpleUnjsonDef _ _ g) a = g a +unjsonToJSON' opt (ArrayUnjsonDef _ m g k f) a = + case (m, k a) of + (ArrayModeParseAndOutputSingle,[b]) -> unjsonToJSON' opt f b + (_,c) -> Aeson.toJSON (map (unjsonToJSON' opt f) c) +unjsonToJSON' opt (ObjectUnjsonDef f) a = + Aeson.object (objectDefToArray (nulls opt) (unjsonToJSON' opt) a f) +unjsonToJSON' opt (TupleUnjsonDef f) a = + Aeson.toJSON (tupleDefToArray (unjsonToJSON' opt) a f) +unjsonToJSON' opt (DisjointUnjsonDef k l) a = + Aeson.object ((k,Aeson.toJSON nm) : objectDefToArray (nulls opt) (unjsonToJSON' opt) a f) + where + [(nm,_,f)] = filter (\(_,is,_) -> is a) l +unjsonToJSON' opt (UnionUnjsonDef l) a = + Aeson.object (objectDefToArray (nulls opt) (unjsonToJSON' opt) a f) + where + [(_,f)] = filter (\(is,_) -> is a) l +unjsonToJSON' opt (MapUnjsonDef f _ g) a = + Aeson.Object $ fmap (unjsonToJSON' opt f) (g a) + +-- | Given a definition of a value and a value produce a 'BSL.ByteString'. +-- +-- Example: +-- +-- > let v = Thing { ... } +-- > let utf8bsrep = unjsonToByteStringLazy unjsonThing v +-- +unjsonToByteStringLazy :: UnjsonDef a -> a -> BSL.ByteString +unjsonToByteStringLazy = unjsonToByteStringLazy' (Options { pretty = False, indent = 4, nulls = False }) + +-- | Given a definition of a value and a value produce a +-- 'BSL.ByteString'. Also takes formatting 'Options'. +-- +-- Example: +-- +-- > let v = Thing { ... } +-- > let utf8bsrep = unjsonToByteStringLazy' options unjsonThing v +-- +unjsonToByteStringLazy' :: Options -> UnjsonDef a -> a -> BSL.ByteString +unjsonToByteStringLazy' opt ud a = Builder.toLazyByteString (unjsonToByteStringBuilder' opt ud a) + + +unjsonGroup :: Int -> Options -> Builder.Builder -> Builder.Builder -> (a -> Builder.Builder) -> [a] -> Builder.Builder +unjsonGroup level _ open close _peritem [] = + mconcat $ [open, close] +unjsonGroup level opt open close peritem items = + mconcat $ [open, newline] ++ intersperse (Builder.char8 ',' <> newline) (map ((idnt2 <>) . peritem) items) ++ [newline, idnt, close] + where + newline :: Builder.Builder + newline = if pretty opt then Builder.char8 '\n' else mempty + idnt :: Builder.Builder + idnt = if pretty opt then mconcat (take level (repeat (Builder.char8 ' '))) else mempty + idnt2 :: Builder.Builder + idnt2 = if pretty opt then mconcat (take (level + indent opt) (repeat (Builder.char8 ' '))) else mempty + +-- | Given a definition of a value and a value produce a +-- 'Builder.Builder'. Functionally it is the same as +-- 'unjsonToByteStringLazy' but useful if json serialization is a part +-- of some bigger serialization function. Also takes formatting +-- 'Options'. +unjsonToByteStringBuilder' :: Options -> UnjsonDef a -> a -> Builder.Builder +unjsonToByteStringBuilder' = unjsonToByteStringBuilder'' 0 + +-- | Given a definition of a value and a value produce a +-- 'Builder.Builder'. Functionally it is the same as +-- 'unjsonToByteStringLazy' but useful if json serialization is a part +-- of some bigger serialization function. +unjsonToByteStringBuilder :: UnjsonDef a -> a -> Builder.Builder +unjsonToByteStringBuilder = unjsonToByteStringBuilder' (Options { pretty = False, indent = 4, nulls = False }) + +-- | Given a definition of a value and a value produce a +-- 'Builder.Builder'. Useful when JSON serialization is +-- a part of a bigger serialization function. +unjsonToByteStringBuilder'' :: Int -> Options -> UnjsonDef a -> a -> Builder.Builder +unjsonToByteStringBuilder'' level opt (SimpleUnjsonDef _ _ g) a = Builder.lazyByteString (Aeson.encode (g a)) +unjsonToByteStringBuilder'' level opt (ArrayUnjsonDef _ m g k f) a = + case (m, k a) of + (ArrayModeParseAndOutputSingle,[b]) -> unjsonToByteStringBuilder'' level opt f b + (_,c) -> unjsonGroup level opt (Builder.char8 '[') (Builder.char8 ']') (unjsonToByteStringBuilder'' (level+indent opt) opt f) c +unjsonToByteStringBuilder'' level opt (ObjectUnjsonDef f) a = + unjsonGroup level opt (Builder.char8 '{') (Builder.char8 '}') serx obj + where + obj :: [(Text.Text, Builder.Builder)] + obj = objectDefToArray (nulls opt) (unjsonToByteStringBuilder'' (level + indent opt) opt) a f + serx :: (Text.Text, Builder.Builder) -> Builder.Builder + serx (key,val) = Builder.lazyByteString (Aeson.encode (Aeson.toJSON key)) <> Builder.char8 ':' + <> (if pretty opt then Builder.char8 ' ' else mempty) <> val +unjsonToByteStringBuilder'' level opt (TupleUnjsonDef f) a = + unjsonGroup level opt (Builder.char8 '[') (Builder.char8 ']') id (tupleDefToArray (unjsonToByteStringBuilder'' (level+indent opt) opt) a f) +unjsonToByteStringBuilder'' level opt (DisjointUnjsonDef k l) a = + unjsonGroup level opt (Builder.char8 '{') (Builder.char8 '}') serx obj + where + obj :: [(Text.Text, Builder.Builder)] + obj = (k,Builder.lazyByteString (Aeson.encode (Aeson.toJSON nm))) : objectDefToArray (nulls opt) (unjsonToByteStringBuilder'' (level + indent opt) opt) a f + serx :: (Text.Text, Builder.Builder) -> Builder.Builder + serx (key,val) = Builder.lazyByteString (Aeson.encode (Aeson.toJSON key)) <> Builder.char8 ':' + <> (if pretty opt then Builder.char8 ' ' else mempty) <> val + [(nm,_,f)] = filter (\(_,is,_) -> is a) l +unjsonToByteStringBuilder'' level opt (UnionUnjsonDef l) a = + unjsonGroup level opt (Builder.char8 '{') (Builder.char8 '}') serx obj + where + obj :: [(Text.Text, Builder.Builder)] + obj = objectDefToArray (nulls opt) (unjsonToByteStringBuilder'' (level + indent opt) opt) a f + serx :: (Text.Text, Builder.Builder) -> Builder.Builder + serx (key,val) = Builder.lazyByteString (Aeson.encode (Aeson.toJSON key)) <> Builder.char8 ':' + <> (if pretty opt then Builder.char8 ' ' else mempty) <> val + [(_,f)] = filter (\(is,_) -> is a) l +unjsonToByteStringBuilder'' level opt (MapUnjsonDef f _ g) a = + unjsonGroup level opt (Builder.char8 '{') (Builder.char8 '}') serx obj + where + obj = LazyHashMap.toList (fmap (unjsonToByteStringBuilder'' (level + indent opt) opt f) (g a)) + serx (key,val) = Builder.lazyByteString (Aeson.encode (Aeson.toJSON key)) <> Builder.char8 ':' + <> (if pretty opt then Builder.char8 ' ' else mempty) <> val + +listRequiredKeysForField :: FieldDef s a -> [Text.Text] +listRequiredKeysForField (FieldReqDef key _docstring _f _d) = [key] +listRequiredKeysForField (FieldOptDef _key _docstring _f _d) = [] +listRequiredKeysForField (FieldDefDef _key _docstring _f _ _d) = [] +listRequiredKeysForField (FieldRODef _key _docstring _f _d) = [] + +listRequiredKeys :: Ap (FieldDef s) a -> [Text.Text] +listRequiredKeys (Pure _) = [] +listRequiredKeys (Ap f r) = + listRequiredKeysForField f ++ listRequiredKeys r + + +-- | Count how many applications there are. Useful for error +-- reporting. +countAp :: Int -> Ap x a -> Int +countAp !n (Pure _) = n +countAp n (Ap _ r) = countAp (succ n) r + +mapResultsIssuePaths :: (Path -> Path) -> Result a -> Result a +mapResultsIssuePaths f (Result v paths) = Result v' paths' + where + paths' = map fa paths + v' = mapException fa v + fa (Anchored path x) = Anchored (f path) x + +resultPrependIndex :: Int -> Result a -> Result a +resultPrependIndex i = mapResultsIssuePaths (Path [PathElemIndex i]<>) + +resultPrependKey :: Text.Text -> Result a -> Result a +resultPrependKey k = mapResultsIssuePaths (Path [PathElemKey k]<>) + +parseUpdating :: UnjsonDef a -> Maybe a -> Aeson.Value -> Result a +parseUpdating (SimpleUnjsonDef _ f _) _ov v = f v +parseUpdating (ArrayUnjsonDef (Just (PrimaryKeyExtraction pk_from_object pk_from_json)) m g k f) (Just ov) v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> join $ fmap g $ + sequenceA (zipWith (\v i -> lookupObjectByJson v >>= \ov -> (resultPrependIndex i $ parseUpdating f ov v)) + (Vector.toList v) [0..]) + Left e -> case m of + ArrayModeStrict -> + fail e + _ -> join $ fmap g $ + sequenceA [lookupObjectByJson v >>= \ov -> + parseUpdating f ov + v] + where + -- Note: Map.fromList is right-biased, so that Map.fromList [(1,1),(1,2)] is [(1,2)] + -- we need it to be left-biased, so we use Map.fromListWith (flip const) + objectMap = Map.fromListWith (flip const) (map (\o -> (pk_from_object o, o)) (k ov)) + lookupObjectByJson js = parseUpdating pk_from_json Nothing js >>= \val -> return (Map.lookup val objectMap) + +parseUpdating (ArrayUnjsonDef _ m g k f) _ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> join $ fmap g $ + sequenceA (zipWith (\v i -> resultPrependIndex i $ parseUpdating f Nothing v) (Vector.toList v) [0..]) + Left e -> case m of + ArrayModeStrict -> + fail e + _ -> join $ fmap g $ + sequenceA [parseUpdating f Nothing v] + +parseUpdating (ObjectUnjsonDef f) ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> + join (runAp (lookupByFieldDef v ov) f) + Left e -> + fail e + +parseUpdating (TupleUnjsonDef f) ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> + let r@(Result g h) = runAp (lookupByTupleFieldDef v ov) f + tupleSize = countAp 0 f + arrayLength = Vector.length v + in if tupleSize == arrayLength + then join r + else join $ Result g ([Anchored mempty ("cannot parse array of length " <> Text.pack (show arrayLength) <> + " into tuple of size " <> Text.pack (show tupleSize))] <> h) + Left e -> + fail e + +parseUpdating (DisjointUnjsonDef k l) ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> case HashMap.lookup k v of + Just x -> case Aeson.parseEither Aeson.parseJSON x of + Right xx -> case filter (\(nm,_,_) -> nm==xx) l of + [(_,_,f)] -> join (runAp (lookupByFieldDef v ov) f) + _ -> + resultPrependKey k $ fail $ "value '" ++ Text.unpack xx ++ "' is not one of the allowed for enumeration [" ++ intercalate "," (map (\(a,_,_) -> Text.unpack a) l) ++ "]" + Left e -> + fail e + Nothing -> case ov of + Just xov -> Result xov [] + Nothing -> resultPrependKey k $ fail "missing key" + Left e -> + fail e +parseUpdating (UnionUnjsonDef l) ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> case filter (\(_,f) -> isJust (mapM_ (\k -> HashMap.lookup k v) (listRequiredKeys f))) l of + ((_,f):_) -> join (runAp (lookupByFieldDef v ov) f) + _ -> fail $ "union value type could not be recognized based on presence of keys" + Left e -> + fail e +parseUpdating (MapUnjsonDef f g h) ov v + = case Aeson.parseEither Aeson.parseJSON v of + Right v -> + let hov = fmap h ov in + join $ fmap g $ HashMap.traverseWithKey (\k1 v1 -> resultPrependKey k1 $ parseUpdating f (join (fmap (HashMap.lookup k1) hov)) v1) v + Left e -> + fail e + + +-- | Parse JSON according to unjson definition. +-- +-- Example: +-- +-- > let json = Aeson.object [ ... ] +-- > let Result val iss = parse unjsonThing (Anchored [] json) +-- > if null iss +-- > then putStrLn ("Parsed: " ++ show val) +-- > else putStrLn ("Not parsed, issues: " ++ show iss) +-- +-- Error reporting is a strong side of Unjson, see 'Result'. +-- +-- For parsing of fields the following rules apply: +-- +-- - required fields generate an error if json key is missing +-- +-- - for optional fields Nothing is returned if json key is missing, +-- Just value otherwise +-- +-- - for fields with default value, the default value is returned if +-- key is missing, otherwise the parsed value is returned +-- +-- Note that Unjson makes strong difference between missing keys and +-- values that result in parse errors. +-- +-- For discussion of update mode see 'update'. +parse :: UnjsonDef a -> Aeson.Value -> Result a +parse vd = parseUpdating vd Nothing + +-- | Update object with JSON according to unjson definition. +-- +-- Example: +-- +-- > let original = Thing { ... } +-- > let json = Aeson.object [ ... ] +-- > let Result val iss = update original unjsonThing (Anchored [] json) +-- > if null iss +-- > then putStrLn ("Updated: " ++ show val) +-- > else putStrLn ("Not updated, issues: " ++ show iss) +-- +-- Error reporting is a strong side of Unjson, see 'Result'. +-- +-- For updating of fields the following rules apply: +-- +-- - required fields take the original value if json key is missing +-- +-- - optional fields take the original value if json key is missing +-- unless the value is @null@, then Nothing is returned (reset to +-- Nothing) +-- +-- - fields with default value take the original value if json key is +-- missing unless the value is @null@, then the default value is +-- returned (reset to default) +-- +-- Note that Unjson makes strong difference between missing keys and +-- values that result in parse errors. +-- +-- For discussion of parse mode see 'parse'. +update :: a -> UnjsonDef a -> Aeson.Value -> Result a +update a vd = parseUpdating vd (Just a) + +lookupByFieldDef :: Aeson.Object -> Maybe s -> FieldDef s a -> Result a +lookupByFieldDef v ov (FieldReqDef name docstring f valuedef) + = resultPrependKey name $ case HashMap.lookup name v of + Just x -> parseUpdating valuedef (fmap f ov) x + Nothing -> case ov of + Just xov -> Result (f xov) [] + Nothing -> fail "missing key" +lookupByFieldDef v ov (FieldDefDef name docstring def f valuedef) + = resultPrependKey name $ case HashMap.lookup name v of + Just Aeson.Null -> Result def [] + Just x -> parseUpdating valuedef (fmap f ov) x + Nothing -> case ov of + Just xov -> Result (f xov) [] + Nothing -> Result def [] +lookupByFieldDef v ov (FieldOptDef name docstring f valuedef) + = resultPrependKey name $ case HashMap.lookup name v of + Just Aeson.Null -> Result Nothing [] + Just x -> case ov of + Just xov -> fmap Just (parseUpdating valuedef (f xov) x) + Nothing -> fmap Just (parseUpdating valuedef Nothing x) + Nothing -> case ov of + Just xov -> Result (f xov) [] + Nothing -> Result Nothing [] +lookupByFieldDef _ _ (FieldRODef name docstring f valuedef) = Result () [] + + +lookupByTupleFieldDef :: Aeson.Array -> Maybe s -> TupleFieldDef s a -> Result a +lookupByTupleFieldDef v ov (TupleFieldDef idx f valuedef) + = resultPrependIndex idx $ case v Vector.!? idx of + Just x -> parseUpdating valuedef (fmap f ov) x + Nothing -> fail "missing key" + +-- | Declare a required field with definition given inline by valuedef. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> fieldBy "credentials" +-- > thingCredentials +-- > "Credentials to use" +-- > unjsonCredentials +-- > +-- > data Thing = Thing { thingCredentials :: Credentials, ... } +-- > unjsonCredentials :: UnjsonDef Credentials +fieldBy :: Text.Text -> (s -> a) -> Text.Text -> UnjsonDef a -> Ap (FieldDef s) a +fieldBy key f docstring valuedef = liftAp (FieldReqDef key docstring f valuedef) + +-- | Declare a required field with definition from 'Unjson' typeclass. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> field "credentials" +-- > thingCredentials +-- > "Credentials to use" +-- > +-- > data Thing = Thing { thingCredentials :: Credentials, ... } +-- > instance Unjson Credentials where ... +field :: (Unjson a) => Text.Text -> (s -> a) -> Text.Text -> Ap (FieldDef s) a +field key f docstring = fieldBy key f docstring unjsonDef + +-- | Declare an optional field and definition by valuedef. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> fieldOptBy "credentials" +-- > thingCredentials +-- > "Optional credentials to use" +-- > unjsonCredentials +-- > +-- > data Thing = Thing { thingCredentials :: Credentials, ... } +-- > unjsonCredentials :: UnjsonDef Credentials +fieldOptBy :: Text.Text -> (s -> Maybe a) -> Text.Text -> UnjsonDef a -> Ap (FieldDef s) (Maybe a) +fieldOptBy key f docstring valuedef = liftAp (FieldOptDef key docstring f valuedef) + +-- | Declare an optional field and definition by 'Unjson' typeclass. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> fieldOpt "credentials" +-- > thingCredentials +-- > "Optional credentials to use" +-- > +-- > data Thing = Thing { thingCredentials :: Credentials, ... } +-- > instance Unjson Credentials where ... +fieldOpt :: (Unjson a) => Text.Text -> (s -> Maybe a) -> Text.Text -> Ap (FieldDef s) (Maybe a) +fieldOpt key f docstring = fieldOptBy key f docstring unjsonDef + +-- | Declare a field with default value and definition by valuedef. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> fieldDefBy "credentials" defaultCredentials +-- > thingCredentials +-- > "Credentials to use, defaults to defaultCredentials" +-- > unjsonCredentials +-- > +-- > data Thing = Thing { thingCredentials :: Credentials, ... } +-- > unjsonCredentials :: UnjsonDef Credentials +fieldDefBy :: Text.Text -> a -> (s -> a) -> Text.Text -> UnjsonDef a -> Ap (FieldDef s) a +fieldDefBy key def f docstring valuedef = liftAp (FieldDefDef key docstring def f valuedef) + +-- | Declare a field with default value and definition by 'Unjson' typeclass. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > <*> fieldDef "port" 80 +-- > thingPort +-- > "Port to listen on, defaults to 80" +-- > +-- > data Thing = Thing { thingPort :: Int, ... } +fieldDef :: (Unjson a) => Text.Text -> a -> (s -> a) -> Text.Text -> Ap (FieldDef s) a +fieldDef key def f docstring = fieldDefBy key def f docstring unjsonDef + + +-- | Declare a field that is readonly from the point of view of Haskell structures, +-- it will be serialized to JSON but never read from JSON. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure (\s -> Thing 59123 s) +-- > <* fieldReadonly "port" +-- > thingPort +-- > "Random port the server is listening on" +-- > <*> field "string" +-- > thingString +-- > "Additional string" +-- > +-- > data Thing = Thing { thingPort :: Int, thingString :: String, ... } +fieldReadonly :: (Unjson a) => Text.Text -> (s -> a) -> Text.Text -> Ap (FieldDef s) () +fieldReadonly key f docstring = fieldReadonlyBy key f docstring unjsonDef + +-- | Declare a field that is readonly from the point of view of Haskell structures, +-- it will be serialized to JSON but never read from JSON. Accepts +-- unjson parser as a parameter. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure (\s -> Thing 59123 s) +-- > <* fieldReadonlyBy "port" +-- > thingPort +-- > "Random port the server is listening on" +-- > unjsonPort +-- > <*> field "string" +-- > thingString +-- > "Additional string" +-- > +-- > data Thing = Thing { thingPort :: Port, thingString :: String, ... } +fieldReadonlyBy :: Text.Text -> (s -> a) -> Text.Text -> UnjsonDef a -> Ap (FieldDef s) () +fieldReadonlyBy key f docstring valuedef = liftAp (FieldRODef key docstring f valuedef) + +-- | Declare an object as bidirectional mapping from JSON object to Haskell record and back. +-- +-- Example: +-- +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = objectOf $ pure Thing +-- > ...field definitions go here +-- +-- Use field functions to specify fields of an object: 'field', +-- 'fieldBy', 'fieldOpt', 'fieldOptBy', +-- 'fieldDef' or 'fieldDefBy'. +objectOf :: Ap (FieldDef a) a -> UnjsonDef a +objectOf fields = ObjectUnjsonDef (fmap pure fields) + + +-- | Gather all keys with respective values in a map. +-- +-- Example: +-- +-- > data X = X { xMap :: LazyHashMap.HashMap Text.Text x } +-- > +-- > objectOf $ pure X +-- > <*> fieldBy "xmap" xMap +-- > "Map string to Y value" +-- > (mapOf unjsonY) +-- +-- Note that overloading allows for automatic conversion to more map +-- types, for example: +-- +-- > data X = X { xMap :: Map.Map String x } +-- > +-- > objectOf $ pure X +-- > <*> field "xmap" xMap +-- > "Map string to Y value" +mapOf :: UnjsonDef x -> UnjsonDef (LazyHashMap.HashMap Text.Text x) +mapOf def = MapUnjsonDef def pure id + +-- | Provide sum type support. Bidirectional case matching in Haskell +-- is not good, so some obvious information needs to be given +-- manually. +-- +-- For related functionality see 'enumOf'. +-- +-- Example: +-- +-- > data X = A { aString :: String } | B { bInt :: Int } +-- > deriving (Data,Typeable) +-- > +-- > unjsonX = disjointUnionOf "type" +-- > [("a_thing", unjsonIsConstrByName "A", +-- > pure A <*> field "string" "A string value"), +-- > ("b_thing", unjsonIsConstrByName "B", +-- > pure B <*> field "string" "An int value")] +-- +-- Note that each case in list must be able to discriminate between +-- constructors in a data type and ti has to be able to this both +-- ways: to find out based on json contents which constructor applies +-- and also based on data contructor which of serialization cases to +-- use. +-- +-- Note that 'unjsonIsConstrByName' is helpful, but you may use usual +-- @case ... of@ if you do not like the 'Data.Data.Data' typeclass. +disjointUnionOf :: Text.Text -> [(Text.Text, k -> Bool, Ap (FieldDef k) k)] -> UnjsonDef k +disjointUnionOf key alternates = + DisjointUnjsonDef key (map (\(a,b,c) -> (a,b,fmap return c)) alternates) + +-- | Provide sum type support, non-disjoin version. Bidirectional case matching in Haskell +-- is not good, so some obvious information needs to be given +-- manually. +-- +-- For related functionality see 'enumOf'. +-- +-- Example: +-- +-- > data X = A { aString :: String } | B { bInt :: Int } +-- > deriving (Data,Typeable) +-- > +-- > unjsonX = unionOf +-- > [(unjsonIsConstrByName "A", +-- > pure A <*> field "string" "A string value"), +-- > (unjsonIsConstrByName "B", +-- > pure B <*> field "int" "An int value")] +-- +-- Note that each case in list must be able to discriminate between +-- constructors in a data type and ti has to be able to this both +-- ways: to find out based on json contents which constructor applies +-- and also based on data contructor which of serialization cases to +-- use. To know what constructor to use at parsing time unjson looks +-- at fields present in json object and on list of field names +-- required to satisfy. First constructor for which all fields are +-- present is chosen. +-- +-- Note that 'unjsonIsConstrByName' is helpful, but you may use usual +-- @case ... of@ if you do not like the 'Data.Data.Data' typeclass. +unionOf :: [(k -> Bool, Ap (FieldDef k) k)] -> UnjsonDef k +unionOf alternates = + UnionUnjsonDef (map (\(b,c) -> (b,fmap return c)) alternates) + +-- | Provide sum type support for parametersless constructors. +-- +-- For related functionality see 'disjointUnionOf'. +-- +-- Example: +-- +-- > data X = A | B +-- > +-- > unjsonX = enumOf "type_thing" +-- > [("a_thing", A), +-- > ("b_thing", B)] +-- +enumOf :: (Eq k) => Text.Text -> [(Text.Text, k)] -> UnjsonDef k +enumOf key alternates = + DisjointUnjsonDef key (map (\(a,b) -> (a,(==)b,fmap return (pure b))) alternates) + +-- | Declare array of values where each of them is described by +-- valuedef. Use 'unjsonAeson' to parse. +-- +-- Example: +-- +-- > unjsonArrayOfThings :: UnjsonDef [Thing] +-- > unjsonArrayOfThings = arrayOf unjsonThing +-- > +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = ... +arrayOf :: UnjsonDef a -> UnjsonDef [a] +arrayOf = arrayWithModeOf ArrayModeStrict + +-- | Declare array of values where each of them is described by +-- valuedef. Accepts mode specifier. +-- +-- Example: +-- +-- > unjsonArrayOfThings :: UnjsonDef [Thing] +-- > unjsonArrayOfThings = arrayOf unjsonThing +-- > +-- > unjsonThing :: UnjsonDef Thing +-- > unjsonThing = ... +arrayWithModeOf :: ArrayMode -> UnjsonDef a -> UnjsonDef [a] +arrayWithModeOf mode valuedef = ArrayUnjsonDef Nothing mode pure id valuedef + +-- | Declare array of primitive values lifed from 'Aeson'. Accepts +-- mode specifier. +-- +-- Example: +-- +-- > unjsonArrayOfIntOrSimpleInt :: UnjsonDef [Int] +-- > unjsonArrayOfIntOrSimpleInt = arrayWithModeOf' +arrayWithModeOf' :: (Aeson.FromJSON a,Aeson.ToJSON a, Typeable a) + => ArrayMode + -> UnjsonDef [a] +arrayWithModeOf' mode = arrayWithModeOf mode unjsonAeson + + +-- | Declare array of objects with given parsers that should be +-- matched by a primary key and accepts mode specifier. +-- +-- For discussion of primary key see 'arrayWithPrimaryKeyOf'. For +-- discussion of array modes see 'ArrayMode'. +-- +-- Example: +-- +-- > unjsonArrayOfIntToInt :: UnjsonDef [(Int,Int)] +-- > unjsonArrayOfIntToInt = arrayWithPrimaryKeyOf ArrayModeParseSingle +-- > (fst) +-- > (objectOf $ pure id +-- > <*> field "key" id "Key in mapping") +-- > (objectOf $ pure (,) +-- > <*> field "key" fst "Key in mapping" +-- > <*> field "value" fst "Value in mapping") +arrayWithModeAndPrimaryKeyOf :: (Ord pk) + => ArrayMode + -> (a -> pk) + -> UnjsonDef pk + -> UnjsonDef a + -> UnjsonDef [a] +arrayWithModeAndPrimaryKeyOf mode pk1 pk2 valuedef = + ArrayUnjsonDef (Just (PrimaryKeyExtraction pk1 pk2)) mode pure id valuedef + +-- | Declare array of objects with given parsers that should be +-- matched by a primary key. Uses 'ArrayModeStrict'. +-- +-- Primary key: +-- +-- Primary keys are used to match objects in 'update' mode. When a +-- request to update array is issued and array has primary key +-- specification then the following steps are used: +-- +-- 1. primary keys from old array elements are extracted and a mapping +-- from primary key to element is created. Mapping is left biased +-- meaning that first element with specific primary key in array is +-- used +-- +-- 2. for each object in json array primary key is extracted and is +-- looked up in old elements mapping +-- +-- 3. if mapping is found then element is 'update'd, if mapping is not +-- found then element is 'parse'd +-- +-- 4. in all cases the order of elements in the *new* array is respected +-- +-- Example: +-- +-- > unjsonArrayOfIntToInt :: UnjsonDef [(Int,Int)] +-- > unjsonArrayOfIntToInt = arrayWithPrimaryKeyOf +-- > (fst) +-- > (objectOf $ pure id +-- > <*> field "key" id "Key in mapping") +-- > (objectOf $ pure (,) +-- > <*> field "key" fst "Key in mapping" +-- > <*> field "value" fst "Value in mapping") +arrayWithPrimaryKeyOf :: (Ord pk) + => (a -> pk) + -> UnjsonDef pk + -> UnjsonDef a + -> UnjsonDef [a] +arrayWithPrimaryKeyOf pk1 pk2 valuedef = + arrayWithModeAndPrimaryKeyOf ArrayModeStrict pk1 pk2 valuedef + +-- | Use 'Aeson.fromJSON' and 'Aeson.toJSON' to create a +-- 'UnjsonDef'. This function is useful when lifted type is one of the +-- primitives. Although it can be used to lift user defined instances, +-- it is not advisable as there is too much information lost in the +-- process and proper error infomation is not possible. Use full +-- 'UnjsonDef' instance whenever possible. +-- +-- Example: +-- +-- > instance FromJSON MyType where ... +-- > instance ToJSON MyType where ... +-- > instance Unjson MyType where +-- > unjsonDef = unjsonAeson +unjsonAeson :: forall a . (Aeson.FromJSON a,Aeson.ToJSON a, Typeable a) => UnjsonDef a +unjsonAeson = unjsonAesonFixCharArrayToString + +-- | Like 'unjsonAeson' but accepts docstring as additional parameter +-- that should identify type. +unjsonAesonWithDoc :: (Aeson.FromJSON a,Aeson.ToJSON a) => Text.Text -> UnjsonDef a +unjsonAesonWithDoc docstring = SimpleUnjsonDef docstring + (\value -> + case Aeson.fromJSON value of + Aeson.Success result -> Result result [] + Aeson.Error message -> fail message) + Aeson.toJSON + +-- | Rename @[Char]@ to @String@ everywhere. +unjsonAesonFixCharArrayToString :: forall a . (Aeson.FromJSON a,Aeson.ToJSON a, Typeable a) => UnjsonDef a +unjsonAesonFixCharArrayToString = + unjsonAesonWithDoc (Text.pack typeNameFixed) + where + typeName = show (typeOf (undefined :: a)) + typeNameFixed = fixup typeName + fixup [] = [] + fixup ('[':'C':'h':'a':'r':']':rest) = "String" ++ fixup rest + fixup (x:xs) = x : fixup xs + +-- | Useful in 'DisjointUnjsonDef' as second element in tuples list to +-- check out if constructor is matching. +-- +-- Example: +-- +-- > data X = A | B | C +-- > unjsonIsConstrByName "B" B => True +unjsonIsConstrByName :: (Data a) => String -> a -> Bool +unjsonIsConstrByName nm v = nm == show (toConstr v) + +-- | Renders documentation for a parser into a multiline string. It is +-- expected that this string is a human readable representation that +-- can go directly to console. +-- +-- Example rendering: +-- +-- > hostname (req): +-- > The hostname this service is visible as +-- > Text +-- > port (def): +-- > Port to listen on, defaults to 80 +-- > Int +-- > credentials (req): +-- > User admin credentials +-- > username (req): +-- > Name of the user +-- > Text +-- > password (req): +-- > Password for the user +-- > Text +-- > domain (opt): +-- > Domain for user credentials +-- > Text +-- > comment (opt): +-- > Optional comment, free text +-- > Text +-- > options (def): +-- > Additional options, defaults to empty +-- > array of: +-- > Text +-- > alternates (opt): +-- > Alternate names for this server +-- > tuple of size 2 with elements: +-- > 0: +-- > Text +-- > 1: +-- > username (req): +-- > Name of the user +-- > Text +-- > password (req): +-- > Password for the user +-- > Text +-- > domain (opt): +-- > Domain for user credentials +-- > Text +render :: UnjsonDef a -> String +render = P.render . renderDoc + +-- | Render only selected part of structure documentation. Path should +-- point to a subtree, if it does not then Nothing is returned. +renderForPath :: (Functor m, Monad m) => Path -> UnjsonDef a -> m String +renderForPath path def = fmap P.render (renderDocForPath path def) + +-- | Renders documentation for a parser into a 'P.Doc'. See 'render' +-- for example. +renderDoc :: UnjsonDef a -> P.Doc +renderDoc (SimpleUnjsonDef doc _ _) = P.text (ansiDimmed ++ Text.unpack doc ++ ansiReset) +renderDoc (ArrayUnjsonDef _ _m g k f) = P.text (ansiDimmed ++ "array of" ++ ansiReset ++ ":") P.$+$ + P.nest 4 (renderDoc f) +renderDoc (MapUnjsonDef f _ _) = P.text (ansiDimmed ++ "map of" ++ ansiReset ++ ":") P.$+$ + P.nest 4 (renderDoc f) +renderDoc (ObjectUnjsonDef f) = + P.vcat (renderFields f) +renderDoc (TupleUnjsonDef f) = P.text (ansiDimmed ++ "tuple of size " ++ show (countAp 0 f) ++ " with elements:" ++ ansiReset) P.$+$ + P.vcat (renderTupleFields f) +renderDoc (DisjointUnjsonDef k z) = P.text (ansiDimmed ++ "disjoint union based on key:" ++ ansiReset) P.$+$ + P.vcat [P.text (ansiBold ++ Text.unpack k ++ ": " ++ Text.unpack l ++ ansiReset) P.$+$ P.nest 4 (P.vcat (renderFields f)) | (l,_,f) <- z] +renderDoc (UnionUnjsonDef z) = P.text (ansiDimmed ++ "plain union based on presence of required keys:" ++ ansiReset) P.$+$ + P.vcat [P.text (ansiBold ++ "case " ++ show i ++ ":" ++ ansiReset) P.$+$ P.nest 4 (P.vcat (renderFields f)) | ((_,f),i) <- zip z [1..]] + +-- | Render only selected part of structure documentation as +-- 'P.Doc'. Path should point to a subtree, if it does not then +-- Nothing is returned. +renderDocForPath :: (Monad m) => Path -> UnjsonDef a -> m P.Doc +renderDocForPath path def = findNestedUnjson path def + + +renderField :: FieldDef s a -> P.Doc +renderField (FieldReqDef key docstring _f d) = + P.text (ansiBold ++ Text.unpack key ++ ansiReset) P.<> P.text " (req):" P.$+$ P.nest 4 (P.text (Text.unpack docstring) P.$+$ renderDoc d) +renderField (FieldOptDef key docstring _f d) = + P.text (ansiBold ++ Text.unpack key ++ ansiReset) P.<> P.text " (opt):" P.$+$ P.nest 4 (P.text (Text.unpack docstring) P.$+$ renderDoc d) +renderField (FieldDefDef key docstring _f _ d) = + P.text (ansiBold ++ Text.unpack key ++ ansiReset) P.<> P.text " (def):" P.$+$ P.nest 4 (P.text (Text.unpack docstring) P.$+$ renderDoc d) +renderField (FieldRODef key docstring _f d) = + P.text (ansiBold ++ Text.unpack key ++ ansiReset) P.<> P.text " (ro):" P.$+$ P.nest 4 (P.text (Text.unpack docstring) P.$+$ renderDoc d) + +renderFields :: Ap (FieldDef s) a -> [P.Doc] +renderFields (Pure _) = [] +renderFields (Ap f r) = + renderField f : renderFields r + +renderTupleFields :: Ap (TupleFieldDef s) a -> [P.Doc] +renderTupleFields (Pure _) = [] +renderTupleFields (Ap f r) = + renderTupleField f : renderTupleFields r + +renderTupleField :: TupleFieldDef s a -> P.Doc +renderTupleField (TupleFieldDef index _f d) = + P.text (ansiBold ++ show index ++ ansiReset) P.<> P.text ":" P.$+$ P.nest 4 s + where + s = renderDoc d + +findNestedUnjson :: (Monad m) => Path -> UnjsonDef a -> m P.Doc +findNestedUnjson (Path []) u = return (renderDoc u) +findNestedUnjson (Path (PathElemIndex n : rest)) (TupleUnjsonDef d) = findNestedTupleUnjson n (Path rest) d +findNestedUnjson (Path (PathElemIndex _ : rest)) (ArrayUnjsonDef _ _ _ _ d) = findNestedUnjson (Path rest) d +findNestedUnjson (Path (PathElemKey k : rest)) (ObjectUnjsonDef d) = findNestedFieldUnjson k (Path rest) d +findNestedUnjson _ _ = fail "cannot find crap" + +findNestedTupleUnjson :: (Monad m) => Int -> Path -> Ap (TupleFieldDef s) a -> m P.Doc +findNestedTupleUnjson n path (Ap (TupleFieldDef index _f d) _r) | n == index = findNestedUnjson path d +findNestedTupleUnjson n path (Ap (TupleFieldDef _index _f _d) r) = + findNestedTupleUnjson n path r +findNestedTupleUnjson _ _ _ = fail "findNestedTupleUnjson" + +findNestedFieldUnjson :: (Monad m) => Text.Text -> Path -> Ap (FieldDef s) a -> m P.Doc +findNestedFieldUnjson key (Path []) (Ap f@(FieldReqDef k _ _ _d) _r) | k==key = return (renderField f) +findNestedFieldUnjson key (Path []) (Ap f@(FieldOptDef k _ _ _d) _r) | k==key = return (renderField f) +findNestedFieldUnjson key (Path []) (Ap f@(FieldDefDef k _ _ _ _d) _r) | k==key = return (renderField f) +findNestedFieldUnjson key (Path []) (Ap f@(FieldRODef k _ _ _d) _r) | k==key = return (renderField f) +findNestedFieldUnjson key path (Ap (FieldReqDef k _ _ d) _r) | k==key = findNestedUnjson path d +findNestedFieldUnjson key path (Ap (FieldOptDef k _ _ d) _r) | k==key = findNestedUnjson path d +findNestedFieldUnjson key path (Ap (FieldDefDef k _ _ _ d) _r) | k==key = findNestedUnjson path d +findNestedFieldUnjson key path (Ap (FieldRODef k _ _ d) _r) | k==key = findNestedUnjson path d +findNestedFieldUnjson key path (Ap _ r) = + findNestedFieldUnjson key path r +findNestedFieldUnjson _ _ _ = fail "findNestedFieldUnjson" + +-- Add some colors to the mix + +ansiReset :: String +ansiReset = "\ESC[0m" + +ansiBold :: String +ansiBold = "\ESC[1m" + +ansiDimmed :: String +ansiDimmed = "\ESC[2m" + +parseIPv4 :: ReadP.ReadP Word32 +parseIPv4 = do + d1 <- ReadP.munch1 isDigit + _ <- ReadP.char '.' + d2 <- ReadP.munch1 isDigit + _ <- ReadP.char '.' + d3 <- ReadP.munch1 isDigit + _ <- ReadP.char '.' + d4 <- ReadP.munch1 isDigit + ReadP.eof + let r = map read [d1,d2,d3,d4] + when (any (>255) r) ReadP.pfail + return (sum (zipWith shiftL r [24,16,8,0])) + + +-- | Parse and serialize dotted decimal notation for IPv4 addresses +-- and uses 'Word32' as representation type. Note that network byte +-- order applies, so 127.0.0.1 is 0x7F000001. +unjsonIPv4AsWord32 :: UnjsonDef Word32 +unjsonIPv4AsWord32 = SimpleUnjsonDef "IPv4 in decimal dot notation A.B.C.D" + (\value -> + case Aeson.fromJSON value of + Aeson.Success result -> + -- a number, treat it as is, for example 0x7f000001 = 2130706433 = 127.0.0.1 + Result result [] + Aeson.Error _ -> + case Aeson.fromJSON value of + Aeson.Success result -> case ReadP.readP_to_S parseIPv4 result of + [(r,"")] -> Result r [] + _ -> fail "cannot parse as decimal dot IPv4" + Aeson.Error _ -> + fail "expected IPv4 as decimal dot string or a single integer") + (Aeson.toJSON . showAsIPv4) + where + showAsIPv4 :: Word32 -> String + showAsIPv4 v = intercalate "." [show (shiftR v b .&. 255) | b <- [24,16,8,0]] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,862 @@ +{-# LANGUAGE CPP #-} +module Main where + +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Typeable +import Data.Unjson +import Control.Applicative +import qualified Data.Aeson as Aeson +import Data.Aeson ((.=)) +import Control.Exception +import Test.HUnit +import Data.Monoid +import Data.List +import Data.Data +import Data.Functor.Invariant +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Lazy as LazyHashMap +import qualified Data.Map as Map + +import System.Exit (ExitCode (..), exitWith) + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +default (Text.Text, String, Int, Double) + +-- As an example we will use a hypothetical configuration data. +-- There are some mandatory fields and some optional fields. +data Konfig = + Konfig { konfigHostname :: Text.Text + , konfigPort :: Integer + , konfigCredentials :: Credentials + , konfigComment :: Maybe Text.Text + , konfigOptions :: [Text.Text] + , konfigAlternates :: Maybe (Text.Text,Credentials) + } + deriving (Eq,Ord,Show,Typeable) + +data Credentials = + Credentials { credentialsUsername :: Text.Text + , credentialsPassword :: Text.Text + , credentialsDomain :: Maybe Text.Text + } + deriving (Eq,Ord,Show,Typeable) + + +unjsonKonfig :: UnjsonDef Konfig +unjsonKonfig = objectOf $ pure Konfig + <*> field "hostname" + konfigHostname + "The hostname this service is visible as" + <*> fieldDef "port" 80 + konfigPort + "Port to listen on, defaults to 80" + <*> fieldBy "credentials" + konfigCredentials + "User admin credentials" + unjsonCredentials + <*> fieldOpt "comment" + konfigComment + "Optional comment, free text" + <*> fieldDef "options" [] + konfigOptions + "Additional options, defaults to empty" + <*> fieldOpt "alternates" + konfigAlternates + "Alternate names for this server" + +unjsonCredentials :: UnjsonDef Credentials +unjsonCredentials = objectOf $ pure Credentials + <*> field "username" + credentialsUsername + "Name of the user" + <*> field "password" + credentialsPassword + "Password for the user" + <*> fieldOpt "domain" + credentialsDomain + "Domain for user credentials" + + + +instance Unjson Credentials where + unjsonDef = unjsonCredentials + +test_proper_parse :: Test +test_proper_parse = "Proper parsing of a complex structure" ~: do + let json = Aeson.object + [ "hostname" .= "www.example.com" + , "comment" .= "nice server" + , "credentials" .= Aeson.object + [ "username" .= "usr1" + , "password" .= "pass1" + ] + ] + let expect = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 80 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" Nothing + , konfigAlternates = Nothing + , konfigOptions = [] + } + + let Result val iss = parse unjsonKonfig json + assertEqual "There are no issues in parsing" [] iss + assertEqual "Value parsed is the one expected" expect val + return () + +test_missing_key :: Test +test_missing_key = "Key missing" ~: do + + -- Note: + -- + -- This test is strange with respect to what is returned as + -- exceptions. We would expect to have whole path to problematic + -- place returned, for some reason only last part of the path is + -- returned. This is good enough to keep this mechanism in place but + -- overall it is unknown why not everything is returned. + -- + -- Underlying mechanism is supposed to use mapException inside of + -- mapException and that should stack them on top concatenating the + -- path. Tests with external setup prove this is really the case, + -- but for some reason does not happen in general scenario. + -- + -- *Data.Unjson> resultPrependKey "a" (resultPrependKey "b" (fail "d" :: Result ())) + -- Result *** Exception: a.b: "d" + -- + let json1 = Aeson.object + [ "hostname" .= "www.example.com" + , "port" .= 12345 + , "comment" .= "nice server" + , "credentials" .= Aeson.object + [ "username" .= "usr1" + ] + ] + let json = Aeson.object + [ "payload" .= json1 + ] + let unjsonEnvelope :: UnjsonDef Konfig + unjsonEnvelope = objectOf $ pure id + <*> fieldBy "payload" + id + "Enveloped Konfig" + unjsonKonfig + do + let Result val iss = parse unjsonEnvelope json + assertEqual "There is one issue in parsing" [Anchored (Path [ PathElemKey "payload" + , PathElemKey "credentials" + , PathElemKey "password" + ]) "missing key"] iss + assertEqual "Value is accessible in parsed parts" "usr1" (credentialsUsername (konfigCredentials val)) + catch + (do + evaluate $ credentialsPassword (konfigCredentials val) + assertFailure "Should have thrown an exception") + (\(Anchored path (msg :: Text.Text)) -> do + assertEqual "Path to problematic key" + (Path [ PathElemKey "password" + ]) path + assertEqual "Message about the problem" (Text.pack "missing key") msg) + return () + + do + let Result val iss = parse unjsonKonfig json1 + assertEqual "There is one issue in parsing" [Anchored (Path [ PathElemKey "credentials" + , PathElemKey "password" + ]) "missing key"] iss + assertEqual "Value is accessible in parsed parts" "usr1" (credentialsUsername (konfigCredentials val)) + catch + (do + evaluate $ credentialsPassword (konfigCredentials val) + assertFailure "Should have thrown an exception") + (\(Anchored path (msg :: Text.Text)) -> do + assertEqual "Path to problematic key" + (Path [ PathElemKey "password" + ]) path + assertEqual "Message about the problem" (Text.pack "missing key") msg) + return () + +test_wrong_value_type :: Test +test_wrong_value_type = "Value at key is wrong type" ~: do + let json = Aeson.object + [ "hostname" .= 12345 + , "port" .= Aeson.object + [ "username" .= "usr1" + ] + , "credentials" .= "www.example.com" + ] + + let Result val iss = parse unjsonKonfig json + assertEqual "Number of issues in parsing" 3 (length iss) + assertEqual "Hostname must be string error info is present" + (Anchored (Path [ PathElemKey "hostname" + ]) "expected Text, encountered Number") (iss!!0) + assertEqual "Port must be number error info is present" + (Anchored (Path [ PathElemKey "port" + ]) "expected Integer, encountered Object") (iss!!1) + assertEqual "Credentials must be object error info is present" + (Anchored (Path [ PathElemKey "credentials" + ]) "Error in $: expected HashMap ~Text v, encountered String") (iss!!2) + return () + +test_tuple_parsing :: Test +test_tuple_parsing = "Tuple parsing" ~: do + let json = Aeson.toJSON + [ ("hostname" :: Aeson.Value) + , ("port" :: Aeson.Value) + , (Aeson.toJSON 123) + ] + + let Result (val1 :: String, val2 :: Text.Text, val3 ::Integer) iss = parse unjsonDef json + assertEqual "Number of issues in parsing" [] iss + assertEqual "First element of tuple" "hostname" val1 + assertEqual "Second element of tuple" "port" val2 + assertEqual "Third element of tuple" 123 val3 + + let Result (xval1 :: String, xval2 :: Text.Text, xval3 :: Int, xval4 :: Int) iss = parse unjsonDef json + assertEqual "Issue in parsing" [Anchored mempty "cannot parse array of length 3 into tuple of size 4" + ,Anchored (Path [PathElemIndex 3]) "missing key"] iss + + catch + (do + evaluate $ xval4 + assertFailure "Should have thrown an exception") + (\(Anchored path (msg :: Text.Text)) -> do + assertEqual "Path to problematic key" + (Path [PathElemIndex 3]) path + assertEqual "Message about the problem" (Text.pack "missing key") msg) + + let Result (yval1 :: Integer, yval2 :: Integer, yval3 :: Text.Text) iss = parse unjsonDef json + assertEqual "Issues in parsing" + [ Anchored (Path [PathElemIndex 0]) "expected Integer, encountered String" + , Anchored (Path [PathElemIndex 1]) "expected Integer, encountered String" + , Anchored (Path [PathElemIndex 2]) "expected Text, encountered Number" + ] iss + + let Result (zval1 :: String, zval2 :: Text.Text) iss = parse unjsonDef json + assertEqual "Array too long for 2-tuple" [Anchored mempty "cannot parse array of length 3 into tuple of size 2"] iss + + return () + +test_symmetry_of_serialization :: Test +test_symmetry_of_serialization = "Key missing" ~: do + let expect = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 12345 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" Nothing + , konfigAlternates = Nothing + , konfigOptions = [] + } + + let json = unjsonToJSON unjsonKonfig expect + let Result val iss = parse unjsonKonfig json + assertEqual "Serialize-parse produces no problems" expect val + assertEqual "Serialize-parse is identity" expect val + return () + +test_pretty_serialization :: Test +test_pretty_serialization = "Pretty serialization" ~: do + let konfig = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 12345 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" Nothing + , konfigAlternates = Nothing + , konfigOptions = [] + } + + let jsonstr = BSL.unpack $ unjsonToByteStringLazy' (Options { nulls = False, indent = 4, pretty = True }) unjsonKonfig konfig + let expect = intercalate "\n" + [ "{" + , " \"hostname\": \"www.example.com\"," + , " \"port\": 12345," + , " \"credentials\": {" + , " \"username\": \"usr1\"," + , " \"password\": \"pass1\"" + , " }," + , " \"comment\": \"nice server\"," + , " \"options\": []" + , "}" + ] + assertEqual "Serialize pretty prints proper indents" expect jsonstr + let jsonstr5 = BSL.unpack $ unjsonToByteStringLazy' (Options { nulls = False, indent = 5, pretty = True }) unjsonKonfig konfig + let expect5 = intercalate "\n" + [ "{" + , " \"hostname\": \"www.example.com\"," + , " \"port\": 12345," + , " \"credentials\": {" + , " \"username\": \"usr1\"," + , " \"password\": \"pass1\"" + , " }," + , " \"comment\": \"nice server\"," + , " \"options\": []" + , "}" + ] + assertEqual "Serialize pretty prints proper indents" expect5 jsonstr5 + let jsonstr3 = BSL.unpack $ unjsonToByteStringLazy' (Options { nulls = False, indent = 3, pretty = False }) unjsonKonfig konfig + let expect3 = concat + [ "{" + , "\"hostname\":\"www.example.com\"," + , "\"port\":12345," + , "\"credentials\":{" + , "\"username\":\"usr1\"," + , "\"password\":\"pass1\"" + , "}," + , "\"comment\":\"nice server\"," + , "\"options\":[]" + , "}" + ] + assertEqual "Serialize pretty prints proper indents" expect3 jsonstr3 + return () + +test_serialize_with_nulls :: Test +test_serialize_with_nulls = "Serialize with nulls" ~: do + let konfig = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 12345 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" Nothing + , konfigAlternates = Nothing + , konfigOptions = [] + } + + let jsonstr = BSL.unpack $ unjsonToByteStringLazy' (Options { nulls = True, indent = 4, pretty = True }) unjsonKonfig konfig + let expect = intercalate "\n" + [ "{" + , " \"hostname\": \"www.example.com\"," + , " \"port\": 12345," + , " \"credentials\": {" + , " \"username\": \"usr1\"," + , " \"password\": \"pass1\"," + , " \"domain\": null" + , " }," + , " \"comment\": \"nice server\"," + , " \"options\": []," + , " \"alternates\": null" + , "}" + ] + assertEqual "Serialize pretty prints proper indents" expect jsonstr + +unjsonButThirteen :: UnjsonDef Int +unjsonButThirteen = objectOf $ pure id + <*> fieldBy "value" id "Integer but god forbid 13" (unjsonInvmapR whenParse id $ unjsonDef) + where + whenParse 13 = fail "13 is a bad luck number" + whenParse x = return x + +test_semantic_errors_on_values :: Test +test_semantic_errors_on_values = "test_semantic_errors_on_values" ~: do + do + let json = Aeson.object + [ "value" .= (13 :: Int) + ] + let Result _val iss = parse unjsonButThirteen json + assertEqual "Problem is reported" [Anchored (Path [PathElemKey "value"]) "13 is a bad luck number"] iss + -- assertEqual "Just numerical_value present" (13) val + +unjsonEitherIntText :: UnjsonDef (Either Int Text.Text) +unjsonEitherIntText = disjointUnionOf "mode" + [ ("number", unjsonIsConstrByName "Left", + pure Left + <*> field "numerical_value" + fromLeft + "Numerical value") + , ("text", unjsonIsConstrByName "Right", + pure Right + <*> field "text_value" + fromRight + "Text value")] + where fromLeft ~(Left x) = x + fromRight ~(Right x) = x + + +test_parse_either_field :: Test +test_parse_either_field = "test_parse_either_field" ~: do + do + let json = Aeson.object + [ "mode" .= "number" + , "numerical_value" .= 12345 + ] + let Result val iss = parse unjsonEitherIntText json + assertEqual "No problems" [] iss + assertEqual "Just numerical_value present" (Left 12345) val + do + let json = Aeson.object + [ "mode" .= "text" + , "text_value" .= "asfsdfaf" + ] + let Result val iss = parse unjsonEitherIntText json + assertEqual "No problems" [] iss + assertEqual "Just text_value present" (Right "asfsdfaf") val + do + let json = Aeson.object + [ "text_value" .= False + , "numerical_value" .= 12345 + ] + let Result val iss = parse unjsonEitherIntText json + assertEqual "Problem when mode is missing" [Anchored (Path [PathElemKey "mode"]) "missing key"] iss + do + let json = Aeson.object + [ "mode" .= "something else" + ] + let Result val iss = parse unjsonEitherIntText json + assertEqual "Problem when mode is missing" [Anchored (Path [PathElemKey "mode"]) "value 'something else' is not one of the allowed for enumeration [number,text]"] iss + do + let json = Aeson.object + [ "mode" .= "number" + , "numerical_value" .= 123 + ] + let ex = Left 123 + let js = unjsonToJSON unjsonEitherIntText ex + assertEqual "Serialized makes what expected" json js + do + let docstr = render unjsonEitherIntText + assertBool "Documentation generates" (length docstr > 0) + return () + +data AB = A | B + deriving (Show, Eq, Ord) + + +unjsonEnumAB :: UnjsonDef AB +unjsonEnumAB = enumOf "mode" + [ ("A", A) + , ("B", B)] + + +test_enum_field :: Test +test_enum_field = "test_enum_field" ~: do + do + let json = Aeson.object + [ "mode" .= "A" + ] + let Result val iss = parse unjsonEnumAB json + assertEqual "No problems" [] iss + assertEqual "Proper value present" A val + do + let json = Aeson.object + [ "mode" .= "B" + ] + let Result val iss = parse unjsonEnumAB json + assertEqual "No problems" [] iss + assertEqual "Proper value present" B val + do + let json = Aeson.object + [ "mode" .= "wrong" + ] + let Result val iss = parse unjsonEnumAB json + assertEqual "No problems" [Anchored (Path [PathElemKey "mode"]) "value 'wrong' is not one of the allowed for enumeration [A,B]"] iss + catch + (do + evaluate val + assertFailure "Should have thrown an exception") + (\(Anchored path (msg :: Text.Text)) -> do + assertEqual "Path to problematic key" + (Path [ PathElemKey "mode" + ]) path + assertEqual "Message about the problem" (Text.pack "value 'wrong' is not one of the allowed for enumeration [A,B]") msg) + +test_update_from_serialization :: Test +test_update_from_serialization = "test_update_from_serialization" ~: do + let initial = Konfig + { konfigHostname = "old-www.server.com" + , konfigPort = 12345 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" Nothing + , konfigAlternates = Nothing + , konfigOptions = [] + } + let expect = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 999 + , konfigComment = Just "a better server" + , konfigCredentials = Credentials "usr2" "pass1" (Just "domain") + , konfigAlternates = Nothing + , konfigOptions = [] + } + + let json = Aeson.object + [ "hostname" .= "www.example.com" -- mandatory field + , "port" .= 999 -- optional with default + , "comment" .= "a better server" -- optional field + , "credentials" .= Aeson.object + [ "domain" .= "domain" + , "username" .= "usr2" ] + ] + let Result val iss = update initial unjsonKonfig json + assertEqual "No problems" [] iss + assertEqual "Object updated with json" expect val + return () + +test_update_from_serialization_with_reset_to_default :: Test +test_update_from_serialization_with_reset_to_default = "test_update_from_serialization_with_reset_to_default" ~: do + let initial = Konfig + { konfigHostname = "old-www.server.com" + , konfigPort = 12345 + , konfigComment = Just "nice server" + , konfigCredentials = Credentials "usr1" "pass1" (Just "domain") + , konfigAlternates = Nothing + , konfigOptions = [] + } + let expect = Konfig + { konfigHostname = "www.example.com" + , konfigPort = 80 + , konfigComment = Nothing + , konfigCredentials = Credentials "usr1" "pass1" (Nothing) + , konfigAlternates = Just ("abc", Credentials "usrx" "passx" Nothing) + , konfigOptions = [] + } + + let json = Aeson.object + [ "hostname" .= Aeson.Null -- mandatory field + , "port" .= Aeson.Null -- optional with default + , "comment" .= Aeson.Null -- optional field + , "credentials" .= Aeson.object + [ "domain" .= Aeson.Null ] + , "alternates" .= [ Aeson.toJSON "abc" + , Aeson.object + [ "username" .= "usrx" + , "password" .= "passx" + ] + ] + ] + let Result val iss = update initial unjsonKonfig json + assertEqual "Cannot reset mangatory field without default" + [Anchored (Path [PathElemKey "hostname"]) "expected Text, encountered Null"] iss + assertEqual "Can reset value with default" (konfigPort expect) (konfigPort val) + assertEqual "Can reset optional value" (konfigComment expect) (konfigComment val) + return () + +test_array_modes :: Test +test_array_modes = "test_array_modes" ~: do + + let json = Aeson.object + [ "hostname" .= ("www.example.com" ::Text.Text) + ] + let json1 = Aeson.object + [ "hostname" .= ["www.example.com" ::Text.Text] + ] + let p0 :: UnjsonDef [Text.Text] + p0 = objectOf $ pure id + <*> fieldBy "hostname" id + "Single value or array" + (arrayOf unjsonDef) + let p1 :: UnjsonDef [Text.Text] + p1 = objectOf $ pure id + <*> fieldBy "hostname" id + "Single value or array" + (arrayWithModeOf ArrayModeParseSingle unjsonAeson) + let p2 :: UnjsonDef [Text.Text] + p2 = objectOf $ pure id + <*> fieldBy "hostname" id + "Single value or array" + (arrayWithModeOf ArrayModeParseAndOutputSingle unjsonDef) + let Result val0 iss0 = parse p0 json + assertEqual "Does not parse value in strict array mode" + [Anchored (Path [PathElemKey "hostname"]) + "Error in $: expected Vector a, encountered String"] iss0 + let Result val1 iss1 = parse p1 json + assertEqual "No problems" [] iss1 + assertEqual "Accepts singel value in ArrayModeParseSingle" ["www.example.com"] val1 + let sjson1 = unjsonToJSON p1 val1 + assertEqual "Same json" json1 sjson1 + + let Result val2 iss2 = parse p2 json + assertEqual "No problems" [] iss2 + assertEqual "Array fetch produced result" ["www.example.com"] val2 + let sjson2 = unjsonToJSON p2 val2 + assertEqual "Same json" json sjson2 + return () + +test_array_update_by_primary_key :: Test +test_array_update_by_primary_key = "test_array_update_by_primary_key" ~: do + + let json = Aeson.object + [ "array" .= [ Aeson.object + [ "id" .= 12 + , "value" .= "for 12" + ] + , Aeson.object + [ "id" .= 17 + , "value" .= "for 17" + ] + , Aeson.object + [ "id" .= 3 + , "value" .= "for 3" + ] + , Aeson.object + [ "id" .= 17 + , "value" .= "wrong value for 17" + ] + ] + ] + let json1 = Aeson.object + [ "array" .= [ Aeson.object -- 17 is first now, value left intact + [ "id" .= 17 + ] + , Aeson.object -- 3 is not there, but 4 is new + [ "id" .= 4 + , "value" .= "for 4" + ] + , Aeson.object + [ "id" .= 12 -- 12 got new value + , "value" .= "for 12 new value" + ] + ] + ] + let unjsonPair = objectOf $ pure (,) + <*> field "id" + fst + "Unique id" + <*> field "value" + snd + "Value" + let pk1 = fst + pk2 = objectOf $ field "id" id "Unique id" + let p0 :: UnjsonDef [(Int,Text.Text)] + p0 = objectOf $ pure id + <*> fieldBy "array" + id + "Array updated by primary key" + (arrayWithPrimaryKeyOf pk1 pk2 unjsonPair) + let Result val0 iss0 = parse p0 json + assertEqual "No problems" [] iss0 + assertEqual "Parsing keeps proper order" [(12,"for 12"),(17,"for 17"),(3,"for 3"),(17,"wrong value for 17")] val0 + let Result val1 iss1 = update val0 p0 json1 + assertEqual "No problems" [] iss1 + assertEqual "Update keeps proper order" [(17,"for 17"),(4,"for 4"),(12,"for 12 new value")] val1 + return () + +test_maps :: Test +test_maps = "test_maps" ~: do + + let json = Aeson.object + [ "k1" .= (12 :: Int) + , "k2" .= (1122 :: Int) + , "a4" .= (666 :: Int) + ] + jsonEmbedded = Aeson.object + [ "a_map" .= json ] + let unjsonMapByInstance :: (Unjson a) => UnjsonDef a + unjsonMapByInstance = objectOf $ pure id + <*> field "a_map" + id + "The only map" + let unjsonMapByExplicit :: (Unjson a) => UnjsonDef (HashMap.HashMap Text.Text a) + unjsonMapByExplicit = objectOf $ pure id + <*> fieldBy "a_map" + id + "The only map" + (mapOf unjsonDef) + let Result val0 iss0 = parse unjsonMapByInstance jsonEmbedded + assertEqual "No problems" [] iss0 + assertEqual "Parsing keeps proper order in Data.Map" (Map.fromList [("k1"::String, 12::Int),("k2", 1122), ("a4", 666)]) val0 + let Result val1 iss1 = parse unjsonMapByInstance jsonEmbedded + assertEqual "No problems" [] iss1 + assertEqual "Parsing keeps proper order" (HashMap.fromList [("k1"::String, 12::Int),("k2", 1122), ("a4", 666)]) val1 + let Result val2 iss2 = parse unjsonMapByExplicit jsonEmbedded + assertEqual "No problems" [] iss2 + assertEqual "Parsing keeps proper order" (LazyHashMap.fromList [("k1"::Text.Text, 12::Int),("k2", 1122), ("a4", 666)]) val2 + return () + + +data PlainUnion + = PlainUnionA + { plainUnionKey1 :: String + , plainUnionKey2 :: Maybe Int + } + | PlainUnionB + { plainUnionKey3 :: Int + , plainUnionKey4 :: Int + } + deriving (Eq, Show, Typeable, Data) + +unjsonPlainUnion :: UnjsonDef PlainUnion +unjsonPlainUnion = unionOf + [ (unjsonIsConstrByName "PlainUnionA", + pure PlainUnionA + <*> field "key1" plainUnionKey1 "" + <*> fieldOpt "key2" plainUnionKey2 "") + , (unjsonIsConstrByName "PlainUnionB", + pure PlainUnionB + <*> field "key3" plainUnionKey3 "" + <*> fieldDef "key4" 123 plainUnionKey4 "") + ] + +test_plain_unions :: Test +test_plain_unions = "test_maps" ~: do + + -- simplest case + let json1 = Aeson.object + [ "key1" .= ("abc" :: String) + ] + + let Result val1 iss1 = parse unjsonPlainUnion json1 + assertEqual "No problems" [] iss1 + assertEqual "Got expected value" (PlainUnionA "abc" Nothing) val1 + + -- anyway choose first object on list, because 'key1' is present + let json2 = Aeson.object + [ "key1" .= ("abc" :: String) + , "key3" .= ("abc" :: String) + , "key4" .= ("abc" :: String) + ] + + let Result val2 iss2 = parse unjsonPlainUnion json2 + assertEqual "No problems" [] iss2 + assertEqual "Got expected value" (PlainUnionA "abc" Nothing) val2 + + -- key is present so PlainUnionA will be chosen and then fail + -- because of wrong types + let json3 = Aeson.object + [ "key1" .= (123 :: Int) + ] + + let Result val3 iss3 = parse unjsonPlainUnion json3 + assertEqual "Cannot parse PlainUnionA" [Anchored (Path [PathElemKey "key1"]) "expected String, encountered Number"] iss3 + + + -- choose PlainUnionB + let json4 = Aeson.object + [ "xx" .= (123 :: Int) + , "key3" .= (15523 :: Int) + , "key4" .= (13 :: Int) + ] + + let Result val4 iss4 = parse unjsonPlainUnion json4 + assertEqual "No issues" [] iss4 + assertEqual "Got expected value" (PlainUnionB 15523 13) val4 + + return () + + +data ROTest = ROTest + { roTestF1 :: Int + , roTestF2 :: String + } + deriving (Eq,Ord,Show) + +unjsonROTest :: UnjsonDef ROTest +unjsonROTest = objectOf $ + pure (\f2 -> ROTest 444 f2) + <*> field "f2" roTestF2 "f2 is a normal field" + <* fieldReadonly "f1" roTestF1 "f1 is readonly field" + + +test_readonly_fields :: Test +test_readonly_fields = "test_readonly_fields" ~: do + + -- simplest case + let json1 = Aeson.object + [ "f2" .= ("abc" :: String) + , "f1" .= (123 :: Int) + ] + + let Result val1 iss1 = parse unjsonROTest json1 + assertEqual "No problems" [] iss1 + assertEqual "Got expected value" (ROTest 444 "abc") val1 + + let json2 = Aeson.object + [ "f2" .= ("abc" :: String) + ] + + let Result val2 iss2 = parse unjsonROTest json2 + assertEqual "No problems" [] iss2 + assertEqual "Got expected value" (ROTest 444 "abc") val2 + + let json3 = Aeson.object + [ "f2x" .= ("abc" :: String) + , "f1" .= ("should not be inspected" :: String) + ] + + let Result _val3 iss3 = parse unjsonROTest json3 + assertEqual "There are problems" [Anchored (Path [ PathElemKey "f2" + ]) "missing key"] iss3 + return () + + +tests :: Test +tests = test [ test_proper_parse + , test_missing_key + , test_wrong_value_type + , test_tuple_parsing + , test_symmetry_of_serialization + , test_serialize_with_nulls + , test_parse_either_field + , test_enum_field + , test_update_from_serialization + , test_update_from_serialization_with_reset_to_default + , test_array_modes + , test_array_update_by_primary_key + , test_pretty_serialization + , test_semantic_errors_on_values + , test_maps + , test_plain_unions + , test_readonly_fields + ] + +main :: IO Counts +main = do results <- runTestTT tests + if (errors results + failures results == 0) + then exitWith ExitSuccess + else exitWith (ExitFailure 1) + +updateExampleRendering :: IO () +updateExampleRendering = do + contents <- readFile "src/Data/Unjson.hs" + let (before,exampleAndRest) = break (=="-- Example rendering:") (lines contents) + (example,after) = break ("render ::" `isPrefixOf`) exampleAndRest + _ <- return $! length after + writeFile "src/Data/Unjson.hs" + (unlines (before ++ ["-- Example rendering:", "--"] ++ + (map ((++)"-- > ") $ lines $ filterOutAnsi $ render unjsonKonfig) ++ + after)) + +filterOutAnsi :: String -> String +filterOutAnsi "" = "" +filterOutAnsi ('\ESC' : '[' : rest) = filterOutAnsiTillEndOfMulticharSequence rest +filterOutAnsi ('\ESC' : _ : rest) = filterOutAnsi rest +filterOutAnsi (c : rest) = c : filterOutAnsi rest + +filterOutAnsiTillEndOfMulticharSequence :: String -> String +filterOutAnsiTillEndOfMulticharSequence (c : rest) | c >= '@' = filterOutAnsi rest +filterOutAnsiTillEndOfMulticharSequence (c : rest) = + filterOutAnsiTillEndOfMulticharSequence rest +filterOutAnsiTillEndOfMulticharSequence [] = [] + + +data Example = Example + { exampleName :: Text.Text, + exampleArray :: [Int], + exampleOptional :: Maybe Bool, + exampleIntAsString :: Int } + +unjsonExample :: UnjsonDef Example +unjsonExample = objectOf $ pure Example + <*> field "name" + exampleName + "Name used for example" + <*> fieldDefBy "array_of_ints" [] + exampleArray + "Array of integers, optional, defaults to empty list" + (arrayOf unjsonDef) + <*> fieldOpt "optional_bool" + exampleOptional + "Optional boolean" + <*> fieldBy "int_as_string" + exampleIntAsString + "Integer value serialized as a string value in json" + (invmap (read :: String -> Int) (show :: Int -> String) unjsonDef) + +newtype Theme = Theme { unTheme :: Int } + +unjsonTheme :: UnjsonDef Theme +unjsonTheme = invmap (Theme . read :: String -> Theme) (show . unTheme :: Theme -> String) unjsonDef + +instance Unjson Theme where + unjsonDef = unjsonTheme diff --git a/unjson.cabal b/unjson.cabal new file mode 100644 --- /dev/null +++ b/unjson.cabal @@ -0,0 +1,79 @@ +-- Initial unjson.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: unjson +version: 0.14 +synopsis: Bidirectional JSON parsing and generation. +description: Bidirectional JSON parsing and generation with automatic documentation support. +license: BSD3 +license-file: LICENSE +author: Gracjan Polak +maintainer: Gracjan Polak , Mikhail Glushenkov +copyright: Gracjan Polak +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.18 +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 + +source-repository head + type: git + location: https://github.com/scrive/unjson + +source-repository this + type: git + location: https://github.com/scrive/unjson + tag: 0.14 + +library + exposed-modules: Data.Unjson + -- other-modules: + -- other-extensions: + build-depends: base >= 4.5 && < 5, text, aeson >= 0.10 && < 1.1, + free, scientific, attoparsec, + unordered-containers, vector, pretty, + bytestring >= 0.10, containers, hashable, + primitive, time, invariant + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: DeriveDataTypeable, + OverloadedStrings, + DeriveFunctor, + ExtendedDefaultRules, + GeneralizedNewtypeDeriving, + RankNTypes, + FlexibleContexts, + FlexibleInstances, + TypeFamilies, + OverloadedStrings, + UndecidableInstances, + ScopedTypeVariables, + OverlappingInstances, + BangPatterns, + GADTs + +Test-Suite test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src, test + build-depends: base >= 4.5 && < 5, text, aeson >= 0.10 && < 1.1, + free, scientific, attoparsec, + unordered-containers, vector, HUnit, bytestring >= 0.10, + pretty, primitive, containers, time, + hashable, invariant + default-language: Haskell2010 + default-extensions: DeriveDataTypeable, + OverloadedStrings, + GeneralizedNewtypeDeriving, + DeriveFunctor, + ExtendedDefaultRules, + RankNTypes, + UndecidableInstances, + FlexibleContexts, + FlexibleInstances, + TypeFamilies, + OverloadedStrings, + ScopedTypeVariables, + OverlappingInstances, + BangPatterns, + GADTs