diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,9 +2,59 @@ [![0.0-branch](https://circleci.com/gh/haskell-works/hw-mquery/tree/0.0-branch.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-mquery/tree/0.0-branch) ``` -λ> import HaskellWorks.Data.MQuery -λ> import qualified Data.DList as DL -λ> !json <- loadJsonPartial "data/78mb.json" -λ> let q = MQuery (DL.singleton json) -λ> q >>= expandArray >>= expandObject +import Control.Monad +import qualified Data.DList as DL +import Data.Function +import Data.List +import HaskellWorks.Data.LoadJson +import HaskellWorks.Data.Micro +import HaskellWorks.Data.MQuery +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Row +import HaskellWorks.Diagnostics +import Text.PrettyPrint.ANSI.Leijen +``` + +``` +!json <- loadJsonPartial "data/78mb.json" +!json <- loadJsonWithIndex "data/78mb.json" +!json <- loadJsonWithPoppy512Index "data/78mb.json" +let q = MQuery (DL.singleton json) +``` + +``` +putPretty $ q >>= item & limit 10 +putPretty $ q >>= item & page 10 1 +putPretty $ q >>= item >>= hasKV "founded_year" (JsonPartialNumber 2005) & limit 10 +putPretty $ q >>= item >>= entry +putPretty $ q >>= item >>= entry >>= named "name" & limit 10 +putPretty $ q >>= item >>= entry >>= satisfying (\(k, _) -> k == "name") >>= value & limit 10 +putPretty $ q >>= item >>= entry >>= satisfying ((== "name") . fst) >>= value & limit 10 +putPretty $ q >>= (item >=> entry >=> key) & limit 10 +putPretty $ q >>= item >>= entry >>= key & limit 100 & onList (uniq . sort) +putPretty $ (q >>= item >>= entry & limit 1) >>= field "name" & limit 10 +putPretty $ do {j <- q; e <- item j; (k, v) <- entry e; return k} +putPretty $ do {j <- q; e <- item j; (k, v) <- entry e; guard (k == "name"); return v} +``` + +### Decoding +#### Line separated base 64 encoded gzipped json +while read in; do echo "$in" | base64 --decode | gunzip; echo ""; done < file.lgz > firehose.json + +### Profiling with stack traces +``` +mafia build -p +cabal repl --ghc-options='-fexternal-interpreter -prof' +``` + +``` +import HaskellWorks.Data.Succinct.BalancedParens +import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 +import HaskellWorks.Data.Positioning +import qualified Data.Vector.Storable as DVS +import HaskellWorks.Data.Vector.VectorLike +(jsonBS, jsonIb, jsonBp) <- loadJsonRawWithIndex "firehose.json" +let bp1 = SimpleBalancedParens jsonBp +let bp2 = SimpleBalancedParens (makePoppy512 jsonBp) +let bp3 = makePoppy512 jsonBp ``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +-- import Control.Monad +-- import qualified Data.DList as DL +-- import Data.Function +-- import HaskellWorks.Data.LoadJson +-- import HaskellWorks.Data.Micro +-- import HaskellWorks.Data.MQuery + +main :: IO () +main = do + putStrLn "Hello world" + -- !json <- loadJsonWithPoppy512SMinMaxIndex "firehose.json" + -- let q = MQuery (DL.singleton json) + -- putPretty $ q >>= ( + -- item >=> entry >=> named "attack" + -- >=> entry >=> named "instances" + -- >=> entry >=> named "instance" + -- >=> item + -- >=> entry >=> named "dataset" + -- >=> item >=> having (entry >=> named "name") >=> having (entry >=> named "name" >=> asString >=> valueOf "protos_bytes") + -- >=> entry >=> named "item" + -- >=> item >=> having (entry >=> named "name" >=> asString >=> valueOf "tcp") + -- >=> entry >=> named "class" + -- >=> entry >=> named "current" + -- >=> entry >=> named "value" + -- >=> castAsInteger) & aggregate sum diff --git a/hw-mquery.cabal b/hw-mquery.cabal --- a/hw-mquery.cabal +++ b/hw-mquery.cabal @@ -1,5 +1,5 @@ name: hw-mquery -version: 0.0.0.1 +version: 0.1.0.0 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-mquery#readme @@ -13,32 +13,28 @@ extra-source-files: README.md cabal-version: >= 1.22 +executable hw-mquery-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 + build-depends: base >= 4 && < 5 + , hw-mquery + default-language: Haskell2010 + library hs-source-dirs: src - exposed-modules: HaskellWorks.Data.LoadJson + exposed-modules: HaskellWorks.Data.AtLeastSize + , HaskellWorks.Data.Entry , HaskellWorks.Data.Micro , HaskellWorks.Data.Mini , HaskellWorks.Data.MQuery + , HaskellWorks.Data.Row + , HaskellWorks.Data.Shows + , HaskellWorks.Data.ToBool + build-depends: base >= 4 && < 5 - , array - , attoparsec - , bytestring - , conduit - , containers + , ansi-wl-pprint , dlist - , hw-bits - , hw-conduit - , hw-diagnostics - , hw-json - , hw-parser - , hw-prim >= 0.0.3.1 - , hw-rankselect >= 0.0.0.5 - , mmap - , mono-traversable - , resourcet - , text - , vector - , word8 default-language: Haskell2010 ghc-options: -Wall -O2 -msse4.2 @@ -49,22 +45,8 @@ main-is: Spec.hs other-modules: HaskellWorks.Data.MQuerySpec build-depends: base >= 4 && < 5 - , attoparsec - , bytestring - , containers - , conduit , hspec - , hw-bits - , hw-conduit - , hw-mquery - , hw-prim >= 0.0.3.1 - , hw-rankselect >= 0.0.0.5 - , mmap - , parsec , QuickCheck - , resourcet - , transformers - , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/src/HaskellWorks/Data/AtLeastSize.hs b/src/HaskellWorks/Data/AtLeastSize.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/AtLeastSize.hs @@ -0,0 +1,10 @@ + +module HaskellWorks.Data.AtLeastSize where + +class AtLeastSize a where + atLeastSize :: a -> Int -> Bool + +instance AtLeastSize [a] where + atLeastSize _ 0 = True + atLeastSize (_:as) n | n > 0 = atLeastSize as (n - 1) + atLeastSize _ _ = False diff --git a/src/HaskellWorks/Data/Entry.hs b/src/HaskellWorks/Data/Entry.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Entry.hs @@ -0,0 +1,8 @@ +module HaskellWorks.Data.Entry where + +import Text.PrettyPrint.ANSI.Leijen + +data Entry k v = Entry k v + +instance (Pretty k, Pretty v) => Pretty (Entry k v) where + pretty (Entry k v) = pretty k <> text ": " <> pretty v diff --git a/src/HaskellWorks/Data/LoadJson.hs b/src/HaskellWorks/Data/LoadJson.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/LoadJson.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.LoadJson where - -import Control.Monad -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Decode -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Json.PartialValue -import HaskellWorks.Data.Json.Succinct.Cursor -import HaskellWorks.Data.Json.Succinct.Index -import HaskellWorks.Data.Json.Succinct.PartialIndex -import HaskellWorks.Data.Json.Value -import HaskellWorks.Data.Succinct.BalancedParens.Simple -import HaskellWorks.Diagnostics.Time - -readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) -readJson path = do - bs <- BS.readFile path - putStrLn "Read file" - !cursor <- measure (fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) - putStrLn "Created cursor" - return cursor - -loadJson :: String -> IO (Either DecodeError [JsonValue]) -loadJson filename = do - !cursor <- readJson filename - let !jsonResult = (jsonIndexAt >=> jsonValueAt) cursor - return $ (:[]) `fmap` jsonResult - -loadJsonPartial :: String -> IO JsonPartialValue -loadJsonPartial filename = do - !cursor <- readJson filename - let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor) - return jsonResult diff --git a/src/HaskellWorks/Data/MQuery.hs b/src/HaskellWorks/Data/MQuery.hs --- a/src/HaskellWorks/Data/MQuery.hs +++ b/src/HaskellWorks/Data/MQuery.hs @@ -2,14 +2,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module HaskellWorks.Data.MQuery where import Control.Monad +import Data.List import qualified Data.DList as DL import GHC.Base -import HaskellWorks.Data.Json.PartialValue -import HaskellWorks.Data.Mini +import HaskellWorks.Data.Entry +-- import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Row +import HaskellWorks.Data.ToBool +import Text.PrettyPrint.ANSI.Leijen newtype MQuery a = MQuery (DL.DList a) @@ -19,39 +24,123 @@ deriving instance Alternative MQuery deriving instance MonadPlus MQuery -instance Show (MQuery JsonPartialValue) where - showsPrec _ (MQuery das) = shows (Mini (Mini `fmap` das)) +class IsPredicate a where + type ArgOf a + toPredicate :: ArgOf a -> (a -> Bool) -instance Show (MQuery (String, JsonPartialValue)) where - showsPrec _ (MQuery das) = shows (Mini (Mini `fmap` das)) +mQuery :: MQuery a -> DL.DList a +mQuery (MQuery a) = a -expandArray :: JsonPartialValue -> MQuery JsonPartialValue -expandArray jpv = case jpv of - JsonPartialArray es -> MQuery $ DL.fromList es - _ -> MQuery DL.empty +instance ToBool (MQuery a) where + toBool = toBool . mQuery -expandObject :: JsonPartialValue -> MQuery (String, JsonPartialValue) -expandObject jpv = case jpv of - JsonPartialObject fs -> MQuery $ DL.fromList fs - _ -> MQuery DL.empty +-- instance Pretty (MQuery JsonPartialValue) where +-- pretty = pretty . Row 120 . mQuery -selectField :: String -> (String, JsonPartialValue) -> MQuery JsonPartialValue -selectField fieldName (fieldName', jpv) | fieldName == fieldName' = MQuery $ DL.singleton jpv -selectField _ _ = MQuery DL.empty +instance Pretty (MQuery String) where + pretty x = prettyRowOfString (Row 120 (mQuery x)) -jsonKeys :: JsonPartialValue -> [String] -jsonKeys jpv = case jpv of - JsonPartialObject fs -> fst `map` fs - _ -> [] +instance Pretty (MQuery Integer) where + pretty x = prettyRowOfString (Row 120 (mQuery x)) -hasKey :: String -> JsonPartialValue -> Bool -hasKey fieldName jpv = fieldName `elem` jsonKeys jpv +instance Pretty (MQuery Int) where + pretty x = prettyRowOfString (Row 120 (mQuery x)) -inArray :: MQuery JsonPartialValue -> MQuery JsonPartialValue -inArray jpvs = jpvs >>= expandArray +-- instance Pretty (MQuery (Entry String JsonPartialValue)) where +-- pretty (MQuery das) = pretty (Row 120 das) +-- +-- hasKV :: String -> JsonPartialValue -> JsonPartialValue -> MQuery JsonPartialValue +-- hasKV k v (JsonPartialObject xs) = if (k, v) `elem` xs then MQuery (DL.singleton (JsonPartialObject xs)) else MQuery DL.empty +-- hasKV _ _ _ = MQuery DL.empty +-- +-- item :: JsonPartialValue -> MQuery JsonPartialValue +-- item jpv = case jpv of +-- JsonPartialArray es -> MQuery $ DL.fromList es +-- _ -> MQuery DL.empty +-- +-- entry :: JsonPartialValue -> MQuery (Entry String JsonPartialValue) +-- entry jpv = case jpv of +-- JsonPartialObject fs -> MQuery $ DL.fromList (uncurry Entry `map` fs) +-- _ -> MQuery DL.empty +-- +-- asString :: JsonPartialValue -> MQuery String +-- asString jpv = case jpv of +-- JsonPartialString s -> MQuery $ DL.singleton s +-- _ -> MQuery DL.empty +-- +-- asInteger :: JsonPartialValue -> MQuery Integer +-- asInteger jpv = case jpv of +-- JsonPartialNumber n -> MQuery $ DL.singleton (floor n) +-- _ -> MQuery DL.empty +-- +-- castAsInteger :: JsonPartialValue -> MQuery Integer +-- castAsInteger jpv = case jpv of +-- JsonPartialString n -> MQuery $ DL.singleton (read n) +-- JsonPartialNumber n -> MQuery $ DL.singleton (floor n) +-- _ -> MQuery DL.empty +-- +-- named :: String -> Entry String JsonPartialValue -> MQuery JsonPartialValue +-- named fieldName (Entry fieldName' jpv) | fieldName == fieldName' = MQuery $ DL.singleton jpv +-- named _ _ = MQuery DL.empty -jsonSize :: JsonPartialValue -> MQuery JsonPartialValue -jsonSize jpv = case jpv of - JsonPartialArray es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) - JsonPartialObject es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) - _ -> MQuery (DL.singleton (JsonPartialNumber 0)) +satisfying :: (a -> Bool) -> a -> MQuery a +satisfying p a | p a = MQuery $ DL.singleton a +satisfying _ _ = MQuery DL.empty + +key :: Entry k v -> MQuery k +key (Entry k _) = MQuery $ DL.singleton k + +value :: Entry k v -> MQuery v +value (Entry _ v) = MQuery $ DL.singleton v + +dlTake :: Int -> DL.DList a -> DL.DList a +dlTake n = DL.fromList . take n . DL.toList + +select :: ToBool b => a -> (a -> b) -> MQuery a +select a f = if toBool (f a) then MQuery (DL.singleton a) else MQuery DL.empty + +-- jsonKeys :: JsonPartialValue -> [String] +-- jsonKeys jpv = case jpv of +-- JsonPartialObject fs -> fst `map` fs +-- _ -> [] +-- +-- hasKey :: String -> JsonPartialValue -> Bool +-- hasKey fieldName jpv = fieldName `elem` jsonKeys jpv +-- +-- jsonSize :: JsonPartialValue -> MQuery JsonPartialValue +-- jsonSize jpv = case jpv of +-- JsonPartialArray es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) +-- JsonPartialObject es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) +-- _ -> MQuery (DL.singleton (JsonPartialNumber 0)) + +having :: (a -> MQuery b) -> a -> MQuery a +having p a = case p a of + MQuery das -> case DL.toList das of + _:_ -> MQuery (DL.singleton a) + _ -> MQuery DL.empty + +valueOf :: Eq a => a -> a -> MQuery a +valueOf a b = if a == b then MQuery (DL.singleton b) else MQuery DL.empty + +limit :: Int -> MQuery a -> MQuery a +limit n (MQuery xs) = MQuery ((DL.fromList . take n . DL.toList) xs) + +skip :: Int -> MQuery a -> MQuery a +skip n (MQuery xs) = MQuery ((DL.fromList . drop n . DL.toList) xs) + +page :: Int -> Int -> MQuery a -> MQuery a +page size n (MQuery xs) = MQuery ((DL.fromList . take size . drop (size * n) . DL.toList) xs) + +sorted :: Ord a => MQuery a -> MQuery a +sorted (MQuery xs) = MQuery ((DL.fromList . sort . DL.toList) xs) + +onList :: ([a] -> [a]) -> MQuery a -> MQuery a +onList f (MQuery xs) = MQuery ((DL.fromList . f . DL.toList) xs) + +aggregate :: ([a] -> b) -> MQuery a -> MQuery b +aggregate f (MQuery xs) = MQuery (DL.fromList [f (DL.toList xs)]) + +uniq :: Eq a => [a] -> [a] +uniq (a:b:cs) | a == b = uniq (b:cs) +uniq (a:b:cs) = a:uniq (b:cs) +uniq cs = cs diff --git a/src/HaskellWorks/Data/Micro.hs b/src/HaskellWorks/Data/Micro.hs --- a/src/HaskellWorks/Data/Micro.hs +++ b/src/HaskellWorks/Data/Micro.hs @@ -1,37 +1,48 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.Data.Micro where import qualified Data.DList as DL -import Data.List -import HaskellWorks.Data.Json.PartialValue +-- import HaskellWorks.Data.Json.PartialValue +import Text.PrettyPrint.ANSI.Leijen newtype Micro a = Micro a -instance Show (Micro JsonPartialValue) where - showsPrec _ v = case v of - Micro (JsonPartialString s ) -> shows s - Micro (JsonPartialNumber n ) -> shows n - Micro (JsonPartialObject []) -> ("{}" ++) - Micro (JsonPartialObject _ ) -> ("{..}" ++) - Micro (JsonPartialArray [] ) -> ("[]" ++) - Micro (JsonPartialArray _ ) -> ("[..]" ++) - Micro (JsonPartialBool w ) -> shows w - Micro JsonPartialNull -> ("null" ++) - Micro (JsonPartialError s ) -> ("" ++) +prettyVs :: Pretty a => [a] -> Doc +prettyVs (kv:kvs) = pretty kv <> foldl (<>) empty ((\jv -> text ", " <> pretty jv) `map` kvs) +prettyVs [] = empty -instance Show (Micro (String, JsonPartialValue)) where - showsPrec _ (Micro (fieldName, jpv)) = shows fieldName . (": " ++) . shows (Micro jpv) +putPretty :: Pretty a => a -> IO () +putPretty a = putDoc (pretty a <> hardline) -instance Show a => Show (Micro [a]) where - show (Micro xs) = case length xs of - xsLen | xsLen == 0 -> "[]" - xsLen | xsLen <= 50 -> "[" ++ intercalate ", " (show `map` xs) ++ "]" - _ -> "[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]" +prettyKvs :: Pretty (Micro a) => [a] -> Doc +prettyKvs (kv:kvs) = pretty (Micro kv) <> foldl (<>) empty ((\jv -> text ", " <> pretty (Micro jv)) `map` kvs) +prettyKvs [] = empty -instance Show a => Show (Micro (DL.DList a)) where - showsPrec _ (Micro dxs) = case DL.toList dxs of - xs@(_:_:_:_:_:_:_:_:_:_:_:_:_) -> (("[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]") ++) - [] -> ("[]" ++) - xs -> (("[" ++ intercalate ", " (show `map` xs) ++ "]") ++) +-- instance Pretty (Micro JsonPartialValue) where +-- pretty (Micro (JsonPartialString s )) = dullgreen (text (show s)) +-- pretty (Micro (JsonPartialNumber n )) = cyan (text (show n)) +-- pretty (Micro (JsonPartialObject [])) = text "{}" +-- pretty (Micro (JsonPartialObject _ )) = text "{..}" +-- pretty (Micro (JsonPartialArray [] )) = text "[]" +-- pretty (Micro (JsonPartialArray _ )) = text "[..]" +-- pretty (Micro (JsonPartialBool w )) = red (text (show w)) +-- pretty (Micro JsonPartialNull ) = text "null" +-- pretty (Micro (JsonPartialError s )) = text " text s <> text ">" +-- +-- instance Pretty (Micro (String, JsonPartialValue)) where +-- pretty (Micro (fieldName, jpv)) = red (text (show fieldName)) <> text ": " <> pretty (Micro jpv) + +instance Pretty a => Pretty (Micro [a]) where + pretty (Micro xs) = case length xs of + xsLen | xsLen == 0 -> text "[]" + xsLen | xsLen <= 10 -> text "[" <> prettyVs xs <> text "]" + _ -> text "[" <> prettyVs (take 10 xs) <> text ", ..]" + +instance Pretty a => Pretty (Micro (DL.DList a)) where + pretty (Micro dxs) = case DL.toList dxs of + xs@(_:_:_:_:_:_:_:_:_:_:_:_:_) -> text "[" <> prettyVs (take 50 xs) <> text ", ..]" + [] -> text "[]" + xs -> text "[" <> prettyVs xs <> text "]" diff --git a/src/HaskellWorks/Data/Mini.hs b/src/HaskellWorks/Data/Mini.hs --- a/src/HaskellWorks/Data/Mini.hs +++ b/src/HaskellWorks/Data/Mini.hs @@ -1,50 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.Data.Mini where import qualified Data.DList as DL -import Data.List -import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.AtLeastSize +-- import HaskellWorks.Data.Json.PartialValue import HaskellWorks.Data.Micro +import Text.PrettyPrint.ANSI.Leijen newtype Mini a = Mini a -instance Show a => Show (Mini [a]) where - show (Mini xs) = case length xs of - xsLen | xsLen == 0 -> "[]" - xsLen | xsLen <= 50 -> "[" ++ intercalate ", " (show `map` xs) ++ "]" - _ -> "[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]" - -instance Show a => Show (Mini (DL.DList a)) where - showsPrec _ (Mini dxs) = case DL.toList dxs of - xs@(_:_:_:_:_:_:_:_:_:_:_:_:_) -> (("[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]") ++) - [] -> ("[]" ++) - xs -> (("[" ++ intercalate ", " (show `map` xs) ++ "]") ++) +instance Pretty (Micro a) => Pretty (Mini [a]) where + pretty (Mini xs) | xs `atLeastSize` 11 = text "[" <> nest 2 (prettyVs (take 10 (Micro `map` xs))) <> text ", ..]" + pretty (Mini xs) | xs `atLeastSize` 1 = text "[" <> nest 2 (prettyVs (take 10 (Micro `map` xs))) <> text "]" + pretty (Mini _ ) = text "[]" -instance Show (Mini JsonPartialValue) where - showsPrec _ mjpv = case mjpv of - Mini (JsonPartialString s ) -> shows s - Mini (JsonPartialNumber n ) -> shows n - Mini (JsonPartialObject [] ) -> ("{}" ++) - Mini (JsonPartialObject kvs ) -> case kvs of - (_:_:_:_:_:_:_:_:_:_:_:_:_) -> ("{" ++) . showKvs kvs . (", ..}" ++) - [] -> ("{}" ++) - _ -> ("{" ++) . showKvs kvs . ("}" ++) - Mini (JsonPartialArray [] ) -> ("[]" ++) - Mini (JsonPartialArray vs ) -> case vs of - (_:_:_:_:_:_:_:_:_:_:_:_:_) -> ("[" ++) . showVs vs . (", ..]" ++) - [] -> ("[]" ++) - _ -> ("[" ++) . showVs vs . ("]" ++) - Mini (JsonPartialBool w ) -> shows w - Mini JsonPartialNull -> ("null" ++) - Mini (JsonPartialError s ) -> ("" ++) - where showKvs :: [(String, JsonPartialValue)] -> String -> String - showKvs (kv:kvs) = shows (Micro kv) . foldl (.) id ((\jv -> (", " ++) . shows (Micro jv)) `map` kvs) - showKvs [] = id - showVs :: [JsonPartialValue] -> String -> String - showVs (kv:kvs) = shows (Micro kv) . foldl (.) id ((\jv -> (", " ++) . shows (Micro jv)) `map` kvs) - showVs [] = id +instance Pretty (Mini a) => Pretty (Mini (DL.DList a)) where + pretty (Mini xs) = vcat (punctuate (text ",") ((pretty . Mini) `map` take 10 (DL.toList xs))) -instance Show (Mini (String, JsonPartialValue)) where - showsPrec _ (Mini (fieldName, jpv)) = shows fieldName . (": " ++) . shows (Mini jpv) +-- instance Pretty (Mini JsonPartialValue) where +-- pretty mjpv = case mjpv of +-- Mini (JsonPartialString s ) -> dullgreen (text (show s)) +-- Mini (JsonPartialNumber n ) -> cyan (text (show n)) +-- Mini (JsonPartialObject [] ) -> text "{}" +-- Mini (JsonPartialObject kvs ) -> case kvs of +-- (_:_:_:_:_:_:_:_:_:_:_:_:_) -> text "{" <> prettyKvs kvs <> text ", ..}" +-- [] -> text "{}" +-- _ -> text "{" <> prettyKvs kvs <> text "}" +-- Mini (JsonPartialArray [] ) -> text "[]" +-- Mini (JsonPartialArray vs ) | vs `atLeastSize` 11 -> text "[" <> nest 2 (prettyVs (Micro `map` take 10 vs)) <> text ", ..]" +-- Mini (JsonPartialArray vs ) | vs `atLeastSize` 1 -> text "[" <> nest 2 (prettyVs (Micro `map` take 10 vs)) <> text "]" +-- Mini (JsonPartialArray _ ) -> text "[]" +-- Mini (JsonPartialBool w ) -> red (text (show w)) +-- Mini JsonPartialNull -> text "null" +-- Mini (JsonPartialError s ) -> text " text s <> text ">" +-- +-- instance Pretty (Mini (String, JsonPartialValue)) where +-- pretty (Mini (fieldName, jpv)) = text (show fieldName) <> text ": " <> pretty (Mini jpv) diff --git a/src/HaskellWorks/Data/Row.hs b/src/HaskellWorks/Data/Row.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Row.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.Row where + +import qualified Data.DList as DL +import Text.PrettyPrint.ANSI.Leijen + +type MaxChars = Int + +data Row a = Row MaxChars a + +instance Pretty a => Pretty (Row (DL.DList a)) where + pretty (Row maxChars xs) = vcat (((bold . yellow) (text "==> ") <>) `map` prettyRows) + where + prettyRows :: [Doc] + prettyRows = (\row -> text (take maxChars (displayS (renderCompact (pretty row)) []))) `map` DL.toList xs + +prettyRowOfString :: Show a => Row (DL.DList a) -> Doc +prettyRowOfString (Row _ xs) = vcat (((bold . yellow) (text "==> ") <>) `map` prettyRows) + where + prettyRows :: [Doc] + prettyRows = (text . show) `map` DL.toList xs diff --git a/src/HaskellWorks/Data/Shows.hs b/src/HaskellWorks/Data/Shows.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Shows.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} + +module HaskellWorks.Data.Shows where + +import HaskellWorks.Data.Micro + +showsVs :: Show a => [a] -> String -> String +showsVs (kv:kvs) = shows kv . foldl (.) id ((\jv -> (", " ++) . shows jv) `map` kvs) +showsVs [] = id + +showKvs :: Show (Micro a) => [a] -> String -> String +showKvs (kv:kvs) = shows (Micro kv) . foldl (.) id ((\jv -> (", " ++) . shows (Micro jv)) `map` kvs) +showKvs [] = id diff --git a/src/HaskellWorks/Data/ToBool.hs b/src/HaskellWorks/Data/ToBool.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/ToBool.hs @@ -0,0 +1,17 @@ + +module HaskellWorks.Data.ToBool where + +import qualified Data.DList as DL + +class ToBool a where + toBool :: a -> Bool + +instance ToBool Bool where + toBool = id + +instance ToBool [a] where + toBool (_:_) = True + toBool _ = False + +instance ToBool (DL.DList a) where + toBool = toBool . DL.toList