{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.Data.Json.LightJson where import Control.Arrow import Control.Monad import Data.String import Data.Text (Text) import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Drop import HaskellWorks.Data.Json.Internal.CharLike import HaskellWorks.Data.Json.Internal.Doc import HaskellWorks.Data.Json.Internal.Slurp import HaskellWorks.Data.Json.Standard.Cursor.Generic import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.AtLeastSize import HaskellWorks.Data.MQuery.Entry import HaskellWorks.Data.MQuery.Micro import HaskellWorks.Data.MQuery.Mini import HaskellWorks.Data.MQuery.Row import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.TreeCursor import HaskellWorks.Data.Uncons import Prelude hiding (drop) import Text.PrettyPrint.ANSI.Leijen import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BSU import qualified Data.List as L import qualified Data.Text as T import qualified HaskellWorks.Data.BalancedParens as BP import qualified HaskellWorks.Data.Json.Simple.Cursor as JSC data LightJson c = LightJsonString Text | LightJsonNumber BS.ByteString | LightJsonObject [(Text, c)] | LightJsonArray [c] | LightJsonBool Bool | LightJsonNull | LightJsonError Text deriving Int -> LightJson c -> ShowS forall c. Show c => Int -> LightJson c -> ShowS forall c. Show c => [LightJson c] -> ShowS forall c. Show c => LightJson c -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [LightJson c] -> ShowS $cshowList :: forall c. Show c => [LightJson c] -> ShowS show :: LightJson c -> String $cshow :: forall c. Show c => LightJson c -> String showsPrec :: Int -> LightJson c -> ShowS $cshowsPrec :: forall c. Show c => Int -> LightJson c -> ShowS Show instance LightJsonAt c => Eq (LightJson c) where == :: LightJson c -> LightJson c -> Bool (==) (LightJsonString Text a) (LightJsonString Text b) = Text a forall a. Eq a => a -> a -> Bool == Text b (==) (LightJsonNumber ByteString a) (LightJsonNumber ByteString b) = ByteString a forall a. Eq a => a -> a -> Bool == ByteString b (==) (LightJsonBool Bool a) (LightJsonBool Bool b) = Bool a forall a. Eq a => a -> a -> Bool == Bool b (==) (LightJsonObject [(Text, c)] a) (LightJsonObject [(Text, c)] b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. LightJsonAt a => a -> LightJson a lightJsonAt) [(Text, c)] a forall a. Eq a => a -> a -> Bool == forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. LightJsonAt a => a -> LightJson a lightJsonAt) [(Text, c)] b (==) (LightJsonArray [c] a) (LightJsonArray [c] b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. LightJsonAt a => a -> LightJson a lightJsonAt [c] a forall a. Eq a => a -> a -> Bool == forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. LightJsonAt a => a -> LightJson a lightJsonAt [c] b (==) LightJson c LightJsonNull LightJson c LightJsonNull = Bool True (==) (LightJsonError Text a) (LightJsonError Text b) = Text a forall a. Eq a => a -> a -> Bool == Text b (==) LightJson c _ LightJson c _ = Bool False data LightJsonField c = LightJsonField Text (LightJson c) class LightJsonAt a where lightJsonAt :: a -> LightJson a instance LightJsonAt c => Pretty (LightJsonField c) where pretty :: LightJsonField c -> Doc pretty (LightJsonField Text k LightJson c v) = String -> Doc text (forall a. Show a => a -> String show Text k) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc pretty LightJson c v instance LightJsonAt c => Pretty (LightJson c) where pretty :: LightJson c -> Doc pretty LightJson c c = case LightJson c c of LightJsonString Text s -> Doc -> Doc dullgreen (String -> Doc text (forall a. Show a => a -> String show Text s)) LightJsonNumber ByteString n -> Doc -> Doc cyan (String -> Doc text (forall a. Show a => a -> String show ByteString n)) LightJsonObject [] -> String -> Doc text String "{}" LightJsonObject [(Text, c)] kvs -> Doc -> Doc -> Doc -> [Doc] -> Doc hEncloseSep (String -> Doc text String "{") (String -> Doc text String "}") (String -> Doc text String ",") ((forall a. Pretty a => a -> Doc pretty forall b c a. (b -> c) -> (a -> b) -> a -> c . (Text, LightJson c) -> LightJsonField c toLightJsonField forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (d, b) (d, c) second forall a. LightJsonAt a => a -> LightJson a lightJsonAt) forall a b. (a -> b) -> [a] -> [b] `map` [(Text, c)] kvs) LightJsonArray [c] vs -> Doc -> Doc -> Doc -> [Doc] -> Doc hEncloseSep (String -> Doc text String "[") (String -> Doc text String "]") (String -> Doc text String ",") ((forall a. Pretty a => a -> Doc pretty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. LightJsonAt a => a -> LightJson a lightJsonAt) forall a b. (a -> b) -> [a] -> [b] `map` [c] vs) LightJsonBool Bool w -> Doc -> Doc red (String -> Doc text (forall a. Show a => a -> String show Bool w)) LightJson c LightJsonNull -> String -> Doc text String "null" LightJsonError Text s -> String -> Doc text String "<error " forall a. Semigroup a => a -> a -> a <> String -> Doc text (Text -> String T.unpack Text s) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ">" where toLightJsonField :: (Text, LightJson c) -> LightJsonField c toLightJsonField :: (Text, LightJson c) -> LightJsonField c toLightJsonField (Text k, LightJson c v) = forall c. Text -> LightJson c -> LightJsonField c LightJsonField Text k LightJson c v instance Pretty (Micro (LightJson c)) where pretty :: Micro (LightJson c) -> Doc pretty (Micro (LightJsonString Text s )) = Doc -> Doc dullgreen (String -> Doc text (forall a. Show a => a -> String show Text s)) pretty (Micro (LightJsonNumber ByteString n )) = Doc -> Doc cyan (String -> Doc text (forall a. Show a => a -> String show ByteString n)) pretty (Micro (LightJsonObject [])) = String -> Doc text String "{}" pretty (Micro (LightJsonObject [(Text, c)] _ )) = String -> Doc text String "{..}" pretty (Micro (LightJsonArray [] )) = String -> Doc text String "[]" pretty (Micro (LightJsonArray [c] _ )) = String -> Doc text String "[..]" pretty (Micro (LightJsonBool Bool w )) = Doc -> Doc red (String -> Doc text (forall a. Show a => a -> String show Bool w)) pretty (Micro LightJson c LightJsonNull ) = String -> Doc text String "null" pretty (Micro (LightJsonError Text s )) = String -> Doc text String "<error " forall a. Semigroup a => a -> a -> a <> String -> Doc text (Text -> String T.unpack Text s) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ">" instance Pretty (Micro (String, LightJson c)) where pretty :: Micro (String, LightJson c) -> Doc pretty (Micro (String fieldName, LightJson c jpv)) = Doc -> Doc red (String -> Doc text (forall a. Show a => a -> String show String fieldName)) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc pretty (forall a. a -> Micro a Micro LightJson c jpv) instance Pretty (Micro (Text, LightJson c)) where pretty :: Micro (Text, LightJson c) -> Doc pretty (Micro (Text fieldName, LightJson c jpv)) = Doc -> Doc red (String -> Doc text (forall a. Show a => a -> String show Text fieldName)) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc pretty (forall a. a -> Micro a Micro LightJson c jpv) instance LightJsonAt c => Pretty (Mini (LightJson c)) where pretty :: Mini (LightJson c) -> Doc pretty Mini (LightJson c) mjpv = case Mini (LightJson c) mjpv of Mini (LightJsonString Text s ) -> Doc -> Doc dullgreen (String -> Doc text (forall a. Show a => a -> String show Text s)) Mini (LightJsonNumber ByteString n ) -> Doc -> Doc cyan (String -> Doc text (forall a. Show a => a -> String show ByteString n)) Mini (LightJsonObject [] ) -> String -> Doc text String "{}" Mini (LightJsonObject [(Text, c)] kvs ) -> case [(Text, c)] kvs of ((Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:(Text, c) _:[(Text, c)] _) -> String -> Doc text String "{" forall a. Semigroup a => a -> a -> a <> forall a. Pretty (Micro a) => [a] -> Doc prettyKvs (forall a b. (a -> b) -> [a] -> [b] map (forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (d, b) (d, c) second forall a. LightJsonAt a => a -> LightJson a lightJsonAt) [(Text, c)] kvs) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ", ..}" [] -> String -> Doc text String "{}" [(Text, c)] _ -> String -> Doc text String "{" forall a. Semigroup a => a -> a -> a <> forall a. Pretty (Micro a) => [a] -> Doc prettyKvs (forall a b. (a -> b) -> [a] -> [b] map (forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (d, b) (d, c) second forall a. LightJsonAt a => a -> LightJson a lightJsonAt) [(Text, c)] kvs) forall a. Semigroup a => a -> a -> a <> String -> Doc text String "}" Mini (LightJsonArray [] ) -> String -> Doc text String "[]" Mini (LightJsonArray [c] vs ) | [c] vs forall a. AtLeastSize a => a -> Int -> Bool `atLeastSize` Int 11 -> String -> Doc text String "[" forall a. Semigroup a => a -> a -> a <> Int -> Doc -> Doc nest Int 2 (forall a. Pretty a => [a] -> Doc prettyVs ((forall a. a -> Micro a Micro forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. LightJsonAt a => a -> LightJson a lightJsonAt) forall a b. (a -> b) -> [a] -> [b] `map` forall a. Int -> [a] -> [a] take Int 10 [c] vs)) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ", ..]" Mini (LightJsonArray [c] vs ) | [c] vs forall a. AtLeastSize a => a -> Int -> Bool `atLeastSize` Int 1 -> String -> Doc text String "[" forall a. Semigroup a => a -> a -> a <> Int -> Doc -> Doc nest Int 2 (forall a. Pretty a => [a] -> Doc prettyVs ((forall a. a -> Micro a Micro forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. LightJsonAt a => a -> LightJson a lightJsonAt) forall a b. (a -> b) -> [a] -> [b] `map` forall a. Int -> [a] -> [a] take Int 10 [c] vs)) forall a. Semigroup a => a -> a -> a <> String -> Doc text String "]" Mini (LightJsonArray [c] _ ) -> String -> Doc text String "[]" Mini (LightJsonBool Bool w ) -> Doc -> Doc red (String -> Doc text (forall a. Show a => a -> String show Bool w)) Mini LightJson c LightJsonNull -> String -> Doc text String "null" Mini (LightJsonError Text s ) -> String -> Doc text String "<error " forall a. Semigroup a => a -> a -> a <> String -> Doc text (Text -> String T.unpack Text s) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ">" instance LightJsonAt c => Pretty (Mini (String, LightJson c)) where pretty :: Mini (String, LightJson c) -> Doc pretty (Mini (String fieldName, LightJson c jpv)) = String -> Doc text (forall a. Show a => a -> String show String fieldName) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc pretty (forall a. a -> Mini a Mini LightJson c jpv) instance LightJsonAt c => Pretty (Mini (Text, LightJson c)) where pretty :: Mini (Text, LightJson c) -> Doc pretty (Mini (Text fieldName, LightJson c jpv)) = String -> Doc text (forall a. Show a => a -> String show Text fieldName) forall a. Semigroup a => a -> a -> a <> String -> Doc text String ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc pretty (forall a. a -> Mini a Mini LightJson c jpv) instance LightJsonAt c => Pretty (MQuery (LightJson c)) where pretty :: MQuery (LightJson c) -> Doc pretty = forall a. Pretty a => a -> Doc pretty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Int -> a -> Row a Row Int 120 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. MQuery a -> DList a mQuery instance LightJsonAt c => Pretty (MQuery (Entry String (LightJson c))) where pretty :: MQuery (Entry String (LightJson c)) -> Doc pretty (MQuery DList (Entry String (LightJson c)) das) = forall a. Pretty a => a -> Doc pretty (forall a. Int -> a -> Row a Row Int 120 DList (Entry String (LightJson c)) das) instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (GenericCursor BS.ByteString v w) where lightJsonAt :: GenericCursor ByteString v w -> LightJson (GenericCursor ByteString v w) lightJsonAt GenericCursor ByteString v w k = case forall v. Uncons v => v -> Maybe (Elem v, v) uncons ByteString remainder of Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isLeadingDigit2 Elem ByteString c -> forall c. ByteString -> LightJson c LightJsonNumber (ByteString -> ByteString slurpNumber ByteString remainder) Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isQuotDbl Elem ByteString c -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall c. Text -> LightJson c LightJsonError forall c. Text -> LightJson c LightJsonString (ByteString -> Either Text Text slurpText ByteString remainder) Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isChar_t Elem ByteString c -> forall c. Bool -> LightJson c LightJsonBool Bool True Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isChar_f Elem ByteString c -> forall c. Bool -> LightJson c LightJsonBool Bool False Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isChar_n Elem ByteString c -> forall c. LightJson c LightJsonNull Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isBraceLeft Elem ByteString c -> forall c. [(Text, c)] -> LightJson c LightJsonObject (Maybe (GenericCursor ByteString v w) -> [(Text, GenericCursor ByteString v w)] mapValuesFrom (forall k. TreeCursor k => k -> Maybe k firstChild GenericCursor ByteString v w k)) Just (!Elem ByteString c, ByteString _) | forall c. JsonCharLike c => c -> Bool isBracketLeft Elem ByteString c -> forall c. [c] -> LightJson c LightJsonArray (Maybe (GenericCursor ByteString v w) -> [GenericCursor ByteString v w] arrayValuesFrom (forall k. TreeCursor k => k -> Maybe k firstChild GenericCursor ByteString v w k)) Just (Elem ByteString, ByteString) _ -> forall c. Text -> LightJson c LightJsonError Text "Invalid Json Type" Maybe (Elem ByteString, ByteString) Nothing -> forall c. Text -> LightJson c LightJsonError Text "End of data" where ik :: v ik = forall t v w. GenericCursor t v w -> v interests GenericCursor ByteString v w k bpk :: w bpk = forall t v w. GenericCursor t v w -> w balancedParens GenericCursor ByteString v w k p :: Position p = Count -> Position lastPositionOf (forall v. Select1 v => v -> Count -> Count select1 v ik (forall v. Rank1 v => v -> Count -> Count rank1 w bpk (forall t v w. GenericCursor t v w -> Count cursorRank GenericCursor ByteString v w k))) remainder :: ByteString remainder = forall v. Drop v => Count -> v -> v drop (forall a. ToCount a => a -> Count toCount Position p) (forall t v w. GenericCursor t v w -> t cursorText GenericCursor ByteString v w k) arrayValuesFrom :: Maybe (GenericCursor ByteString v w) -> [GenericCursor ByteString v w] arrayValuesFrom = forall b a. (b -> Maybe (a, b)) -> b -> [a] L.unfoldr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a. a -> a id forall (a :: * -> * -> *) b c c'. Arrow a => a b c -> a b c' -> a b (c, c') &&& forall k. TreeCursor k => k -> Maybe k nextSibling)) mapValuesFrom :: Maybe (GenericCursor ByteString v w) -> [(Text, GenericCursor ByteString v w)] mapValuesFrom Maybe (GenericCursor ByteString v w) j = forall {b}. [b] -> [(b, b)] pairwise (Maybe (GenericCursor ByteString v w) -> [GenericCursor ByteString v w] arrayValuesFrom Maybe (GenericCursor ByteString v w) j) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall {a} {b}. LightJsonAt a => (a, b) -> [(Text, b)] asField pairwise :: [b] -> [(b, b)] pairwise (b a:b b:[b] rs) = (b a, b b) forall a. a -> [a] -> [a] : [b] -> [(b, b)] pairwise [b] rs pairwise [b] _ = [] asField :: (a, b) -> [(Text, b)] asField (a a, b b) = case forall a. LightJsonAt a => a -> LightJson a lightJsonAt a a of LightJsonString Text s -> [(Text s, b b)] LightJson a _ -> [] instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (JSC.JsonCursor BS.ByteString v w) where lightJsonAt :: JsonCursor ByteString v w -> LightJson (JsonCursor ByteString v w) lightJsonAt JsonCursor ByteString v w k = if Count kra forall a. Integral a => a -> a -> a `mod` Count 2 forall a. Eq a => a -> a -> Bool == Count 1 then let i :: Int i = forall a b. (Integral a, Num b) => a -> b fromIntegral (Count kpa forall a. Num a => a -> a -> a - Count 1) :: Int in if Int i forall a. Ord a => a -> a -> Bool < ByteString -> Int BS.length ByteString kt then case ByteString -> Int -> Word8 BSU.unsafeIndex ByteString kt Int i of Word8 91 -> forall c. [c] -> LightJson c LightJsonArray [] Word8 123 -> forall c. [(Text, c)] -> LightJson c LightJsonObject [] Word8 _ -> forall c. Text -> LightJson c LightJsonError Text "Invalid collection character" else forall c. Text -> LightJson c LightJsonError Text "Index out of bounds" else forall c. Text -> LightJson c LightJsonError Text "Unaligned cursor" where kpa :: Count kpa = forall v. Select1 v => v -> Count -> Count select1 v kib Count kta forall a. Num a => a -> a -> a + Count km kib :: v kib = forall t v w. JsonCursor t v w -> v JSC.interests JsonCursor ByteString v w k kra :: Count kra = forall t v w. JsonCursor t v w -> Count JSC.cursorRank JsonCursor ByteString v w k ksa :: Count ksa = Count kra forall a. Num a => a -> a -> a + Count 1 kta :: Count kta = Count ksa forall a. Integral a => a -> a -> a `div` Count 2 km :: Count km = Count ksa forall a. Integral a => a -> a -> a `mod` Count 2 kt :: ByteString kt = forall t v w. JsonCursor t v w -> t JSC.cursorText JsonCursor ByteString v w k