json-tools 0.5.0 → 0.5.1
raw patch · 9 files changed
+680/−195 lines, 9 filesdep +attoparsec-exprdep +scientificdep +string-conversions
Dependencies added: attoparsec-expr, scientific, string-conversions
Files
- Utils.hs +0/−1
- jq.hs +638/−171
- json-concat.hs +6/−1
- json-lines.hs +3/−1
- json-select.hs +13/−1
- json-strings.hs +0/−1
- json-tools.cabal +17/−15
- json-xargs.hs +1/−3
- tar2json.hs +2/−1
Utils.hs view
@@ -6,7 +6,6 @@ import Data.Aeson import Data.Maybe-import Data.Functor import Control.Exception import qualified Data.ByteString.Lazy as L import System.IO (hClose)
jq.hs view
@@ -1,278 +1,745 @@-{-# LANGUAGE PatternGuards, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-} import Control.Applicative as A-import Prelude hiding (filter)+import Control.Arrow (first,second,(***))+import Control.Monad ((<=<),(>=>))+import Control.Exception (evaluate, try, SomeException)+import Data.Ord (comparing)+import Prelude hiding (filter,sequence,Ordering(..)) import Data.Maybe import Data.Char+import Data.List ((\\),sort,sortBy,intersperse,nub) import Data.Monoid-import Data.Aeson+import Data.Aeson hiding ((<?>)) import Data.Aeson.Parser (jstring, value) import qualified Data.HashMap.Strict as H import Data.HashMap.Strict (HashMap)+import Data.Scientific hiding (scientific)+import Data.String.Conversions (cs) import qualified Data.Text as T import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Vector as V import Data.Vector (Vector) import qualified Data.HashSet as S-import Data.Attoparsec.Char8 hiding (Result, parse)+import Data.Attoparsec.ByteString.Char8 hiding (Result, parse, try) import qualified Data.Attoparsec.Lazy as L+import Data.Attoparsec.Expr import System.Environment+import Data.Traversable (Traversable(..),foldMapDefault)+import System.IO.Unsafe+import System.Process (readProcess) -type ValueOp = Value -> Value-type ValueBinOp = Value -> Value -> Value-type Filter = [Value] -> [Value]-type Obj = HashMap Text+type ValueOp1 = Value -> Value+type ValueOp2 = Value -> Value -> Value+type ValueOp3 = Value -> Value -> Value -> Value+type BoolOp2 = Value -> Value -> Bool+type Filter = Value -> [Value] -err2 :: Value -> Value -> String -> a-err2 x y msg = error . unwords $ [show x, "and", show y, msg]+newtype Obj a = Obj { unObj :: [(a,a)] }+ deriving (Eq, Show) +instance Functor Obj where+ fmap f = Obj . fmap (f *** f) . unObj++instance Traversable Obj where+ traverse f (Obj o) = Obj <$> traverse trPair o+ where trPair (x,y) = (,) <$> f x <*> f y++instance Foldable Obj where+ foldMap = foldMapDefault++data Kind = KNull | KNumber | KString | KBool | KArray | KObject+ deriving (Eq)++kinds :: [Kind]+kinds = [KNull, KNumber, KString, KBool, KArray, KObject]++instance Show Kind where+ show KNull = "null"+ show KNumber = "number"+ show KString = "string"+ show KBool = "boolean"+ show KArray = "array"+ show KObject = "object"++kindOf :: Value -> Kind+kindOf Null = KNull+kindOf Number{} = KNumber+kindOf String{} = KString+kindOf Bool{} = KBool+kindOf Array{} = KArray+kindOf Object{} = KObject++err :: [String] -> a+err = error . unwords++err2 :: Value -> Value -> (String -> String -> [String]) -> a+err2 x y msg = err (msg (show (kindOf x)) (show (kindOf y)))++err3 :: Value -> Value -> Value -> (String -> String -> String -> [String]) -> a+err3 x y z msg = err (msg (show (kindOf x)) (show (kindOf y)) (show (kindOf z)))++err1 :: Value -> (String -> [String]) -> a+err1 x msg = err (msg (show (kindOf x)))++errK :: String -> [(Value,[Kind])] -> a+errK nm vks =+ err . head $+ [ "cannot call" : nm : "since argument" :+ show i : "is a" : show kv :+ "and not a" : intersperse "or a" (map show ks)+ | (i,(v,ks)) <- zip [1::Int ..] vks+ , let kv = kindOf v+ , kv `notElem` ks+ ]+ vecDiff :: Vector Value -> Vector Value -> Vector Value x `vecDiff` y = V.filter p x where p = not . (`S.member`s) s = S.fromList (V.toList y) -(+|), (-|), (/|), ( *| ) :: ValueBinOp+(+|), (-|), (/|), ( *| ), (%|) :: ValueOp2 +Null +| x = x+x +| Null = x Number x +| Number y = Number (x + y) String x +| String y = String (x <> y) Array x +| Array y = Array (x <> y) Object x +| Object y = Object (y <> x) -- Right biased-x +| y = err2 x y "cannot be added"+x +| y = err2 x y $ \x' y' -> [x', "and", y', "cannot be added"] Number x -| Number y = Number (x - y) Array x -| Array y = Array (x `vecDiff` y)-x -| y = err2 x y "cannot be subtracted"+x -| y = err2 x y $ \x' y' -> [x', "and", y', "cannot be subtracted"] Number x *| Number y = Number (x * y)-x *| y = err2 x y "cannot be multiplied"+x *| y = err2 x y $ \x' y' -> [x', "and", y', "cannot be multiplied"] Number x /| Number y = Number (x / y)-x /| y = err2 x y "cannot be divided"+x /| y = err2 x y $ \x' y' -> [x', "and", y', "cannot be divided"] -lengthFi :: Value -> Int+Number x %| Number y = Number (fromInteger $ floor x `rem` floor y)+x %| y = err2 x y $ \x' y' -> [x', "and", y', "cannot be 'mod'ed"]++newtype NObj a = NObj (HashMap Text a)+ deriving (Eq)+instance Ord a => Ord (NObj a) where+ x <= y | x == y = True+ NObj x <= NObj y = f x <= f y where f = sortBy (comparing fst) . H.toList++instance Ord Value where+ Null <= _ = True+ _ <= Null = False+ Bool x <= Bool y = x <= y+ Bool _ <= _ = True+ _ <= Bool _ = False+ Number x <= Number y = x <= y+ Number _ <= _ = True+ _ <= Number _ = False+ String x <= String y = x <= y+ String _ <= _ = True+ _ <= String _ = False+ Array x <= Array y = x <= y+ Array _ <= _ = True+ _ <= Array _ = False+ Object x <= Object y = NObj x <= NObj y++boolOp2 :: BoolOp2 -> ValueOp2+boolOp2 f x y = Bool (f x y)++boolOp2' :: (Bool -> Bool -> Bool) -> ValueOp2+boolOp2' f x y = Bool (f (trueValue x) (trueValue y))++-- NOTE: As in jq length is the identity on numbers.+lengthFi :: Value -> Scientific lengthFi Null = 0-lengthFi (Array v) = V.length v-lengthFi (Object o) = length . H.toList $ o-lengthFi (String s) = B.length . encodeUtf8 $ s-lengthFi (Number _) = error "number has no length"-lengthFi (Bool _) = error "boolean has no length"+lengthFi (Array v) = fromIntegral $ V.length v+lengthFi (Object o) = fromIntegral $ length . H.toList $ o+lengthFi (String s) = fromIntegral $ T.length s+lengthFi (Number n) = n+lengthFi (Bool b) = err1 (Bool b) $ \x' -> [x', "has no length"] -lengthOp :: ValueOp-lengthOp = toJSON . lengthFi+lengthOp, keysOp, addOp, negateOp, sqrtOp, floorOp, sortOp,+ uniqueOp, toNumberOp, toStringOp, fromjsonOp, linesOp, unlinesOp,+ wordsOp, unwordsOp, tailOp, initOp, reverseOp :: ValueOp1 -keysOp :: ValueOp+lengthOp = Number . lengthFi+ keysOp (Array v) = toJSON [0.. V.length v - 1]-keysOp (Object o) = toJSON $ H.keys o-keysOp Number{} = error "number has no keys"-keysOp Null = error "null has no keys"-keysOp Bool{} = error "boolean has no keys"-keysOp String{} = error "string has no keys"+keysOp (Object o) = toJSON . sort . H.keys $ o+keysOp x = err1 x $ \x' -> [x', "has no keys"] -at :: Value -> Value -> Maybe Value-Object o `at` String s = H.lookup s o-Array a `at` Number mn- | Success n <- fromJSON (Number mn) = a V.!? n-_ `at` _ = Nothing+addOp = foldr (+|) Null . toList -atF :: Value -> Filter-atF key = fmap (fromMaybe Null . (`at` key))+negateOp (Number n) = Number (negate n)+negateOp x = err1 x $ \x' -> [x', "cannot be negated"] -allF :: Filter-allF xs = [ y | Array ys <- xs, y <- V.toList ys ]+sqrtOp (Number n) = Number (fromFloatDigits (sqrt (toRealFloat n :: Double)))+sqrtOp x = err1 x $ \x' -> [x', "has no square root"] +floorOp (Number n) = Number (fromInteger $ floor n)+floorOp x = err1 x $ \x' -> [x', "cannot be floored"]++sortOp (Array v) = Array (V.fromList . sort . V.toList $ v)+sortOp x = err1 x $ \x' -> [x', "cannot be sorted, as it is not an array"]++uniqueOp (Array v) = Array (V.fromList . nub . sort . V.toList $ v)+uniqueOp x = err1 x $ \x' -> [x', "cannot be grouped, as it is not an array"]++toNumberOp n@Number{} = n+toNumberOp (String s) = either (const e) Number $ parseM "number" scientific (cs s)+ where e = error $ "Invalid numeric literal (while parsing '" <> T.unpack s <> "'"+toNumberOp x = err1 x $ \x' -> [x', "cannot be parsed as a number"]++toStringOp s@String{} = s+toStringOp x = String . cs . encode $ x++fromjsonOp (String s) = either error id . parseM "JSON value" value . cs $ s+fromjsonOp x = errK "fromjson" [(x,[KString])]++linesOp (String s) = Array (V.fromList . map String . T.lines $ s)+linesOp x = errK "lines" [(x,[KString])]++unlinesOp (Array v) = String (T.unlines . map fromString . V.toList $ v)+unlinesOp x = err1 x $ \x' -> ["cannot take unlines of", x', "(not an array of string)"]++wordsOp (String s) = Array (V.fromList . map String . T.words $ s)+wordsOp x = errK "words" [(x,[KString])]++unwordsOp (Array v) = String (T.unwords . map fromString . V.toList $ v)+unwordsOp x = err1 x $ \x' -> ["cannot take unwords of", x', "(not an array of string)"]++tailOp (String s) = String (T.tail s)+tailOp (Array v) = Array (V.tail v)+tailOp x = errK "tail" [(x,[KString,KArray])]++initOp (String s) = String (T.init s)+initOp (Array v) = Array (V.init v)+initOp x = errK "init" [(x,[KString,KArray])]++reverseOp (String s) = String (T.reverse s)+reverseOp (Array v) = Array (V.reverse v)+reverseOp x = errK "reverse" [(x,[KString,KArray])]++fromString :: Value -> Text+fromString (String s) = s+fromString x = err1 x $ \x' -> [x', "is not a string"]++endoTextOp :: String -> (T.Text -> T.Text) -> ValueOp1+endoTextOp _ textOp (String s) = String (textOp s)+endoTextOp name _ x = errK name [(x,[KString])]++at, intercalateOp, intersperseOp, splitOp, chunksOp, takeOp, dropOp :: ValueOp2++intercalateOp (String s) (Array v) = String . T.intercalate s . map fromString . V.toList $ v+intercalateOp x y = errK "intercalate" [(x,[KString]),(y,[KArray])]++intersperseOp x (Array v) = Array . V.fromList . intersperse x . V.toList $ v+intersperseOp x y = errK "intersperse" [(x,kinds),(y,[KArray])]++splitOp (String x) (String y) = toJSON $ T.splitOn x y+splitOp x y = errK "split" [(x,[KString]),(y,[KString])]++chunksOp (Number n) (String s) = toJSON $ T.chunksOf (floor n) s+chunksOp x y = errK "chunks" [(x,[KNumber]),(y,[KString])]++takeOp (Number n) (String s) = String (T.take (floor n) s)+takeOp (Number n) (Array v) = Array (V.take (floor n) v)+takeOp x y = errK "take" [(x,[KNumber]),(y,[KString,KArray])]++dropOp (Number n) (String s) = String (T.drop (floor n) s)+dropOp (Number n) (Array v) = Array (V.drop (floor n) v)+dropOp x y = errK "drop" [(x,[KNumber]),(y,[KString,KArray])]++Object o `at` String s = fromMaybe Null $ H.lookup s o+Array a `at` Number n = fromMaybe Null $ a V.!? floor n+Null `at` String{} = Null+Null `at` Number{} = Null+x `at` y = err2 x y $ \x' y' -> ["Cannot index", x', "with", y']++has :: BoolOp2+Object o `has` String s = H.member s o+Array a `has` Number s = fromInteger (floor s) < V.length a+Null `has` String{} = False+Null `has` Number{} = False+x `has` y = err2 x y $ \x' y' -> ["Cannot check whether", x', "has a", y', "key"]++contains :: BoolOp2+x `contains` y+ | kindOf x /= kindOf y = err2 x y $ \x' y' -> [x', "and", y', "cannot have their containment checked"]+ | x == y = True+String x `contains` String y = x `T.isInfixOf` y+-- TODO: subarray, ...+x `contains` _ = err1 x $ \x' -> ["Not yet implemented: containement on", x']++toList :: Filter+toList (Array v) = V.toList v+toList (Object o) = H.elems o+toList x = err1 x $ \x' -> ["Cannot iterate over", x']+ bothF :: Filter -> Filter -> Filter-bothF f g xs = f xs ++ g xs+bothF f g x = f x ++ g x arrayF :: Filter -> Filter-arrayF f xs = [Array (V.fromList . f $ xs)]+arrayF f x = [Array (V.fromList $ f x)] +dist :: Obj [Value] -> [Obj Value]+dist = sequence++asObjectKey :: Value -> Text+asObjectKey (String x) = x+asObjectKey x = err1 x $ \x' -> ["Cannot use", x', "as object key"]+ objectF :: Obj Filter -> Filter-objectF o xs = [Object . H.fromList $ [ (k,y) | (k,f) <- H.toList o, y <- f xs ]]+objectF o x = fmap (Object . H.fromList . fmap (first asObjectKey) . unObj) . dist . fmap ($x) $ o -{- Confusing:-$ jq -n -c '[(1,2,3,4) | .+.]'-[2,4,6,8]+op2VF :: ValueOp2 -> Filter -> Filter+op2VF op f inp = [ op x inp | x <- f inp ] -$ jq -n -c '[(1,2,3,4) | .+1]'-[2,3,4,5]+-- This is actually in IO!+systemOp :: ValueOp2+systemOp cmdargs (String inp) =+ case fromJSON cmdargs of+ Success (cmd:args) ->+ -- Yes I am ashamed!+ unsafePerformIO . fmap (String . T.pack) . readProcess cmd args . T.unpack $ inp+ _ ->+ err1 cmdargs $ \cmdargs' -> ["system()'s second argument must be an array of strings and not a", cmdargs']+systemOp _cmdargs inp =+ err1 inp $ \inp' -> ["system()'s input must be a string and not a", inp']+ -- errK "system" [(inp,[KString])] -But:+filterOp3 :: ValueOp3 -> Filter -> Filter -> Filter+filterOp3 op f g x = [ op x y z | z <- g x, y <- f x ] -$ jq -n -c '[(1,2)+(2,1)]'-[3,4,2,3]+op3F :: a -> F a -> F a -> F a+op3F op f g = OpF op [f,g] -instead of [3,3]--}-ap2F :: ValueBinOp -> Filter -> Filter -> Filter--- ap2F op f g xs = [ op x y | x <- f xs, y <- g xs ]-ap2F op f g xs = zipWith op (f xs) (g xs)+op2to3 :: ValueOp2 -> ValueOp3+op2to3 = const emptyF :: Filter emptyF _ = [] constF :: Value -> Filter-constF v xs = [ v | _ <- xs ]+constF v _ = [v] +type Name = String+ -- Filter-data F = IdF -- .- | CompF F F -- f | g- | AtF Value -- .[key]- | AllF -- .[]- | BothF F F -- f, g- | ArrayF F -- [f]- | ObjectF (Obj F) -- {a: f, b: g}- | EmptyF -- empty- | OpF Op -- length, keys- | Ap2F BinOp F F -- f + g, f - g, f / g, f * g- | ConstF Value -- 1, "foo", null- | ErrorF String+data F a+ = IdF -- .+ | CompF (F a) (F a) -- f | g+ | BothF (F a) (F a) -- f, g+ | ArrayF (F a) -- [f]+ | ObjectF (Obj (F a)) -- {a: f, b: g}+ | OpF a [F a] -- F, F(f₀;...;fn)+ | ConstF Value -- 1, "foo", null+ | ErrorF String deriving (Show) -data Op = Length | Keys- deriving (Show)+type F' = F Name -data BinOp = Plus | Minus | Times | Div- deriving (Show)+keyF :: Text -> F a+keyF = ConstF . String +-- f[g]+atF :: F' -> F' -> F'+atF = op3F "_at"++-- f[g]+-- f[]+atFm :: F' -> Maybe F' -> F'+atFm f (Just g) = atF f g+atFm f Nothing = f `CompF` OpF "[]" []+ -- .key-keyF :: Text -> F-keyF = AtF . String+atKeyF :: Text -> F'+atKeyF = atF IdF . keyF --- def map(f): [.[] | f];-mapF :: F -> F-mapF f = ArrayF (AllF `CompF` f)+trueValue :: Value -> Bool+trueValue (Bool b) = b+trueValue Null = False+trueValue _ = True --- TODO: deal properly with "f + g - h" and "f - g + h"-binOpF :: BinOp -> [F] -> F-binOpF _ [] = IdF-binOpF _ [x] = x-binOpF op [x,y] = Ap2F op x y-binOpF _ _ = error "binOpF: not supported yet"+selectF :: Filter -> Filter+selectF f x = [x | any trueValue (f x)] -concatF, composeF, sumF, productF, minusF, divF :: [F] -> F+whenF :: Filter -> Filter+whenF f x = [x | all trueValue (f x)] +concatF, composeF :: [F a] -> F a+ concatF [] = IdF concatF xs = foldr1 BothF xs composeF [] = IdF composeF xs = foldr1 CompF xs -sumF = binOpF Plus-productF = binOpF Times-minusF = binOpF Minus-divF = binOpF Div+toEntry :: (Value,Value) -> Value+toEntry (k,v) = Object $ H.fromList [("key",k),("value",v)] -valueBinOp :: BinOp -> ValueBinOp-valueBinOp Plus = (+|)-valueBinOp Times = (*|)-valueBinOp Minus = (-|)-valueBinOp Div = (/|)+toEntries :: [(Value,Value)] -> Value+toEntries = Array . V.fromList . fmap toEntry -valueOp :: Op -> ValueOp-valueOp Keys = keysOp-valueOp Length = lengthOp+-- In ./jq to_entries is defined as:+-- def to_entries: [keys[] as $k | {key: $k, value: .[$k]}];+-- However I have no plan to implement variables yet+toEntriesOp :: ValueOp1+toEntriesOp (Object o) = toEntries . fmap (first String) . H.toList $ o+toEntriesOp (Array v) = toEntries . zip ((Number . fromInteger) <$> [0..]) . V.toList $ v+toEntriesOp x = err1 x $ \x' -> [x', "has no keys"] -filter :: F -> Filter-filter IdF = id-filter (CompF f g) = filter g . filter f-filter (AtF key) = atF key-filter AllF = allF-filter (BothF f g) = bothF (filter f) (filter g)-filter (ArrayF f) = arrayF (filter f)-filter (ObjectF o) = objectF (fmap filter o)-filter (Ap2F op f g) = ap2F (valueBinOp op) (filter f) (filter g)-filter EmptyF = emptyF-filter (OpF op) = fmap (valueOp op)-filter (ConstF v) = constF v-filter (ErrorF err) = error err+fromEntriesF :: F'+fromEntriesF = parseF "map({(.key): .value}) | add" -parseSimpleFilter, parseTimesFilter, parseDivFilter,- parseMinusFilter, parsePlusFilter, parseCommaFilter,- parseNoCommaFilter, parseFilter, parseDotFilter :: Parser F+{-+subst :: (a -> [F b] -> F b) -> F a -> F b+subst _ IdF = IdF+subst env (CompF f g) = CompF (subst env f) (subst env g)+subst env (BothF f g) = BothF (subst env f) (subst env g)+subst env (ArrayF f) = ArrayF (subst env f)+subst env (ObjectF o) = ObjectF (fmap (subst env) o)+subst env (OpF op fs) = env op (fmap (subst env) fs)+subst _ (ConstF v) = ConstF v+subst _ (ErrorF msg) = ErrorF msg+-} -parseDotFilter- = pure AllF <* string "[]"- <|> AtF <$> (char '[' *> value <* tok ']')- <|> keyF <$> bareWord- <|> pure IdF+filterF2 :: String -> String -> Filter -> Filter+filterF2 nmf sf f = filter env (parseF sf)+ where env nm [] | nm == nmf = f+ env nm fs = filterOp nm fs -bareWord :: Parser Text-bareWord = T.pack <$> some (satisfy (\c -> isAscii c && isAlpha c))+{-+data Def = Def { name :: Text, params :: [Text], body :: F } -parseConstFilter :: Parser Value-parseConstFilter- = String <$> jstring- <|> Number <$> number- <|> pure (Bool True) <* string "true"- <|> pure (Bool False) <* string "false"- <|> pure Null <* string "null"- <|> pure (Array mempty) <* string "[]"- <|> pure (Object mempty) <* string "{}"+paramsP :: Parser [Text]+paramsP = tok '(' *> (bareWord `sepBy1` tok ';') <* tok ')'+ <|> pure []+ <?> "parameters" -parseOp :: Parser Op-parseOp = pure Length <* string "length"- <|> pure Keys <* string "keys"+definitionP :: Parser Def+definitionP = Def <$ string "def" <*> bareWord <*> paramsP <* tok ':' <*> parseFilter <* tok ';'+ <?> "definition"+-} +filterOp1 :: Name -> Filter+filterOp1 = lookupOp tbl 1 where+ tbl = H.fromList . (tbl' ++) $+ [("empty" , emptyF)+ ,("[]" , toList)+ ,("from_entries" , filter filterOp fromEntriesF)]++ tbl' = map (second (pure .))+ [("keys" , keysOp)+ ,("length" , lengthOp)+ ,("add" , addOp)+ ,("min" , minimum . toList)+ ,("max" , minimum . toList)+ ,("type" , String . T.pack . show . kindOf)+ ,("to_entries" , toEntriesOp)+ ,("negate" , negateOp)+ ,("_negate" , negateOp)+ ,("sqrt" , sqrtOp)+ ,("_sqrt" , sqrtOp)+ ,("floor" , floorOp)+ ,("_floor" , floorOp)+ ,("sort" , sortOp)+ ,("tonumber" , toNumberOp)+ ,("tostring" , toStringOp)+ ,("not" , Bool . not . trueValue)+ ,("unique" , uniqueOp)+ ,("tojson" , String . cs . encode)+ ,("fromjson" , fromjsonOp)+ -- NP extensions+ ,("lines" , linesOp)+ ,("unlines" , unlinesOp)+ ,("words" , wordsOp)+ ,("unwords" , unwordsOp)+ ,("init" , initOp)+ ,("tail" , tailOp)+ ,("reverse" , reverseOp)+ ,("casefold" , endoTextOp "casefold" T.toCaseFold)+ ,("lowercase" , endoTextOp "lowercase" T.toLower)+ ,("uppercase" , endoTextOp "uppercase" T.toUpper)+ ,("strip" , endoTextOp "strip" T.strip)+ ,("rstrip" , endoTextOp "rstrip" T.stripEnd)+ ,("lstrip" , endoTextOp "lstrip" T.stripStart)+ -- Arrays and String:+ -- null+ -- Text:+ -- isPrefixOf :: Text -> Text -> Bool+ -- isSuffixOf :: Text -> Text -> Bool+ -- isInfixOf :: Text -> Text -> Bool+ ]++filterOp2 :: Name -> Filter -> Filter+filterOp2 = lookupOp tbl 2+ where tbl = H.fromList+ [("select" , selectF)+ ,("has" , op2VF (boolOp2 (flip has)))+ ,("contains" , op2VF (boolOp2 contains))+ ,("map" , filterF2 "f" "[.[] | f]") -- def map(f): [.[] | f];+ ,("with_entries", filterF2 "f" "to_entries | map(f) | from_entries") -- "def with_entries(f): to_entries | map(f) | from_entries;"+ -- NP extensions+ ,("when" , whenF)+ ,("system" , op2VF systemOp)+ ,("intercalate" , op2VF intercalateOp)+ ,("intersperse" , op2VF intersperseOp)+ ,("split" , op2VF splitOp)+ ,("chunks" , op2VF chunksOp)+ ,("take" , op2VF takeOp)+ ,("drop" , op2VF dropOp)+ -- NP definitions+ ,("jsystem" , filterF2 "f" "tojson | system(f) | fromjson")+ ]++unknown :: Int -> Name -> a+unknown a nm = error $ nm ++ " is not defined (arity " ++ show a ++ ")"++lookupOp :: HashMap Name a -> Int -> Name -> a+lookupOp tbl a nm = fromMaybe (unknown a nm) (H.lookup nm tbl)++replaceOp :: ValueOp3+replaceOp (String x) (String y) (String z) = String (T.replace y z x)+replaceOp x y z = err3 x y z $ \x' y' z' -> ["replace expects 3 string arguments not", x', y', z']++valueOp3 :: Name -> ValueOp3+valueOp3 = lookupOp tbl 3 where+ tbl = H.fromList $+ [("replace" , replaceOp)]+ ++ map (second op2to3)+ [("_plus" , (+|))+ ,("_multiply" , (*|))+ ,("_minus" , (-|))+ ,("_divide" , (/|))+ ,("_mod" , (%|))+ ,("_less" , boolOp2 (<))+ ,("_lesseq" , boolOp2 (<=))+ ,("_greatereq" , boolOp2 (>=))+ ,("_greater" , boolOp2 (>))+ ,("_equal" , boolOp2 (==))+ ,("_notequal" , boolOp2 (/=))+ ,("_and" , boolOp2' (&&))+ ,("_or" , boolOp2' (||))+ ,("_at" , at)+ ]++filterOp :: Name -> [Filter] -> Filter+filterOp nm [] = filterOp1 nm+filterOp nm [f] = filterOp2 nm f+filterOp nm [f,g] = filterOp3 (valueOp3 nm) f g+filterOp nm fs = unknown (length fs) nm++filter :: (a -> [Filter] -> Filter) -> F a -> Filter+filter _ IdF = pure+filter env (CompF f g) = filter env f >=> filter env g+filter env (BothF f g) = bothF (filter env f) (filter env g)+filter env (ArrayF f) = arrayF (filter env f)+filter env (ObjectF o) = objectF (fmap (filter env) o)+filter env (OpF op fs) = env op (fmap (filter env) fs)+filter _ (ConstF v) = constF v+filter _ (ErrorF msg) = error msg++parseSimpleFilter, parseOpFilter, parseCommaFilter,+ parseNoCommaFilter, parseFilter, parseDotFilter, parseConcFilter :: Parser F'++parseDotFilter = atKeyF <$> (char '.' *> skipSpace *> (bareWord <|> jstring))+ <?> "dot filter"++parseAtFilters :: F' -> Parser F'+parseAtFilters f = do+ b <- tok '[' *> (atFm f <$> optional parseFilter) <* tok ']'+ <|> (f `CompF`) <$> parseDotFilter+ <|> pure IdF+ case b of+ IdF -> pure f+ _ -> parseAtFilters b++ident :: Parser String+ident = (:) <$> satisfy lic <*> many (satisfy ic)+ where lic c = c == '_' || isAscii c && isAlpha c+ ic c = c == '_' || isAscii c && isAlphaNum c++bareWord :: Parser Text+bareWord = T.pack <$> ident+ <?> "bare word"++parseOp0 :: Parser Value+parseOp0+ = String <$> jstring+ <|> Number <$> scientific+ <|> Bool True <$ string "true"+ <|> Bool False <$ string "false"+ <|> Null <$ string "null"+ <|> Array mempty <$ string "[]"+ <|> Object mempty <$ string "{}"+ <?> "arity 0 operator (\"a\", 42, true, null, [], {}, ...)"+ tok :: Char -> Parser Char tok c = skipSpace *> char c parseSimpleFilter- = skipSpace *>- ( char '.' *> skipSpace *> parseDotFilter- <|> string "empty" *> pure EmptyF- <|> OpF <$> parseOp- <|> mapF <$> (string "map" *> tok '(' *> parseFilter <* tok ')')- <|> ConstF <$> parseConstFilter- <|> ArrayF <$> (char '[' *> parseFilter <* tok ']')- <|> ObjectF <$> obj parseNoCommaFilter- <|> char '(' *> parseFilter <* tok ')'+ = skipSpace *>+ ( parseDotFilter+ <|> IdF <$ char '.'+ <|> ConstF <$> parseOp0+ <|> OpF <$> ident <*> (tok '(' *> parseFilter `sepBy1` tok ';' <* tok ')' <|> pure [])+ <|> ArrayF <$ char '[' <*> parseFilter <* tok ']'+ <|> ObjectF <$> objectFilterP+ <|> char '(' *> parseFilter <* tok ')'+ <?> "simple filter" ) -parseTimesFilter = productF <$> parseSimpleFilter `sepBy` (tok '*')+parseConcFilter = parseAtFilters =<< parseSimpleFilter+ <?> "conc filter" -parseDivFilter = divF <$> parseTimesFilter `sepBy` (tok '/')+table :: [[Operator B.ByteString F']]+table = [ [binary op AssocLeft | op <- [("*","_multiply"),("/","_divide"),("%","_mod")]]+ , [binary op AssocLeft | op <- [("+","_plus"),("-","_minus")]]+ , [binary op AssocNone | op <- [("<=","_lesseq"),("<","_less"),("==","_equal")+ ,("!=","_notequal"),(">=","_greatereq"),(">","_greater")]]+ , [binary ("and","_and") AssocRight]+ , [binary ("or","_or") AssocRight]+ ] -parsePlusFilter = sumF <$> parseDivFilter `sepBy` (tok '+')+binary :: (B.ByteString, Name) -> Assoc -> Operator B.ByteString F'+binary (name, fun) = Infix (op3F fun <$ skipSpace <* string name) -parseMinusFilter = minusF <$> parsePlusFilter `sepBy` (tok '-')+parseOpFilter = buildExpressionParser table parseConcFilter+ <?> "op filter" -parseCommaFilter = concatF <$> parseMinusFilter `sepBy` (tok ',')+parseCommaFilter = concatF <$> parseOpFilter `sepBy1` tok ','+ <?> "comma filter" -parseNoCommaFilter = composeF <$> parseMinusFilter `sepBy` (tok '|')+parseNoCommaFilter = composeF <$> parseOpFilter `sepBy1` tok '|'+ <?> "no comma filter" -parseFilter = composeF <$> parseCommaFilter `sepBy1` (tok '|')+parseFilter = composeF <$> parseCommaFilter `sepBy1` tok '|'+ <?> "filter" -obj :: Parser a -> Parser (Obj a)-obj p = char '{' *> objectValues (skipSpace *> (bareWord <|> jstring)) p+objectFilterP :: Parser (Obj F')+objectFilterP = Obj+ <$> (char '{' *> skipSpace *>+ ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace))+ <* char '}')+ where fill k = (keyF k , atKeyF k)+ keyFilterP = ConstF . String <$> (bareWord <|> jstring)+ <|> char '(' *> parseFilter <* tok ')'+ <?> "key filter"+ pair = (,) <$> (keyFilterP <* skipSpace) <*> (char ':' *> skipSpace *> parseNoCommaFilter)+ <|> fill <$> bareWord --- From: https://github.com/bos/aeson/blob/master/Data/Aeson/Parser/Internal.hs-objectValues :: Parser Text -> Parser a -> Parser (Obj a)-objectValues str val = do- skipSpace- let pair = do- a <- str <* skipSpace- b <- char ':' *> skipSpace *> val- return (a,b)- vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'- return (H.fromList vals)-{-# INLINE objectValues #-}+parseF :: String -> F'+parseF = either error id . parseM "filter" parseFilter . L8.pack -parse :: Parser a -> L.ByteString -> Maybe a-parse p s =- case L.parse p s of- L.Done rest v | L.null rest -> Just v- _ -> Nothing-{-# INLINE parse #-}+parseM :: String -> Parser a -> L.ByteString -> Either String a+parseM msg p s =+ case L.parse (top p) s of+ L.Done _ r -> Right r+ L.Fail _ ctx msg' -> Left (msg <> ": " <> msg' <> " context:" <> show ctx) +parseIO :: String -> Parser a -> L.ByteString -> IO a+parseIO msg p s = either fail return $ parseM msg p s++top :: Parser a -> Parser a+top p = p <* skipSpace <* endOfInput+ stream :: Parser [Value] stream = value `sepBy` skipSpace +readInput :: Bool -> IO [Value]+readInput True = return [Null]+readInput _ = parseIO "JSON decoding" stream =<< L.getContents++mainFilter :: Bool -> Bool -> Bool -> String -> IO ()+mainFilter wrap_output noinput raw_output arg = do+ f <- parseIO "parsing filter" parseFilter (L8.pack arg)+ -- print f+ input <- readInput noinput+ mapM_ (outputValue wrap_output raw_output) $ concatMap (filter filterOp f) input++type TestCase = (L.ByteString,L.ByteString,[L.ByteString])++parseTestCase :: TestCase -> Either String (F',Value,[Value])+parseTestCase (prg,inp,out) =+ (,,) <$> parseM "test program" parseFilter prg+ <*> parseM "test input" value inp+ <*> parseM "test output" stream (L8.unwords out)++runTest :: Either String (F', Value, [Value]) -> IO ()+runTest (Left msg) = putStrLn msg >> putStrLn (color 31 "ERROR\n")+runTest (Right {-test@-}(f, input, reference)) = do+ let output = filter filterOp f input+ encoded = encode <$> output+ result <- try $ evaluate (sum (L8.length <$> encoded) `seq` ())+ case result of+ Right ()+ | output == reference ->+ {-print test >>-} putStrLn (color 32 "PASS\n")+ | otherwise -> do+ putStrLn "was expected, but instead this is the output"+ mapM_ L8.putStrLn encoded+ putStrLn (color 31 "FAIL\n")+ Left exn -> do+ putStrLn "execution failed with this error:"+ putStrLn (show (exn :: SomeException))+ putStrLn (color 31 "ERROR\n")++color :: Int -> String -> String+color n = ("\^[["++) . shows n . ('m':) . (++ "\^[[m")++printTestCase :: TestCase -> IO TestCase+printTestCase t@(x,y,zs) = mapM_ L8.putStrLn (x:y:zs) >> return t++runTests :: IO ()+runTests = mapM_ (runTest . parseTestCase <=< printTestCase)+ . fmap splitTestCase+ . splitOnEmptyLines+ . fmap dropComment+ . L8.lines+ =<< L.getContents++splitTestCase :: [a] -> (a,a,[a])+splitTestCase (x:y:zs) = (x,y,zs)+splitTestCase _ = error "splitTestCase: too few lines for a test case"++splitOnEmptyLines :: [L.ByteString] -> [[L.ByteString]]+splitOnEmptyLines [] = []+splitOnEmptyLines xss =+ case break L.null (dropWhile L.null xss) of+ (yss,zss) -> yss : splitOnEmptyLines zss++dropComment :: L.ByteString -> L.ByteString+dropComment s+ | "#" `L.isPrefixOf` s = L.empty+ | otherwise = s++encodeValue :: Bool -> Value -> L.ByteString+encodeValue True (String s) = cs s+encodeValue _ v = encode v++outputValue :: Bool -> Bool -> Value -> IO ()+outputValue False raw_output = L8.putStrLn . encodeValue raw_output+outputValue True raw_output = mapM_ L.putStr . ($["\n"]) . f+ where f (Array a) = t"[" . cat (intersperse (t"\n,") (map j . V.toList $ a)) . t"]"+ f (Object o) = t"{" . cat (intersperse (t"\n,") (map g . H.toList $ o)) . t"}"+ f v = t $ encodeValue raw_output v+ g (key, val) = t (encode key) . t(L8.pack ":") . j val+ j = t . encode+ t x = (x:)+ cat = appEndo . mconcat . map Endo+ main :: IO ()-main = do [arg] <- getArgs- let Just f = parse (parseFilter <* skipSpace) (L8.pack arg)- -- print f- input <- maybe (fail "JSON decoding") return . parse (stream <* skipSpace) =<< L.getContents- mapM_ (L8.putStrLn . encode) $ filter f input+main = do args <- getArgs+ if "--run-tests" `elem` args then+ runTests+ else do+ -- -c is ignored+ let [arg] = args \\ ["-n","-r","--raw-output","-c","--run-tests","-w"]+ mainFilter ("-w" `elem` args) ("-n" `elem` args)+ ("-r" `elem` args || "--raw-output" `elem` args)+ arg
json-concat.hs view
@@ -12,7 +12,12 @@ ["Usage: json-concat [--help]" ,"" ,"Reads the standard input as a JSON array of arrays, and writes"- ,"on standard output the concatenations of these arrays as a JSON array."]+ ,"on standard output the concatenations of these arrays as a JSON array."+ ,""+ ,"Actually this tool does no more than the following ./jq filter:"+ ," map(.[])"+ ,"or equivalently:"+ ," [.[][]]"] >> exitFailure main :: IO ()
json-lines.hs view
@@ -18,7 +18,9 @@ ,"" ,"Reads the given files as JSON arrays (or standard input, if '-' or" ,"no file is given). Writes on standard output the elements of these"- ,"arrays as one JSON document per line."]+ ,"arrays as one JSON document per line."+ ,""+ ,"Same as: jq -c '.[]' <file>*"] >> exitFailure main :: IO ()
json-select.hs view
@@ -1,5 +1,4 @@ import Data.List-import Data.Monoid import qualified Data.HashMap.Strict as HM import Control.Arrow import Data.Aeson@@ -125,6 +124,19 @@ ," | [ '0' - '9' ]* # Access the array/sequence at the given index" ," | '*' # Keep all children of the given node (requires -m)" ,""+ ,"The same behavior can be obtained with jq (or hjq) following this translation:"+ ,""+ ,"path() = ."+ ,"path(/<segment><path>) = .[segment(<segment>)]"+ ,""+ ,"segment(\"<char>*\" as s) = s"+ ,"segment(['0'-'9']* as n) = n"+ ,"segment('*') = "+ ,""+ ,"Finally calling ./jq with following filter: [path(p)]"+ ,""+ ,"For instance the path /\"foo\"/\"$bar\"/*/42 becomes:"+ ," jq '[.foo[\"$bar\"][][42]]'" ,msg] >> exitFailure main :: IO ()
json-strings.hs view
@@ -3,7 +3,6 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Monoid import Data.Maybe-import Data.Foldable hiding (mapM_) import Control.Monad (when) import System.IO (hPutStrLn, stderr) import System.Environment (getArgs)
json-tools.cabal view
@@ -1,6 +1,6 @@ Name: json-tools Cabal-Version: >=1.6-Version: 0.5.0+Version: 0.5.1 License: BSD3 License-File: LICENSE Copyright: (c) Nicolas Pouillard@@ -15,66 +15,68 @@ executable json-concat main-is: json-concat.hs Build-depends: base>=3&&<5, aeson, bytestring- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-deep-select-key main-is: json-deep-select-key.hs Build-depends: base>=3&&<5, aeson, bytestring, containers- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-select main-is: json-select.hs Build-depends: base>=3&&<5, aeson, bytestring, containers- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-iter main-is: json-iter.hs Build-depends: base>=3&&<5, aeson, bytestring, process Other-modules: Utils- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-lines main-is: json-lines.hs Build-depends: base>=3&&<5, aeson, bytestring Other-modules: Utils- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-strings main-is: json-strings.hs Build-depends: base>=3&&<5, aeson, bytestring- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-unlines main-is: json-unlines.hs Build-depends: base>=3&&<5, bytestring Other-modules: Utils- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-wrap main-is: json-wrap.hs Build-depends: base>=3&&<5, aeson, bytestring, vector- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable json-xargs main-is: json-xargs.hs Build-depends: base>=3&&<5, aeson, bytestring- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable tar2json main-is: tar2json.hs Build-depends: base>=3&&<5, bytestring, aeson, unordered-containers,- text, tar>=0.4.0- ghc-options: -Wall -Odph+ text, tar>=0.4.0, string-conversions+ ghc-options: -Wall -O2 executable json-quote main-is: json-quote.hs Build-depends: base>=3&&<5, aeson, text- ghc-options: -Wall -Odph+ ghc-options: -Wall -O2 executable hjq main-is: jq.hs- Build-depends: base>=3&&<5, aeson, text, attoparsec- ghc-options: -Wall -Odph+ Build-depends: base>=3&&<5, aeson, text, attoparsec, attoparsec-expr,+ unordered-containers, vector, bytestring, process,+ scientific, string-conversions+ ghc-options: -Wall source-repository head type: git
json-xargs.hs view
@@ -3,11 +3,9 @@ import Data.Text as T import Data.Monoid import Data.Maybe-import Data.Foldable-import Data.Functor import System.Environment import System.Exit-import System.Cmd (rawSystem)+import System.Process (rawSystem) -- NOTE that the map keys are not included
tar2json.hs view
@@ -1,6 +1,7 @@ import Codec.Archive.Tar as Tar import qualified Data.HashMap.Strict as HM import qualified Data.Aeson as Aeson+import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.ByteString.Lazy as L import System.IO@@ -19,7 +20,7 @@ path = T.pack . entryPath contents :: Tar.Entry -> Maybe Aeson.Value- contents = fmap Aeson.toJSON . f . entryContent where+ contents = fmap (Aeson.String . cs) . f . entryContent where f (NormalFile s _) = Just s f _ = Nothing