Init commit

.gitignore

@@ -0,0 +1,8 @@
+IDE.session
+dist
+*.swp
+*.hi
+.DS_Store
+*.o
+*.manifest
+*.exe

COPYING.txt

@@ -0,0 +1,14 @@
+            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+                    Version 2, December 2004
+
+ Copyright (C) 2011 Oscar Finnsson
+
+ Everyone is permitted to copy and distribute verbatim or modified
+ copies of this license document, and changing it is allowed as long
+ as the name is changed.
+
+            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. You just DO WHAT THE FUCK YOU WANT TO.
+

README.markdown

@@ -0,0 +1,8 @@
+## JSON.QQ ##
+
+JSON quasiquatation library for Haskell.
+
+This package only expose functionality so quasiquoters for different JSON-libraries can
+more easily be constructed.
+
+See text-json-qq and aeson-qq for libraries that are based on json-qq.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

json-qq.cabal

@@ -0,0 +1,32 @@
+name:                json-qq
+version:             0.4.0
+synopsis:            Json Quasiquatation library for Haskell.
+
+-- A longer description of the package.
+description:  
+    JSON quasiquatation library for Haskell.
+    .
+    This package only expose functionality so quasiquoters for different JSON-libraries can
+    more easily be constructed.
+    .
+    See @text-json-qq@ and @aeson-qq@ for libraries that are based on json-qq.
+
+homepage:            http://github.com/finnsson/json-qq
+license:             OtherLicense
+license-file:        COPYING.txt
+author:              Oscar Finnsson
+maintainer:          oscar.finnsson@gmail.com
+category:            JSON
+build-type:          Simple
+cabal-version:       >=1.6
+
+library
+  hs-source-dirs: src
+  exposed-modules: JSON.QQ
+  build-depends: base >= 4.3 && < 5, parsec >= 2 && < 3, template-haskell, haskell-src-meta >= 0.1.0
+
+source-repository head
+  type:     git
+  location: https://github.com/finnsson/json-qq/
+
+

src/JSON/QQ.hs

@@ -0,0 +1,208 @@
+{-# OPTIONS_GHC -XTemplateHaskell -XQuasiQuotes -XUndecidableInstances #-}
+
+-- | This package expose the parser @sonParser@.
+--
+-- Only developers that develop new json quasiquoters should use this library!
+--
+-- See @text-json-qq@ and @aeson-qq@ for usage.
+--    
+
+module JSON.QQ (
+  JsonValue (..),
+  HashKey (..),
+  parsedJson
+) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+import Data.Data
+import Data.Maybe
+
+import Data.Ratio
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Error
+
+import Language.Haskell.Meta.Parse
+
+parsedJson :: String -> Either ParseError JsonValue
+parsedJson txt = parse jpValue "txt" txt
+
+-------
+-- Internal representation
+
+data JsonValue =
+  JsonNull
+  | JsonString String
+  | JsonNumber Bool Rational
+  | JsonObject [(HashKey,JsonValue)]
+  | JsonArray [JsonValue]
+  | JsonIdVar String
+  | JsonBool Bool
+  | JsonCode Exp
+
+data HashKey =
+  HashVarKey String
+  | HashStringKey String
+
+------
+-- Grammar
+-- jp = json parsec
+-----
+
+(=>>) :: Monad m => m a -> b -> m b
+x =>> y = x >> return y
+
+
+(>>>=) :: Monad m => m a -> (a -> b) -> m b
+x >>>= y = x >>= return . y
+
+type JsonParser = Parser JsonValue
+
+-- data QQJsCode =
+--   QQjs JSValue
+--   | QQcode String
+
+jsonParser :: JsonParser
+jsonParser = do
+  spaces
+  res <- jpTrue <|> jpFalse <|> try jpIdVar <|> jpNull <|> jpString <|> jpObject <|> jpNumber  <|> jpArray <|> jpCode
+  spaces
+  return res
+
+jpValue = jsonParser
+
+jpTrue :: JsonParser
+jpTrue = jpBool "true" True
+
+jpFalse :: JsonParser
+jpFalse = jpBool "false" False
+
+jpBool :: String -> Bool -> JsonParser
+jpBool txt b = string txt =>> JsonBool b
+
+jpCode :: JsonParser
+jpCode = do
+  string "<|"
+  parseExp' >>>= JsonCode
+  where
+    parseExp' = do
+      str <- untilString
+      case (parseExp str) of
+        Left l -> fail l
+        Right r -> return r
+
+
+
+
+jpIdVar :: JsonParser
+jpIdVar = between (string "<<") (string ">>") symbol >>>= JsonIdVar
+
+
+jpNull :: JsonParser
+jpNull = do
+  string "null" =>> JsonNull
+
+jpString :: JsonParser 
+jpString = between (char '"') (char '"') (option [""] $ many chars) >>= return . JsonString . concat -- do
+
+jpNumber :: JsonParser 
+jpNumber = do
+  val <- float
+  return $ JsonNumber False (toRational val)
+
+jpObject :: JsonParser
+jpObject = do
+  list <- between (char '{') (char '}') (commaSep jpHash)
+  return $ JsonObject $ list
+  where
+    jpHash :: CharParser () (HashKey,JsonValue) -- (String,JsonValue)
+    jpHash = do
+      spaces
+      name <- varKey <|> symbolKey <|> quotedStringKey
+      spaces
+      char ':'
+      spaces
+      value <- jpValue
+      spaces
+      return (name,value)
+
+symbolKey :: CharParser () HashKey
+symbolKey = symbol >>>= HashStringKey
+
+quotedStringKey :: CharParser () HashKey
+quotedStringKey = quotedString >>>= HashStringKey
+
+varKey :: CharParser () HashKey
+varKey = do
+  char '$'
+  sym <- symbol
+  return $ HashVarKey sym
+
+jpArray :: CharParser () JsonValue
+jpArray = between (char '[') (char ']') (commaSep jpValue) >>>= JsonArray
+
+-------
+-- helpers for parser/grammar
+
+untilString :: Parser String
+untilString = do
+      n0 <- option "" $ many1 (noneOf "|")
+      char '|'
+      n1 <- option "" $ many1 (noneOf ">")
+      char '>'
+      if not $ null n1
+        then do n2 <- untilString
+                return $ concat [n0,n1,n2]
+        else return $ concat [n0,n1]
+
+
+
+float :: CharParser st Double 
+float = do
+  isMinus <- option ' ' (char '-')
+  d <- many1 digit
+  o <- option "" withDot
+  e <- option "" withE
+  return $ (read $ isMinus : d ++ o ++ e :: Double)
+
+withE = do
+  e <- char 'e' <|> char 'E'
+  plusMinus <- option "" (string "+" <|> string "-")
+  d <- many digit
+  return $ e : plusMinus ++ d 
+
+withDot = do
+  o <- char '.'
+  d <- many digit
+  return $ o:d
+
+quotedString :: CharParser () String
+quotedString = between (char '"') (char '"') (option [""] $ many chars) >>>= concat
+
+symbol :: CharParser () String
+symbol = many1 (noneOf "\\ \":;><$")
+
+commaSep p  = p `sepBy` (char ',')
+
+chars :: CharParser () String
+chars = do
+   try (string "\\\"")
+   <|> try (string "\\/")
+   <|> try (string "\\\\")
+   <|> try (string "\\b")
+   <|> try (string "\\f")
+   <|> try (string "\\n")
+   <|> try (string "\\r")
+   <|> try (string "\\t")
+   <|> try (unicodeChars)
+   <|> many1 (noneOf "\\\"")
+
+unicodeChars :: CharParser () String
+unicodeChars = do
+  u <- string "\\u"
+  d1 <- hexDigit
+  d2 <- hexDigit
+  d3 <- hexDigit
+  d4 <- hexDigit
+  return $ u ++ [d1] ++ [d2] ++ [d3] ++ [d4]

src/JSON/TestQQ.hs

@@ -0,0 +1,109 @@
+{-# OPTIONS_GHC -XDeriveDataTypeable -XTemplateHaskell -XQuasiQuotes #-}
+module JSON.TestQQ where
+
+import JSON.QQ
+
+-- for test
+import Test.Framework.TH
+import Test.Framework.Providers.HUnit
+import Test.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.Framework (defaultMain)
+
+import Text.JSON
+import Text.JSON.Types
+import Text.JSON.Generic
+
+import Data.Ratio
+
+import Data.Char
+
+-- import Data.Ratio
+
+import Language.Haskell.TH 
+
+main = $defaultMainGenerator
+
+-- main = defaultMain [tests]
+
+-- tests = $testGroupGenerator
+
+case_get_QQ_to_compile = do
+  let actual = [jsonQQ| {foo: "ba r.\".\\.r\n"} |]
+      expected = JSObject $ toJSObject [("foo", JSString $ toJSString "ba r.\\\".\\\\.r\\n")]
+  expected @=? actual
+
+case_arrays = do
+  let actual = [jsonQQ| [null,{foo: -42}] |]
+      expected = JSArray [JSNull, JSObject $ toJSObject [("foo", JSRational False (-42 % 1))] ]
+  expected @=? actual
+
+case_code = do
+  let actual = [jsonQQ| [null,{foo: <|x|>}] |]
+      expected = JSArray [JSNull, JSObject $ toJSObject [("foo", JSRational False (42 % 1))] ]
+      x = 42 :: Integer
+  expected @=? actual
+
+case_true = do
+  let actual = [jsonQQ| [true,false,null] |]
+      expected = JSArray [JSBool True, JSBool False, JSNull]
+  expected @=? actual
+
+case_json_var = do
+  let actual = [jsonQQ| [null,{foo: <<x>>}] |]
+      expected = JSArray [JSNull, JSObject $ toJSObject [("foo", JSRational False (42 % 1))] ]
+      x = toJSON ( 42 :: Integer)
+  expected @=? actual
+
+case_foo = do
+  let actual = [jsonQQ| <|foo|> |]
+      expected = JSObject $ toJSObject [("age", JSRational False (42 % 1) ) ]
+      foo = Bar 42
+  expected @=? actual
+
+case_quoted_name = do
+  let actual = [jsonQQ| {"foo": "bar"} |]
+      expected = JSObject $ toJSObject [("foo", JSString $ toJSString "bar")]
+      foo = "zoo"
+  expected @=? actual
+
+case_var_name = do
+  let actual = [jsonQQ| {$foo: "bar"} |]
+      expected = JSObject $ toJSObject [("zoo", JSString $ toJSString "bar")]
+      foo = "zoo"
+  expected @=? actual
+
+case_multiline = do
+  let actual =
+        [jsonQQ|
+          [   {
+            user: 
+              "Pelle"},
+           {user: "Arne"}]
+         |]
+      expected = JSArray [JSObject $ toJSObject [("user", JSString $ toJSString "Pelle")], JSObject $ toJSObject [ ("user", JSString $ toJSString "Arne")] ]
+  expected @=? actual
+
+case_simple_code = do
+  let actual = [jsonQQ| { foo: <| foo |> } |]
+      expected = JSObject $ toJSObject [("foo", JSString $ toJSString "zoo")]
+      foo = "zoo"
+  expected @=? actual
+
+case_semi_advanced_code = do
+  let actual = [jsonQQ| { foo: <| foo + 45 |> } |]
+      expected = JSObject $ toJSObject [("foo", JSRational False (133 % 1))]
+      foo = 88 :: Integer
+  expected @=? actual
+
+
+case_semi_advanced_char = do
+  let actual = [jsonQQ| { name: <| map toUpper name |> } |]
+      expected = JSObject $ toJSObject [("name", JSString $ toJSString "PELLE")]
+      name = "Pelle" 
+  expected @=? actual
+
+-- Data types
+
+data Foo = Bar { age :: Integer}
+  deriving (Eq, Show, Typeable, Data)