diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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) diff --git a/jq.hs b/jq.hs --- a/jq.hs +++ b/jq.hs @@ -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 diff --git a/json-concat.hs b/json-concat.hs --- a/json-concat.hs +++ b/json-concat.hs @@ -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 () diff --git a/json-lines.hs b/json-lines.hs --- a/json-lines.hs +++ b/json-lines.hs @@ -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 '.[]' *"] >> exitFailure main :: IO () diff --git a/json-select.hs b/json-select.hs --- a/json-select.hs +++ b/json-select.hs @@ -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()]" + ,"" + ,"segment(\"*\" 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 () diff --git a/json-strings.hs b/json-strings.hs --- a/json-strings.hs +++ b/json-strings.hs @@ -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) diff --git a/json-tools.cabal b/json-tools.cabal --- a/json-tools.cabal +++ b/json-tools.cabal @@ -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 diff --git a/json-xargs.hs b/json-xargs.hs --- a/json-xargs.hs +++ b/json-xargs.hs @@ -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 diff --git a/tar2json.hs b/tar2json.hs --- a/tar2json.hs +++ b/tar2json.hs @@ -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