From eca89acee00faf6e9ef55d84780e6eeddf225e5c Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Wed, 18 Jul 2012 20:57:59 +0100 Subject: [PATCH] initial --- JQ.hs | 157 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Lexer.x | 101 +++++++++++++++++++++++++++++++++++ Main.hs | 22 ++++++++ Parser.y | 78 +++++++++++++++++++++++++++ 4 files changed, 358 insertions(+) create mode 100644 JQ.hs create mode 100644 Lexer.x create mode 100644 Main.hs create mode 100644 Parser.y diff --git a/JQ.hs b/JQ.hs new file mode 100644 index 00000000..ca8df794 --- /dev/null +++ b/JQ.hs @@ -0,0 +1,157 @@ +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') + diff --git a/Lexer.x b/Lexer.x new file mode 100644 index 00000000..700c69e6 --- /dev/null +++ b/Lexer.x @@ -0,0 +1,101 @@ +{ +module Lexer where +import Control.Monad.Error +} + +%wrapper "monadUserState" + +$digit = 0-9 +$alpha = [a-zA-Z_] +@reserved = "."|"["|"]"|","|":"|"("|")"|"{"|"}"|"|"|"=="|"+" +@ident = $alpha [$alpha $digit]* +@string = \" ($printable)* \" + + +tokens :- + +<0> $white+ ; +<0> @reserved { tok TRes } +<0> @ident { tok TIdent } +<0> $digit+ { tok $ TInt . read } + + +<0> \" { enterString } + \" { leaveString } + ($printable # [\"\\]) { pushString id } + \\ [\"\\\/] { pushString (drop 1) } + \\ [nrt] { pushString (escape . drop 1) } +-- \\ 'u' [0-9a-fA-F]{4} +-- { pushString (parseUnicode . drop 2) } + +-- @string { \s -> TString $ init $ tail s} + + +{ + +escape :: String -> String +escape "r" = "\r" +escape "n" = "\n" +escape "t" = "\t" + +getState :: Alex AlexState +getState = Alex $ \s -> Right (s, s) + +getUserState :: Alex AlexUserState +getUserState = liftM alex_ust getState + +setUserState :: AlexUserState -> Alex () +setUserState s' = Alex $ \s -> Right (s{alex_ust = s'}, ()) + +alexEOF = return $ Nothing + +enterString input len = do + setUserState [] + alexSetStartCode string + skip input len + +pushString f i@(p, _, s) len = do + buf <- getUserState + setUserState (buf ++ [f $ take len s]) + skip i len + +leaveString input len = do + s <- getUserState + alexSetStartCode 0 + return $ Just $ TString $ concat s + + +tok f (p,_,s) len = return $ Just $ f (take len s) +data Token = TRes String | TString String | TIdent String | TInt Int + +instance Show Token where + show (TRes t) = "token " ++ t + show (TString t) = "string " ++ t + show (TIdent t) = "identifier " ++ t + show (TInt t) = "integer " ++ show t + + +type AlexUserState = [String] + +alexInitUserState = undefined + +wrapError (Alex scanner) = Alex $ \s -> case scanner s of + Left message -> Left (message ++ " at " ++ showpos (alex_pos s)) + where + showpos (AlexPn off line col) = "line " ++ show line ++ ", column " ++ show col + x -> x + +scanner = do + tok <- wrapError alexMonadScan + case tok of + Nothing -> do + s <- getState + case alex_scd s of + 0 -> return [] + string -> alexError "Unterminated string literal" + Just tok -> liftM (tok:) scanner + +runLexer :: String -> Either String [Token] +runLexer input = runAlex input scanner + +} \ No newline at end of file diff --git a/Main.hs b/Main.hs new file mode 100644 index 00000000..695520cb --- /dev/null +++ b/Main.hs @@ -0,0 +1,22 @@ +import Parser +import Lexer +import JQ +import Text.JSON +import Text.JSON.String +import System.Environment +import Control.Monad +import System.IO + + +parseJS :: String -> JSValue +parseJS s = case runGetJSON readJSValue s of + Left err -> error err + Right val -> val + + +main = do + [program] <- getArgs + json <- liftM parseJS $ hGetContents stdin + case runLexer program >>= runParser of + Left err -> putStrLn err + Right program -> mapM_ (putStrLn . encode) (runJQ program json) \ No newline at end of file diff --git a/Parser.y b/Parser.y new file mode 100644 index 00000000..544fe5b4 --- /dev/null +++ b/Parser.y @@ -0,0 +1,78 @@ +{ +module Parser where +import Lexer +import JQ +import Text.JSON +import Debug.Trace +import Data.List +import Control.Monad.Error +import Control.Monad.Reader +} + +%name runParser Exp +%tokentype { Token } + +%monad { Either String } +%error { \t -> fail $ "parse error: unexpected " ++ if null t then [] else (show $ head t) } + +%token + '|' { TRes "|" } + '.' { TRes "." } + '[' { TRes "[" } + ']' { TRes "]" } + '{' { TRes "{" } + '}' { TRes "}" } + '(' { TRes "(" } + ')' { TRes ")" } + ',' { TRes "," } + ':' { TRes ":" } + '==' { TRes "==" } + '+' { TRes "+" } + Ident { TIdent $$ } + String { TString $$ } + Int { TInt $$ } + +%left '|' +%left ',' +%nonassoc '==' +%left '+' + +%% + +Exp + : Exp '|' Exp { $1 >| $3 } + | Exp ',' Exp { $1 `mplus` $3 } + | Exp '==' Exp { liftM2 eqj $1 $3 } + | Exp '+' Exp { liftM2 plusj $1 $3 } + | Term { $1 } + +ExpD + : ExpD '|' ExpD { $1 >| $3 } + | ExpD '==' ExpD { liftM2 eqj $1 $3 } + | Term { $1 } + + +Term + : '.' { ask } + | Term '.' Ident { $1 >| index $3 } + | '.' Ident { index $2 } + | String { constStr $1 } + | Term '[' Exp ']' { do {t <- $1; i <- $3; lookupj t i} } + | Term '[' ']' { $1 >| childp } + | '(' Exp ')' { $2 } + | '[' Exp ']' { arrayp $2 } + | Int { constInt $1 } + | '{' MkDict '}' { dictp $2 } + | Ident '(' Exp ')' { callp $1 [$3] } + | Ident { callp $1 [] } + +MkDict + : { [] } + | MkDictPair { [$1] } + | MkDictPair ',' MkDict { $1:$3 } + +MkDictPair + : Ident ':' ExpD { (constStr $1, $3) } + | Ident { (constStr $1, index $1) } + | String ':' ExpD { (constStr $1, $3) } + | '(' Exp ')' ':' ExpD{ ($2, $5) }