JPath.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

{- | I wanted to insert a description here, but got tired fighting with haddock escaping. Documentation: <http://bitcheese.net/wiki/code/hjpath>
-}

module Text.JSON.JPath (jPath, jPathModify, QueryElement(..), HJsonLike, QueryLike) where

import qualified Data.Map as Map
import Data.List
import Data.Maybe
import Text.HJson as JSON
import Text.ParserCombinators.Parsec.Combinator
import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec.Prim

-- | JPath query building blocks
data QueryElement
	-- | Look up element in object
	= ObjectLookup String
	-- | Look up array element (from 0 forward or from -1 backward)
	| ArrayLookup Integer
	-- | Matches any child element (array or hash entries)
	| WildcardLookup
	-- | Matches any number of child entries
	| DeepLookup
		deriving (Show)

-- | Class that allows type to be used as JPath query
class QueryLike a where
	toQuery :: a -> [QueryElement]

instance QueryLike String where
	toQuery = either (const []) (id) . parseExpression

instance QueryLike QueryElement where
	toQuery e = [e]

instance QueryLike [QueryElement] where
	toQuery = id

-- | Class that allows type to be used as JSON, all you need to implement is converting to and from Text.HJson.Json
class HJsonLike a where
	toHJson :: a -> Json
	fromHJson :: Json -> a

instance HJsonLike String where
	toHJson = either (const JNull) (id) . JSON.fromString
	fromHJson = JSON.toString

instance HJsonLike Json where
	toHJson = id
	fromHJson = id

-- | Evaluates JPath query on JSON String
jPath :: (HJsonLike j, QueryLike q) =>
	q -- ^ JPath query
	-> j 	-- ^ JSON 
	-> [j] -- ^ Results
jPath q j = 
	let json = toHJson j;
		query = toQuery q
		in map (fromHJson) $ jPathP query json

-- | Modifies JSON content under JPath expression
jPathModify :: (HJsonLike j, QueryLike q) =>	q -- ^ JPath query
	-> (Json -> Json) -- ^ modifier function
	-> j -- ^ JSON
	-> j -- ^ Modified JSON
jPathModify q modifier j = 
	let json = toHJson j;
		query = toQuery q
		in fromHJson $ jPathModifyP query modifier json

-- private functions

expression = do
	result <- element `sepBy` slash
	eof
	return $ concat result

slash = string "/"

element :: GenParser Char st [QueryElement]
element = do
	parsedName <- optionMaybe (try deepLookup <|> wildcard <|> name)
	parsedIndex <- optionMaybe index
	return $ catMaybes [parsedName, parsedIndex]

name = do
	parsedName <- many1 (noneOf "/[]")
	return $ ObjectLookup parsedName

deepLookup = do
	string "**"
	return DeepLookup

wildcard = do
	string "*"
	return WildcardLookup

integer = do
	minus <- optionMaybe (string "-")
	number <- many1 digit
	return $ (fromMaybe "" minus) ++ number

index = do
	result <- between (string "[") (string "]") integer
	return $ ArrayLookup $ read result

parseExpression = parse expression "JPath query" 

jPathP :: [QueryElement] -> Json -> [Json]
jPathP [] v = [v]
jPathP (e:es) v = case e of
	ObjectLookup s -> case v of
		JObject wtf -> maybe [] (jPathP es) $ s `Map.lookup` wtf
		otherwise -> []
	ArrayLookup i -> case v of
		JArray vs -> if i >= genericLength vs || i < 0 - genericLength vs then
			[]
			else
			jPathP es $ vs `genericIndex` (if i < 0 then genericLength vs - abs i else i)
		otherwise -> []
	WildcardLookup -> case v of
		JObject wtf -> concat $ map (jPathP es) (Map.elems wtf)
		JArray vs -> concat $ map (jPathP es) vs
		otherwise -> []
	DeepLookup -> concat [jPathP (WildcardLookup:es) v, jPathP ([WildcardLookup, DeepLookup] ++ es) v]

jPathModifyP :: [QueryElement] -> (Json -> Json) -> Json -> Json
jPathModifyP [] modifier v = modifier v
jPathModifyP (e:es) modifier v = let traverse = jPathModifyP es modifier in case e of
	ObjectLookup s -> case v of
		JObject wtf -> JObject $ Map.alter (Just . traverse . fromMaybe (JObject Map.empty)) s wtf
		otherwise -> v
	ArrayLookup i -> case v of
		JArray vs -> if i >= genericLength vs || i < 0 - genericLength vs then
			JArray vs
			else
			let num = if i < 0 then genericLength vs - abs i else i;
				(hd, tl) = genericSplitAt (num + 1) vs
				in JArray $ concat [init hd, [traverse (last hd)], tl]
				-- Ugly. why Data.List doesn't have 'modify by index' function
		otherwise -> v
	WildcardLookup -> case v of
		JObject wtf -> JObject $ Map.map (traverse) wtf
		JArray vs -> JArray $ map (traverse) vs
		otherwise -> v
	DeepLookup -> jPathModifyP (WildcardLookup:es) modifier  (jPathModifyP ([WildcardLookup, DeepLookup] ++ es) modifier v)