{-# 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 {Name a
SrcSpan
span :: forall a. StackFrame a -> SrcSpan
name :: forall a. StackFrame a -> Name a
span :: SrcSpan
name :: Name a
..} =
SrcSpan -> Doc
forall a. Pretty a => a -> Doc
pretty SrcSpan
span Doc -> Doc -> Doc
<+> Doc -> Doc
forall a. Pretty a => a -> Doc
pretty (String -> Doc
forall a. (Eq a, IsString a, Pretty a) => a -> Doc
f (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Name a -> String
forall a. Name a -> String
name2String Name a
name)
where
f :: a -> Doc
f a
"top-level" = Doc
forall a. Monoid a => a
mempty
f a
x = String -> Doc
text String
"function" Doc -> Doc -> Doc
<+> (Doc -> Doc
angles (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x)
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)