mirror of
https://github.com/stedolan/jq.git
synced 2024-05-11 05:55:39 +00:00
158 lines
3.6 KiB
Haskell
158 lines
3.6 KiB
Haskell
module JQ where
|
|
import Text.JSON
|
|
import Text.JSON.String
|
|
import Data.Maybe
|
|
import Data.List (sortBy,sort,groupBy)
|
|
import Data.Function (on)
|
|
import Data.Ord (comparing)
|
|
import Control.Monad
|
|
import Control.Monad.Writer
|
|
import Control.Monad.List
|
|
import Control.Monad.Reader
|
|
|
|
type Path = [Either Int String]
|
|
|
|
type Program = JSValue -> [(JSValue, Path)]
|
|
|
|
type JQ = ReaderT JSValue (WriterT Path [])
|
|
|
|
runJQ :: JQ a -> JSValue -> [a]
|
|
runJQ prog val = map fst $ runWriterT $ runReaderT prog val
|
|
|
|
(>|) :: JQ JSValue -> JQ a -> JQ a
|
|
a >| b = do
|
|
val <- a
|
|
local (const val) b
|
|
|
|
collect :: JQ a -> JQ [a]
|
|
collect prog = do
|
|
arg <- ask
|
|
return $ runJQ prog arg
|
|
|
|
collectPaths :: JQ a -> JQ [(a,Path)]
|
|
collectPaths prog = do
|
|
arg <- ask
|
|
return $ runWriterT $ runReaderT prog arg
|
|
|
|
insert :: JSValue -> (JSValue, Path) -> JSValue
|
|
insert base (replace, []) = replace
|
|
insert (JSArray values) (replace, ((Left n):rest)) = JSArray values'
|
|
where
|
|
(left, (_:right)) = splitAt n values
|
|
values' = left ++ [replace] ++ right
|
|
insert (JSObject obj) (replace, ((Right k):rest))= JSObject $ toJSObject obj'
|
|
where
|
|
withoutK = filter ((/= k) . fst) $ fromJSObject obj
|
|
obj' = (k, replace):withoutK
|
|
|
|
|
|
eqj a b = JSBool $ a == b
|
|
|
|
|
|
liftp :: (JSValue -> JSValue) -> JQ JSValue
|
|
liftp f = liftM f ask
|
|
|
|
idp = undefined
|
|
failp t = []
|
|
|
|
constp :: JSValue -> Program
|
|
constp t t' = idp t
|
|
|
|
anyj :: [JSValue] -> Bool
|
|
anyj values = any isTrue values
|
|
where
|
|
isTrue (JSBool False) = False
|
|
isTrue (JSNull) = False
|
|
isTrue _ = True
|
|
|
|
selectp prog = do
|
|
match <- collect prog
|
|
guard $ anyj match
|
|
ask
|
|
|
|
constStr :: String -> JQ JSValue
|
|
constStr = return . JSString . toJSString
|
|
|
|
constInt :: Int -> JQ JSValue
|
|
constInt = return . JSRational False . toRational
|
|
|
|
updatep p = do
|
|
t <- ask
|
|
liftM (foldl insert t) $ collectPaths p
|
|
|
|
arrayp prog = liftM JSArray $ collect prog
|
|
|
|
|
|
childp' :: JSValue -> JQ JSValue
|
|
childp' (JSArray values) = msum [tell [Left i] >> return v | (v,i) <- zip values [0..]]
|
|
childp' (JSObject obj) = msum [tell [Right k] >> return v | (k,v) <- fromJSObject obj]
|
|
childp' _ = mzero
|
|
|
|
childp = ask >>= childp'
|
|
|
|
--findp :: Program -> Program
|
|
findp prog = do
|
|
found <- collect prog
|
|
if anyj found then ask else childp >| findp prog
|
|
|
|
groupp prog = do
|
|
list <- ask
|
|
case list of
|
|
JSArray values -> do
|
|
marked <- forM values $ \v -> do
|
|
m <- collect (return v >| prog)
|
|
return (m,v)
|
|
msum $
|
|
map (return . JSArray . map snd) $
|
|
groupBy ((==) `on` fst) $
|
|
sortBy (comparing fst) $
|
|
marked
|
|
_ -> return JSNull
|
|
|
|
|
|
|
|
|
|
withArray f (JSArray values) = JSArray $ f values
|
|
withArray f x = x
|
|
|
|
callp "select" [p] = selectp p
|
|
callp "find" [p] = findp p
|
|
callp "set" [p] = updatep p
|
|
callp "sort" [] = liftp (withArray sort)
|
|
callp "group" [p] = groupp p
|
|
|
|
lookupj :: JSValue -> JSValue -> JQ JSValue
|
|
lookupj (JSArray values) (JSRational _ n) = do
|
|
let idx = round n
|
|
tell [Left idx]
|
|
if idx >= 0 && idx < length values
|
|
then return $ values !! idx
|
|
else return $ JSNull
|
|
lookupj (JSObject obj) (JSString s) = do
|
|
tell [Right (fromJSString s)]
|
|
case (lookup (fromJSString s) (fromJSObject obj)) of
|
|
Just x -> return x
|
|
Nothing -> return JSNull
|
|
lookupj _ _ = mzero
|
|
|
|
|
|
plusj (JSRational _ n1) (JSRational _ n2) = JSRational True (n1 + n2)
|
|
plusj (JSString s1) (JSString s2) = JSString $ toJSString (fromJSString s1 ++ fromJSString s2)
|
|
plusj (JSArray a1) (JSArray a2) = JSArray $ a1 ++ a2
|
|
|
|
|
|
js :: JSON a => a -> JSValue
|
|
js = showJSON
|
|
|
|
index s = do
|
|
v <- ask
|
|
lookupj v (js s)
|
|
|
|
|
|
dictp progs = do
|
|
liftM (JSObject . toJSObject) $ forM progs $ \(k,v) -> do
|
|
JSString k' <- k
|
|
v' <- v
|
|
return (fromJSString k', v')
|
|
|