module Language.Thrift.Pretty
(
prettyPrintHighlighted
, prettyPrint
, program
, header
, include
, namespace
, definition
, constant
, typeDefinition
, service
, typedef
, enum
, struct
, union
, exception
, senum
, typeReference
, constantValue
, docstring
, Config(..)
, defaultConfig
) where
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<$>))
#endif
import Data.Text (Text)
import qualified Data.Text as Text
import Text.PrettyPrint.ANSI.Leijen
( Doc
, Pretty (..)
, align
, bold
, cyan
, double
, dquotes
, dullblue
, empty
, enclose
, group
, hcat
, hsep
, integer
, line
, linebreak
, magenta
, nest
, plain
, space
, vsep
, yellow
, (<$$>)
, (<$>)
, (<+>)
, (<>)
)
import qualified Language.Thrift.Internal.AST as T
import qualified Text.PrettyPrint.ANSI.Leijen as P
data Config = Config
{ indentWidth :: Int
} deriving (Show, Ord, Eq)
defaultConfig :: Config
defaultConfig = Config 4
prettyPrint :: T.Program ann -> Doc
prettyPrint = plain . prettyPrintHighlighted
prettyPrintHighlighted :: T.Program ann -> Doc
prettyPrintHighlighted = program defaultConfig
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)
instance Pretty (T.Program a) where
pretty = program defaultConfig
header :: T.Header ann -> Doc
header (T.HeaderInclude inc) = include inc
header (T.HeaderNamespace ns) = namespace ns
instance Pretty (T.Header a) where
pretty = header
include :: T.Include ann -> Doc
include T.Include{..} = reserved "include" <+> literal includePath
instance Pretty (T.Include a) where
pretty = include
namespace :: T.Namespace ann -> Doc
namespace T.Namespace{..} = hsep
[reserved "namespace", text namespaceLanguage, text namespaceName]
instance Pretty (T.Namespace a) where
pretty = namespace
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
instance Pretty (T.Definition a) where
pretty = definition defaultConfig
constant :: Config -> T.Const ann -> Doc
constant c T.Const{..} = constDocstring $$ hsep
[ reserved "const"
, typeReference c constValueType
, declare constName
, equals
, constantValue c constValue
]
instance Pretty (T.Const a) where
pretty = constant defaultConfig
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
instance Pretty (T.Service a) where
pretty = service defaultConfig
function :: Config -> T.Function ann -> Doc
function c@Config{indentWidth} T.Function{..} = functionDocstring $$
oneway <> returnType <+> text functionName <>
encloseSep
indentWidth lparen rparen comma
(map (field c) functionParameters) <>
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
instance Pretty (T.Function a) where
pretty = function defaultConfig
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
instance Pretty (T.Type a) where
pretty = typeDefinition defaultConfig
typedef :: Config -> T.Typedef ann -> Doc
typedef c T.Typedef{..} = typedefDocstring $$
reserved "typedef" <+> typeReference c typedefTargetType <+>
declare typedefName <> typeAnnots c typedefAnnotations
instance Pretty (T.Typedef a) where
pretty = typedef defaultConfig
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
instance Pretty (T.Enum a) where
pretty = enum defaultConfig
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"
instance Pretty (T.Struct a) where
pretty = struct defaultConfig
union :: Config -> T.Struct ann -> Doc
union = struct
exception :: Config -> T.Struct ann -> Doc
exception = 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
instance Pretty (T.Senum a) where
pretty = senum defaultConfig
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
]
instance Pretty (T.Field a) where
pretty = field defaultConfig
requiredness :: T.FieldRequiredness -> Doc
requiredness T.Optional = reserved "optional"
requiredness T.Required = reserved "required"
instance Pretty T.FieldRequiredness where
pretty = requiredness
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
instance Pretty (T.EnumDef a) where
pretty = enumValue defaultConfig
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
instance Pretty (T.TypeReference a) where
pretty = typeReference defaultConfig
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
instance Pretty (T.ConstValue a) where
pretty = constantValue defaultConfig
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
instance Pretty T.TypeAnnotation where
pretty = typeAnnot
literal :: Text -> Doc
literal = cyan . dquotes . text
text :: Text -> Doc
text = P.text . Text.unpack
reserved :: String -> Doc
reserved = magenta . P.text
op :: String -> Doc
op = yellow . P.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 ls = align . vsep
$ 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 "="