diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,10 +4,16 @@ ### Added +- Support for GHC 9.8 ([#775]). + ### Changed ### Fixed +- Wrong default HIndent configuration in [`README.md`] ([#750]). +- Fix the bug of panicking when the given source code has CPP lines and space-prefixed lines ([#780]). +- Fix not pretty-printing multiple signatures in a `SPECIALISE` ([#784]). + ### Removed ## [6.1.0] - 2023-05-17 @@ -362,6 +368,10 @@ [@uhbif19]: https://github.com/uhbif19 [@toku-sa-n]: https://github.com/toku-sa-n +[#784]: https://github.com/mihaimaruseac/hindent/pull/784 +[#780]: https://github.com/mihaimaruseac/hindent/pull/780 +[#775]: https://github.com/mihaimaruseac/hindent/pull/775 +[#750]: https://github.com/mihaimaruseac/hindent/pull/750 [#742]: https://github.com/mihaimaruseac/hindent/pull/742 [#741]: https://github.com/mihaimaruseac/hindent/pull/741 [#739]: https://github.com/mihaimaruseac/hindent/pull/739 @@ -407,5 +417,6 @@ [`TESTS.md`]: TESTS.md [`BENCHMARKS.md`]: BENCHMARKS.md +[`README.md`]: README.md [Johan Tibell's Haskell Style Guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,6 @@ Copyright (c) 2014, Chris Done +Copyright (c) 2015, Andrew Gibiansky +Copyright (c) 2021, Mihai Maruseac All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -56,11 +56,9 @@ indent-size: 2 line-length: 80 force-trailing-newline: true -line-breaks: [":>", ":<|>"] -extensions: - - DataKinds - - GADTs - - TypeApplications +sort-imports: true +line-breaks: [] +extensions: [] ``` By default, hindent preserves the newline or lack of newline in your input. With `force-trailing-newline`, it will make sure there is always a trailing newline. diff --git a/TESTS.md b/TESTS.md --- a/TESTS.md +++ b/TESTS.md @@ -1416,6 +1416,13 @@ {-# SPECIALISE lookup :: [(Int, Int)] -> Int -> Maybe Int #-} ``` +Multiple signatures in a `SPECIALISE` + +```haskell +-- https://github.com/mihaimaruseac/hindent/pull/784 +{-# SPECIALISE foo :: Int -> Int, Double -> Double #-} +``` + A `SCC` ```haskell @@ -3408,6 +3415,24 @@ isDebug = True #else isDebug = False +#endif +``` + +Conditionals inside a `where` with empty lines and CPP + +```haskell +-- https://github.com/mihaimaruseac/hindent/issues/779 +foo = bar + baz + where + +#if 0 + bar = 1 + + baz = 1 +#else + bar = 2 + + baz = 2 #endif ``` diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,13 +1,14 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hindent -version: 6.1.0 +version: 6.1.1 synopsis: Extensible Haskell pretty printer -description: Extensible Haskell pretty printer. Both a library and an executable. See the GitHub page for usage / explanation: +description: Extensible Haskell pretty printer. Both a library and an executable. + See the GitHub page for usage \/ explanation: category: Development stability: Unstable homepage: https://github.com/mihaimaruseac/hindent @@ -85,6 +86,7 @@ , directory , exceptions , filepath + , ghc-lib-parser >=9.2 && <9.9 , ghc-lib-parser-ex , monad-loops , mtl @@ -99,16 +101,6 @@ , utf8-string , yaml default-language: Haskell2010 - if impl(ghc >= 9.6.1) - build-depends: - ghc-lib-parser >=9.6.1.20230312 && <9.7 - else - if impl(ghc >= 9.4.1) - build-depends: - ghc-lib-parser >=9.4.1.20220807 && <9.5 - else - build-depends: - ghc-lib-parser >=9.2.3.20220527 && <9.3 library hindent-internal exposed-modules: @@ -129,6 +121,7 @@ , directory , exceptions , filepath + , ghc-lib-parser >=9.2 && <9.9 , ghc-lib-parser-ex , monad-loops , mtl @@ -143,16 +136,6 @@ , utf8-string , yaml default-language: Haskell2010 - if impl(ghc >= 9.6.1) - build-depends: - ghc-lib-parser >=9.6.1.20230312 && <9.7 - else - if impl(ghc >= 9.4.1) - build-depends: - ghc-lib-parser >=9.4.1.20220807 && <9.5 - else - build-depends: - ghc-lib-parser >=9.2.3.20220527 && <9.3 executable hindent main-is: Main.hs @@ -171,6 +154,7 @@ , directory , exceptions , filepath + , ghc-lib-parser >=9.2 && <9.9 , ghc-lib-parser-ex , hindent , monad-loops @@ -186,16 +170,6 @@ , utf8-string , yaml default-language: Haskell2010 - if impl(ghc >= 9.6.1) - build-depends: - ghc-lib-parser >=9.6.1.20230312 && <9.7 - else - if impl(ghc >= 9.4.1) - build-depends: - ghc-lib-parser >=9.4.1.20220807 && <9.5 - else - build-depends: - ghc-lib-parser >=9.2.3.20220527 && <9.3 test-suite hindent-test type: exitcode-stdio-1.0 @@ -216,6 +190,7 @@ , directory , exceptions , filepath + , ghc-lib-parser >=9.2 && <9.9 , ghc-lib-parser-ex , hindent , hindent-internal @@ -233,16 +208,6 @@ , utf8-string , yaml default-language: Haskell2010 - if impl(ghc >= 9.6.1) - build-depends: - ghc-lib-parser >=9.6.1.20230312 && <9.7 - else - if impl(ghc >= 9.4.1) - build-depends: - ghc-lib-parser >=9.4.1.20220807 && <9.5 - else - build-depends: - ghc-lib-parser >=9.2.3.20220527 && <9.3 benchmark hindent-bench type: exitcode-stdio-1.0 @@ -264,6 +229,7 @@ , directory , exceptions , filepath + , ghc-lib-parser >=9.2 && <9.9 , ghc-lib-parser-ex , hindent , hindent-internal @@ -280,13 +246,3 @@ , utf8-string , yaml default-language: Haskell2010 - if impl(ghc >= 9.6.1) - build-depends: - ghc-lib-parser >=9.6.1.20230312 && <9.7 - else - if impl(ghc >= 9.4.1) - build-depends: - ghc-lib-parser >=9.4.1.20220807 && <9.5 - else - build-depends: - ghc-lib-parser >=9.2.3.20220527 && <9.3 diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -25,7 +25,6 @@ import Control.Exception import Control.Monad -import Control.Monad.State.Strict import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (Builder) @@ -123,7 +122,11 @@ processBlock (HaskellSource yPos text) = let ls = S8.lines text prefix = findPrefix ls - code = unlines' (map (stripPrefix prefix) ls) + code = unlines' (map stripPrefixIfNotNull ls) + stripPrefixIfNotNull s = + if S.null s + then s + else stripPrefix prefix s in case parseModule mfilepath allExts (UTF8.toString code) of POk _ m -> Right @@ -180,21 +183,3 @@ prettyPrint :: Config -> HsModule' -> Builder prettyPrint config m = runPrinterStyle config (pretty $ modifyASTForPrettyPrinting m) - --- | Pretty print the given printable thing. -runPrinterStyle :: Config -> Printer () -> Builder -runPrinterStyle config m = - maybe (error "Printer failed with mzero call.") psOutput - $ execStateT (runPrinter m) initState - where - initState = - PrintState - { psIndentLevel = 0 - , psOutput = mempty - , psNewline = False - , psColumn = 0 - , psLine = 1 - , psConfig = config - , psFitOnOneLine = False - , psEolComment = False - } diff --git a/src/HIndent/Parse.hs b/src/HIndent/Parse.hs --- a/src/HIndent/Parse.hs +++ b/src/HIndent/Parse.hs @@ -20,6 +20,9 @@ import GHC.Utils.Error import GHC.Utils.Outputable hiding ((<>), empty, text) #endif +#if MIN_VERSION_ghc_lib_parser(9,8,1) +import GHC.Unit.Module.Warnings +#endif -- | This function parses the given Haskell source code with the given file -- path (if any) and parse options. parseModule :: @@ -49,7 +52,30 @@ -- The 'StarIsType' extension is always enabled to compile a code using -- kinds like '* -> *'. parserOptsFromExtensions :: [GLP.Extension] -> ParserOpts -#if MIN_VERSION_ghc_lib_parser(9,4,1) +#if MIN_VERSION_ghc_lib_parser(9,8,1) +parserOptsFromExtensions opts = + mkParserOpts + opts' + diagOpts + [] -- There are no supported languages and extensions (this list is used only in error messages) + False -- Safe imports are off. + False -- Haddock comments are treated as normal comments. + True -- Comments are kept in an AST. + False -- Do not update the internal position of a comment. + where + opts' = ES.fromList $ GLP.StarIsType : opts + diagOpts = + DiagOpts + { diag_warning_flags = ES.empty + , diag_fatal_warning_flags = ES.empty + , diag_custom_warning_categories = emptyWarningCategorySet + , diag_fatal_custom_warning_categories = emptyWarningCategorySet + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } +#elif MIN_VERSION_ghc_lib_parser(9,4,1) parserOptsFromExtensions opts = mkParserOpts opts' diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -139,6 +139,7 @@ , (importsExist m, prettyImports) , (declsExist m, prettyDecls) ] + prettyModuleDecl :: HsModule GhcPs -> Printer () prettyModuleDecl HsModule {hsmodName = Nothing} = error "The module declaration does not exist." prettyModuleDecl HsModule { hsmodName = Just name @@ -249,7 +250,7 @@ pretty' (InstD _ inst) = pretty inst pretty' (DerivD _ x) = pretty x pretty' (ValD _ bind) = pretty bind - pretty' (SigD _ s) = pretty $ DeclSig s + pretty' (SigD _ s) = pretty s pretty' (KindSigD _ x) = pretty x pretty' (DefD _ x) = pretty x pretty' (ForD _ x) = pretty x @@ -401,18 +402,21 @@ string " ::" horizontal <-|> vertical where - horizontal = space >> pretty (hswc_body params) + horizontal = do + space + pretty $ HsSigTypeInsideDeclSig <$> hswc_body params vertical = do headLen <- printerLength printFunName indentSpaces <- getIndentSpaces if headLen < indentSpaces - then space - else newline - indentedBlock - $ indentedWithSpace 3 - $ pretty - $ HsSigTypeInsideVerticalFuncSig <$> hswc_body params - printFunName = pretty $ head funName + then space |=> pretty (HsSigTypeInsideDeclSig <$> hswc_body params) + else do + newline + indentedBlock + $ indentedWithSpace 3 + $ pretty + $ HsSigTypeInsideDeclSig <$> hswc_body params + printFunName = hCommaSep $ fmap pretty funName pretty' (PatSynSig _ names sig) = spaced [string "pattern", hCommaSep $ fmap pretty names, string "::", pretty sig] @@ -437,12 +441,12 @@ pretty' (FixSig _ x) = pretty x pretty' (InlineSig _ name detail) = spaced [string "{-#", pretty detail, pretty name, string "#-}"] - pretty' (SpecSig _ name sig _) = + pretty' (SpecSig _ name sigs _) = spaced [ string "{-# SPECIALISE" , pretty name , string "::" - , pretty $ head sig + , hCommaSep $ fmap pretty sigs , string "#-}" ] pretty' (SpecInstSig _ sig) = @@ -466,18 +470,21 @@ string " ::" horizontal <-|> vertical where - horizontal = space >> pretty (hswc_body params) + horizontal = do + space + pretty $ HsSigTypeInsideDeclSig <$> hswc_body params vertical = do headLen <- printerLength printFunName indentSpaces <- getIndentSpaces if headLen < indentSpaces - then space - else newline - indentedBlock - $ indentedWithSpace 3 - $ pretty - $ HsSigTypeInsideVerticalFuncSig <$> hswc_body params - printFunName = pretty $ head funName + then space |=> pretty (HsSigTypeInsideDeclSig <$> hswc_body params) + else do + newline + indentedBlock + $ indentedWithSpace 3 + $ pretty + $ HsSigTypeInsideDeclSig <$> hswc_body params + printFunName = hCommaSep $ fmap pretty funName pretty' (PatSynSig _ names sig) = spaced [string "pattern", hCommaSep $ fmap pretty names, string "::", pretty sig] @@ -503,12 +510,12 @@ pretty' (FixSig _ x) = pretty x pretty' (InlineSig _ name detail) = spaced [string "{-#", pretty detail, pretty name, string "#-}"] - pretty' (SpecSig _ name sig _) = + pretty' (SpecSig _ name sigs _) = spaced [ string "{-# SPECIALISE" , pretty name , string "::" - , pretty $ head sig + , hCommaSep $ fmap pretty sigs , string "#-}" ] pretty' (SpecInstSig _ _ sig) = @@ -526,28 +533,6 @@ , string "#-}" ] #endif -instance Pretty DeclSig where - pretty' (DeclSig (TypeSig _ funName params)) = do - printFunName - string " ::" - horizontal <-|> vertical - where - horizontal = do - space - pretty $ HsSigTypeInsideDeclSig <$> hswc_body params - vertical = do - headLen <- printerLength printFunName - indentSpaces <- getIndentSpaces - if headLen < indentSpaces - then space |=> pretty (HsSigTypeInsideDeclSig <$> hswc_body params) - else do - newline - indentedBlock - $ indentedWithSpace 3 - $ pretty - $ HsSigTypeInsideDeclSig <$> hswc_body params - printFunName = hCommaSep $ fmap pretty funName - pretty' (DeclSig x) = pretty x #if MIN_VERSION_ghc_lib_parser(9,6,1) instance Pretty (HsDataDefn GhcPs) where pretty' HsDataDefn {..} = @@ -714,7 +699,7 @@ string " @" pretty r #endif -prettyHsExpr (OpApp _ l o r) = pretty (InfixApp l o r False) +prettyHsExpr (OpApp _ l o r) = pretty (InfixApp l o r) prettyHsExpr (NegApp _ x _) = string "-" >> pretty x #if MIN_VERSION_ghc_lib_parser(9,4,1) prettyHsExpr (HsPar _ _ expr _) = parens $ pretty expr @@ -797,9 +782,35 @@ vertical = do pretty name (space >> pretty fields) <-|> (newline >> indentedBlock (pretty fields)) -#if MIN_VERSION_ghc_lib_parser(9,4,1) +#if MIN_VERSION_ghc_lib_parser(9,8,1) prettyHsExpr (RecordUpd _ name fields) = hor <-|> ver where + hor = spaced [pretty name, printHorFields fields] + ver = do + pretty name + newline + indentedBlock $ printHorFields fields <-|> printVerFields fields + printHorFields RegularRecUpdFields {..} = + hFields $ fmap (`printCommentsAnd` horField) recUpdFields + printHorFields OverloadedRecUpdFields {..} = + hFields $ fmap (`printCommentsAnd` horField) olRecUpdFields + printVerFields RegularRecUpdFields {..} = + vFields $ fmap printField recUpdFields + printVerFields OverloadedRecUpdFields {..} = + vFields $ fmap printField olRecUpdFields + printField x = printCommentsAnd x $ (<-|>) <$> horField <*> verField + horField HsFieldBind {..} = do + pretty hfbLHS + string " = " + pretty hfbRHS + verField HsFieldBind {..} = do + pretty hfbLHS + string " =" + newline + indentedBlock $ pretty hfbRHS +#elif MIN_VERSION_ghc_lib_parser(9,4,1) +prettyHsExpr (RecordUpd _ name fields) = hor <-|> ver + where hor = spaced [pretty name, either printHorFields printHorFields fields] ver = do pretty name @@ -1207,7 +1218,7 @@ ver = newline >> indentedBlock (pretty body) pretty' ApplicativeStmt {} = notGeneratedByParser pretty' (BodyStmt _ (L loc (OpApp _ l o r)) _ _) = - pretty (L loc (InfixApp l o r True)) + pretty (L loc (InfixApp l o r)) pretty' (BodyStmt _ body _ _) = pretty body pretty' (LetStmt _ l) = string "let " |=> pretty l pretty' (ParStmt _ xs _ _) = hvBarSep $ fmap pretty xs @@ -1308,7 +1319,11 @@ where hor = spaced $ fmap pretty [l, r] ver = pretty $ HsTypeWithVerticalAppTy x +#if MIN_VERSION_ghc_lib_parser(9,8,1) +prettyHsType (HsAppKindTy _ l _ r) = pretty l >> string " @" >> pretty r +#else prettyHsType (HsAppKindTy _ l r) = pretty l >> string " @" >> pretty r +#endif prettyHsType (HsFunTy _ _ a b) = (pretty a >> string " -> ") |=> pretty b prettyHsType (HsListTy _ xs) = brackets $ pretty xs prettyHsType (HsTupleTy _ HsUnboxedTuple []) = string "(# #)" @@ -1317,11 +1332,11 @@ prettyHsType (HsTupleTy _ HsBoxedOrConstraintTuple xs) = hvTuple' $ fmap pretty xs prettyHsType (HsSumTy _ xs) = hvUnboxedSum' $ fmap pretty xs - -- For `HsOpTy`, we do not need a single quote for the infix operator. An - -- explicit promotion is necessary if there is a data constructor and - -- a type with the same name. However, infix data constructors never - -- share their names with types because types cannot contain symbols. - -- Thus there is no ambiguity. +-- For `HsOpTy`, we do not need a single quote for the infix operator. An +-- explicit promotion is necessary if there is a data constructor and +-- a type with the same name. However, infix data constructors never +-- share their names with types because types cannot contain symbols. +-- Thus there is no ambiguity. #if MIN_VERSION_ghc_lib_parser(9,4,1) prettyHsType (HsOpTy _ _ l op r) = do lineBreak <- gets (configLineBreaks . psConfig) @@ -1608,7 +1623,7 @@ pretty' (TExpBr _ x) = typedBrackets $ pretty x #endif instance Pretty SigBindFamily where - pretty' (Sig x) = pretty $ DeclSig x + pretty' (Sig x) = pretty x pretty' (Bind x) = pretty x pretty' (TypeFamily x) = pretty x pretty' (TyFamInst x) = pretty x @@ -2053,15 +2068,25 @@ case famEqnFor of DataFamInstDeclForTopLevel -> "data instance" DataFamInstDeclForInsideClassInst -> "data" - -- | HsArg (LHsType GhcPs) (LHsType GhcPs) +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance Pretty (HsArg + GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))) where pretty' (HsValArg x) = pretty x pretty' (HsTypeArg _ x) = string "@" >> pretty x pretty' HsArgPar {} = notUsedInParsedStage +#else +instance Pretty + (HsArg + (GenLocated SrcSpanAnnA (HsType GhcPs)) + (GenLocated SrcSpanAnnA (HsType GhcPs))) where + pretty' (HsValArg x) = pretty x + pretty' (HsTypeArg _ x) = string "@" >> pretty x + pretty' HsArgPar {} = notUsedInParsedStage +#endif #if MIN_VERSION_ghc_lib_parser(9,4,1) instance Pretty (HsQuote GhcPs) where pretty' (ExpBr _ x) = brackets $ wrapWithBars $ pretty x @@ -2080,10 +2105,25 @@ instance Pretty (WarnDecls GhcPs) where pretty' (Warnings _ _ x) = lined $ fmap pretty x #endif +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance Pretty (WarnDecl GhcPs) where pretty' (Warning _ names deprecatedOrWarning) = case deprecatedOrWarning of DeprecatedTxt _ reasons -> prettyWithTitleReasons "DEPRECATED" reasons + WarningTxt _ _ reasons -> prettyWithTitleReasons "WARNING" reasons + where + prettyWithTitleReasons title reasons = + lined + [ string $ "{-# " ++ title + , spaced + [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons] + , string " #-}" + ] +#else +instance Pretty (WarnDecl GhcPs) where + pretty' (Warning _ names deprecatedOrWarning) = + case deprecatedOrWarning of + DeprecatedTxt _ reasons -> prettyWithTitleReasons "DEPRECATED" reasons WarningTxt _ reasons -> prettyWithTitleReasons "WARNING" reasons where prettyWithTitleReasons title reasons = @@ -2093,6 +2133,7 @@ [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons] , string " #-}" ] +#endif #if MIN_VERSION_ghc_lib_parser(9,4,1) instance Pretty (WithHsDocIdentifiers StringLiteral GhcPs) where pretty' WithHsDocIdentifiers {..} = pretty hsDocString @@ -2218,11 +2259,16 @@ , string "::" , pretty fd_sig_ty ] -#if MIN_VERSION_ghc_lib_parser(9,6,1) +#if MIN_VERSION_ghc_lib_parser(9,8,0) instance Pretty (ForeignImport GhcPs) where pretty' (CImport (L _ (SourceText s)) conv safety _ _) = - spaced [pretty conv, pretty safety, string s] + spaced [pretty conv, pretty safety, output s] pretty' (CImport _ conv safety _ _) = spaced [pretty conv, pretty safety] +#elif MIN_VERSION_ghc_lib_parser(9,6,0) +instance Pretty (ForeignImport GhcPs) where + pretty' (CImport (L _ (SourceText s)) conv safety _ _ ) = + spaced [pretty conv, pretty safety, string s] + pretty' (CImport _ conv safety _ _) = spaced [pretty conv, pretty safety] #else instance Pretty ForeignImport where pretty' (CImport conv safety _ _ (L _ (SourceText s))) = @@ -2230,8 +2276,12 @@ pretty' (CImport conv safety _ _ _) = spaced [pretty conv, pretty safety] #endif -#if MIN_VERSION_ghc_lib_parser(9,6,1) +#if MIN_VERSION_ghc_lib_parser(9,8,0) instance Pretty (ForeignExport GhcPs) where + pretty' (CExport (L _ (SourceText s)) conv) = spaced [pretty conv, output s] + pretty' (CExport _ conv) = pretty conv +#elif MIN_VERSION_ghc_lib_parser(9,6,0) +instance Pretty (ForeignExport GhcPs) where pretty' (CExport (L _ (SourceText s)) conv) = spaced [pretty conv, string s] pretty' (CExport _ conv) = pretty conv #else @@ -2359,11 +2409,15 @@ pretty' (HsIntegral x) = pretty x pretty' (HsFractional x) = pretty x pretty' (HsIsString _ x) = string $ unpackFS x - +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance Pretty IntegralLit where + pretty' IL {il_text = SourceText s} = output s + pretty' IL {..} = string $ show il_value +#else +instance Pretty IntegralLit where pretty' IL {il_text = SourceText s} = string s pretty' IL {..} = string $ show il_value - +#endif instance Pretty FractionalLit where pretty' = output @@ -2553,13 +2607,19 @@ pretty' StdCallConv = string "stdcall" pretty' PrimCallConv = string "prim" pretty' JavaScriptCallConv = string "javascript" - +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance Pretty ModuleDeprecatedPragma where + pretty' (ModuleDeprecatedPragma (WarningTxt _ _ xs)) = + spaced [string "{-# WARNING", spaced $ fmap pretty xs, string "#-}"] + pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ xs)) = + spaced [string "{-# DEPRECATED", spaced $ fmap pretty xs, string "#-}"] +#else +instance Pretty ModuleDeprecatedPragma where pretty' (ModuleDeprecatedPragma (WarningTxt _ xs)) = spaced [string "{-# WARNING", spaced $ fmap pretty xs, string "#-}"] pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ xs)) = spaced [string "{-# DEPRECATED", spaced $ fmap pretty xs, string "#-}"] - +#endif instance Pretty HsSrcBang where pretty' (HsSrcBang _ unpack strictness) = do pretty unpack diff --git a/src/HIndent/Pretty/NodeComments.hs b/src/HIndent/Pretty/NodeComments.hs --- a/src/HIndent/Pretty/NodeComments.hs +++ b/src/HIndent/Pretty/NodeComments.hs @@ -147,9 +147,6 @@ nodeComments (SCCFunSig x _ _ _) = nodeComments x nodeComments (CompleteMatchSig x _ _ _) = nodeComments x #endif -instance CommentExtraction DeclSig where - nodeComments (DeclSig x) = nodeComments x - instance CommentExtraction (HsDataDefn GhcPs) where nodeComments HsDataDefn {} = emptyNodeComments @@ -623,9 +620,19 @@ instance CommentExtraction ModuleNameWithPrefix where nodeComments ModuleNameWithPrefix {} = emptyNodeComments - +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance CommentExtraction (IE GhcPs) where nodeComments IEVar {} = emptyNodeComments + nodeComments (IEThingAbs (_, x) _) = nodeComments x + nodeComments (IEThingAll (_, x) _) = nodeComments x + nodeComments (IEThingWith (_, x) _ _ _) = nodeComments x + nodeComments (IEModuleContents (_, x) _) = nodeComments x + nodeComments IEGroup {} = emptyNodeComments + nodeComments IEDoc {} = emptyNodeComments + nodeComments IEDocNamed {} = emptyNodeComments +#else +instance CommentExtraction (IE GhcPs) where + nodeComments IEVar {} = emptyNodeComments nodeComments (IEThingAbs x _) = nodeComments x nodeComments (IEThingAll x _) = nodeComments x nodeComments (IEThingWith x _ _ _) = nodeComments x @@ -633,7 +640,7 @@ nodeComments IEGroup {} = emptyNodeComments nodeComments IEDoc {} = emptyNodeComments nodeComments IEDocNamed {} = emptyNodeComments - +#endif instance CommentExtraction (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where nodeComments FamEqn {..} = nodeComments feqn_ext @@ -644,15 +651,25 @@ -- | Pretty-print a data instance. instance CommentExtraction (FamEqn GhcPs (HsDataDefn GhcPs)) where nodeComments FamEqn {..} = nodeComments feqn_ext - -- | HsArg (LHsType GhcPs) (LHsType GhcPs) +#if MIN_VERSION_ghc_lib_parser(9,8,1) instance CommentExtraction (HsArg + GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))) where nodeComments HsValArg {} = emptyNodeComments nodeComments HsTypeArg {} = emptyNodeComments nodeComments HsArgPar {} = emptyNodeComments +#else +instance CommentExtraction + (HsArg + (GenLocated SrcSpanAnnA (HsType GhcPs)) + (GenLocated SrcSpanAnnA (HsType GhcPs))) where + nodeComments HsValArg {} = emptyNodeComments + nodeComments HsTypeArg {} = emptyNodeComments + nodeComments HsArgPar {} = emptyNodeComments +#endif #if MIN_VERSION_ghc_lib_parser(9,4,1) instance CommentExtraction (HsQuote GhcPs) where nodeComments ExpBr {} = emptyNodeComments @@ -969,6 +986,12 @@ instance CommentExtraction (HsUntypedSplice GhcPs) where nodeComments (HsUntypedSpliceExpr x _) = nodeComments x nodeComments HsQuasiQuote {} = emptyNodeComments +#endif + +#if MIN_VERSION_ghc_lib_parser(9,8,1) +instance CommentExtraction (LHsRecUpdFields GhcPs) where + nodeComments RegularRecUpdFields {} = emptyNodeComments + nodeComments OverloadedRecUpdFields {} = emptyNodeComments #endif -- | Marks an AST node as never appearing in the AST. -- diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs --- a/src/HIndent/Pretty/Types.hs +++ b/src/HIndent/Pretty/Types.hs @@ -33,7 +33,6 @@ , pattern FamEqnInsideClassInst , StmtLRInsideVerticalList(..) , ParStmtBlockInsideVerticalList(..) - , DeclSig(..) , TopLevelTyFamInstDecl(..) , Context(..) , HorizontalContext(..) @@ -89,7 +88,6 @@ { lhs :: LHsExpr GhcPs , op :: LHsExpr GhcPs , rhs :: LHsExpr GhcPs - , immediatelyAfterDo :: Bool } -- | `GRHSs` with a label indicating in which context the RHS is located @@ -204,10 +202,6 @@ -- | `ParStmtBlock` inside a vertically printed list. newtype ParStmtBlockInsideVerticalList = ParStmtBlockInsideVerticalList (ParStmtBlock GhcPs GhcPs) - --- | A top-level function signature. -newtype DeclSig = - DeclSig (Sig GhcPs) -- | A top-level type family instance declaration. newtype TopLevelTyFamInstDecl = diff --git a/src/HIndent/Printer.hs b/src/HIndent/Printer.hs --- a/src/HIndent/Printer.hs +++ b/src/HIndent/Printer.hs @@ -8,11 +8,12 @@ module HIndent.Printer ( Printer(..) , PrintState(..) + , runPrinterStyle ) where import Control.Applicative import Control.Monad -import Control.Monad.State.Strict (MonadState(..), StateT) +import Control.Monad.State.Strict import Data.ByteString.Builder import Data.Int (Int64) import HIndent.Config @@ -48,3 +49,21 @@ -- the maximum column. , psEolComment :: !Bool } + +-- | Pretty print the given printable thing. +runPrinterStyle :: Config -> Printer () -> Builder +runPrinterStyle config m = + maybe (error "Printer failed with mzero call.") psOutput + $ execStateT (runPrinter m) initState + where + initState = + PrintState + { psIndentLevel = 0 + , psOutput = mempty + , psNewline = False + , psColumn = 0 + , psLine = 1 + , psConfig = config + , psFitOnOneLine = False + , psEolComment = False + }