json2 0.3.1 → 0.8
raw patch · 14 files changed
+1155/−720 lines, 14 filesdep +blaze-builderdep +bytestringdep +json2-types
Dependencies added: blaze-builder, bytestring, json2-types, mtl, parsec, pretty, utf8-string
Files
- Data/JSON2.hs +0/−296
- Data/JSON2/FromSQL.hs +0/−79
- Data/JSON2/Query.hs +0/−247
- Examples/ExampleQuery.hs +0/−42
- Examples/ExampleSqlite.hs +0/−44
- examples/ExampleQuery.hs +42/−0
- json2.cabal +24/−12
- src/Data/JSON2.hs +409/−0
- src/Data/JSON2/Blaze.hs +60/−0
- src/Data/JSON2/Instances/Time.hs +165/−0
- src/Data/JSON2/Internal.hs +87/−0
- src/Data/JSON2/Parser.hs +102/−0
- src/Data/JSON2/Pretty.hs +81/−0
- src/Data/JSON2/Query.hs +185/−0
− Data/JSON2.hs
@@ -1,296 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Data.JSON2- (- -- * Data types and classes- Json(..), Jsons,- ToJson(..), FromJson(..),- -- * Building JSON objects- emptyObj, (==>), fromList,- -- * Union JSON objects- unionObj, unionsObj, unionRecObj,- -- * Rendering to string- toString,- -- * Debug print- pprint, pprints,- -- * Deprecated- singleObj- ) -where--import Data.List-import qualified Data.Map as Map-import Data.Ratio-import Data.Typeable (Typeable)-import Data.Time.Clock (UTCTime)-import Data.Time.Format (formatTime, parseTime)-import System.Locale (defaultTimeLocale)---infixr 6 ==>---- * Data types and classes--data Json = JString String- | JNumber Rational- | JBool !Bool- | JNull- | JArray [Json]- | JObject (Map.Map String Json) deriving (Eq, Ord, Typeable, Show, Read)--type Jsons = [Json]---- | This module provides instances @ToJson@ for :--- @(), Char, Json, Maybe, Either, Bool, String, Integr, Int, Double, Float,--- UTCTime format: UTC YYYY-MM-DD HH:MM:SS , Map String a, List, tuples 2-5 sizes@ .------ Examples :------ > getCurrentTime >>= print . toJson == JString "2011-01-29 12:12:39 UTC"--- >--- > table :: [(Int, Maybe String, Bool)]--- > table = [--- > (1, Just "One", False),--- > (2, Nothing, True)--- > ]--- > jTable = toJson table--- > pprint jTable--- > [[1, "One", false], [2, null, true]]-class ToJson a where- toJson :: a -> Json---- | This module provides instances @FromJson@ for :--- @Json, Maybe, Bool, String, Integr, Int, Double, Float,--- Maybe UTCTime ,Map String a, List, tuples 2-5 sizes@ .------ Example :------ > fromJson jTable :: [(Double, Maybe String, Bool)]--- > [(1.0, Just "One", False), (2.0, Nothing, True)]-class FromJson a where- fromJson :: Json -> a---- ** Instances FromJson and ToJson----instance ToJson UTCTime where- toJson ut = JString $ formatTime defaultTimeLocale templateUTC ut-instance FromJson (Maybe UTCTime) where- fromJson (JString t) = parseTime defaultTimeLocale templateUTC t :: Maybe UTCTime-templateUTC = "%Y-%m-%d %T UTC"--instance ToJson () where- toJson () = JArray []--instance ToJson Char where- toJson x = JString [x]--instance ToJson Json where- toJson = id-instance FromJson Json where- fromJson = id--instance ToJson a => ToJson (Maybe a) where- toJson = maybe JNull toJson-instance FromJson a => FromJson (Maybe a) where- fromJson x = if x == JNull then Nothing else Just (fromJson x)--instance (ToJson a, ToJson b) => ToJson (Either a b) where- toJson (Left a) = toJson a- toJson (Right b) = toJson b--instance ToJson Bool where- toJson x = JBool x-instance FromJson Bool where- fromJson (JBool x) = x--instance ToJson String where- toJson x = JString x-instance FromJson String where- fromJson (JString x) = x--instance ToJson Integer where- toJson = jsonifyIntegral-instance FromJson Integer where- fromJson (JNumber i) = round i--instance ToJson Int where- toJson = jsonifyIntegral-instance FromJson Int where- fromJson (JNumber i) = round i--instance ToJson Double where- toJson = jsonifyRealFrac-instance FromJson Double where- fromJson (JNumber i) = fromRational i--instance ToJson Float where- toJson = jsonifyRealFrac-instance FromJson Float where- fromJson (JNumber i) = fromRational i--instance (ToJson a) => ToJson (Map.Map String a) where- toJson = JObject . Map.map toJson-instance (FromJson a) => FromJson (Map.Map String a) where- fromJson (JObject m) = Map.map fromJson m---instance (ToJson a) => ToJson [a] where- toJson = JArray . map toJson-instance (FromJson a) => FromJson [a] where- fromJson (JArray xs) = map fromJson xs--instance (ToJson t1, ToJson t2) => ToJson (t1, t2) where- toJson (x1, x2) = JArray [toJson x1, toJson x2]-instance (FromJson t1, FromJson t2) => FromJson (t1, t2) where- fromJson (JArray [x, y]) = (fromJson x, fromJson y)---instance (ToJson t1, ToJson t2, ToJson t3) => ToJson (t1, t2, t3) where- toJson (x1, x2, x3) = JArray [toJson x1, toJson x2, toJson x3]-instance (FromJson t1, FromJson t2, FromJson t3) => FromJson (t1, t2, t3) where- fromJson (JArray [x1, x2, x3]) = (fromJson x1, fromJson x2, fromJson x3)--instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4) => ToJson (t1, t2, t3, t4) where- toJson (x1, x2, x3, x4) = JArray [toJson x1, toJson x2, toJson x3, toJson x4]-instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4) => FromJson (t1, t2, t3, t4) where- fromJson (JArray [x1, x2, x3, x4]) = (fromJson x1, fromJson x2, fromJson x3, fromJson x4)--instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4, ToJson t5) => ToJson (t1, t2, t3, t4, t5) where- toJson (x1, x2, x3, x4, x5) = JArray [toJson x1, toJson x2, toJson x3, toJson x4, toJson x5]-instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4, FromJson t5) => FromJson (t1, t2, t3, t4, t5) where- fromJson (JArray [x1, x2, x3, x4, x5]) = (fromJson x1, fromJson x2, fromJson x3, fromJson x4, fromJson x5)----- * Building JSON objects---- | Create empty JSON object.-emptyObj :: Json-emptyObj = JObject (Map.empty)---- | DEPRECATED see @(`==>`)@.-singleObj :: ToJson a => String -> a -> Json-singleObj k v = JObject (Map.singleton k (toJson v))---- | @(`==>`)@ Eq @`singleObj`@ .-(==>) :: ToJson a => String -> a -> Json-(==>) = singleObj---- | Create JSON object from list.-fromList :: ToJson a => [(String, a)] -> Json-fromList xs = JObject $ Map.fromList (map (\(k,v) -> (k, toJson v)) xs)---- * Union JSON objects---- | Merge two JSON Objects.------ Example:------ > objA = fromList [("a", toJson "1"), ("r", fromList [("ra", "11"), ("rb", "12")])]--- > pprint objA--- > {--- > "a": "1",--- > "r": {--- > "ra": "11",--- > "rb": "12"--- > }--- > }--- > objB = fromList [("b", toJson "2"), ("r", fromList [("rb", "13"), ("rc", "14")])]--- > pprint objB--- > {--- > "b": "2",--- > "r": {--- > "rb": "13",--- > "rc": "14"--- > }--- > }--- > pprint $ objA `unionObj` objB--- > {--- > "a": "1",--- > "b": "2",--- > "r": {--- > "ra": "11",--- > "rb": "12"--- > }--- > }--- > -unionObj :: Json -> Json -> Json-unionObj (JObject x ) (JObject y) = JObject $ Map.union x y-unionObj x _ = x---- | Merge JSON objects from list.-unionsObj :: [Json] -> Json-unionsObj xs = foldl unionObj emptyObj xs---- | Recursive merge two JSON Objects.------ Example :------ > objR = objA `unionRecObj` objB--- > pprint objR--- > {--- > "a": "1",--- > "b": "2",--- > "r": {--- > "ra": "11",--- > "rb": "12",--- > "rc": "14"--- > }--- > }--unionRecObj :: Json -> Json -> Json-unionRecObj (JObject x) (JObject y) = JObject $- Map.unionWith (\v1 v2 -> unionRecObj v1 v2) x y-unionRecObj x _ = x---- * Renders JSON to String---- | Renders JSON to String.-toString :: Json -> String-toString (JNumber r) - | denominator r == 1 = show (numerator r)- | otherwise = show (fromRational r :: Double)-toString (JBool True) = "true"-toString (JBool False) = "false"-toString JNull = "null"-toString (JString s) = "\"" ++ escJStr s ++ "\""-toString (JArray vs) = "[" ++ (intercalate ", " $ map (toString) vs) ++ "]"-toString (JObject l) = "{" ++ (intercalate ", " $ map (\(k, v) -> toString (JString k) ++ ": " ++ toString v) (Map.toList l)) ++ "}"---- * Debug print---- | Pretty-prints JSON.-pprint :: Json -> IO ()-pprint j = putStrLn $ pprint' " " 0 j--pprint' :: String -> Integer -> Json -> String--pprint' indenter levels (JArray xs) = "[" ++ (intercalate ", " $ map (pprint' indenter levels) xs) ++ "]"--pprint' indenter levels (JObject mp) = let- currentIndent = (concat (genericReplicate levels indenter))- in intercalate "\n" $ ["{", intercalate ",\n" (map (((currentIndent ++ indenter) ++) . (\(key, value) -> pprint' indenter levels (JString key) ++ ": " ++ pprint' indenter (levels + 1) value)) $ Map.toList mp), currentIndent ++ "}"]-pprint' _ _ a = toString a---- | Pretty-prints JSONs.-pprints :: [Json] -> IO ()-pprints js = putStrLn $- "[\n " ++ ( intercalate "," $ map (\j -> (pprint' " " 1 ) j) js) ++ "\n]"--------------- private functions ------------------------------------------------jsonifyRealFrac i = JNumber (approxRational i 1e-666)-jsonifyIntegral i = JNumber (fromIntegral i % 1)--escJStr :: String -> String-escJStr = concat . map (escJChar)--escJChar c = case c of- '\n' -> "\\n"- '\b' -> "\\b"- '\f' -> "\\f"- '\t' -> "\\t"- '\r' -> "\\r"- '\\' -> "\\\\"- '\"' -> "\\\""- _ -> [c]
− Data/JSON2/FromSQL.hs
@@ -1,79 +0,0 @@-module Data.JSON2.FromSQL where-import Data.JSON2-import qualified Data.Map as Map---- | Conversion SQL-like JSON array to tree-like JSON object with use column.-groupWithCol :: Json -> Json-groupWithCol (JArray xs) = merges $ map objHT xs where- merges xs = foldl merge emptyObj xs- merge (JObject x) (JObject y) = JObject $ Map.unionWith (jConcat) x y- jConcat(JArray xs) (JArray ys) = JArray (xs ++ ys)- objHT (JArray ((JString x):xs)) = singleObj x [xs]- objHT (JArray (x:xs)) = singleObj (toString x) [xs]- objHT _ = emptyObj-groupWithCol _ = emptyObj---- | Conversion SQL-like JSON array to tree-like JSON object with use columns.------ COMPLEX EXAMPLE :------ > import Database.HDBC--- > import Database.HDBC.Sqlite3--- > import Data.JSON2--- > --- > dbName = "..."--- > selectSql = "SELECT * from test"--- > --- > main = do--- > conn <- connectSqlite3 dbName--- > stmtSel <- prepare conn selectSql--- > execute stmtSel []--- > q <- sFetchAllRows stmtSel--- > mapM print q--- > -- [Just "A",Just "1",Just "Pupkin",Just "1"]--- > -- [Just "A",Just "2",Just "Sidorov",Just "2"]--- > -- [Just "B",Just "22",Just "Petrov",Just "3"]--- > -- [Just "B",Just "22",Just "Ivanov",Just "4"]--- > -- [Just "B",Just "22",Just "Golubev",Just "5"]--- > -- [Just "B",Just "33",Just "Petrov",Just "6"]--- > let json = toJson (q :: [[Maybe String]])--- > pprint json--- > -- [--- > -- ["A", "1", "Pupkin", "1"],--- > -- ["A", "2", "Sidorov", "2"],--- > -- ["B", "22", "Petrov", "3"],--- > -- ["B", "22", "Ivanov", "4"],--- > -- ["B", "22", "Golubev", "5"],--- > -- ["B", "33", "Petrov", "6"]--- > -- ]--- > let json' = groupWithNCol 2 json--- > pprint json'--- > -- {--- > -- "A": {--- > -- "1": [["Pupkin", "1"]],--- > -- "2": [["Sidorov", "2"]]--- > -- },--- > -- "B": {--- > -- "22": [["Petrov", "3"], ["Ivanov", "4"], ["Golubev", "5"]],--- > -- "33": [["Petrov", "6"]]--- > -- }--- > -- }--- > disconnect conn--groupWithNCol :: Int -> Json -> Json-groupWithNCol n j | n > 0 = mapj (n - 1) (groupWithCol j) - | otherwise = j- where- mapj n j@(JObject xs)- | n > 0 = JObject ( Map.map ((mapj (n-1)) . groupWithCol) xs)- | otherwise = j -{--j0 = toJson ["a"]-j1 = toJson ["a", "aa", "aaa"]-j2 = toJson ["a", "ab", "abb"]-j3 = toJson ["a", "aa"]-j4 = toJson ["b", "bb", "bbb"]-j5 = toJson ["c", "87319827"]-j6 = toJson ["a", "ab", "abb"]-j7 = toJson ["a", "ab", "abb"]--}
− Data/JSON2/Query.hs
@@ -1,247 +0,0 @@--- | See also: <http://www.haskell.org/haskellwiki/HXT#The_concept_of_filters>-module Data.JSON2.Query-(--- * Data Types- JFilter--- * Filtering- ,isObj, isArr- ,isStr ,isStrBy- ,isNum ,isNumBy- ,isBool, isTrue, isFalse- ,isNull,isAtomic- ,getFromObj, getFromKey, getFromKeys- ,getFromArr ,getFromIndex ,getFromIndexes- ,getChildern--- * Filter Combinators- ,(>>>) ,(<+>)- ,orElse ,when ,guards- ,deep, deepObj, deepArr-)-where-import qualified Data.Map as M (empty, singleton, unionWith, elems, union, lookup)-import qualified Data.Maybe as Mb (catMaybes)-import qualified Data.List as L (nub)-import Data.JSON2--type JFilter = Json -> Jsons--infixl 1 >>>-infixr 2 <+>---- Fitering---- | Filter JSON objects.-isObj :: JFilter-isObj (JObject o) = [JObject o]-isObj _ = []---- | Filter JSON arrays.-isArr :: JFilter-isArr (JArray a) = [JArray a]-isArr _ = []---- | Filter JSON strings.-isStr :: JFilter-isStr (JString s) = [JString s]-isStr _ = []---- | Predicative filter JSON strings.-isStrBy :: (String -> Bool) -> JFilter-isStrBy p (JString s) = if p s then [JString s] else []-isStrBy _ _ = []---- | Filter JSON numbers.-isNum :: JFilter-isNum (JNumber n) = [JNumber n]-isNum _ = []----- | Predicative filter JSON numbers.-isNumBy :: Fractional a => (a -> Bool) -> JFilter-isNumBy p (JNumber n) = if p (fromRational n) then [JNumber n] else []-isNumBy _ _ = []---- | Filter JSON Bool.-isBool :: JFilter-isBool (JBool p) = [JBool p]-isBool _ = []---- | Filter JSON True.-isTrue :: JFilter-isTrue (JBool True) = [JBool True]-isTrue _ = []---- | Filter JSON False.-isFalse :: JFilter-isFalse (JBool False) = [JBool False]-isFalse _ = []---- | Filter JSON null.-isNull :: JFilter-isNull JNull = [JNull]-isNull _ = []---- | Filter primitive types.-isAtomic :: JFilter-isAtomic (JString s) = [JString s]-isAtomic (JNumber n) = [JNumber n]-isAtomic (JBool p) = [JBool p]-isAtomic JNull = [JNull]-isAtomic _ = []----- | Get elements from object with key.-getFromKey :: String -> JFilter-getFromKey k (JObject m) = Mb.catMaybes [(M.lookup k m)]-getFromKey _ _ = []---- | Get elements from object with keys.--- --- Examles:------ > citys :: Jsons--- > citys =--- > [--- > "Europa" ==> "Ukraine" ==> ["Kiyv", "Gitomir", "Lviv"],--- > "Asia" ==> "Japan" ==> ["Tokyo"],--- > "Europa" ==> "UK" ==> ["London", "Glasgow"],--- > "Europa" ==> "Germany" ==> ["Berlin", "Bonn"],--- > "America" ==> "USA" ==> ["NewYork"],--- > "America" ==> "Canada" ==> ["Toronto"],--- > "Australia" ==> ["Melburn", "Adelaida"]--- > ]--- > jCitys = foldl unionRecObj emptyObj citys--- > ex1 = pprint jCitys--- > {--- > "America": {--- > "Canada": ["Toronto"],--- > "USA": ["NewYork"]--- > },--- > "Asia": {--- > "Japan": ["Tokyo"]--- > },--- > "Australia": ["Melburn", "Adelaida"],--- > "Europa": {--- > "Germany": ["Berlin", "Bonn"],--- > "UK": ["London", "Glasgow"],--- > "Ukraine": ["Kiyv", "Gitomir", "Lviv"]--- > }--- > }--- > query2 = getFromKeys ["Europa", "America", "Atlantida"]--- > ex2 = pprints $ query2 jCitys--- > [--- > {--- > "Germany": ["Berlin", "Bonn"],--- > "UK": ["London", "Glasgow"],--- > "Ukraine": ["Kiyv", "Gitomir", "Lviv"]--- > },{--- > "Canada": ["Toronto"],--- > "USA": ["NewYork"]--- > }--- > ]-getFromKeys :: [String] -> JFilter-getFromKeys ks (JObject m) = Mb.catMaybes $ map (\k -> (M.lookup k m)) (L.nub ks) -getFromKeys _ _ = []---- | Get all elements from object.-getFromObj :: JFilter-getFromObj (JObject o) = M.elems o-getFromObj _ = []---- | Get all elements from array.-getFromArr :: JFilter-getFromArr (JArray a) = a-getFromArr _ = []---- | Get element from array with index.-getFromIndex :: Int -> JFilter-getFromIndex i (JArray a) = if i < length a then [a !! i] else []-getFromIndex _ _ = []---- | Get elements from array with indexes.-getFromIndexes :: [Int] -> JFilter-getFromIndexes is ja = concat [getFromIndex i ja | i <- is]---- | Get all elements from object and array.-getChildern :: JFilter-getChildern (JObject o) = M.elems o-getChildern (JArray a) = a-getChildern _ = []---- Filter combinators---- | @(f >>> g)@ - Apply filter f, later filter g .------ Examples:------ > query3 = getFromKeys ["Europa", "America"] >>> getFromObj --- > ex3 = pprints $ query3 jCitys------ Result:------ > [--- > ["Berlin", "Bonn"],["London", "Glasgow"],["Kiyv", "Gitomir", "Lviv"],["Toronto"],["NewYork"]--- > ]-(>>>) :: JFilter -> JFilter -> JFilter -(f >>> g) t = concat [g t' | t' <- f t]---- | Concat results two filters.-(<+>) :: JFilter -> JFilter -> JFilter-(f <+> g) t = f t ++ g t---- | @(f `orElse` g)@ - Apply f, if @f@ returned @null@ apply @g@.-orElse :: JFilter -> JFilter -> JFilter-orElse f g t- | null res1 = g t- | otherwise = res1- where res1 = f t---- | @(f `when` g)@ - When @g@ returned @not null@, apply @f@.-when :: JFilter -> JFilter -> JFilter-when f g t- | null (g t) = [t]- | otherwise = f t- --- | @(f `guards` g )@ - If @f@ returned null then @null@ else apply @g@.-guards :: JFilter -> JFilter -> JFilter-guards f g t- | null (f t) = []- | otherwise = g t----- | Tree traversal filter for object and array.-deep :: JFilter -> JFilter-deep f = f `orElse` (getChildern >>> deep f)---- | Tree traversal filter for array.-deepObj :: JFilter -> JFilter-deepObj f = f `orElse` (getFromObj >>> deepObj f)---- | Tree traversal filter for array.------ Example:------ > -- Query: All city Europa and Australia.--- > -- query31, query32, query33 is equal.--- > --- > query31 = getFromKeys ["Europa", "Australia"] --- > >>> (getFromArr `orElse` getFromObj)--- > >>> (isStr `orElse` getFromArr)--- > ex31 = pprints $ query31 jCitys--- > --- > query32 = getFromKeys ["Europa", "Australia"] --- > >>> (getFromObj `when` isObj)--- > >>> getFromArr--- > ex32 = pprints $ query32 jCitys--- > --- > query33 = getFromKeys ["Europa", "Australia"] --- > >>> deep getFromArr--- > ex33 = pprints $ query33 jCitys------ Result:------ > [--- > "Berlin","Bonn","London","Glasgow","Kiyv","Gitomir","Lviv","Melburn","Adelaida"--- > ]-deepArr :: JFilter -> JFilter-deepArr f = f `orElse` (getFromArr >>> deepArr f)
− Examples/ExampleQuery.hs
@@ -1,42 +0,0 @@-module Main where-import Data.JSON2-import Data.JSON2.Query--citys :: Jsons-citys =- [- "Europa" ==> "Ukraine" ==> ["Kiyv", "Gitomir", "Lviv"],- "Asia" ==> "Japan" ==> ["Tokyo"],- "Europa" ==> "UK" ==> ["London", "Glasgow"],- "Europa" ==> "Germany" ==> ["Berlin", "Bonn"],- "America" ==> "USA" ==> ["NewYork"],- "America" ==> "Canada" ==> ["Toronto"],- "Australia" ==> ["Melburn", "Adelaida"]- ]-ex0 = pprints citys--jCitys = foldl unionRecObj emptyObj citys-ex1 = pprint jCitys--query2 = getFromKeys ["Europa", "America", "Atlantida"]-ex2 = pprints $ query2 jCitys--query3 = getFromKeys ["Europa", "America"] >>> getFromObj -ex3 = pprints $ query3 jCitys-- -- Query: All city Europa and Australia- -- query31, query32, query33 is equal- -query31 = getFromKeys ["Europa", "Australia"] - >>> (getFromArr `orElse` getFromObj)- >>> (isStr `orElse` getFromArr)-ex31 = pprints $ query31 jCitys--query32 = getFromKeys ["Europa", "Australia"] - >>> (getFromObj `when` isObj)- >>> getFromArr-ex32 = pprints $ query32 jCitys--query33 = getFromKeys ["Europa", "Australia"] - >>> deep getFromArr-ex33 = pprints $ query33 jCitys
− Examples/ExampleSqlite.hs
@@ -1,44 +0,0 @@-module Main where-import Database.HDBC-import Database.HDBC.Sqlite3-import Data.JSON2-import Data.JSON2.FromSQL--dbName = "Examples/test.db"-selectSql = "SELECT * from test"--main = do- conn <- connectSqlite3 dbName- stmtSel <- prepare conn selectSql- execute stmtSel []- q <- sFetchAllRows stmtSel- mapM print q- -- [Just "A",Just "1",Just "Pupkin",Just "1"]- -- [Just "A",Just "2",Just "Sidorov",Just "2"]- -- [Just "B",Just "22",Just "Petrov",Just "3"]- -- [Just "B",Just "22",Just "Ivanov",Just "4"]- -- [Just "B",Just "22",Just "Golubev",Just "5"]- -- [Just "B",Just "33",Just "Petrov",Just "6"]- let json = toJson (q :: [[Maybe String]])- pprint json- -- [- -- ["A", "1", "Pupkin", "1"],- -- ["A", "2", "Sidorov", "2"],- -- ["B", "22", "Petrov", "3"],- -- ["B", "22", "Ivanov", "4"],- -- ["B", "22", "Golubev", "5"],- -- ["B", "33", "Petrov", "6"]- -- ]- let json' = groupWithNCol 2 json- pprint json'- -- {- -- "A": {- -- "1": [["Pupkin", "1"]],- -- "2": [["Sidorov", "2"]]- -- },- -- "B": {- -- "22": [["Petrov", "3"], ["Ivanov", "4"], ["Golubev", "5"]],- -- "33": [["Petrov", "6"]]- -- }- -- }- disconnect conn
+ examples/ExampleQuery.hs view
@@ -0,0 +1,42 @@+module Main where+import Data.JSON2+import Data.JSON2.Query++citys :: Jsons+citys =+ [+ "Europa" .= "Ukraine" .= ["Kiyv", "Gitomir", "Lviv"],+ "Asia" .= "Japan" .= ["Tokyo"],+ "Europa" .= "UK" .= ["London", "Glasgow"],+ "Europa" .= "Germany" .= ["Berlin", "Bonn"],+ "America" .= "USA" .= ["NewYork"],+ "America" .= "Canada" .= ["Toronto"],+ "Australia" .= ["Melburn", "Adelaida"]+ ]+ex0 = pprint citys++jCitys = foldl mergeRec emptyObj citys+ex1 = pprint jCitys++query2 = getFromKeys ["Europa", "America", "Atlantida"]+ex2 = pprint $ query2 jCitys++query3 = getFromKeys ["Europa", "America"] >>> getFromObj +ex3 = pprint $ query3 jCitys++ -- Query: All city Europa and Australia+ -- query31, query32, query33 is equal+ +query31 = getFromKeys ["Europa", "Australia"] + >>> (getFromArr `orElse` getFromObj)+ >>> (isStr `orElse` getFromArr)+ex31 = pprint $ query31 jCitys++query32 = getFromKeys ["Europa", "Australia"] + >>> (getFromObj `when` isObj)+ >>> getFromArr+ex32 = pprint $ query32 jCitys++query33 = getFromKeys ["Europa", "Australia"] + >>> deep getFromArr+ex33 = pprint $ query33 jCitys
json2.cabal view
@@ -1,11 +1,11 @@ Name: json2-Version: 0.3.1-Synopsis: This library provides support for JSON. +Version: 0.8+Synopsis: Library provides support for JSON. Category: Data, Text, JSON Description: This library provides support for JSON. License: BSD3 License-file: LICENSE-Author: YuriyIskra <iskra.yw@gmail.com>+Author: YuriyIskra Maintainer: YuriyIskra <iskra.yw@gmail.com> Stability: Experimental Copyright: Copyright (c) 2011 Yuriy Iskra@@ -13,16 +13,28 @@ Cabal-version: >= 1.6 extra-source-files:- Examples/ExampleSqlite.hs- Examples/ExampleQuery.hs+ examples/ExampleQuery.hs library Exposed-modules:- Data.JSON2- Data.JSON2.FromSQL- Data.JSON2.Query+ Data.JSON2+ Data.JSON2.Pretty+ Data.JSON2.Parser+ Data.JSON2.Query+ Data.JSON2.Blaze+ Data.JSON2.Internal+ Data.JSON2.Instances.Time - Build-Depends: base >= 4 && < 5,- containers >= 0.2 && < 1,- old-locale >= 1,- time >= 1.1+ Build-Depends: base >= 4 && < 5,+ containers >= 0.2 && < 1,+ old-locale >= 1,+ time >= 1.1,+ mtl >= 2,+ utf8-string >= 0.3,+ bytestring >= 0.9,+ blaze-builder >= 0.2,+ parsec >= 2.0,+ pretty -any,+ json2-types -any++ hs-source-dirs: src
+ src/Data/JSON2.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+1. /Pretty prints/++Re-export module Data.JSON2.Pretty. Example of use:++@+ *ghci> pp $ mkObj [(show x, x) | x <- [0..7]]+ {"0": 0, "1": 1, "2": 2, "3": 3, "4": 4, "5": 5, "6": 6, "7": 7}+@++2. /Renders JSON to String/++Haskell value has a JSON string:++@+ HASKELL value JSON string (toString . toJson)+ ------------------------------- -----------------------------+ Just \"bla\" :: Maybe String \"bla\"+ Nothing :: Maybe String null+ Left 1 :: Either Int Int [[1], []]+ Right 1 :: Either Int Int [[], [1]]+ \'a\' :: Char 97+ () :: () []+ (1, \"bla\") :: (Int, String) [1, \"bla\"]+ fromList [1,2,3,4] :: Set Int [1, 2, 3, 4]+ fromList [(\"0\",0),(\"1\",10),(\"2\",20)] {\"0\": 0, \"1\": 10, \"2\": 20}+ :: Map String Int+@++3. /Conversion haskell values from and to JSON/++This module provides many instances classes `FromJson` and `ToJson`+for haskell data types.+See instances class `ToJson` for SQL (HDBC) in module Database.HDBC.JSON2+(package json2-hdbc).++ /Adding Instance class ToJson or FromJson/+++Transformation of algebraic product in `Json`. For example:++@+ data Person = Person {name :: String, age:: Int}+ deriving (Typeable, Show, Eq)+@++@+ instance ToJson Person where+ toJson (Person s n) = toJson [toJson s, toJson n]+@++@+ instance FromJson Person where+ safeFromJson (JArray [js, jn])+ = return $ Person (fromJson js) (fromJson jn)+ safeFromJson x = mkError x+@++Converting `Bounded` and `Enum` values to Json. For example:++@+ data Color = Red | Green | Blue | Black+ deriving (Typeable, Show, Eq, Enum, Bounded)+@++@+ instance ToJson Color where+ toJson = JNumber . toRational . fromEnum+ instance FromJson Color where+ safeFromJson (JNumber x) = checkBoundsEnum (toEnum . round) x+ safeFromJson x = mkError x+@+-}++module Data.JSON2+ ( -- * Re-export module for pretty printing+ module Data.JSON2.Pretty + -- * Base data types+ , Json (..)+ , Jsons (..)+ -- * Renders JSON to string+ , toString+ -- * Conversion haskell values from and to JSON+ , ToJson (toJson)+ , FromJson(safeFromJson)+ , fromJson+ -- * Building JSON objects+ , emptyObj, (.=), mkObj+ -- * Merges JSON objects+ , (+=), merges, mergeRec+ )+where++import Data.JSON2.Internal+import Data.JSON2.Types+import Data.JSON2.Pretty+import Data.Typeable (Typeable)++import Data.List+import Data.Ratio+import Data.Int+import Data.Word+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set++import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as L(ByteString)+import qualified Data.ByteString.UTF8 as U8 (fromString, toString) +import qualified Data.ByteString.Lazy.UTF8 as LU8 (fromString, toString) ++infixl 4 +=+infixr 6 .=++-------------- Conversion from and to JSON --------------------------------------++-- | Class for conversion from `Json`.+class Typeable a => ToJson a where+ toJson :: a -> Json++-- | Class for conversion from `Json`.+class Typeable a => FromJson a where+ safeFromJson :: Json -> ConvResult a++-- | Conversion from `Json`.+fromJson :: FromJson a => Json -> a+fromJson x = case safeFromJson x of+ Left e -> error (show e)+ Right r -> r+++---------------- Building and manipulation JSON objects ---------++-- Building JSON objects++-- | Create empty `Json` object.+--+-- > pp $ emptyObj == {}+emptyObj :: Json+emptyObj = JObject Map.empty++-- | Create single `Json` object.+--+-- > pp ("key" .= (Just False)) == {"key": false}+(.=) :: (ToJson v, Typeable v) => String -> v -> Json+k .= v = JObject $ Map.singleton k (toJson v)++-- | Create `Json` object from list.+--+-- > pp $ mkObj [("a", "old"), ("a", "new"), ("bb", "other")] == {"a": "new", "bb": "other"}+mkObj :: (ToJson v, Typeable v) => [(String ,v)] -> Json+mkObj xs = JObject $ Map.fromList (map (\(k,v) -> (k, toJson v)) xs)++-- * Merges JSON objects++-- | Merge two `JObject`. Other `Json` values interpreted as `emptyObj`.+--+-- > pp $ ("a" .= "old") += ("a" .= "new") += ("bb" .= "other") == {"a": "new", "bb": "other"}+--+-- > obj += emptyObj == emptyObj += obj+-- > obj += obj == emptyObj += obj == obj += emptyObj +-- > obj1 += (obj2 += obj3) == (obj1 += obj2) += obj3+(+=) :: Json -> Json -> Json+(+=) (JObject x ) (JObject y) = JObject $ Map.union y x+(+=) (JObject x ) _ = JObject x+(+=) _ (JObject y) = JObject y+(+=) _ _ = emptyObj++-- | Merge `Json` objects from list.+--+-- > pp $ merges [("a" .= "old"), ("a" .= "new"), ("bb" .= "other")] == {"a": "new", "bb": "other"}+merges :: [Json] -> Json+merges = foldl (+=) emptyObj++-- | Recursively merge the two `Json` objects.+mergeRec :: Json -> Json -> Json+mergeRec ox@(JObject x) oy@(JObject y) = mergeRec' ox oy+mergeRec _ _ = emptyObj++mergeRec' (JObject x) (JObject y) = JObject $ Map.unionWith mergeRec' x y+mergeRec' _ js = js+++------------------------- Instances -----------------------------++-- Mix instances++instance ToJson Json where+ toJson = id+instance FromJson Json where+ safeFromJson = return++instance ToJson () where+ toJson () = JArray []+instance FromJson () where+ safeFromJson (JArray []) = return ()+ safeFromJson x = mkError x++instance ToJson a => ToJson (Maybe a) where+ toJson = maybe JNull toJson+instance FromJson a => FromJson (Maybe a) where+ safeFromJson x = if x == JNull then return Nothing+ else return $ Just (fromJson x)+instance ToJson Bool where+ toJson = JBool+instance FromJson Bool where+ safeFromJson (JBool x) = return x+ safeFromJson x = mkError x++instance (ToJson a, ToJson b) => ToJson (Either a b) where+ toJson (Right x) = toJson [[], [x]] + toJson (Left x) = toJson [[x], []]+instance (FromJson a, FromJson b) => FromJson (Either a b) where+ safeFromJson (JArray [JArray [], JArray [x]]) = (return . Right . fromJson) x+ safeFromJson (JArray [JArray [x], JArray []]) = (return . Left . fromJson) x+ safeFromJson x = mkError x+++-- Instances String++instance ToJson String where+ toJson = JString+instance FromJson String where+ safeFromJson (JString x) = return x+ safeFromJson x = mkError x++instance ToJson B.ByteString where+ toJson = JString . U8.toString+instance FromJson B.ByteString where+ safeFromJson (JString x) = (return . U8.fromString) x+ safeFromJson x = mkError x++instance ToJson L.ByteString where+ toJson = JString . LU8.toString+instance FromJson L.ByteString where+ safeFromJson (JString x) = (return . LU8.fromString) x+ safeFromJson x = mkError x++-- Instances Char++instance ToJson Char where+ toJson = jsonifyIntegral . fromEnum+instance FromJson Char where+ safeFromJson (JNumber x) = checkBoundsEnum (toEnum . round) x+ safeFromJson x = mkError x++-- Instances Numeric++instance ToJson Integer where+ toJson = jsonifyIntegral+instance FromJson Integer where+ safeFromJson (JNumber x) = return (round x)+ safeFromJson x = mkError x++-- Instances Int++instance ToJson Int where+ toJson = jsonifyIntegral+instance FromJson Int where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Int8 where+ toJson = jsonifyIntegral+instance FromJson Int8 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Int16 where+ toJson = jsonifyIntegral+instance FromJson Int16 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Int32 where+ toJson = jsonifyIntegral+instance FromJson Int32 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Int64 where+ toJson = jsonifyIntegral+instance FromJson Int64 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++-- Instances Word++instance ToJson Word where+ toJson = jsonifyIntegral+instance FromJson Word where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Word8 where+ toJson = jsonifyIntegral+instance FromJson Word8 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Word16 where+ toJson = jsonifyIntegral+instance FromJson Word16 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Word32 where+ toJson = jsonifyIntegral+instance FromJson Word32 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x++instance ToJson Word64 where+ toJson = jsonifyIntegral+instance FromJson Word64 where+ safeFromJson (JNumber x) = checkBoundsIntegral round x+ safeFromJson x = mkError x+--+jsonifyIntegral :: (Integral a) => a -> Json+jsonifyIntegral i = JNumber (fromIntegral i % 1)++-- Instances Floating and Rational++instance ToJson Double where+ toJson = jsonifyRealFrac+instance FromJson Double where+ safeFromJson (JNumber x) = checkInfinite fromRational x+ safeFromJson x = mkError x++instance ToJson Float where+ toJson = jsonifyRealFrac+instance FromJson Float where+ safeFromJson (JNumber x) = checkInfinite fromRational x+ safeFromJson x = mkError x+++instance ToJson Rational where+ toJson = JNumber+instance FromJson Rational where+ safeFromJson (JNumber x) = return x+ safeFromJson x = mkError x++--+jsonifyRealFrac :: (RealFrac a) => a -> Json+jsonifyRealFrac i = JNumber (approxRational i 1e-666)++-- ** Instances Containers+++instance ToJson a => ToJson [a] where+ toJson = JArray . map toJson+instance FromJson a => FromJson [a] where+ safeFromJson (JArray xs) = return (map fromJson xs)+ safeFromJson x = mkError x++instance ToJson v => ToJson (Map String v) where+ toJson = JObject . Map.map toJson+instance FromJson v => FromJson (Map String v) where+ safeFromJson (JObject m) = return $ Map.map fromJson m+ safeFromJson x = mkError x++instance ToJson a => ToJson (Set a) where+ toJson = JArray . (map toJson) . Set.toList+instance (FromJson a, Ord a) => FromJson (Set a) where+ safeFromJson (JArray xs) = return . Set.fromList $ map fromJson xs+ safeFromJson x = mkError x++-- Instances Tuples++instance ( ToJson t1, ToJson t2)+ => ToJson (t1, t2) where+ toJson (x1, x2) = JArray [toJson x1, toJson x2]+instance (FromJson t1, FromJson t2)+ => FromJson (t1, t2) where+ safeFromJson (JArray [x1, x2]) = return (fromJson x1, fromJson x2)+ safeFromJson x = mkError x++instance (ToJson t1, ToJson t2, ToJson t3)+ => ToJson (t1, t2, t3) where+ toJson (x1, x2, x3) = JArray [toJson x1, toJson x2, toJson x3]+instance (FromJson t1, FromJson t2, FromJson t3)+ => FromJson (t1, t2, t3) where+ safeFromJson (JArray [x1, x2, x3]) = return (fromJson x1, fromJson x2, fromJson x3)+ safeFromJson x = mkError x++instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4) => ToJson (t1, t2, t3, t4) where+ toJson (x1, x2, x3, x4) = JArray [toJson x1, toJson x2, toJson x3, toJson x4]+instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4)+ => FromJson (t1, t2, t3, t4) where+ safeFromJson (JArray [x1, x2, x3, x4]) = return (fromJson x1, fromJson x2, fromJson x3,+ fromJson x4)+ safeFromJson x = mkError x++instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4, ToJson t5)+ => ToJson (t1, t2, t3, t4, t5) where+ toJson (x1, x2, x3, x4, x5) = JArray [toJson x1, toJson x2, toJson x3, toJson x4, toJson x5]+instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4, FromJson t5)+ => FromJson (t1, t2, t3, t4, t5) where+ safeFromJson (JArray [x1, x2, x3, x4, x5]) = return (fromJson x1, fromJson x2, fromJson x3,+ fromJson x4, fromJson x5)+ safeFromJson x = mkError x+++
+ src/Data/JSON2/Blaze.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Efficient build ByteString from `Json` with escaped string.++/For example - use in YESOD:/++@+ import Yesod+ import Data.JSON2 as JSON+ import Data.JSON2.Blaze as JSON+ import Blaze.ByteString.Builder (toLazyByteString)+ --+ toRepJson :: ToJson a => a -> RepJson+ toRepJson = RepJson . toContent . toLazyByteString . (JSON.blazeJson) . (JSON.toJson)+@++-}++module Data.JSON2.Blaze (blazeJson) where+import Data.JSON2.Types+import Data.ByteString.Char8 ()+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Internal(runWrite, boundedWrite)+import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromChar, fromString, fromShow)+import Data.Ratio (denominator, numerator)+import Data.Monoid (mempty, mappend, mconcat)+import Data.Map as Map++blazeJson :: Json -> Builder+blazeJson JNull = fromByteString "null"+blazeJson (JBool True) = fromByteString "true"+blazeJson (JBool False) = fromByteString "false"+blazeJson (JString xs) = escQuoted xs --fromWriteList writeJsonEscChar xs+blazeJson (JNumber x)+ | denominator x == 1 = fromShow (numerator x)+ | otherwise = fromShow (fromRational x :: Double)+blazeJson (JArray []) = fromByteString "[]"+blazeJson (JArray (x:xs)) = mconcat [fromChar '[', blazeJson x, go xs, fromChar ']' ]+ where go xs = mconcat [fromChar ',' `mappend` blazeJson x | x <- xs]+blazeJson (JObject x) = goo (Map.toList x)+ where goo [] = fromByteString "{}"+ goo (p:ps) = mconcat [fromChar '{', buildPair p, goo' ps, fromChar '}' ]+ goo' vs = mconcat [fromChar ',' `mappend` buildPair w | w <- vs]+ buildPair (k,v) = mconcat[escQuoted k, fromChar ':', blazeJson v]++escQuoted :: String -> Builder+escQuoted xs = mconcat [fromChar '\"', (fromWriteList writeJsonEscChar xs), fromChar '\"']++writeJsonEscChar :: Char -> Write+writeJsonEscChar x = + boundedWrite 2 (wc x) where+ wc '\"' = runWrite $ writeByteString "\\\""+ wc '\\' = runWrite $ writeByteString "\\\\"+ wc '/' = runWrite $ writeByteString "\\/"+ wc '\b' = runWrite $ writeByteString "\\b"+ wc '\f' = runWrite $ writeByteString "\\f"+ wc '\n' = runWrite $ writeByteString "\\n"+ wc '\r' = runWrite $ writeByteString "\\r"+ wc '\t' = runWrite $ writeByteString "\\t"+ wc c = runWrite $ writeChar c
+ src/Data/JSON2/Instances/Time.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{- |++This module provides Instances classes `ToJson` and `FromJson` for Time.++Time transforms to JSON as: ++@+ `Day` [\"2011\", \"04\", \"03\"]+ `TimeOfDay` [\"13\", \"12\", \"47\", \".244649\"]+ `TimeZone` \"EEST\"+ `LocalTime` [\"2011\", \"04\", \"03\", \"13\", \"12\", \"47\", \".244649\"]+ `ZonedTime` [\"2011\", \"04\", \"03\", \"13\", \"12\", \"47\", \".244649\", \"EEST\"]+ `UTCTime` [\"2011\", \"04\", \"03\", \"10\", \"12\", \"47\", \".244777\", \"UTC\"]+ `NominalDiffTime` 1.301825863528051e9+ `POSIXTime` 1.301825863528051e9+@+ +-}+module Data.JSON2.Instances.Time where++import Data.JSON2+import Data.JSON2.Internal+import Data.Time+import Data.Time.Clock.POSIX(POSIXTime) -- POSIXTime synonym NominalDiffTime+import System.Locale (iso8601DateFormat, defaultTimeLocale)+++fmtYear x = JString $ formatTime defaultTimeLocale "%Y" x+fmtMonth x = JString $ formatTime defaultTimeLocale "%m" x+fmtDay x = JString $ formatTime defaultTimeLocale "%d" x+fmtHour x = JString $ formatTime defaultTimeLocale "%H" x+fmtMin x = JString $ formatTime defaultTimeLocale "%M" x+fmtSec x = JString $ formatTime defaultTimeLocale "%S" x+fmtPico x = JString $ formatTime defaultTimeLocale "%Q" x+fmtZone x = JString $ formatTime defaultTimeLocale "%Z" x++-- WARNING: Not instance Eq for ZonedTime+-- Zoned Time+instance ToJson ZonedTime where+ toJson x = toJson [ fmtYear x, fmtMonth x, fmtDay x+ , fmtHour x, fmtMin x, fmtSec x+ , fmtPico x+ , fmtZone x+ ]++fmtZT = "%Y-%m-%d %T%Q %Z"+instance FromJson ZonedTime where+ safeFromJson js@(JArray [ JString y, JString mon, JString d+ , JString h, JString m, JString s+ , JString p, JString z+ ]+ ) = case (parseTime defaultTimeLocale fmtZT zt) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtZT) js+ where zt = concat [ y, "-", mon, "-", d+ , " ", h, ":", m, ":", s+ , p, " ", z+ ]+ safeFromJson x = mkError x+++-- Day+instance ToJson Day where+ toJson x = toJson [ fmtYear x, fmtMonth x, fmtDay x]++fmtDayT = "%Y-%m-%d"+instance FromJson Day where+ safeFromJson js@(JArray [ JString y, JString mon, JString d]) = + case (parseTime defaultTimeLocale fmtDayT dt) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtDayT) js+ where dt = concat [ y, "-", mon, "-", d]+ safeFromJson x = mkError x++-- TimeOfDay++instance ToJson TimeOfDay where+ toJson x = toJson [fmtHour x, fmtMin x, fmtSec x, fmtPico x]++fmtTD = "%T%Q"+instance FromJson TimeOfDay where+ safeFromJson js@(JArray [JString h, JString m, JString s, JString p]) =+ case (parseTime defaultTimeLocale fmtTD td) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtTD) js+ where td = concat [h, ":", m, ":", s, p]+ safeFromJson x = mkError x++-- WARNING: Test via for TimeZone fail+-- TimeZone+instance ToJson TimeZone where+ toJson tz = fmtZone tz++instance FromJson TimeZone where+ safeFromJson js@(JString tz) = case parseTime defaultTimeLocale "%Z" tz of+ Just t -> return t+ Nothing -> mkError' "No parse format: %Z" js+ safeFromJson x = mkError x+++-- LocalTime+instance ToJson LocalTime where+ toJson x = toJson [ fmtYear x, fmtMonth x, fmtDay x+ , fmtHour x, fmtMin x, fmtSec x+ , fmtPico x+ ]++fmtLT = "%Y-%m-%d %T%Q"+instance FromJson LocalTime where+ safeFromJson js@(JArray [ JString y, JString mon, JString d+ , JString h, JString m, JString s+ , JString p+ ]+ ) = case (parseTime defaultTimeLocale fmtLT zt) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtLT) js+ where zt = concat [ y, "-", mon, "-", d+ , " ", h, ":", m, ":", s , p+ ]+ safeFromJson x = mkError x+++-- UTC Time+instance ToJson UTCTime where+ toJson x = toJson [ fmtYear x, fmtMonth x, fmtDay x+ , fmtHour x, fmtMin x, fmtSec x+ , fmtPico x+ , fmtZone x+ ]+++fmtUTC = "%Y-%m-%d %T%Q %Z"+instance FromJson UTCTime where+ safeFromJson js@(JArray [ JString y, JString mon, JString d+ , JString h, JString m, JString s+ , JString p, JString z+ ]+ ) = case (parseTime defaultTimeLocale fmtUTC zt) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtUTC) js+ where zt = concat [ y, "-", mon, "-", d+ , " ", h, ":", m, ":", s+ , p, " ", z+ ]+ safeFromJson x = mkError x++-- NominalDiffTime aka POSIXTime+instance ToJson NominalDiffTime where+ toJson x = (JNumber . toRational) x++instance FromJson NominalDiffTime where+ safeFromJson (JNumber x) = (return . fromRational) x+ safeFromJson x = mkError x+++{-+-- Text format UTCTime.+fmtUTC = "%Y-%m-%d %T%Q UTC"+instance FromJson UTCTime where+ safeFromJson (JString x) = case (parseTime defaultTimeLocale fmtUTC x) of+ Just t -> return t+ Nothing -> mkError' ("No parse format: " ++ fmtUTC ) x+ safeFromJson x = mkError x+-}
+ src/Data/JSON2/Internal.hs view
@@ -0,0 +1,87 @@+module Data.JSON2.Internal+ ( -- * Helpers of check conversion.+ ConvResult+ , checkBoundsIntegral+ , checkBoundsEnum+ , checkInfinite+ , ConvError(ConvError)+ , mkError+ , mkError'+ )+where+import Control.Monad.Error+import Data.Typeable++-- Conversion+type ConvResult a = Either ConvError a++-- | Conversion `Rational` number to `Integral` number with check bounds.+checkBoundsIntegral :: (Typeable a, Bounded a, Integral a)+ => (Rational -> a) -> Rational -> ConvResult a+checkBoundsIntegral f x = do+ let res = f x+ let min = toRational (asTypeOf minBound res)+ let max = toRational (asTypeOf maxBound res)+ if x >= min && x <= max+ then+ return res+ else+ mkError' ("Value must between: (" ++ show min ++ ", "+ ++ show max ++ ")") x++-- | Conversion `Rational` number to `Bounded` values with check bounds.+-- checkBoundsEnum (toEnum . round)+checkBoundsEnum :: (Typeable a, Bounded a, Enum a)+ => (Rational -> a) -> Rational -> ConvResult a+checkBoundsEnum f x = do+ let x' = fromEnum x+ let res = f x+ let min = fromEnum (asTypeOf minBound res)+ let max = fromEnum (asTypeOf maxBound res)+ if x' >= min && x' <= max+ then+ return res+ else+ mkError' ("Value must between: (" ++ show min ++ ", "+ ++ show max ++ ")") x++-- | Conversion `Rational` to `RealFloat` values with check infinity.+checkInfinite :: (Typeable a, RealFloat a)+ => (Rational -> a) -> Rational -> ConvResult a+checkInfinite f x = do+ let res = f x+ if not (isInfinite res)+ then+ return res+ else+ mkError' ("Value conveversion to infinity. ") x +++-- Error Handling++-- | Create conversion error.+mkError :: (Show a, Typeable a, Typeable b) => a -> ConvResult b+mkError inpval = mkErrorGen "" inpval undefined++-- | Create conversion error with message.+mkError' :: (Show a, Typeable a, Typeable b)+ => String -> a -> ConvResult b+mkError' msg inpval = mkErrorGen msg inpval undefined++mkErrorGen :: (Show a, Typeable a, Typeable b)+ => String -> a -> b -> ConvResult b+mkErrorGen msg inp ret =+ Left ConvError {jsonValue = show inp,+ jsonType = show . typeOf $ inp,+ destType = show . typeOf $ ret,+ errorMessage = msg}++data ConvError = ConvError {+ jsonValue :: String,+ jsonType :: String,+ destType :: String,+ errorMessage :: String}+ deriving (Eq, Read, Show)++instance Error ConvError where+ strMsg s = ConvError "" "" "" s
+ src/Data/JSON2/Parser.hs view
@@ -0,0 +1,102 @@+module Data.JSON2.Parser+ ( encodeJson+ , parseJson+ )+where+import Data.JSON2.Types+import Data.Char+import Data.Map (Map)+import qualified Data.Map as Map+import Numeric+import Control.Monad+import Text.ParserCombinators.Parsec++-- | Encode `String` to `Json`.+encodeJson :: String -> Json+encodeJson s = case parseJson s of+ Right j -> j+ Left e -> error $ show e++-- | Parses JSON string.+parseJson :: String -> Either ParseError Json+parseJson s = parse jsonP' "user input" s++jsonP' = do+ spaces+ js <- jsonP+ eof+ return js+ +jsonP :: GenParser Char () Json+jsonP = (JNull <$ tok nullP)+ <|> (JBool <$> tok boolP )+ <|> (JString <$> tok stringP)+ <|> (JNumber . fst . head . readSigned readFloat) <$> (tok numP)+ <|> (JArray <$> tok arrayP)+ <|> ((JObject . Map.fromList) <$> tok objectP)++nullP :: GenParser Char st String+nullP = tok (string "null")++boolP :: GenParser Char () Bool+boolP = ( True <$ string "true") <|> (False <$ string "false")++stringP :: GenParser Char () String+stringP = char '"' >> manyTill (escCharP <|> anyChar) (char '"')+ where+ escCharP = (char '\\') >> + ( (char '"') <|> (char '\\') <|>+ (char '/') <|> ('\b' <$ char 'b') <|>+ ('\f' <$ char 'f') <|> ('\n' <$ char 'n') <|>+ ('\r' <$ char 'r') <|> ('\t' <$ char 't') <|>+ (char 'u'>> uniP)+ )+ -- TODO check??? bounded .+ uniP = (chr . fst . head . readHex) <$> (count 4 hexDigit)++numP = (try $ liftM2 (++) int frac_exp)+ <|> int+-- where+digits = many digit+digits1 = many1 digit+digit19 = oneOf "123456789" +nat1 = consP digit19 digits+nat = ("0" <$ char '0') <|> nat1+neg = consP (char '-') nat+int = neg <|> nat+frac = consP (char '.') digits1+numz = consP (oneOf "+-") digits1+expp = consP (oneOf "eE") (numz <|> digits1)+frac_exp = (try $ liftM2 (++) frac expp)+ <|> (try expp)+ <|> frac++arrayP :: CharParser () [Json]+arrayP = between (tok (char '[')) (tok (char ']'))+ $ jsonP `sepBy` tok (char ',')++objectP :: GenParser Char () [(String, Json)]+objectP = between (tok $ char '{' ) (tok $ char '}')+ $ pairP `sepBy` tok (char ',')+ where+ pairP = do+ k <- tok stringP+ tok $ char ':'+ v <- tok jsonP+ return (k, v)++---------------------------------------------------------------------------------+tok :: CharParser st b -> CharParser st b+tok p = do {x <- p; spaces; return x}++consP :: CharParser () Char -> CharParser () String -> CharParser () String+consP = liftM2 (\x y -> [x] ++ y)++(<$) :: a -> CharParser () b -> CharParser () a+x <$ m = m >> return x++(<$>) :: (a -> b) -> CharParser () a -> CharParser () b+(<$>) = fmap+++
+ src/Data/JSON2/Pretty.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE IncoherentInstances, TypeSynonymInstances #-}+-- | Class and Instances for pretty printing Your data.+--+-- Minimal definition for instances @Pretty@ - method @pp@ . +module Data.JSON2.Pretty where++import Data.JSON2.Types+import Text.PrettyPrint+import Data.Ratio+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)++class Show a => Pretty a where+ pp :: a -> Doc+ pp = text . show++ pstring :: a -> String+ pstring = render . pp++ pprint :: a -> IO ()+ pprint = putStrLn . pstring++-- Instances++instance Pretty ()+instance Pretty Char+instance Pretty Int +instance Pretty Integer+instance Pretty Float+instance Pretty Double+instance Pretty Rational+-- String+instance Pretty String where+ pp = text+-- Maybe+instance Pretty a => Pretty (Maybe a) where+ pp (Just x) = text "Just" <+> pp x+ pp Nothing = text "Noting"+-- Either+instance (Pretty a,Pretty b) => Pretty (Either a b) where+ pp (Right x) = text "Right" <+> pp x+ pp (Left x) = text "Left" <+> pp x+-- List+instance Pretty a => Pretty [a] where+ pp xs = brackets $ fsep $ punctuate comma $ map pp xs+-- Map+instance (Pretty k, Pretty v) => Pretty (Map k v) where+ pp m = braces $ sep $ punctuate comma $ map ppair xs+ where xs = Map.toList m+ ppair (k,v) = pp k <> colon <+> pp v+-- Set+instance Pretty a => Pretty (Set a) where+ pp s = braces $ fsep $ punctuate comma $ map pp (Set.toList s)+-- Tuples+instance (Pretty a, Pretty b) => Pretty (a, b) where+ pp (a, b) = parens $ pp a <> comma <+> pp b+instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where+ pp (a, b, c) = parens $ pp a <> comma <+> pp b <> comma <+> pp c+instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where+ pp (a, b, c, d) = parens $ pp a <> comma <+> pp b <> comma <+> pp c+ <> comma <+> pp d+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e)+ => Pretty (a, b, c, d, e) where+ pp (a, b, c, d, e) = parens $ pp a <> comma <+> pp b <> comma <+> pp c+ <> comma <+> pp d <> comma <+> pp e+-- JSON+instance Pretty Json where+ pp (JNumber x)+ | denominator x == 1 = text $ show (numerator x)+ | otherwise = text $ show (fromRational x :: Double)+ pp (JBool True) = text "true"+ pp (JBool False) = text "false"+ pp JNull = text "null"+ pp (JString x) = doubleQuotes $ text $ escJString x+ pp (JArray xs) = brackets $ fsep $ punctuate comma $ map pp xs+ pp (JObject m)= braces $ sep $ punctuate comma $ map ppair xs+ where xs = Map.toList m+ ppair (k,v) = (doubleQuotes $ text k) <> colon <+> pp v+
+ src/Data/JSON2/Query.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE ParallelListComp #-}++-- | See also: <http://www.haskell.org/haskellwiki/HXT#The_concept_of_filters>+module Data.JSON2.Query+ ( -- * Data Types+ JFilter+ -- * Filtering primitive types+ , isStr, isStrBy+ , isNum, isNumBy+ , isBool, isTrue, isFalse+ , isNull, isAtomic+ -- * Filtering JSON objects+ , isObj+ , getFromObj, getFromKey+ , getFromKeys, getFromKeyBy+ -- * Filtering JSON arrays+ , isArr+ , getFromArr, getFromIndex+ , getFromIndexes, getFromIndexBy+ -- * Filtering JSON arrays and objects+ , getChildern+ -- * Filter Combinators+ , (>>>), (<+>)+ , orElse, when, guards+ , deep, deepObj, deepArr+ )+where+import qualified Data.Map as M (empty, singleton, unionWith,+ filterWithKey, elems, union, lookup)+import qualified Data.Maybe as Mb (catMaybes)+import qualified Data.List as L (nub)+import Data.JSON2.Types++type JFilter = Json -> Jsons++infixl 1 >>>+infixr 2 <+>++-- Fitering++-- | Filter `Json` objects.+isObj :: JFilter+isObj (JObject o) = [JObject o]+isObj _ = []++-- | Filter `Json` arrays.+isArr :: JFilter+isArr (JArray a) = [JArray a]+isArr _ = []++-- | Filter `Json` strings.+isStr :: JFilter+isStr (JString s) = [JString s]+isStr _ = []++-- | Predicative filter `Json` strings.+isStrBy :: (String -> Bool) -> JFilter+isStrBy p (JString s) = if p s then [JString s] else []+isStrBy _ _ = []++-- | Filter `Json` numbers.+isNum :: JFilter+isNum (JNumber n) = [JNumber n]+isNum _ = []++-- | Predicative filter `Json` numbers.+isNumBy :: Fractional a => (a -> Bool) -> JFilter+isNumBy p (JNumber n) = if p (fromRational n) then [JNumber n] else []+isNumBy _ _ = []++-- | Filter `Json` Bool.+isBool :: JFilter+isBool (JBool p) = [JBool p]+isBool _ = []++-- | Filter `Json` True.+isTrue :: JFilter+isTrue (JBool True) = [JBool True]+isTrue _ = []++-- | Filter `Json` False.+isFalse :: JFilter+isFalse (JBool False) = [JBool False]+isFalse _ = []++-- | Filter `Json` null.+isNull :: JFilter+isNull JNull = [JNull]+isNull _ = []++-- | Filter primitive types.+isAtomic :: JFilter+isAtomic (JString s) = [JString s]+isAtomic (JNumber n) = [JNumber n]+isAtomic (JBool p) = [JBool p]+isAtomic JNull = [JNull]+isAtomic _ = []++-- | Get elements from object with key.+getFromKey :: String -> JFilter+getFromKey k (JObject m) = Mb.catMaybes [(M.lookup k m)]+getFromKey _ _ = []++-- | Get elements from object with keys.+getFromKeys :: [String] -> JFilter+getFromKeys ks (JObject m) = Mb.catMaybes $ map (\k -> (M.lookup k m)) (L.nub ks) +getFromKeys _ _ = []++-- | Get elements from object with key by.+getFromKeyBy :: (String -> Bool) -> JFilter+getFromKeyBy f (JObject m) = M.elems $ M.filterWithKey (\k _ -> f k) m+getFromKeyBy _ _ = []++-- | Get all elements from object.+getFromObj :: JFilter+getFromObj (JObject o) = M.elems o+getFromObj _ = []++-- | Get all elements from array.+getFromArr :: JFilter+getFromArr (JArray a) = a+getFromArr _ = []++-- | Get element from array with index.+getFromIndex :: Int -> JFilter+getFromIndex i (JArray a) = [a !! i | i <length a]+getFromIndex _ _ = []++{-# DEPRECATED getFromIndexes "use: getFromIndexBy" #-}+-- | Get elements from array with index by.+--+-- DEPRECATED use: getFromIndexBy+getFromIndexes :: [Int] -> JFilter+getFromIndexes is ja = concat [getFromIndex i ja | i <- is]++-- | Get elements from array with indexes.+getFromIndexBy :: (Int -> Bool) -> JFilter+getFromIndexBy f (JArray xs) = [y| (y,k) <- [(x,i) | x <- xs | i <- [0..]], f k]+getFromIndexBy _ _ = []++-- | Get all elements from object and array.+getChildern :: JFilter+getChildern (JObject o) = M.elems o+getChildern (JArray a) = a+getChildern _ = []++-- Filter combinators++-- | @(f >>> g)@ - Apply filter f, later filter g .+(>>>) :: JFilter -> JFilter -> JFilter +(f >>> g) t = concat [g t' | t' <- f t]++-- | Concat results two filters.+(<+>) :: JFilter -> JFilter -> JFilter+(f <+> g) t = f t ++ g t++-- | @(f `orElse` g)@ - Apply f, if @f@ returned @empty@ apply @g@.+orElse :: JFilter -> JFilter -> JFilter+orElse f g t+ | null res1 = g t+ | otherwise = res1+ where res1 = f t++-- | @(f `when` g)@ - When @g@ returned @not empty@, apply @f@.+when :: JFilter -> JFilter -> JFilter+when f g t+ | null (g t) = [t]+ | otherwise = f t+ +-- | @(f `guards` g )@ - If @f@ returned @empty@ then @empty@ else apply @g@.+guards :: JFilter -> JFilter -> JFilter+guards f g t+ | null (f t) = []+ | otherwise = g t+++-- | Tree traversal filter for object and array.+deep :: JFilter -> JFilter+deep f = f `orElse` (getChildern >>> deep f)++-- | Tree traversal filter for array.+deepObj :: JFilter -> JFilter+deepObj f = f `orElse` (getFromObj >>> deepObj f)+deepArr :: JFilter -> JFilter+deepArr f = f `orElse` (getFromArr >>> deepArr f)