Pretty.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
-- |
-- Module      :  Language.Thrift.Pretty
-- Copyright   :  (c) Abhinav Gupta 2016
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- This module provides a pretty printer for Thrift IDLs. Most of the printers
-- defined in this module produce output highlighted using ANSI escape codes.
-- Get plain output by using 'Text.PrettyPrint.ANSI.Leijen.plain'.
--
-- Use 'prettyPrintHighlighted' to produce output highlighted using ANSI escape
-- codes. Note that this output will be unparseable and is suitable for printing
-- inside a compatible terminal only. Use 'prettyPrint' if you don't want
-- highlighted output.
--
-- The behavior of the printer can be customized using 'Config' objects.
--
-- The module also exports instances of the 'Pretty' typeclass for elements of
-- the AST.
module Language.Thrift.Pretty
    (
      prettyPrintHighlighted
    , prettyPrint

    -- * Components

    , program

    , header
    , include
    , namespace

    , functionParameters
    , definition
    , constant
    , typeDefinition
    , service

    , typedef
    , enum
    , struct
    , union
    , exception
    , senum

    , typeReference
    , constantValue

    , docstring

    -- * Configuration

    , Config(..)
    , defaultConfig
    ) where

#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<$>))
#endif

import qualified Data.List as List
import           Data.Text (Text)
import qualified Data.Text as Text

import Text.PrettyPrint.ANSI.Leijen
    ( Doc
    , align
    , bold
    , cyan
    , double
    , dquotes
    , dullblue
    , empty
    , enclose
    , group
    , hardline
    , hcat
    , hsep
    , integer
    , line
    , linebreak
    , magenta
    , nest
    , plain
    , space
    , vsep
    , yellow
    , (<$$>)
    , (<$>)
    , (<+>)
    )

import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Language.Thrift.Internal.AST as T

-- | Configuration for the pretty printer.
data Config = Config
    { indentWidth :: Int
    -- ^ Number of spaces to use for indentation.
    } deriving (Show, Ord, Eq)


-- | Default pretty printing configuration.
defaultConfig :: Config
defaultConfig = Config 4

-- | Top-level pretty printer for Thrift documents that uses the default
-- configuration ('defaultConfig') for pretty printing.
prettyPrint :: T.Program ann -> Doc
prettyPrint = plain . prettyPrintHighlighted

-- | Top-level pretty printer for Thrift documents.
prettyPrintHighlighted :: T.Program ann -> Doc
prettyPrintHighlighted = program defaultConfig

-- | Pretty print a Thrift IDL.
program :: Config -> T.Program ann -> Doc
program c T.Program{..} =
    ( if null programHeaders
        then empty
        else vsep (map header programHeaders) <$> line
    ) <> map (definition c) programDefinitions `sepBy` (line <> line)

-- | Print the headers for a program.
header :: T.Header ann -> Doc
header (T.HeaderInclude inc)  = include inc
header (T.HeaderNamespace ns) = namespace ns

include :: T.Include ann -> Doc
include T.Include{..} = reserved "include" <+> literal includePath

namespace :: T.Namespace ann -> Doc
namespace T.Namespace{..} = hsep
    [reserved "namespace", text namespaceLanguage, text namespaceName]

-- | Print a constant, type, or service definition.
definition :: Config -> T.Definition ann -> Doc
definition c (T.ConstDefinition cd)  = constant c cd
definition c (T.TypeDefinition def)  = typeDefinition c def
definition c (T.ServiceDefinition s) = service c s

constant :: Config -> T.Const ann -> Doc
constant c T.Const{..} = constDocstring $$ hsep
    [ reserved "const"
    , typeReference c constValueType
    , declare constName
    , equals
    , constantValue c constValue
    ]

service :: Config -> T.Service ann -> Doc
service c@Config{indentWidth} T.Service{..} =
  serviceDocstring $$
    reserved "service" <+> declare serviceName <> extends <+>
    block indentWidth (line <> line) (map (function c) serviceFunctions) <>
    typeAnnots c serviceAnnotations
  where
    extends = case serviceExtends of
      Nothing   -> empty
      Just name -> space <> reserved "extends" <+> text name

functionParameters :: Config -> [T.Field ann] -> Doc
functionParameters c@Config{..}
  = encloseSep indentWidth lparen rparen comma
  . map (field c)

-- | Pretty print a function definition.
--
function :: Config -> T.Function ann -> Doc
function c@Config{indentWidth} T.Function{functionParameters = params, ..} = functionDocstring $$
  oneway <> returnType <+> text functionName
    <> functionParameters c params
    <> exceptions <> typeAnnots c functionAnnotations <> semi
  where
    exceptions = case functionExceptions of
      Nothing -> empty
      Just es -> space <> reserved "throws" <+>
        encloseSep indentWidth lparen rparen comma (map (field c) es)
    returnType = case functionReturnType of
      Nothing -> reserved "void"
      Just rt -> typeReference c rt
    oneway =
      if functionOneWay
          then reserved "oneway" <> space
          else empty

typeDefinition :: Config -> T.Type ann -> Doc
typeDefinition c td = case td of
  T.TypedefType   t -> c `typedef`   t
  T.EnumType      t -> c `enum`      t
  T.StructType    t -> c `struct`    t
  T.SenumType     t -> c `senum`     t

typedef :: Config -> T.Typedef ann -> Doc
typedef c T.Typedef{..} = typedefDocstring $$
    reserved "typedef" <+> typeReference c typedefTargetType <+>
    declare typedefName <> typeAnnots c typedefAnnotations

enum :: Config -> T.Enum ann -> Doc
enum c@Config{indentWidth} T.Enum{..} = enumDocstring $$
    reserved "enum" <+> declare enumName <+>
      block indentWidth (comma <> line) (map (enumValue c) enumValues)
    <> typeAnnots c enumAnnotations

struct :: Config -> T.Struct ann -> Doc
struct c@Config{indentWidth} T.Struct{..} = structDocstring $$
    kind <+> declare structName <+>
      block indentWidth line (map (\f -> field c f <> semi) structFields)
    <> typeAnnots c structAnnotations
  where
    kind = case structKind of
        T.StructKind    -> reserved "struct"
        T.UnionKind     -> reserved "union"
        T.ExceptionKind -> reserved "exception"

union :: Config -> T.Struct ann -> Doc
union = struct
{-# DEPRECATED union "Use struct." #-}

exception :: Config -> T.Struct ann -> Doc
exception = struct
{-# DEPRECATED exception "Use struct." #-}

senum :: Config -> T.Senum ann -> Doc
senum c@Config{indentWidth} T.Senum{..} = senumDocstring $$
    reserved "senum" <+> declare senumName <+>
      encloseSep indentWidth lbrace rbrace comma (map literal senumValues)
    <> typeAnnots c senumAnnotations

field :: Config -> T.Field ann -> Doc
field c T.Field{..} = fieldDocstring $$ hcat
    [ case fieldIdentifier of
        Nothing -> empty
        Just i  -> yellow (integer i) <> colon <> space
    , case fieldRequiredness of
        Nothing -> empty
        Just r  -> requiredness r <> space
    , typeReference c fieldValueType
    , space
    , text fieldName
    , case fieldDefaultValue of
        Nothing -> empty
        Just v  -> space <> equals <+> constantValue c v
    , typeAnnots c fieldAnnotations
    ]

requiredness :: T.FieldRequiredness -> Doc
requiredness T.Optional = reserved "optional"
requiredness T.Required = reserved "required"

enumValue :: Config -> T.EnumDef ann -> Doc
enumValue c T.EnumDef{..} = enumDefDocstring $$
    text enumDefName <> value <> typeAnnots c enumDefAnnotations
  where
    value = case enumDefValue of
      Nothing -> empty
      Just v  -> space <> equals <+> integer v

-- | Pretty print a field type.
typeReference :: Config -> T.TypeReference ann -> Doc
typeReference c ft = case ft of
  T.DefinedType t _ -> text t

  T.StringType anns _ -> reserved "string" <> typeAnnots c anns
  T.BinaryType anns _ -> reserved "binary" <> typeAnnots c anns
  T.SListType  anns _ -> reserved "slist"  <> typeAnnots c anns
  T.BoolType   anns _ -> reserved "bool"   <> typeAnnots c anns
  T.ByteType   anns _ -> reserved "byte"   <> typeAnnots c anns
  T.I16Type    anns _ -> reserved "i16"    <> typeAnnots c anns
  T.I32Type    anns _ -> reserved "i32"    <> typeAnnots c anns
  T.I64Type    anns _ -> reserved "i64"    <> typeAnnots c anns
  T.DoubleType anns _ -> reserved "double" <> typeAnnots c anns

  T.MapType k v anns _ ->
    reserved "map"
        <> enclose langle rangle
            (typeReference c k <> comma <+> typeReference c v)
        <> typeAnnots c anns
  T.SetType v anns _ ->
    reserved "set"
        <> enclose langle rangle (typeReference c v)
        <> typeAnnots c anns
  T.ListType v anns _ ->
    reserved "list"
        <> enclose langle rangle (typeReference c v)
        <> typeAnnots c anns

-- | Pretty print a constant value.
constantValue :: Config -> T.ConstValue ann -> Doc
constantValue c@Config{indentWidth} value = case value of
  T.ConstInt        i _ -> integer i
  T.ConstFloat      f _ -> double  f
  T.ConstLiteral    l _ -> literal l
  T.ConstIdentifier i _ -> text    i
  T.ConstList      vs _ ->
    encloseSep indentWidth lbracket rbracket comma $ map (constantValue c) vs
  T.ConstMap       vs _ ->
    encloseSep indentWidth lbrace rbrace comma $
      map (\(k, v) -> constantValue c k <> colon <+> constantValue c v) vs

typeAnnots :: Config -> [T.TypeAnnotation] -> Doc
typeAnnots _ [] = empty
typeAnnots Config{indentWidth} anns =
    space <> encloseSep indentWidth lparen rparen comma (map typeAnnot anns)

typeAnnot :: T.TypeAnnotation -> Doc
typeAnnot T.TypeAnnotation{..} =
    text typeAnnotationName <> value
  where
    value = case typeAnnotationValue of
        Nothing -> empty
        Just v  -> space <> equals <+> literal v

literal :: Text -> Doc
literal = cyan . dquotes . text
    -- TODO: escaping?

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

reserved :: String -> Doc
reserved = magenta . PP.text

op :: String -> Doc
op = yellow . PP.text

declare :: Text -> Doc
declare = bold . text

($$) :: T.Docstring -> Doc -> Doc
($$) Nothing y = y
($$) (Just t) y =
    if Text.null t'
        then y
        else docstring t' <$> y
  where
    t' = Text.strip t

infixr 1 $$

docstring :: Text -> Doc
docstring = dullblue . wrapComments . Text.lines
  where
    wrapComments [l] = text "/** " <> text l <> " */"
    wrapComments ls = align . mconcat . List.intersperse hardline
      $ text "/**"
      : map (\l -> text " *" <+> text l) ls
     ++ [text " */"]

block :: Int -> Doc -> [Doc] -> Doc
block indent s items = enclose lbrace rbrace $
    nest indent (linebreak <> (items `sepBy` s)) <> linebreak

sepBy :: [Doc] -> Doc -> Doc
sepBy [] _     = empty
sepBy [x] _    = x
sepBy (x:xs) s = x <> s <> sepBy xs s

encloseSep :: Int -> Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep _ left right _ [] = left <> right
encloseSep _ left right _ [v] = left <> v <> right
encloseSep indent left right s vs = group $
    nest indent (left <$$> go vs) <$$> right
  where go []     = empty
        go [x]    = x
        go (x:xs) = (x <> s) <$> go xs

lbrace :: Doc
lbrace = op "{"

rbrace :: Doc
rbrace = op "}"

lparen :: Doc
lparen = op "("

rparen :: Doc
rparen = op ")"

lbracket :: Doc
lbracket = op "["

rbracket :: Doc
rbracket = op "]"

langle :: Doc
langle = op "<"

rangle :: Doc
rangle = op ">"

comma :: Doc
comma = op ","

semi :: Doc
semi = op ";"

colon :: Doc
colon = op ":"

equals :: Doc
equals = op "="