initial

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')
+

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 }
+<string> \"             { leaveString }
+<string> ($printable # [\"\\]) { pushString id }
+<string> \\ [\"\\\/]    { pushString (drop 1) }
+<string> \\ [nrt]       { pushString (escape . drop 1) }
+--<string> \\ '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
+
+}

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)

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) }