{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Aeson.Match.QQ.Internal.PrettyPrint ( pp ) where import qualified Data.Aeson as Aeson import Data.Bool (bool) import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Char as Char import Data.Foldable (toList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int64) import qualified Data.List as List import Data.Scientific (Scientific, floatingOrInteger) import Data.String (fromString) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text (Text) import Data.Vector (Vector) import Text.PrettyPrint ((<+>)) import qualified Text.PrettyPrint as PP import Aeson.Match.QQ.Internal.Value ( Matcher(..) , HoleSig(..) , Type(..) , Box(..) ) pp :: Matcher Aeson.Value -> PP.Doc pp :: Matcher Value -> Doc pp Matcher Value value = [Doc] -> Doc PP.vcat [ Doc "[qq|" , Int -> Doc -> Doc PP.nest Int 2 (Matcher Value -> Doc rValue Matcher Value value) , Doc "|]" ] rValue :: Matcher Aeson.Value -> PP.Doc rValue :: Matcher Value -> Doc rValue = \case Hole Maybe HoleSig sig Maybe Text name -> Maybe HoleSig -> Maybe Text -> Doc rHole Maybe HoleSig sig Maybe Text name Matcher Value Null -> Doc rNull Bool Bool b -> Bool -> Doc rBool Bool b Number Scientific n -> Scientific -> Doc rNumber Scientific n String Text str -> Text -> Doc rString Text str StringCI CI Text str -> CI Text -> Doc rStringCI CI Text str Array Array Value xs -> Array Value -> Doc rArray Array Value xs ArrayUO Array Value xs -> Array Value -> Doc rArrayUO Array Value xs Object Object Value o -> Object Value -> Doc rObject Object Value o Ext Value ext -> Value -> Doc rExt Value ext rHole :: Maybe HoleSig -> Maybe Text -> PP.Doc rHole :: Maybe HoleSig -> Maybe Text -> Doc rHole Maybe HoleSig sig Maybe Text name = (Doc "_" forall a. Semigroup a => a -> a -> a <> forall b a. b -> (a -> b) -> Maybe a -> b maybe Doc PP.empty Text -> Doc rName Maybe Text name) Doc -> Doc -> Doc <+> forall b a. b -> (a -> b) -> Maybe a -> b maybe Doc PP.empty HoleSig -> Doc rSig Maybe HoleSig sig rName :: Text -> PP.Doc rName :: Text -> Doc rName Text name = String -> Doc PP.text (forall a. a -> a -> Bool -> a bool (Text -> String Text.unpack Text name) (forall a. Show a => a -> String show Text name) (Text -> Bool hasSpaces Text name)) where hasSpaces :: Text -> Bool hasSpaces = (Char -> Bool) -> Text -> Bool Text.any Char -> Bool Char.isSpace rSig :: HoleSig -> PP.Doc rSig :: HoleSig -> Doc rSig HoleSig {Type type_ :: HoleSig -> Type type_ :: Type type_, Bool nullable :: HoleSig -> Bool nullable :: Bool nullable} = (Doc ":" Doc -> Doc -> Doc <+> Type -> Doc rType Type type_) forall a. Semigroup a => a -> a -> a <> forall a. a -> a -> Bool -> a bool Doc PP.empty Doc "?" Bool nullable where rType :: Type -> Doc rType = \case Type BoolT -> Doc "bool" Type NumberT -> Doc "number" Type StringT -> Doc "string" Type StringCIT -> Doc "ci-string" Type ArrayT -> Doc "array" Type ArrayUOT -> Doc "unordered-array" Type ObjectT -> Doc "object" rNull :: PP.Doc rNull :: Doc rNull = Doc "null" rBool :: Bool -> PP.Doc rBool :: Bool -> Doc rBool = forall a. a -> a -> Bool -> a bool Doc "false" Doc "true" rNumber :: Scientific -> PP.Doc rNumber :: Scientific -> Doc rNumber = forall a. IsString a => String -> a fromString forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a. Show a => a -> String show @Double) (forall a. Show a => a -> String show @Int64) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall r i. (RealFloat r, Integral i) => Scientific -> Either r i floatingOrInteger rString :: Text -> PP.Doc rString :: Text -> Doc rString = forall a. IsString a => String -> a fromString forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Show a => a -> String show rStringCI :: CI Text -> PP.Doc rStringCI :: CI Text -> Doc rStringCI CI Text str = [Doc] -> Doc PP.vcat [ Doc "(ci)" , Text -> Doc rString (forall s. CI s -> s CI.original CI Text str) ] rArray :: Box (Vector (Matcher Aeson.Value)) -> PP.Doc rArray :: Array Value -> Doc rArray Box {Vector (Matcher Value) values :: forall a. Box a -> a values :: Vector (Matcher Value) values, Bool extra :: forall a. Box a -> Bool extra :: Bool extra} = case forall (t :: * -> *) a. Foldable t => t a -> [a] toList Vector (Matcher Value) values of [] -> Doc "[]" Matcher Value x : [Matcher Value] xs -> [Doc] -> Doc PP.vcat forall a b. (a -> b) -> a -> b $ [Doc "[" Doc -> Doc -> Doc <+> Matcher Value -> Doc rValue Matcher Value x] forall a. Semigroup a => a -> a -> a <> forall a b. (a -> b) -> [a] -> [b] map (\Matcher Value x' -> Doc "," Doc -> Doc -> Doc <+> Matcher Value -> Doc rValue Matcher Value x') [Matcher Value] xs forall a. Semigroup a => a -> a -> a <> [forall a. a -> a -> Bool -> a bool Doc PP.empty Doc ", ..." Bool extra, Doc "]"] rArrayUO :: Box (Vector (Matcher Aeson.Value)) -> PP.Doc rArrayUO :: Array Value -> Doc rArrayUO Array Value box = [Doc] -> Doc PP.vcat [ Doc "(unordered)" , Array Value -> Doc rArray Array Value box ] rExt :: Aeson.Value -> PP.Doc rExt :: Value -> Doc rExt = forall a. IsString a => String -> a fromString forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> Text Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString ByteString.Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToJSON a => a -> ByteString Aeson.encode rObject :: Box (HashMap Text (Matcher Aeson.Value)) -> PP.Doc rObject :: Object Value -> Doc rObject Box {HashMap Text (Matcher Value) values :: HashMap Text (Matcher Value) values :: forall a. Box a -> a values, Bool extra :: Bool extra :: forall a. Box a -> Bool extra} = case forall b a. Ord b => (a -> b) -> [a] -> [a] List.sortOn forall a b. (a, b) -> a fst (forall k v. HashMap k v -> [(k, v)] HashMap.toList HashMap Text (Matcher Value) values) of [] -> Doc "{}" (Text, Matcher Value) kv : [(Text, Matcher Value)] kvs -> [Doc] -> Doc PP.vcat forall a b. (a -> b) -> a -> b $ [Doc "{" Doc -> Doc -> Doc <+> (Text, Matcher Value) -> Doc rKeyValue (Text, Matcher Value) kv] forall a. Semigroup a => a -> a -> a <> forall a b. (a -> b) -> [a] -> [b] map (\(Text, Matcher Value) kv' -> Doc "," Doc -> Doc -> Doc <+> (Text, Matcher Value) -> Doc rKeyValue (Text, Matcher Value) kv') [(Text, Matcher Value)] kvs forall a. Semigroup a => a -> a -> a <> [forall a. a -> a -> Bool -> a bool Doc PP.empty Doc ", ..." Bool extra, Doc "}"] where rKeyValue :: (Text, Matcher Value) -> Doc rKeyValue (Text key, Matcher Value value) = if Matcher Value -> Bool simpleValue Matcher Value value then (Text -> Doc rName Text key forall a. Semigroup a => a -> a -> a <> Doc ":") Doc -> Doc -> Doc <+> Matcher Value -> Doc rValue Matcher Value value else [Doc] -> Doc PP.vcat [ Text -> Doc rName Text key forall a. Semigroup a => a -> a -> a <> Doc ":" , Matcher Value -> Doc rValue Matcher Value value ] simpleValue :: Matcher Aeson.Value -> Bool simpleValue :: Matcher Value -> Bool simpleValue = \case Hole {} -> Bool True Null {} -> Bool True Bool {} -> Bool True Number {} -> Bool True String {} -> Bool True StringCI {} -> Bool True Array {} -> Bool False ArrayUO {} -> Bool False Object {} -> Bool False Ext {} -> Bool True