├── Setup.hs ├── .gitignore ├── Makefile ├── Data ├── Iso.hs └── Iso │ ├── Common.hs │ ├── TH.hs │ └── Core.hs ├── tests ├── Types.hs └── Tests.hs ├── CHANGES.md ├── Notes.txt ├── LICENSE ├── JsonGrammar.cabal ├── Language └── JsonGrammar.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | .DS_Store 5 | 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: run 2 | 3 | run: 4 | ghci -Wall Example 5 | 6 | clean: 7 | cabal clean 8 | 9 | configure: 10 | cabal configure 11 | 12 | docs: configure 13 | cabal haddock 14 | 15 | install: 16 | cabal install 17 | 18 | opendocs: docs 19 | open dist/doc/html/JsonGrammar/index.html 20 | -------------------------------------------------------------------------------- /Data/Iso.hs: -------------------------------------------------------------------------------- 1 | -- | Convenience module that re-exports the available submodules. 2 | module Data.Iso ( 3 | 4 | module Data.Iso.Core, 5 | module Data.Iso.Common, 6 | module Data.Iso.TH, 7 | module Data.Semigroup 8 | 9 | ) where 10 | 11 | import Data.Iso.Core 12 | import Data.Iso.Common 13 | import Data.Iso.TH 14 | import Data.Semigroup 15 | -------------------------------------------------------------------------------- /tests/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | data Person = Person 4 | { name :: String 5 | , gender :: Gender 6 | , age :: Int 7 | -- , lat :: Float 8 | -- , lng :: Float 9 | , location :: Coords 10 | } deriving (Eq, Show) 11 | 12 | data Gender = Male | Female 13 | deriving (Eq, Show) 14 | 15 | data Coords = Coords { lat :: Float, lng :: Float } 16 | deriving (Eq, Show) 17 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Release notes 2 | 3 | ## 0.3, released 2011-08-12 4 | 5 | * Added more Json instances for common datatypes (lifting from aeson). 6 | 7 | ## 0.2, released 2011-06-18 8 | 9 | * Added combinators `elementBy` and `array` for matching arrays of specific length, with control over the types of individual array elements. 10 | * The old combinator `array` has been renamed to `list`. 11 | 12 | ## 0.1, released 2011-05-08 13 | 14 | * First release. Please see the README for an introduction. 15 | -------------------------------------------------------------------------------- /Notes.txt: -------------------------------------------------------------------------------- 1 | -- Given: 2 | 3 | forall f1, f2, g, (.). 4 | 5 | f1, f2 :: a -> Maybe b 6 | g :: b -> Maybe a 7 | (.) :: (b -> Maybe c) -> (a -> Maybe b) -> (a -> Maybe c) 8 | 9 | -- Do we need (.)'s implementation? 10 | 11 | f1 . g . f1 = f1 12 | f2 . g . f2 = f2 13 | 14 | (<>) :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b) 15 | f1 <> f2 = \x -> 16 | case f1 x of 17 | Nothing -> f2 x 18 | Just y -> Just y 19 | 20 | 21 | -- To prove: 22 | 23 | (f1 <> f2) . g . (f1 <> f2) = f1 <> f2 24 | 25 | exists x, y, x', y'. 26 | y == f1 x 27 | x' == g y 28 | y == f1 x 29 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE NoMonoPatBinds #-} 4 | 5 | import Types 6 | 7 | import Data.Iso 8 | import Language.JsonGrammar 9 | 10 | import Prelude hiding (id, (.), head, either) 11 | import Control.Category 12 | 13 | import Data.Aeson (Object) 14 | import Test.Framework (Test, defaultMain) 15 | import Test.Framework.Providers.HUnit (testCase) 16 | import Test.HUnit (assertEqual) 17 | 18 | 19 | person = $(deriveIsos ''Person) 20 | (male, female) = $(deriveIsos ''Gender) 21 | coords = $(deriveIsos ''Coords) 22 | 23 | 24 | instance Json Person where 25 | grammar = person . object 26 | ( prop "naam" 27 | . prop "geslacht" 28 | . prop "leeftijd" 29 | . coordsProps 30 | ) 31 | 32 | instance Json Gender where 33 | grammar = male . litJson "man" 34 | <> female . litJson "vrouw" 35 | 36 | coordsProps :: Iso (Object :- t) (Object :- Coords :- t) 37 | coordsProps = duck coords . prop "lat" . prop "lng" 38 | 39 | anna :: Person 40 | anna = Person "Anna" Female 36 (Coords 53.0163038 5.1993053) 41 | 42 | main :: IO () 43 | main = defaultMain [personTest] 44 | 45 | personTest :: Test 46 | personTest = testCase "Person" (assertEqual "" anna anna') 47 | where 48 | Just anna' = fromJson annaJson 49 | Just annaJson = toJson anna 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, Martijn van Steenbergen 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the author nor the 12 | names of his contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /JsonGrammar.cabal: -------------------------------------------------------------------------------- 1 | Name: JsonGrammar 2 | Version: 0.3.5 3 | Synopsis: Combinators for bidirectional JSON parsing 4 | Description: Combinators for bidirectional JSON parsing 5 | 6 | 7 | Author: Martijn van Steenbergen 8 | Maintainer: martijn@van.steenbergen.nl 9 | Stability: Experimental 10 | Copyright: Some Rights Reserved (CC) 2010-2012 Martijn van Steenbergen 11 | Homepage: https://github.com/MedeaMelana/JsonGrammar 12 | Bug-reports: https://github.com/MedeaMelana/JsonGrammar/issues 13 | 14 | 15 | Cabal-Version: >= 1.8 16 | License: BSD3 17 | License-file: LICENSE 18 | Category: JSON, Language 19 | Build-type: Simple 20 | 21 | 22 | Library 23 | Exposed-Modules: Data.Iso, 24 | Data.Iso.Core, 25 | Data.Iso.TH, 26 | Data.Iso.Common, 27 | Language.JsonGrammar 28 | Build-Depends: base >= 3.0 && < 5, 29 | aeson >= 0.6 && < 0.8, 30 | semigroups >= 0.5 && < 0.9, 31 | -- constraints copied from aeson-0.6.1.0: 32 | attoparsec >= 0.8.6.1, 33 | bytestring, 34 | containers, 35 | hashable >= 1.1.2.0, 36 | text >= 0.11.0.2, 37 | template-haskell >= 2.4, 38 | time, 39 | unordered-containers >= 0.1.3.0, 40 | vector >= 0.7.1 41 | 42 | Source-Repository head 43 | Type: git 44 | Location: https://github.com/MedeaMelana/JsonGrammar 45 | 46 | 47 | Test-Suite tests 48 | Type: exitcode-stdio-1.0 49 | Hs-Source-Dirs: tests 50 | Main-Is: Tests.hs 51 | Build-Depends: JsonGrammar, 52 | base >= 3.0 && < 5, 53 | aeson >= 0.6 && < 0.8, 54 | test-framework, 55 | test-framework-hunit, 56 | HUnit 57 | -------------------------------------------------------------------------------- /Data/Iso/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE NoMonoPatBinds #-} 4 | 5 | -- | Constructor-destructor isomorphisms for some common datatypes. 6 | module Data.Iso.Common ( 7 | 8 | -- * @()@ 9 | unit, 10 | 11 | -- * @(,)@ 12 | tup, 13 | 14 | -- * @(,,)@ 15 | tup3, 16 | 17 | -- * @Maybe a@ 18 | nothing, just, maybe, 19 | 20 | -- * @[a]@ 21 | nil, cons, 22 | 23 | -- * @Either a b@ 24 | left, right, either, 25 | 26 | -- * @Bool@ 27 | false, true, bool 28 | 29 | ) where 30 | 31 | import Prelude hiding (id, (.), maybe, either) 32 | import Control.Category 33 | 34 | import Data.Iso.Core 35 | import Data.Iso.TH 36 | 37 | import Data.Semigroup 38 | 39 | 40 | unit :: Iso t (() :- t) 41 | unit = Iso f g 42 | where 43 | f t = Just (() :- t) 44 | g (_ :- t) = Just t 45 | 46 | tup :: Iso (a :- b :- t) ((a, b) :- t) 47 | tup = Iso f g 48 | where 49 | f (a :- b :- t) = Just ((a, b) :- t) 50 | g ((a, b) :- t) = Just (a :- b :- t) 51 | 52 | tup3 :: Iso (a :- b :- c :- t) ((a, b, c) :- t) 53 | tup3 = Iso f g 54 | where 55 | f (a :- b :- c :- t) = Just ((a, b, c) :- t) 56 | g ((a, b, c) :- t) = Just (a :- b :- c :- t) 57 | 58 | nothing :: Iso t (Maybe a :- t) 59 | just :: Iso (a :- t) (Maybe a :- t) 60 | (nothing, just) = $(deriveIsos ''Maybe) 61 | 62 | maybe :: Iso t (a :- t) -> Iso t (Maybe a :- t) 63 | maybe el = just . el <> nothing 64 | 65 | 66 | nil :: Iso t ([a] :- t) 67 | nil = Iso f g 68 | where 69 | f t = Just ([] :- t) 70 | g ([] :- t) = Just t 71 | g _ = Nothing 72 | 73 | cons :: Iso (a :- [a] :- t) ([a] :- t) 74 | cons = Iso f g 75 | where 76 | f (x :- xs :- t) = Just ((x : xs) :- t) 77 | g ((x : xs) :- t) = Just (x :- xs :- t) 78 | g _ = Nothing 79 | 80 | 81 | left :: Iso (a :- t) (Either a b :- t) 82 | right :: Iso (b :- t) (Either a b :- t) 83 | (left, right) = $(deriveIsos ''Either) 84 | 85 | either :: Iso t1 (a :- t2) -> Iso t1 (b :- t2) -> Iso t1 (Either a b :- t2) 86 | either f g = left . f <> right . g 87 | 88 | 89 | false :: Iso t (Bool :- t) 90 | true :: Iso t (Bool :- t) 91 | (false, true) = $(deriveIsos ''Bool) 92 | 93 | bool :: Iso t (Bool :- t) 94 | bool = false <> true 95 | -------------------------------------------------------------------------------- /Data/Iso/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Data.Iso.TH (deriveIsos) where 5 | 6 | import Data.Iso.Core 7 | import Language.Haskell.TH 8 | import Control.Applicative 9 | import Control.Monad 10 | 11 | 12 | -- | Derive partial isomorphisms for a given datatype. The resulting 13 | -- expression is a tuple with one isomorphism element for each constructor in 14 | -- the datatype. 15 | -- 16 | -- For example: 17 | -- 18 | -- > nothing :: Iso t (Maybe a :- t) 19 | -- > just :: Iso (a :- t) (Maybe a :- t) 20 | -- > (nothing, just) = $(deriveIsos ''Maybe) 21 | -- 22 | -- Deriving isomorphisms this way requires @-XNoMonoPatBinds@. 23 | deriveIsos :: Name -> Q Exp 24 | deriveIsos name = do 25 | info <- reify name 26 | routers <- 27 | case info of 28 | TyConI (DataD _ _ _ cons _) -> 29 | mapM (deriveIso (length cons /= 1)) cons 30 | TyConI (NewtypeD _ _ _ con _) -> 31 | (:[]) <$> deriveIso False con 32 | _ -> 33 | fail $ show name ++ " is not a datatype." 34 | return (TupE routers) 35 | 36 | 37 | deriveIso :: Bool -> Con -> Q Exp 38 | deriveIso matchWildcard con = 39 | case con of 40 | NormalC name tys -> go name (map snd tys) 41 | RecC name tys -> go name (map (\(_,_,ty) -> ty) tys) 42 | _ -> fail $ "Unsupported constructor " ++ show (conName con) 43 | where 44 | go name tys = do 45 | iso <- [| Iso |] 46 | isoCon <- deriveConstructor name tys 47 | isoDes <- deriveDestructor matchWildcard name tys 48 | return $ iso `AppE` isoCon `AppE` isoDes 49 | 50 | 51 | deriveConstructor :: Name -> [Type] -> Q Exp 52 | deriveConstructor name tys = do 53 | -- Introduce some names 54 | t <- newName "t" 55 | fieldNames <- replicateM (length tys) (newName "a") 56 | 57 | -- Figure out the names of some constructors 58 | ConE just <- [| Just |] 59 | ConE cons <- [| (:-) |] 60 | 61 | let pat = foldr (\f fs -> ConP cons [VarP f, fs]) (VarP t) fieldNames 62 | let applyCon = foldl (\f x -> f `AppE` VarE x) (ConE name) fieldNames 63 | -- applyCon <- [| undefined |] 64 | let body = ConE just `AppE` (ConE cons `AppE` applyCon `AppE` VarE t) 65 | 66 | return $ LamE [pat] body 67 | 68 | 69 | deriveDestructor :: Bool -> Name -> [Type] -> Q Exp 70 | deriveDestructor matchWildcard name tys = do 71 | -- Introduce some names 72 | x <- newName "x" 73 | r <- newName "r" 74 | fieldNames <- replicateM (length tys) (newName "a") 75 | 76 | -- Figure out the names of some constructors 77 | ConE just <- [| Just |] 78 | ConE cons <- [| (:-) |] 79 | nothing <- [| Nothing |] 80 | 81 | let conPat = ConP name (map VarP fieldNames) 82 | let okBody = ConE just `AppE` 83 | foldr 84 | (\h t -> ConE cons `AppE` VarE h `AppE` t) 85 | (VarE r) 86 | fieldNames 87 | let okCase = Match (ConP cons [conPat, VarP r]) (NormalB okBody) [] 88 | let failCase = Match WildP (NormalB nothing) [] 89 | let allCases = 90 | if matchWildcard 91 | then [okCase, failCase] 92 | else [okCase] 93 | 94 | return $ LamE [VarP x] (CaseE (VarE x) allCases) 95 | 96 | 97 | -- Retrieve the name of a constructor. 98 | conName :: Con -> Name 99 | conName con = 100 | case con of 101 | NormalC name _ -> name 102 | RecC name _ -> name 103 | InfixC _ name _ -> name 104 | ForallC _ _ con' -> conName con' -------------------------------------------------------------------------------- /Data/Iso/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module Data.Iso.Core ( 4 | 5 | -- * Partial isomorphisms 6 | Iso(..), convert, inverse, many, 7 | 8 | -- * Stack-based isomorphisms 9 | (:-)(..), stack, unstack, swap, duck, 10 | lit, inverseLit, matchWithDefault, ignoreWithDefault 11 | 12 | ) where 13 | 14 | 15 | import Prelude hiding (id, (.), head) 16 | 17 | import Data.Monoid 18 | import Data.Semigroup 19 | 20 | import Control.Applicative hiding (many) 21 | import Control.Monad 22 | import Control.Category 23 | 24 | 25 | -- Partial isomorphisms 26 | 27 | -- | Bidirectional partial isomorphism. 28 | data Iso a b = Iso (a -> Maybe b) (b -> Maybe a) 29 | 30 | instance Category Iso where 31 | id = Iso Just Just 32 | ~(Iso f1 g1) . ~(Iso f2 g2) = Iso (f1 <=< f2) (g1 >=> g2) 33 | 34 | instance Monoid (Iso a b) where 35 | mempty = Iso (const Nothing) (const Nothing) 36 | ~(Iso f1 g1) `mappend` ~(Iso f2 g2) = 37 | Iso 38 | ((<|>) <$> f1 <*> f2) 39 | ((<|>) <$> g1 <*> g2) 40 | 41 | instance Semigroup (Iso a b) where 42 | (<>) = mappend 43 | 44 | -- | Apply an isomorphism in one direction. 45 | convert :: Iso a b -> a -> Maybe b 46 | convert (Iso f _) = f 47 | 48 | -- | Inverse of an isomorphism. 49 | inverse :: Iso a b -> Iso b a 50 | inverse (Iso f g) = Iso g f 51 | 52 | -- | Apply an isomorphism as many times as possible, greedily. 53 | many :: Iso a a -> Iso a a 54 | many (Iso f g) = Iso manyF manyG 55 | where 56 | manyF = ((<|>) <$> (f >=> manyF) <*> Just) 57 | manyG = ((<|>) <$> (g >=> manyG) <*> Just) 58 | 59 | 60 | -- Stack-based isomorphisms 61 | 62 | -- | Heterogenous stack with a head and a tail. 63 | data h :- t = h :- t 64 | deriving (Eq, Show) 65 | infixr 5 :- 66 | 67 | head :: (h :- t) -> h 68 | head (h :- _) = h 69 | 70 | -- | Convert to a stack isomorphism. 71 | stack :: Iso a b -> Iso (a :- t) (b :- t) 72 | stack (Iso f g) = Iso (lift f) (lift g) 73 | where 74 | lift k (x :- t) = (:- t) <$> k x 75 | 76 | -- | Convert from a stack isomorphism. 77 | unstack :: Iso (a :- ()) (b :- ()) -> Iso a b 78 | unstack (Iso f g) = Iso (lift f) (lift g) 79 | where 80 | lift k = fmap head . k . (:- ()) 81 | 82 | -- | Swap the top two arguments. 83 | swap :: Iso (a :- b :- t) (b :- a :- t) 84 | swap = Iso f f 85 | where 86 | f (x :- y :- t) = Just (y :- x :- t) 87 | 88 | -- | Introduce a head value that is passed unmodified. 89 | duck :: Iso t1 t2 -> Iso (h :- t1) (h :- t2) 90 | duck (Iso f g) = Iso (lift f) (lift g) 91 | where 92 | lift k (h :- t) = (h :-) <$> k t 93 | 94 | -- | Push or pop a specific value. 95 | lit :: Eq a => a -> Iso t (a :- t) 96 | lit x = Iso f g 97 | where 98 | f t = Just (x :- t) 99 | g (x' :- t) = do 100 | guard (x' == x) 101 | Just t 102 | 103 | -- | Inverse of 'lit'. 104 | inverseLit :: Eq a => a -> Iso (a :- t) t 105 | inverseLit = inverse . lit 106 | 107 | -- | When converting from left to right, push the default value on top of the 108 | -- stack. When converting from right to left, pop the value, make sure it 109 | -- matches the predicate and then discard it. 110 | matchWithDefault :: (a -> Bool) -> a -> Iso t (a :- t) 111 | matchWithDefault p x = Iso f g 112 | where 113 | f t = Just (x :- t) 114 | g (x' :- t) = do 115 | guard (p x') 116 | return t 117 | 118 | -- | When converting from left to right, push the default value on top of the stack. When converting from right to left, pop the value and discard it. 119 | ignoreWithDefault :: a -> Iso t (a :- t) 120 | ignoreWithDefault = matchWithDefault (const True) 121 | -------------------------------------------------------------------------------- /Language/JsonGrammar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE NoMonoPatBinds #-} 6 | 7 | module Language.JsonGrammar ( 8 | -- * Constructing JSON grammars 9 | liftAeson, option, greedyOption, list, elementBy, array, 10 | propBy, rawFixedProp, rest, ignoreRest, object, 11 | 12 | -- * Type-directed conversion 13 | Json(..), fromJson, toJson, litJson, prop, fixedProp, element 14 | 15 | ) where 16 | 17 | import Prelude hiding (id, (.), head, maybe, either) 18 | 19 | import Data.Aeson hiding (object) 20 | import Data.Aeson.Types (parseMaybe) 21 | import Data.Attoparsec.Number 22 | import Data.Hashable (Hashable) 23 | import Data.Int 24 | import Data.IntSet (IntSet) 25 | import Data.Iso hiding (option) 26 | import qualified Data.HashMap.Lazy as M 27 | import Data.Maybe (fromMaybe, isNothing) 28 | import Data.String 29 | import Data.Text (Text) 30 | import qualified Data.Text.Lazy as Lazy 31 | import Data.Time.Clock 32 | import qualified Data.Vector as V 33 | import qualified Data.Vector.Generic as VG 34 | import qualified Data.Vector.Fusion.Stream as VS 35 | import Data.Word 36 | 37 | import Control.Category 38 | import Control.Monad 39 | 40 | 41 | aeObject :: Iso (Object :- t) (Value :- t) 42 | aeArray :: Iso (Array :- t) (Value :- t) 43 | aeNull :: Iso t (Value :- t) 44 | (aeObject, aeArray, _, _, _, aeNull) = $(deriveIsos ''Value) 45 | 46 | -- | Convert any Aeson-enabled type to a grammar. 47 | liftAeson :: (FromJSON a, ToJSON a) => Iso (Value :- t) (a :- t) 48 | liftAeson = stack (Iso from to) 49 | where 50 | from = parseMaybe parseJSON 51 | to = Just . toJSON 52 | 53 | -- | Introduce 'Null' as possible value. First gives the argument grammar a 54 | -- chance, only yielding 'Null' or 'Nothing' if the argument grammar fails to 55 | -- handle the input. 56 | option :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t) 57 | option g = just . g <> nothing . inverse aeNull 58 | 59 | -- | Introduce 'Null' as possible (greedy) value. Always converts 'Nothing' to 60 | -- 'Null' and vice versa, even if the argument grammar knows how to handle 61 | -- these values. 62 | greedyOption :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t) 63 | greedyOption g = nothing . inverse aeNull <> just . g 64 | 65 | -- | Convert between a JSON array and Haskell list of arbitrary lengts. The 66 | -- elements are converted using the argument grammar. 67 | list :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) ([a] :- t) 68 | list g = duck nil >>> array (many single) 69 | where 70 | -- With ScopedTypeVariables: 71 | -- single :: Iso ([Value] :- [a] :- t) ([Value] :- [a] :- t) 72 | single = swap -- [a] :- [Value] :- t 73 | >>> duck (elementBy g) -- [a] :- [Value] :- a :- t 74 | >>> swap -- [Value] :- [a] :- a :- t 75 | >>> duck swap -- [Value] :- a :- [a] :- t 76 | >>> duck cons -- [Value] :- [a] :- t 77 | 78 | -- | Wrap a bunch of elements in a JSON array. For example, to match an array of exactly length two: 79 | -- 80 | -- > array (element . element) 81 | -- 82 | -- Or to match an empty array: 83 | -- 84 | -- > array id 85 | array :: Iso ([Value] :- t1) ([Value] :- t2) -> Iso (Value :- t1) t2 86 | array els = inverse aeArray -- Vector Value :- t1 87 | >>> vectorReverseList -- [Value] :- t1 88 | >>> els -- [Value] :- t2 89 | >>> inverse nil -- t2 90 | 91 | -- | Describe a single array element with the given grammar. 92 | elementBy :: Iso (Value :- t1) t2 -> Iso ([Value] :- t1) ([Value] :- t2) 93 | elementBy g = inverse cons -- Value :- [Value] :- t 94 | >>> swap -- [Value] :- Value :- t 95 | >>> duck g -- [Value] :- a :- t 96 | 97 | vectorReverseList :: Iso (V.Vector a :- t) ([a] :- t) 98 | vectorReverseList = stack (Iso f g) 99 | where 100 | f = Just . VS.toList . VG.streamR 101 | g = Just . VG.unstreamR . VS.fromList 102 | 103 | 104 | -- | Describe a property with the given name and value grammar. 105 | propBy :: Iso (Value :- t) (a :- t) -> String -> Iso (Object :- t) (Object :- a :- t) 106 | propBy g name = duck g . rawProp name 107 | 108 | rawProp :: String -> Iso (Object :- t) (Object :- Value :- t) 109 | rawProp name = Iso from to 110 | where 111 | textName = fromString name 112 | from (o :- r) = do 113 | value <- M.lookup textName o 114 | return (M.delete textName o :- value :- r) 115 | to (o :- value :- r) = do 116 | guard (notMember textName o) 117 | return (M.insert textName value o :- r) 118 | 119 | -- | Expect a specific key/value pair. 120 | rawFixedProp :: String -> Value -> Iso (Object :- t) (Object :- t) 121 | rawFixedProp name value = stack (Iso from to) 122 | where 123 | textName = fromString name 124 | from o = do 125 | value' <- M.lookup textName o 126 | guard (value' == value) 127 | return (M.delete textName o) 128 | to o = do 129 | guard (notMember textName o) 130 | return (M.insert textName value o) 131 | 132 | -- Defined in Data.Map but not in Data.HashMap.Lazy: 133 | notMember :: (Eq k, Hashable k) => k -> M.HashMap k v -> Bool 134 | notMember k m = isNothing (M.lookup k m) 135 | 136 | -- | Collect all properties left in an object. 137 | rest :: Iso (Object :- t) (Object :- M.HashMap Text Value :- t) 138 | rest = lit M.empty 139 | 140 | -- | Match and discard all properties left in the object. When converting back to JSON, produces no properties. 141 | ignoreRest :: Iso (Object :- t) (Object :- t) 142 | ignoreRest = lit M.empty . inverse (ignoreWithDefault M.empty) 143 | 144 | -- | Wrap an exhaustive bunch of properties in an object. Typical usage: 145 | -- 146 | -- > object (prop "key1" . prop "key2") 147 | object :: Iso (Object :- t1) (Object :- t2) -> Iso (Value :- t1) t2 148 | object props = inverse aeObject >>> props >>> inverseLit M.empty 149 | 150 | 151 | -- Type-directed conversion 152 | 153 | -- | Convert values of a type to and from JSON. 154 | class Json a where 155 | grammar :: Iso (Value :- t) (a :- t) 156 | 157 | instance Json a => Json [a] where 158 | grammar = list grammar 159 | 160 | instance Json a => Json (Maybe a) where 161 | grammar = option grammar 162 | 163 | instance (Json a, Json b) => Json (Either a b) where 164 | grammar = either grammar grammar 165 | 166 | 167 | instance Json Bool where grammar = liftAeson 168 | instance Json Char where grammar = liftAeson 169 | instance Json Double where grammar = liftAeson 170 | instance Json Float where grammar = liftAeson 171 | instance Json Int where grammar = liftAeson 172 | instance Json Int8 where grammar = liftAeson 173 | instance Json Int16 where grammar = liftAeson 174 | instance Json Int32 where grammar = liftAeson 175 | instance Json Int64 where grammar = liftAeson 176 | instance Json Integer where grammar = liftAeson 177 | instance Json Word where grammar = liftAeson 178 | instance Json Word8 where grammar = liftAeson 179 | instance Json Word16 where grammar = liftAeson 180 | instance Json Word32 where grammar = liftAeson 181 | instance Json Word64 where grammar = liftAeson 182 | instance Json () where grammar = liftAeson 183 | instance Json Number where grammar = liftAeson 184 | instance Json Text where grammar = liftAeson 185 | instance Json Lazy.Text where grammar = liftAeson 186 | instance Json IntSet where grammar = liftAeson 187 | instance Json UTCTime where grammar = liftAeson 188 | instance Json DotNetTime where grammar = liftAeson 189 | instance Json Value where grammar = id 190 | instance Json [Char] where grammar = liftAeson 191 | 192 | unsafeToJson :: Json a => String -> a -> Value 193 | unsafeToJson context value = 194 | fromMaybe err (convert (inverse (unstack grammar)) value) 195 | where 196 | err = error (context ++ 197 | ": could not convert Haskell value to JSON value") 198 | 199 | -- | Convert from JSON. 200 | fromJson :: Json a => Value -> Maybe a 201 | fromJson = convert (unstack grammar) 202 | 203 | -- | Convert to JSON. 204 | toJson :: Json a => a -> Maybe Value 205 | toJson = convert (inverse (unstack grammar)) 206 | 207 | -- | Expect/produce a specific JSON 'Value'. 208 | litJson :: Json a => a -> Iso (Value :- t) t 209 | litJson = inverseLit . unsafeToJson "litJson" 210 | 211 | -- | Describe a property whose value grammar is described by a 'Json' instance. 212 | prop :: Json a => String -> Iso (Object :- t) (Object :- a :- t) 213 | prop = propBy grammar 214 | 215 | -- | Expect a specific key/value pair. 216 | fixedProp :: Json a => String -> a -> Iso (Object :- t) (Object :- t) 217 | fixedProp name value = rawFixedProp name (unsafeToJson "fixedProp" value) 218 | 219 | -- | Describe a single array element whose grammar is given by a 'Json' 220 | -- instance. 221 | element :: Json a => Iso ([Value] :- t) ([Value] :- a :- t) 222 | element = elementBy grammar 223 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Introducing JsonGrammar 2 | 3 | JsonGrammar is a Haskell library for converting between Haskell datatypes and 4 | [JSON](http://en.wikipedia.org/wiki/JSON) ASTs. See the [API documentation on 5 | Hackage](http://hackage.haskell.org/package/JsonGrammar). 6 | 7 | *"What, another JSON library? Don't we have enough already?"* 8 | 9 | It's true that there are already a few JSON libraries out there. These 10 | libraries, however, require you to write `fromJson` and `toJson` separately. 11 | 12 | *"Uhm, yes... is that bad?"* 13 | 14 | Yes. It violates the [DRY 15 | principle](http://en.wikipedia.org/wiki/Don%27t_repeat_yourself). If I show 16 | you an implementation of `fromJson` for a certain type, you can write a 17 | corresponding `toJson` without requiring any further information. Similarly, 18 | if I show you an implementation of `toJson`, you can write the accompanying 19 | `fromJson`. Writing down the same thing twice is tedious and opens up the 20 | possibility to make mistakes. 21 | 22 | *"But most of these libraries offer Template Haskell support that does this 23 | work for you!""* 24 | 25 | This is true, but they also make all the choices for you about how your 26 | datatypes should map to JSON. Usually they assume the names of your record 27 | fields map directly to JSON property names. The shapes of your family of 28 | datatypes need to correspond to how the objects in JSON are nested. These 29 | libraries give you the choice: either you write out `fromJson` and `toJson` by 30 | hand and have full control over the mapping, or you give up this control and 31 | let Template Haskell do all the work for you. 32 | 33 | JsonGrammar gives you the best of both worlds: it gives you full control over 34 | what the mapping should be, with an API that lets you define `fromJson` and 35 | `toJson` at the same time. It achieves this by separating the 36 | constructing/destructing of datatype constructors and its fields from the 37 | description of the JSON values. The former is derived by Template Haskell, the 38 | latter is provided by the programmer. 39 | 40 | ## Design principles 41 | 42 | * Write JSON *grammars* that specify bidirectional conversion between JSON and Haskell datatypes 43 | * Grammars are succinct yet flexible 44 | * Adapt to existing JSON formats 45 | * Adapt to existing Haskell datatypes 46 | * Highly modular 47 | 48 | ## An example 49 | 50 | Suppose we have these two datatypes describing people and their current 51 | location: 52 | 53 | ``` 54 | data Person = Person 55 | { name :: String 56 | , gender :: Gender 57 | , age :: Int 58 | , lat :: Float 59 | , lng :: Float 60 | } 61 | 62 | data Gender = Male | Female 63 | ``` 64 | 65 | Sadly, the JSON source we are communicating with is using JSON with Dutch 66 | property names and values, so we cannot use Template Haskell to derive the 67 | JSON mapping for us, like we would do with other JSON libraries. Neither do we 68 | want to use Dutch names for our record selectors; nobody would be able to 69 | understand our code anymore! Fortunately this isn't a problem with 70 | JsonGrammar. 71 | 72 | The first step is to have Template Haskell derive the constructor-destructor 73 | pairs: 74 | 75 | ``` 76 | person = $(deriveIsos ''Person) 77 | (male, female) = $(deriveIsos ''Gender) 78 | ``` 79 | 80 | Then we write instances of the `Json` type class to define the mapping from/to 81 | Json. The order in which the properties are listed matches that of the fields 82 | in the datatype: 83 | 84 | 
 85 | instance Json Person where
 86 |   grammar = person . object
 87 |     ( prop "naam"
 88 |     . prop "geslacht"
 89 |     . prop "leeftijd"
 90 |     . prop "lat"
 91 |     . prop "lng"
 92 |     )
 93 | 
 94 | instance Json Gender where
 95 |   grammar =  male   . litJson "man"
 96 |           <> female . litJson "vrouw"
 97 |
98 | 99 | The `.` operator is from `Control.Category`. The `<>` is just another name for 100 | `mappend` from `Data.Monoid` and denotes choice. 101 | 102 | That's all! We have just defined both `fromJson` and `toJson` in one simple 103 | definition. Here's how you can use these grammars: 104 | 105 | ``` 106 | > let anna = Person "Anna" Female 36 53.0163038 5.1993053 107 | > let Just annaJson = toJson anna annaJson 108 | Object (fromList [("geslacht",String "vrouw"),("lat",Number 109 | 53.01630401611328),("leeftijd",Number 36),("lng",Number 110 | 5.199305534362793),("naam",String "Anna")]) 111 | > fromJson annaJson :: Maybe Person 112 | Just (Person {name = "Anna", gender = Female, age = 36, lat = 53.016304, 113 | lng = 5.1993055}) 114 | ```````````````````````````````````````````````````````````````````````` 115 | 116 | ## Show me the types! 117 | 118 | The library is based on *partial isomorphisms*: 119 | 120 | ``` 121 | data Iso a b = Iso (a -> Maybe b) (b -> Maybe a) 122 | 123 | instance Category Iso 124 | instance Monoid (Iso a b) 125 | ``` 126 | 127 | A value of type `Iso a b` gives you a function that converts an `a` into a 128 | `Maybe b`, and a function that converts a `b` into a `Maybe a`. This composes 129 | beautifully as a `Category`. The `Monoid` instance denotes choice: first try 130 | the left-hand conversion function, and if it fails, try the right-hand side. 131 | 132 | A JSON `grammar` for some type `a` is nothing more than a value of type `Iso 133 | Value a`, where `Value` is the type of a JSON AST from the 134 | [aeson](http://hackage.haskell.org/package/aeson) package. That is, it's a 135 | pair of conversion functions between JSON trees and your own datatype. 136 | Building JSON grammars like the one above is about composing isomorphisms that 137 | translate between intermediate types. 138 | 139 | The isomorphisms `person`, `male` and `female` translate between constructors and their individual fields. For example: 140 | 141 | ``` 142 | person :: Iso (String, Gender, Int, Float, Float) Person 143 | ``` 144 | 145 | Converting from a constructor to its fields might fail, because the value that 146 | is passed to the conversion function might be a different constructor of the 147 | same datatype. This is why the `Monoid` instance is so useful: we can give 148 | multiple grammars, usually one for each constructor, and they will be tried in 149 | sequence. They are effectively *composable pattern matches*. 150 | 151 | ## Stack isomorphisms 152 | 153 | There is a problem with encoding the fields of such a constructor as an 154 | n-tuple: if we want to compose it with other isomorphisms that handle the 155 | individual fields, we have to use complicated tuple projections to select the 156 | fields that we're interested in. Basically we have unwrapped the fields from 157 | one constructor only to wrap them in another one! 158 | 159 | The solution is to use heterogenous stacks of values. They are reminiscent of 160 | continuation-passing style, because in the way we use them they usually have a 161 | polymorphic tail: 162 | 163 | ``` 164 | person :: Iso (String :- Gender :- Int :- Float :- Float :- t) (Person :- t) 165 | ``` 166 | 167 | Read `:-` as 'cons', but then for types instead of values. Its definition is simple: 168 | 169 | ``` 170 | data h :- t = h :- t 171 | ``` 172 | 173 | The polymorphic tail says that `person` doesn't care what's on the stack below 174 | the two `Floats`; it will simply pass that part of the stack on to the 175 | right-hand side. And vice versa, if we're working with the isomorphism in the 176 | opposite direction. 177 | 178 | Have you thought about what the types of `male` and `female` would be in the 179 | non-stack versions of the isomorphisms? They don't have any fields; we would 180 | have to leave the first type parameter of `Iso` empty somehow, for example by 181 | choosing `()`. Stack isomorphisms have no such problem; we simply make the 182 | first type argument the polymorphic tail on its own, without any values on 183 | top: 184 | 185 | ``` 186 | male :: Iso t (Gender :- t) 187 | female :: Iso t (Gender :- t) 188 | ``` 189 | 190 | Stack isomorphisms compose beautifully using `.`, often without needing any 191 | special projection functions. To get a feeling for it, try compiling the 192 | example Json grammars and looking at the types of the individual components. 193 | 194 | I lied when I wrote that grammars have type `Iso Value a`; they actually use 195 | stacks themselves, too. Here is the true definition of the `Json` type class: 196 | 197 | ``` 198 | class Json a where 199 | grammar :: Iso (Value :- t) (a :- t) 200 | ``` 201 | 202 | ## Different tree shapes 203 | 204 | Let's take our Person example and make a small modification. We decide that 205 | because (lat, lng)-pairs are so common together, we'd like to put them 206 | together in their own datatype: 207 | 208 | ``` 209 | data Coords = Coords { lat :: Float, lng :: Float } 210 | deriving (Eq, Show) 211 | 212 | data Person = Person 213 | { name :: String 214 | , gender :: Gender 215 | , age :: Int 216 | , location :: Coords 217 | } deriving (Eq, Show) 218 | ``` 219 | 220 | However, in this example we have no control over the JSON format and cannot 221 | change it to match our new structure. With JsonGrammar we can express mappings 222 | where the nesting is not one-to-one: 223 | 224 | ``` 225 | instance Json Person where 226 | grammar = person . object 227 | ( prop "naam" 228 | . prop "geslacht" 229 | . prop "leeftijd" 230 | . coordsProps 231 | ) 232 | 233 | coordsProps :: Iso (Object :- t) (Object :- Coords :- t) 234 | coordsProps = duck coords . prop "lat" . prop "lng" 235 | ``` 236 | 237 | Here `duck coords` wraps (or unwraps, depending on the direction) the two 238 | matched `Float` properties in their own `Coords` constructor before continuing 239 | matching the other properties in an object. Function `duck` is a combinator 240 | that makes a grammar (`coords` in this case) work one element down the stack. 241 | Here it makes sure the top values can remain `Object`s, which is needed by 242 | `prop` to build/destruct JSON objects one property at a time. 243 | 244 | What is important to note here is that not only can we express mappings with 245 | different nestings, we can also capture this behaviour in its own grammar for 246 | reuse. JsonGrammar allows this level of modularity in everything it does. 247 | 248 | ## History and related work 249 | 250 | The ideas behind JsonGrammar go back a bit. They are based on 251 | [Zwaluw](https://github.com/MedeaMelana/Zwaluw), a library that Sjoerd 252 | Visscher and I worked on. The library aids in writing bidirectional 253 | parsers/pretty-printers for type-safe URLs, also in a DRY manner. Zwaluw, too, 254 | uses stacks to achieve a high level of modularity. In turn, Zwaluw was 255 | inspired by [HoleyMonoid](http://hackage.haskell.org/package/HoleyMonoid), 256 | which shows that the CPS-like manner of using polymorphic stack tails allows 257 | combinators to build up a list of expected arguments for use in printf-like 258 | functionality. 259 | 260 | The `Iso` datatype comes from 261 | [partial-isomorphisms](http://hackage.haskell.org/package/partial-isomorphisms) 262 | and is described in more detail in [Invertible syntax descriptions: Unifying 263 | parsing and pretty 264 | printing](http://www.informatik.uni-marburg.de/~rendel/unparse/) by Tillmann 265 | Rendel and Klaus Ostermann. They also use stacks (in the form of nested binary 266 | tuples), but they are not using the trick with the polymorphic tail (yet?). 267 | 268 | ## Future work 269 | 270 | Although JsonGrammar is usable, there is still work to be done: 271 | 272 | * **Supporting new use cases**. JsonGrammar has not been used in the wild much yet. If you find any use cases that the library currently does not support, please let me know! 273 | * **Benchmarking**. No performance testing or memory usage profiling has been done yet. 274 | * **Improved error messages**. The `Maybe` return values indicate whenever conversion has failed, but never *how* it has failed. The `aeson` package gives nice error message when for example an expected property was not found. Such error reporting still has to be added to JsonGrammar. 275 | * **Other experiments**. Perhaps a library can be written on top of JsonGrammar that allows grammars to be specified that also compile to JSON Schema. Or maybe grammars could compile to specialized JSON parsers, improving efficiency. 276 | 277 | If you have any questions, comments, ideas or bug reports, feel to leave a 278 | comment or [open a ticket on 279 | GitHub](https://github.com/MedeaMelana/JsonGrammar/issues/new). 280 | --------------------------------------------------------------------------------