{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-orphans #-} module Language.Jsonnet.Pretty where import qualified Data.Aeson as JSON import qualified Data.Aeson.Text as JSON (encodeToLazyText) import qualified Data.HashMap.Lazy as H import Data.List (sortOn) import Data.Scientific (Scientific (..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder.Scientific (scientificBuilder) import qualified Data.Vector as V import GHC.IO.Exception (IOException (..)) import Language.Jsonnet.Common import Language.Jsonnet.Error import Language.Jsonnet.Parser.SrcSpan import Text.Megaparsec.Error (errorBundlePretty) import Text.Megaparsec.Pos import Text.PrettyPrint.ANSI.Leijen hiding (encloseSep, (<$>)) import Unbound.Generics.LocallyNameless (Name, name2String) instance Pretty (Name a) where pretty :: Name a -> Doc pretty Name a v = String -> Doc forall a. Pretty a => a -> Doc pretty (Name a -> String forall a. Name a -> String name2String Name a v) instance Pretty Text where pretty :: Text -> Doc pretty Text v = String -> Doc forall a. Pretty a => a -> Doc pretty (Text -> String T.unpack Text v) ppNumber :: Scientific -> Doc ppNumber Scientific s | Int e Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 Bool -> Bool -> Bool || Int e Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 1024 = String -> Doc text (String -> Doc) -> String -> Doc forall a b. (a -> b) -> a -> b $ Text -> String LT.unpack (Text -> String) -> Text -> String forall a b. (a -> b) -> a -> b $ Builder -> Text toLazyText (Builder -> Text) -> Builder -> Text forall a b. (a -> b) -> a -> b $ Scientific -> Builder scientificBuilder Scientific s | Bool otherwise = Integer -> Doc integer (Scientific -> Integer coefficient Scientific s Integer -> Integer -> Integer forall a. Num a => a -> a -> a * Integer 10 Integer -> Int -> Integer forall a b. (Num a, Integral b) => a -> b -> a ^ Int e) where e :: Int e = Scientific -> Int base10Exponent Scientific s ppJson :: Int -> JSON.Value -> Doc ppJson :: Int -> Value -> Doc ppJson Int i = \case Value JSON.Null -> String -> Doc text String "null" JSON.Number Scientific n -> Scientific -> Doc ppNumber Scientific n JSON.Bool Bool True -> String -> Doc text String "true" JSON.Bool Bool False -> String -> Doc text String "false" JSON.String Text s -> Text -> Doc ppString Text s JSON.Array Array a -> Array -> Doc ppArray Array a JSON.Object Object o -> Object -> Doc ppObject Object o where encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep Doc l Doc r Doc s [Doc] ds = case [Doc] ds of [] -> Doc l Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc r [Doc] _ -> Doc l Doc -> Doc -> Doc <$$> Int -> Doc -> Doc indent Int i ([Doc] -> Doc vcat ([Doc] -> Doc) -> [Doc] -> Doc forall a b. (a -> b) -> a -> b $ Doc -> [Doc] -> [Doc] punctuate Doc s [Doc] ds) Doc -> Doc -> Doc <$$> Doc r ppObject :: Object -> Doc ppObject Object o = Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep Doc lbrace Doc rbrace Doc comma [Doc] xs where prop :: (Text, Value) -> Doc prop (Text k, Value v) = Text -> Doc ppString Text k Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc colon Doc -> Doc -> Doc <+> Int -> Value -> Doc ppJson Int i Value v xs :: [Doc] xs = ((Text, Value) -> Doc) -> [(Text, Value)] -> [Doc] forall a b. (a -> b) -> [a] -> [b] map (Text, Value) -> Doc prop (((Text, Value) -> Text) -> [(Text, Value)] -> [(Text, Value)] forall b a. Ord b => (a -> b) -> [a] -> [a] sortOn (Text, Value) -> Text forall a b. (a, b) -> a fst ([(Text, Value)] -> [(Text, Value)]) -> [(Text, Value)] -> [(Text, Value)] forall a b. (a -> b) -> a -> b $ Object -> [(Text, Value)] forall k v. HashMap k v -> [(k, v)] H.toList Object o) ppArray :: Array -> Doc ppArray Array a = Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep Doc lbracket Doc rbracket Doc comma [Doc] xs where xs :: [Doc] xs = (Value -> Doc) -> [Value] -> [Doc] forall a b. (a -> b) -> [a] -> [b] map (Int -> Value -> Doc ppJson Int i) (Array -> [Value] forall a. Vector a -> [a] V.toList Array a) ppString :: Text -> Doc ppString = String -> Doc text (String -> Doc) -> (Text -> String) -> Text -> Doc forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String LT.unpack (Text -> String) -> (Text -> Text) -> Text -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Text forall a. ToJSON a => a -> Text JSON.encodeToLazyText instance Pretty JSON.Value where pretty :: Value -> Doc pretty = Int -> Value -> Doc ppJson Int 4 instance Pretty SrcSpan where pretty :: SrcSpan -> Doc pretty SrcSpan {SourcePos spanBegin :: SrcSpan -> SourcePos spanBegin :: SourcePos spanBegin, SourcePos spanEnd :: SrcSpan -> SourcePos spanEnd :: SourcePos spanEnd} = String -> Doc text (SourcePos -> String sourceName SourcePos spanBegin) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc colon Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> SourcePos -> SourcePos -> Doc lc SourcePos spanBegin SourcePos spanEnd where lc :: SourcePos -> SourcePos -> Doc lc (SourcePos String _ Pos lb Pos cb) (SourcePos String _ Pos le Pos ce) | Pos lb Pos -> Pos -> Bool forall a. Eq a => a -> a -> Bool == Pos le = Int -> Doc int (Pos -> Int unPos Pos lb) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc colon Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Int -> Doc int (Pos -> Int unPos Pos cb) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc dash Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Int -> Doc int (Pos -> Int unPos Pos ce) | Bool otherwise = Int -> Doc int (Pos -> Int unPos Pos lb) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc colon Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Int -> Doc int (Pos -> Int unPos Pos cb) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc dash Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Int -> Doc int (Pos -> Int unPos Pos le) Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Doc colon Doc -> Doc -> Doc forall a. Semigroup a => a -> a -> a <> Int -> Doc int (Pos -> Int unPos Pos ce) dash :: Doc dash = Char -> Doc char Char '-' instance Pretty ParserError where pretty :: ParserError -> Doc pretty (ParseError ParseErrorBundle Text Void e) = String -> Doc forall a. Pretty a => a -> Doc pretty (ParseErrorBundle Text Void -> String forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String errorBundlePretty ParseErrorBundle Text Void e) pretty (ImportError (IOError Maybe Handle _ IOErrorType _ String _ String desc Maybe CInt _ Maybe String f) Maybe SrcSpan sp) = String -> Doc text String "Parse error:" Doc -> Doc -> Doc <+> Maybe String -> Doc forall a. Pretty a => a -> Doc pretty Maybe String f Doc -> Doc -> Doc <+> Doc -> Doc parens (String -> Doc text String desc) Doc -> Doc -> Doc <$$> Int -> Doc -> Doc indent Int 4 (Maybe SrcSpan -> Doc forall a. Pretty a => a -> Doc pretty Maybe SrcSpan sp) instance Pretty CheckError where pretty :: CheckError -> Doc pretty = \case DuplicateParam String e -> String -> Doc text String "duplicate parameter" Doc -> Doc -> Doc <+> Doc -> Doc squotes (String -> Doc text String e) DuplicateBinding String e -> String -> Doc text String "duplicate local var" Doc -> Doc -> Doc <+> Doc -> Doc squotes (String -> Doc text String e) CheckError PosAfterNamedParam -> String -> Doc text String "positional after named argument" instance Pretty EvalError where pretty :: EvalError -> Doc pretty = \case TypeMismatch {Text actual :: EvalError -> Text expected :: EvalError -> Text actual :: Text expected :: Text ..} -> String -> Doc text String "type mismatch:" Doc -> Doc -> Doc <+> String -> Doc text String "expected" Doc -> Doc -> Doc <+> String -> Doc text (Text -> String T.unpack Text expected) Doc -> Doc -> Doc <+> String -> Doc text String "but got" Doc -> Doc -> Doc <+> String -> Doc text (Text -> String T.unpack Text actual) InvalidKey Doc k -> String -> Doc text String "invalid key:" Doc -> Doc -> Doc <+> Doc k InvalidIndex Doc k -> String -> Doc text String "invalid index:" Doc -> Doc -> Doc <+> Doc k NoSuchKey Doc k -> String -> Doc text String "no such key:" Doc -> Doc -> Doc <+> Doc k IndexOutOfBounds Scientific i -> String -> Doc text String "index out of bounds:" Doc -> Doc -> Doc <+> Scientific -> Doc ppNumber Scientific i EvalError DivByZero -> String -> Doc text String "divide by zero exception" VarNotFound Doc v -> String -> Doc text String "variable" Doc -> Doc -> Doc <+> Doc -> Doc squotes (String -> Doc text (String -> Doc) -> String -> Doc forall a b. (a -> b) -> a -> b $ Doc -> String forall a. Show a => a -> String show Doc v) Doc -> Doc -> Doc <+> String -> Doc text String "is not defined" AssertionFailed Doc e -> String -> Doc text String "assertion failed:" Doc -> Doc -> Doc <+> Doc e StdError Doc e -> Doc e RuntimeError Doc e -> Doc e ParamNotBound Doc s -> String -> Doc text String "parameter not bound:" Doc -> Doc -> Doc <+> String -> Doc text (Doc -> String forall a. Show a => a -> String show Doc s) BadParam Doc s -> String -> Doc text String "function has no parameter" Doc -> Doc -> Doc <+> Doc -> Doc squotes Doc s ManifestError Doc e -> String -> Doc text String "manifest error:" Doc -> Doc -> Doc <+> Doc e TooManyArgs Int n -> String -> Doc text String "too many args, function has" Doc -> Doc -> Doc <+> Int -> Doc int Int n Doc -> Doc -> Doc <+> Doc "parameter(s)" instance Pretty (StackFrame a) where pretty :: StackFrame a -> Doc pretty StackFrame {Maybe (Name a) SrcSpan span :: forall a. StackFrame a -> SrcSpan name :: forall a. StackFrame a -> Maybe (Name a) span :: SrcSpan name :: Maybe (Name a) ..} = SrcSpan -> Doc forall a. Pretty a => a -> Doc pretty SrcSpan span Doc -> Doc -> Doc <+> Maybe Doc -> Doc forall a. Pretty a => a -> Doc pretty Maybe Doc name' where name' :: Maybe Doc name' = Doc -> Doc -> Doc (<+>) (String -> Doc text String "function") (Doc -> Doc) -> (Name a -> Doc) -> Name a -> Doc forall b c a. (b -> c) -> (a -> b) -> a -> c . Doc -> Doc angles (Doc -> Doc) -> (Name a -> Doc) -> Name a -> Doc forall b c a. (b -> c) -> (a -> b) -> a -> c . Name a -> Doc forall a. Pretty a => a -> Doc pretty (Name a -> Doc) -> Maybe (Name a) -> Maybe Doc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe (Name a) name instance Pretty (Backtrace a) where pretty :: Backtrace a -> Doc pretty (Backtrace [StackFrame a] xs) = [Doc] -> Doc vcat ([Doc] -> Doc) -> [Doc] -> Doc forall a b. (a -> b) -> a -> b $ StackFrame a -> Doc forall a. Pretty a => a -> Doc pretty (StackFrame a -> Doc) -> [StackFrame a] -> [Doc] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [StackFrame a] xs instance Pretty Error where pretty :: Error -> Doc pretty = \case EvalError EvalError e Backtrace Core bt -> String -> Doc text String "Runtime error:" Doc -> Doc -> Doc <+> EvalError -> Doc forall a. Pretty a => a -> Doc pretty EvalError e Doc -> Doc -> Doc <$$> Int -> Doc -> Doc indent Int 2 (Backtrace Core -> Doc forall a. Pretty a => a -> Doc pretty Backtrace Core bt) ParserError ParserError e -> ParserError -> Doc forall a. Pretty a => a -> Doc pretty ParserError e CheckError CheckError e Maybe SrcSpan sp -> String -> Doc text String "Static error:" Doc -> Doc -> Doc <+> CheckError -> Doc forall a. Pretty a => a -> Doc pretty CheckError e Doc -> Doc -> Doc <$$> Int -> Doc -> Doc indent Int 2 (Maybe SrcSpan -> Doc forall a. Pretty a => a -> Doc pretty Maybe SrcSpan sp)