module Language.Thrift.Pretty
(
prettyPrint
, program
, header
, definition
, function
, fieldType
, constantValue
, Config(..)
, defaultConfig
) where
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<$>))
#endif
import Data.Text (Text, unpack)
import Text.PrettyPrint.Leijen hiding (encloseSep, indent, text)
import qualified Data.Text as Text
import qualified Language.Thrift.Types as T
import qualified Text.PrettyPrint.Leijen as PP
data Config = Config
{ indentWidth :: Int
} deriving (Show, Ord, Eq)
defaultConfig :: Config
defaultConfig = Config 4
prettyPrint :: T.Program ann -> Doc
prettyPrint = program defaultConfig
program :: Config -> T.Program ann -> Doc
program c T.Program{..} =
vsep (map header programHeaders) <$> line <>
map (definition c) programDefinitions `sepBy` (line <> line)
header :: T.Header -> Doc
header T.Include{..} =
text "include" <+> literal includePath
header T.Namespace{..} = hsep
[text "namespace", text namespaceLanguage, text namespaceName]
definition :: Config -> T.Definition ann -> Doc
definition c T.ConstDefinition{..} = constDocstring $$ hsep
[ text "const"
, fieldType c constType
, text constName
, text "="
, constantValue c constValue
]
definition c T.TypeDefinition{typeDefinition = def, ..} =
typeDefinition c def <> typeAnnots c typeAnnotations
definition c@Config{indentWidth} T.ServiceDefinition{..} =
serviceDocstring $$
text "service" <+> text serviceName <> extends <+>
block indentWidth (line <> line) (map (function c) serviceFunctions) <>
typeAnnots c serviceAnnotations
where
extends = case serviceExtends of
Nothing -> empty
Just name -> space <> text "extends" <+> text name
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 <> text "throws" <+>
encloseSep indentWidth lparen rparen comma (map (field c) es)
returnType = case functionReturnType of
Nothing -> text "void"
Just rt -> fieldType c rt
oneway =
if functionOneWay
then text "oneway" <> space
else empty
typeDefinition :: Config -> T.Type ann -> Doc
typeDefinition c@Config{indentWidth} t = case t of
T.Typedef{..} -> typedefDocstring $$
text "typedef" <+> fieldType c typedefType <+> text typedefName
T.Enum{..} -> enumDocstring $$
text "enum" <+> text enumName <+>
block indentWidth (comma <> line) (map (enumValue c) enumValues)
T.Struct{..} -> structDocstring $$
text "struct" <+> text structName <+>
block indentWidth line (map (\f -> field c f <> semi) structFields)
T.Union{..} -> unionDocstring $$
text "union" <+> text unionName <+>
block indentWidth line (map (\f -> field c f <> semi) unionFields)
T.Exception{..} -> exceptionDocstring $$
text "exception" <+> text exceptionName <+>
block indentWidth line (map (\f -> field c f <> semi) exceptionFields)
T.Senum{..} -> senumDocstring $$
text "senum" <+> text senumName <+>
encloseSep indentWidth lbrace rbrace comma (map literal senumValues)
field :: Config -> T.Field ann -> Doc
field c T.Field{fieldType = typ, ..} = fieldDocstring $$
hcat [fid, req, fieldType c typ, space, text fieldName, def, annots]
where
fid = case fieldIdentifier of
Nothing -> empty
Just i -> integer i <> colon <> space
req = case fieldRequiredness of
Nothing -> empty
Just T.Optional -> text "optional "
Just T.Required -> text "required "
def = case fieldDefault of
Nothing -> empty
Just v -> space <> equals <+> constantValue c v
annots = typeAnnots c fieldAnnotations
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 <> text "=" <+> integer v
fieldType :: Config -> T.FieldType -> Doc
fieldType c ft = case ft of
T.DefinedType t -> text t
T.StringType anns -> text "string" <> typeAnnots c anns
T.BinaryType anns -> text "binary" <> typeAnnots c anns
T.SListType anns -> text "slist" <> typeAnnots c anns
T.BoolType anns -> text "bool" <> typeAnnots c anns
T.ByteType anns -> text "byte" <> typeAnnots c anns
T.I16Type anns -> text "i16" <> typeAnnots c anns
T.I32Type anns -> text "i32" <> typeAnnots c anns
T.I64Type anns -> text "i64" <> typeAnnots c anns
T.DoubleType anns -> text "double" <> typeAnnots c anns
T.MapType k v anns ->
text "map" <> angles (fieldType c k <> comma <+> fieldType c v)
<> typeAnnots c anns
T.SetType v anns ->
text "set" <> angles (fieldType c v) <> typeAnnots c anns
T.ListType v anns ->
text "list" <> angles (fieldType c v) <> typeAnnots c anns
constantValue :: Config -> T.ConstValue -> 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 <+> equals <+> literal typeAnnotationValue
literal :: Text -> Doc
literal = dquotes . text
text :: Text -> Doc
text = PP.text . unpack
($$) :: T.Docstring -> Doc -> Doc
($$) Nothing y = y
($$) (Just t) y = case Text.lines (Text.strip t) of
[] -> y
ls -> wrapComments ls <$> y
where
wrapComments ls = align . vsep
$ text "/**"
: map (\l -> text " *" <+> text l) ls
++ [text " */"]
infixr 1 $$
block :: Int -> Doc -> [Doc] -> Doc
block indent s items = braces $
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 [x] = x
go (x:xs) = (x <> s) <$> go xs