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.Types 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.UnionType t -> c `union` t
T.ExceptionType t -> c `exception` 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 $$
reserved "struct" <+> declare structName <+>
block indentWidth line (map (\f -> field c f <> semi) structFields)
<> typeAnnots c structAnnotations
instance Pretty (T.Struct a) where
pretty = struct defaultConfig
union :: Config -> T.Union ann -> Doc
union c@Config{indentWidth} T.Union{..} = unionDocstring $$
reserved "union" <+> declare unionName <+>
block indentWidth line (map (\f -> field c f <> semi) unionFields)
<> typeAnnots c unionAnnotations
instance Pretty (T.Union a) where
pretty = union defaultConfig
exception :: Config -> T.Exception ann -> Doc
exception c@Config{indentWidth} T.Exception{..} = exceptionDocstring $$
reserved "exception" <+> declare exceptionName <+>
block indentWidth line (map (\f -> field c f <> semi) exceptionFields)
<> typeAnnots c exceptionAnnotations
instance Pretty (T.Exception a) where
pretty = exception defaultConfig
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 "="