Pretty.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

module Thrift.Compiler.Pretty
  ( renderTypeError
  , renderTypeErrorPlain
  , renderType
  , ppHeader, ppName, ppType, ppText
  ) where

import Text.PrettyPrint hiding ((<>))
import Data.Some
import Data.Text (Text)
import qualified Data.Text as Text

import Thrift.Compiler.Parser
import Thrift.Compiler.Plugin
import Thrift.Compiler.Typechecker.Monad
import Thrift.Compiler.Types

renderType :: Typecheckable l => Type l t -> String
renderType = render . ppType

renderTypeError :: Typecheckable l => TypeError l -> String
renderTypeError = render . ppTypeError

renderTypeErrorPlain :: Typecheckable l => TypeError l -> String
renderTypeErrorPlain = render . ppTypeErrorPlain

ppTypeError :: Typecheckable l => TypeError l -> Doc
ppTypeError (TypeError loc msg) = "" $$ hang (ppHeader loc) 1 (ppErrorMsg msg)
ppTypeError EmptyInput = "" $$ red "Error: no input files specified"
ppTypeError (CyclicModules ms) =
  "" $$ hang (red "Error: cycle in modules:") 1
    (sep (punctuate "," (map (text . thriftPath) ms)))

ppTypeErrorPlain :: Typecheckable l => TypeError l -> Doc
ppTypeErrorPlain (TypeError loc msg) =
  ppHeaderPlain loc <+> ppErrorMsg msg
ppTypeErrorPlain EmptyInput = "Error: no input files specified"
ppTypeErrorPlain (CyclicModules ms) =
  "Error: cycle in modules:" <+>
    sep (punctuate "," (map (text . thriftPath) ms))

ppHeader :: Loc -> Doc
ppHeader loc = red (ppHeaderPlain loc)

ppHeaderPlain :: Loc -> Doc
ppHeaderPlain Loc{..} =
  hcat $ map (<> ":") [ text locFile, int locStartLine, int locStartCol ]

ppErrorMsg :: Typecheckable l => ErrorMsg l -> Doc
ppErrorMsg (CyclicTypes decls) =
 "cycle in types:" <+> sep (punctuate "," (foldr getName [] decls))
    where
      getName (D_Typedef Typedef{..}) ns = ppText tdName : ns
      getName (D_Struct Struct{..} )  ns = ppText structName : ns
      getName (D_Union Union{..})     ns = ppText unionName : ns
      getName (D_Enum Enum{..})       ns = ppText enumName : ns
      getName D_Const{}               ns = ns
      getName D_Service{}             ns = ns
      getName D_Interaction{}             ns = ns
ppErrorMsg (CyclicServices ss) =
  "cycle in service hierarchy:" <+> sep (punctuate "," (map getName ss))
    where
      getName Service{..} = quotes $ ppText serviceName
ppErrorMsg (UnknownType name)  = "unknown type" <+> quotes (ppName_ name)
ppErrorMsg (UnknownConst name) = "unknown constant" <+> quotes (ppName_ name)
ppErrorMsg (UnknownService name) = "unknown service" <+> quotes (ppName_ name)
ppErrorMsg (UnknownField name) = "unknown field" <+> quotes (ppText name)
ppErrorMsg (MissingField name) = "missing field" <+> quotes (ppText name)
ppErrorMsg (InvalidFieldId name fid) =
  hang "invalid field id:" 1 $
    "field" <+> quotes (ppText name) <+> "has id" <+> quotes (int fid) $$
    "field ids must be unique and non-zero"
ppErrorMsg (InvalidField val)  =
  hang "invalid field name:" 1 $
    "struct fields must be string literals" $$
    "got" <+> quotes (ppConst val)
ppErrorMsg (InvalidUnion name n) =
  hang ("invalid union literal for type" <+> (quotes (ppName name) <> ":")) 1 $
    "unions must contain exactly 1 field" $$
    "got" <+> int n <+> "fields"
ppErrorMsg (EmptyUnion name) =
  hang ("invalid union declaration" <+> (quotes (ppText name) <> ":")) 1 $
    "unions must contain at least one alternative" $$
    "try using an empty enum"
ppErrorMsg (InvalidThrows ty name) =
  hang ("invalid throws declaration" <+> (quotes (ppText name) <> ":")) 1 $
    "all fields in a throws clause must be exceptions" $$
    "but got type" <+> quotes (ppType ty)
ppErrorMsg (LiteralMismatch ty val) =
  hang "type mismatch:" 1 $
    "expected value of type" <+> quotes (ppType ty) $$
    "but got" <+> quotes (ppConst val)
ppErrorMsg (IdentMismatch expect actual name) =
  hang "type mismatch:" 1 $
    "expected value of type" <+> quotes (ppType expect) $$
    "but got identifier" <+> quotes (ppName_ name) <+>
      "of type" <+> quotes (ppType actual)
ppErrorMsg (AnnotationMismatch place ann) =
  hang "annotation mismatch:" 1 $
    "cannot use annotation" <+> quotes (ppAnnotation ann) $$
    "in" <+> ppPlacement place
ppErrorMsg (DuplicateName name) =
  "multiple definitions of" <+> quotes (ppText name)
ppErrorMsg (DuplicateEnumVal enum names val) =
  hang "duplicate enum value" 1 $
    "enum" <+> quotes (ppText enum) <+>
      "has multiple constructors with value" <+> quotes (int val) $$
    "constructors are" <+> hcat (map (quotes . ppText) names)
ppErrorMsg (TypeMismatch ty1 ty2) =
    hang "type mismatch:" 1 $
    "expected type" <+> quotes (ppType ty1) $$
    "but got type" <+> quotes (ppType ty2)
ppErrorMsg (NotDefinedBeforeUsed ty) =
    "type" <+> quotes (ppType ty) <+> "must be defined before it is used"
ppErrorMsg (UnknownEnumValue name) =
    "no value found for enum" <+> quotes (ppName_ name)
ppErrorMsg (MultipleEnumValues name) =
    "ambiguous values found for enum" <+> quotes (ppName_ name)

red :: Doc -> Doc
red doc = zeroWidthText "\ESC[31;1m" <> doc <> zeroWidthText "\ESC[0m"

ppPlacement :: Typecheckable l => AnnotationPlacement l -> Doc
ppPlacement (AnnType ty) = "type" <+> ppType ty
ppPlacement AnnField = "field"
ppPlacement AnnStruct = "struct"
ppPlacement AnnUnion = "union"
ppPlacement AnnTypedef = "typedef"
ppPlacement AnnEnum = "enum"
ppPlacement AnnPriority = "priority"

ppType :: Typecheckable l => Type l t -> Doc
ppType I8   = "byte"
ppType I16  = "i16"
ppType I32  = "i32"
ppType I64  = "i64"
ppType TDouble = "double"
ppType TFloat  = "float"
ppType TBool   = "bool"
ppType TText   = "string"
ppType TBytes  = "binary"
ppType (TSet u)     = hcat [ "set<", ppType u, ">" ]
ppType (THashSet u) = hcat [ "hash_set<", ppType u, ">" ]
ppType (TList u)    = hcat [ "list<", ppType u, ">" ]
ppType (TMap k v) = hcat [ "map<", ppType k, ", ", ppType v, ">" ]
ppType (THashMap k v) = hcat [ "hash_map<", ppType k, ", ", ppType v, ">" ]
ppType (TTypedef name _ _loc) = ppName name
ppType (TNewtype name _ _loc) = ppName name
ppType (TStruct name _loc)    = ppName name
ppType (TException name _loc) = ppName name
ppType (TUnion name _loc)     = ppName name
ppType (TEnum name _loc _)      = ppName name
ppType (TSpecial ty) = case backTranslateType ty of
  (Some u, name) -> ppType u <+> parens (ppText name)

ppName :: Name -> Doc
ppName Name{..} = ppName_ sourceName

ppName_ :: Name_ s -> Doc
ppName_ (UName name) = text $ Text.unpack name
ppName_ (QName m name) =
    hcat [ ppText m, ".", ppText name ]

ppText :: Text -> Doc
ppText = text . Text.unpack

ppConst :: UntypedConst a -> Doc
ppConst (UntypedConst _ c) = ppConstVal c

ppConstVal :: ConstVal a -> Doc
ppConstVal (IntConst _ i)    = ppText i
ppConstVal (DoubleConst _ d) = ppText d
ppConstVal (StringConst s qt) = addQuotes $ text $ Text.unpack s
  where
    addQuotes = case qt of
      DoubleQuote -> doubleQuotes
      SingleQuote -> quotes
ppConstVal (IdConst x)     = text $ Text.unpack x
ppConstVal ListConst{..} =
  brackets $ sep $ punctuate "," $ map (ppConst . leElem) lvElems
ppConstVal MapConst{..} = braces $ sep $ punctuate "," $ map pp mvElems
  where
    pp ListElem{ leElem = MapPair{..} } =
      hsep [ ppConst mpKey, ":", ppConst mpVal ]
ppConstVal StructConst{..} = braces $ sep $ punctuate "," $ map pp svElems
  where
    pp ListElem{ leElem = StructPair{..} } =
      hsep [ ppText spKey, "=", ppConst spVal ]
ppConstVal (BoolConst b)
  | b         = text "true"
  | otherwise = text "false"

ppAnnotation :: Annotation a -> Doc
ppAnnotation SimpleAnn{..} = parens $ ppText saTag
ppAnnotation ValueAnn{..} = parens $
  ppText vaTag <+> "=" <+>
  case vaVal of
    TextAnn txt _ -> doubleQuotes (ppText txt)
    IntAnn x _ -> int x