diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +0.6.1.0 +======= + +- Output generated by the `ansi-wl-pprint` pretty printer will be colored + using ANSI escape codes. + 0.6.0.1 ======= diff --git a/Language/Thrift/Pretty.hs b/Language/Thrift/Pretty.hs --- a/Language/Thrift/Pretty.hs +++ b/Language/Thrift/Pretty.hs @@ -14,7 +14,7 @@ -- This module provides a pretty printer for Thrift IDLs. The pretty printer -- preserves docstrings specified for types. -- --- The specifics of the printer can be configured using 'Config' objects. +-- 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. @@ -51,7 +51,6 @@ , defaultConfig ) where -import Text.PrettyPrint.Leijen hiding (encloseSep, indent, text) -import qualified Text.PrettyPrint.Leijen as PP - +#define PrettyPrinter Text.PrettyPrint.Leijen #include "Pretty/PrettyInc.hs" +#undef PrettyPrinter diff --git a/Language/Thrift/Pretty/ANSI.hs b/Language/Thrift/Pretty/ANSI.hs --- a/Language/Thrift/Pretty/ANSI.hs +++ b/Language/Thrift/Pretty/ANSI.hs @@ -11,13 +11,20 @@ -- Maintainer : Abhinav Gupta -- Stability : experimental -- --- This module is the same as "Language.Thrift.Pretty" but the pretty printer --- used is the one provided by ansi-wl-pprint. +-- This module provides a pretty printer for Thrift IDLs that produces colored +-- output. It is essentially the same as "Language.Thrift.Pretty" with the +-- exception of the colored output. -- --- The specifics of the printer can be configured using 'Config' objects. +-- The behavior of the printer can be customized using 'Config' objects. -- +-- The system uses ANSI escape codes to produce colored output. That makes the +-- text output of this pretty printer unparseable without printing to a +-- supported terminal. If this is undesirable, use +-- 'Text.PrettyPrint.ANSI.Leijen.plain' to discard coloring information, or +-- simply use the "Language.Thrift.Pretty" pretty printer instead. +-- -- As with "Language.Thrift.Pretty", this module exports instances of the --- 'Pretty' typeclass for @ansi-wl-pprint@. +-- 'Pretty' typeclass for elements of the AST. module Language.Thrift.Pretty.ANSI ( prettyPrint @@ -51,7 +58,8 @@ , defaultConfig ) where -import Text.PrettyPrint.ANSI.Leijen hiding (encloseSep, indent, text) -import qualified Text.PrettyPrint.ANSI.Leijen as PP - +#define PrettyPrinter Text.PrettyPrint.ANSI.Leijen +#define PrettyPrinterSupportsHighlighting #include "PrettyInc.hs" +#undef PrettyPrinterSupportsHighlighting +#undef PrettyPrinter diff --git a/Language/Thrift/Pretty/PrettyInc.hs b/Language/Thrift/Pretty/PrettyInc.hs --- a/Language/Thrift/Pretty/PrettyInc.hs +++ b/Language/Thrift/Pretty/PrettyInc.hs @@ -2,18 +2,39 @@ -- ansi-wl-pprint in scope. #if __GLASGOW_HASKELL__ >= 709 -import Prelude hiding ((<$>), lines) +import Prelude hiding (lines, (<$>)) #else import Prelude hiding (lines) #endif -import Data.Text (Text, unpack, lines, strip) +import Data.Text (Text, lines, strip, unpack) +import PrettyPrinter (Doc, align, double, dquotes, empty, nest, enclose, group, hcat, Pretty(..), + hsep, integer, line, linebreak, space, vsep, (<$$>), + (<$>), (<+>), (<>)) +import qualified PrettyPrinter as P + import qualified Language.Thrift.Internal.Types as T import Language.Thrift.Pretty.Types +bold, dullblue, magenta, yellow, cyan :: Doc -> Doc +#ifdef PrettyPrinterSupportsHighlighting +bold = P.bold +dullblue = P.dullblue +magenta = P.magenta +yellow = P.yellow +cyan = P.cyan +#else +bold = id +dullblue = id +magenta = id +yellow = id +cyan = id +#endif + + -- | Top-level pretty printer for Thrift documents that uses the default -- configuration ('defaultConfig') for pretty printing. prettyPrint :: T.Program ann -> Doc @@ -38,14 +59,14 @@ pretty = header include :: T.Include ann -> Doc -include T.Include{..} = text "include" <+> literal includePath +include T.Include{..} = reserved "include" <+> literal includePath instance Pretty (T.Include a) where pretty = include namespace :: T.Namespace ann -> Doc namespace T.Namespace{..} = hsep - [text "namespace", text namespaceLanguage, text namespaceName] + [reserved "namespace", text namespaceLanguage, text namespaceName] instance Pretty (T.Namespace a) where pretty = namespace @@ -61,10 +82,10 @@ constant :: Config -> T.Const ann -> Doc constant c T.Const{..} = constDocstring $$ hsep - [ text "const" + [ reserved "const" , typeReference c constValueType - , text constName - , text "=" + , declare constName + , equals , constantValue c constValue ] @@ -74,13 +95,13 @@ service :: Config -> T.Service ann -> Doc service c@Config{indentWidth} T.Service{..} = serviceDocstring $$ - text "service" <+> text serviceName <> extends <+> + 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 <> text "extends" <+> text name + Just name -> space <> reserved "extends" <+> text name instance Pretty (T.Service a) where pretty = service defaultConfig @@ -97,14 +118,14 @@ where exceptions = case functionExceptions of Nothing -> empty - Just es -> space <> text "throws" <+> + Just es -> space <> reserved "throws" <+> encloseSep indentWidth lparen rparen comma (map (field c) es) returnType = case functionReturnType of - Nothing -> text "void" + Nothing -> reserved "void" Just rt -> typeReference c rt oneway = if functionOneWay - then text "oneway" <> space + then reserved "oneway" <> space else empty instance Pretty (T.Function a) where @@ -124,15 +145,15 @@ typedef :: Config -> T.Typedef ann -> Doc typedef c T.Typedef{..} = typedefDocstring $$ - text "typedef" <+> typeReference c typedefTargetType <+> text typedefName - <> typeAnnots c typedefAnnotations + 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 $$ - text "enum" <+> text enumName <+> + reserved "enum" <+> declare enumName <+> block indentWidth (comma <> line) (map (enumValue c) enumValues) <> typeAnnots c enumAnnotations @@ -141,7 +162,7 @@ struct :: Config -> T.Struct ann -> Doc struct c@Config{indentWidth} T.Struct{..} = structDocstring $$ - text "struct" <+> text structName <+> + reserved "struct" <+> declare structName <+> block indentWidth line (map (\f -> field c f <> semi) structFields) <> typeAnnots c structAnnotations @@ -150,7 +171,7 @@ union :: Config -> T.Union ann -> Doc union c@Config{indentWidth} T.Union{..} = unionDocstring $$ - text "union" <+> text unionName <+> + reserved "union" <+> declare unionName <+> block indentWidth line (map (\f -> field c f <> semi) unionFields) <> typeAnnots c unionAnnotations @@ -159,7 +180,7 @@ exception :: Config -> T.Exception ann -> Doc exception c@Config{indentWidth} T.Exception{..} = exceptionDocstring $$ - text "exception" <+> text exceptionName <+> + reserved "exception" <+> declare exceptionName <+> block indentWidth line (map (\f -> field c f <> semi) exceptionFields) <> typeAnnots c exceptionAnnotations @@ -168,7 +189,7 @@ senum :: Config -> T.Senum ann -> Doc senum c@Config{indentWidth} T.Senum{..} = senumDocstring $$ - text "senum" <+> text senumName <+> + reserved "senum" <+> declare senumName <+> encloseSep indentWidth lbrace rbrace comma (map literal senumValues) <> typeAnnots c senumAnnotations @@ -176,34 +197,31 @@ pretty = senum defaultConfig field :: Config -> T.Field ann -> Doc -field c f = fieldDocstring $$ - hcat [fid, req, typeReference c typ, space, text fieldName, def, annots] - where - T.Field - { fieldValueType = typ - , fieldRequiredness = requiredness - , .. - } = f - fid = case fieldIdentifier of - Nothing -> empty - Just i -> integer i <> colon <> space - req = case requiredness of - Nothing -> empty - Just r -> fieldRequiredness r <> space - def = case fieldDefaultValue of - Nothing -> empty - Just v -> space <> equals <+> constantValue c v - annots = typeAnnots c fieldAnnotations +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 -fieldRequiredness :: T.FieldRequiredness -> Doc -fieldRequiredness T.Optional = text "optional" -fieldRequiredness T.Required = text "required" +requiredness :: T.FieldRequiredness -> Doc +requiredness T.Optional = reserved "optional" +requiredness T.Required = reserved "required" instance Pretty T.FieldRequiredness where - pretty = fieldRequiredness + pretty = requiredness enumValue :: Config -> T.EnumDef ann -> Doc enumValue c T.EnumDef{..} = enumDefDocstring $$ @@ -211,7 +229,7 @@ where value = case enumDefValue of Nothing -> empty - Just v -> space <> text "=" <+> integer v + Just v -> space <> equals <+> integer v instance Pretty (T.EnumDef a) where pretty = enumValue defaultConfig @@ -221,23 +239,29 @@ typeReference 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.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 -> - text "map" <> angles (typeReference c k <> comma <+> typeReference c v) - <> typeAnnots c anns + reserved "map" + <> enclose langle rangle + (typeReference c k <> comma <+> typeReference c v) + <> typeAnnots c anns T.SetType v anns -> - text "set" <> angles (typeReference c v) <> typeAnnots c anns + reserved "set" + <> enclose langle rangle (typeReference c v) + <> typeAnnots c anns T.ListType v anns -> - text "list" <> angles (typeReference c v) <> typeAnnots c anns + reserved "list" + <> enclose langle rangle (typeReference c v) + <> typeAnnots c anns instance Pretty (T.TypeReference a) where pretty = typeReference defaultConfig @@ -275,18 +299,26 @@ pretty = typeAnnot literal :: Text -> Doc -literal = dquotes . text +literal = cyan . dquotes . text -- TODO: escaping? text :: Text -> Doc -text = PP.text . unpack +text = P.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 = case lines (strip t) of [] -> y - ls -> wrapComments ls <$> y + ls -> dullblue (wrapComments ls) <$> y where wrapComments ls = align . vsep $ text "/**" @@ -297,7 +329,7 @@ block :: Int -> Doc -> [Doc] -> Doc -block indent s items = braces $ +block indent s items = enclose lbrace rbrace $ nest indent (linebreak <> (items `sepBy` s)) <> linebreak sepBy :: [Doc] -> Doc -> Doc @@ -313,3 +345,39 @@ 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 "=" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,7 +9,8 @@ The parser uses [`parsers`] to allow plugging in the underlying parser. A default [`trifecta`] based parser is provided. -The pretty printer supports both, [wl-pprint] and [ansi-wl-pprint]. +The pretty printer supports both, [`wl-pprint`] and [`ansi-wl-pprint`]. The +`ansi-wl-pprint`-based pretty printer produces colored output. Haddock-generated docs are available on [Hackage] and [here]. @@ -17,7 +18,7 @@ [Thrift IDL format]: http://thrift.apache.org/docs/idl [`parsers`]: http://hackage.haskell.org/package/parsers [`trifecta`]: http://hackage.haskell.org/package/trifecta - [wl-pprint]: http://hackage.haskell.org/package/wl-pprint - [ansi-wl-pprint]: http://hackage.haskell.org/package/ansi-wl-pprint + [`wl-pprint`]: http://hackage.haskell.org/package/wl-pprint + [`ansi-wl-pprint`]: http://hackage.haskell.org/package/ansi-wl-pprint [Hackage]: http://hackage.haskell.org/package/language-thrift [here]: http://abhinavg.net/language-thrift/ diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -1,5 +1,5 @@ name: language-thrift -version: 0.6.0.1 +version: 0.6.1.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -49,6 +49,7 @@ main-is: Main.hs build-depends: base -any, + ansi-wl-pprint -any, hspec >=2.0, hspec-discover >=2.1, QuickCheck >=2.5, diff --git a/test/Language/Thrift/TypesSpec.hs b/test/Language/Thrift/TypesSpec.hs --- a/test/Language/Thrift/TypesSpec.hs +++ b/test/Language/Thrift/TypesSpec.hs @@ -3,60 +3,78 @@ import Test.Hspec import Test.Hspec.QuickCheck -import Text.PrettyPrint.Leijen (Doc) -import Text.Parser.Token (whiteSpace) +import Text.Parser.Token (whiteSpace) +import qualified Text.PrettyPrint.ANSI.Leijen as PPA (Doc, plain) +import qualified Text.PrettyPrint.Leijen as PP (Doc) + import Language.Thrift.Arbitrary () import TestUtils -import qualified Language.Thrift.Parser as P -import qualified Language.Thrift.Pretty as PP +import qualified Language.Thrift.Parser as P +import qualified Language.Thrift.Pretty as PP +import qualified Language.Thrift.Pretty.ANSI as PPA spec :: Spec spec = describe "Parser and Printer" $ do prop "can round-trip type references" $ - roundtrip PP.typeReference P.typeReference + roundtrip PP.typeReference PPA.typeReference P.typeReference prop "can round-trip constant values" $ - roundtrip PP.constantValue P.constantValue + roundtrip PP.constantValue PPA.constantValue P.constantValue prop "can round-trip typedefs" $ - roundtrip PP.typedef (whiteSpace >> P.typedef) + roundtrip PP.typedef PPA.typedef (whiteSpace >> P.typedef) prop "can round-trip enums" $ - roundtrip PP.enum (whiteSpace >> P.enum) + roundtrip PP.enum PPA.enum (whiteSpace >> P.enum) prop "can round-trip structs" $ - roundtrip PP.struct (whiteSpace >> P.struct) + roundtrip PP.struct PPA.struct (whiteSpace >> P.struct) prop "can round-trip unions" $ - roundtrip PP.union (whiteSpace >> P.union) + roundtrip PP.union PPA.union (whiteSpace >> P.union) prop "can round-trip exceptions" $ - roundtrip PP.exception (whiteSpace >> P.exception) + roundtrip PP.exception PPA.exception (whiteSpace >> P.exception) prop "can round-trip senums" $ - roundtrip PP.senum (whiteSpace >> P.senum) + roundtrip PP.senum PPA.senum (whiteSpace >> P.senum) prop "can round-trip services" $ - roundtrip PP.service (whiteSpace >> P.service) + roundtrip PP.service PPA.service (whiteSpace >> P.service) prop "can round-trip constants" $ - roundtrip PP.constant (whiteSpace >> P.constant) + roundtrip PP.constant PPA.constant (whiteSpace >> P.constant) prop "can round-trip includes" $ - roundtrip (const PP.include) (whiteSpace >> P.include) + roundtrip + (const PP.include) + (const PPA.include) + (whiteSpace >> P.include) prop "can round-trip namespaces" $ - roundtrip (const PP.namespace) (whiteSpace >> P.namespace) + roundtrip + (const PP.namespace) + (const PPA.namespace) + (whiteSpace >> P.namespace) prop "can round-trip documents" $ - roundtrip PP.program P.program + roundtrip PP.program PPA.program P.program roundtrip - :: (Show a, Eq a) => (PP.Config -> a -> Doc) -> Parser a -> a -> IO () -roundtrip printer parser value = - assertParses parser value (show $ printer (PP.Config 4) value) + :: (Show a, Eq a) + => (PP.Config -> a -> PP.Doc) + -> (PPA.Config -> a -> PPA.Doc) + -> Parser a -> a -> IO () +roundtrip printer ansiPrinter parser value = do + assertParses parser value + (show $ printer (PP.Config 4) value) + + -- For the ANSI pretty printer, we need to discard the color information + -- for the document to be parseable. + assertParses parser value + (show . PPA.plain $ ansiPrinter (PPA.Config 4) value)