diff --git a/Data/JSON2.hs b/Data/JSON2.hs deleted file mode 100644 --- a/Data/JSON2.hs +++ /dev/null @@ -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] diff --git a/Data/JSON2/FromSQL.hs b/Data/JSON2/FromSQL.hs deleted file mode 100644 --- a/Data/JSON2/FromSQL.hs +++ /dev/null @@ -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"] --} diff --git a/Data/JSON2/Query.hs b/Data/JSON2/Query.hs deleted file mode 100644 --- a/Data/JSON2/Query.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | See also: -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) diff --git a/Examples/ExampleQuery.hs b/Examples/ExampleQuery.hs deleted file mode 100644 --- a/Examples/ExampleQuery.hs +++ /dev/null @@ -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 diff --git a/Examples/ExampleSqlite.hs b/Examples/ExampleSqlite.hs deleted file mode 100644 --- a/Examples/ExampleSqlite.hs +++ /dev/null @@ -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 diff --git a/examples/ExampleQuery.hs b/examples/ExampleQuery.hs new file mode 100644 --- /dev/null +++ b/examples/ExampleQuery.hs @@ -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 diff --git a/json2.cabal b/json2.cabal --- a/json2.cabal +++ b/json2.cabal @@ -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 +Author: YuriyIskra Maintainer: YuriyIskra 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 diff --git a/src/Data/JSON2.hs b/src/Data/JSON2.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2.hs @@ -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 + + + diff --git a/src/Data/JSON2/Blaze.hs b/src/Data/JSON2/Blaze.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Blaze.hs @@ -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 diff --git a/src/Data/JSON2/Instances/Time.hs b/src/Data/JSON2/Instances/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Instances/Time.hs @@ -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 +-} diff --git a/src/Data/JSON2/Internal.hs b/src/Data/JSON2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Internal.hs @@ -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 diff --git a/src/Data/JSON2/Parser.hs b/src/Data/JSON2/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Parser.hs @@ -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 + + + diff --git a/src/Data/JSON2/Pretty.hs b/src/Data/JSON2/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Pretty.hs @@ -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 + diff --git a/src/Data/JSON2/Query.hs b/src/Data/JSON2/Query.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON2/Query.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ParallelListComp #-} + +-- | See also: +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 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)