diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +## Ormolu 0.7.3.0 + +* Switched to `ghc-lib-parser-9.8`, with the following new syntactic features: + * `ExtendedLiterals`: `123#Int8` is a literal of type `Int8#`. (disabled by + default) + * `TypeAbstractions`: `@k`-binders in data type declarations (enabled by + default) + * GHC proposal [#134](https://github.com/ghc-proposals/ghc-proposals/blob/0b652bd70258e354dfe4a05940182007596f8bf7/proposals/0134-deprecating-exports-proposal.rst): deprecating/warning about exports + * GHC proposal [#541](https://github.com/ghc-proposals/ghc-proposals/blob/0b652bd70258e354dfe4a05940182007596f8bf7/proposals/0541-warning-pragmas-with-categories.rst): warning categories + ## Ormolu 0.7.2.0 * Preserve necessary braces for final function arguments. [Issue diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/data/examples/declaration/data/invisible-binders-out.hs b/data/examples/declaration/data/invisible-binders-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/invisible-binders-out.hs @@ -0,0 +1,2 @@ +type T :: forall k. k -> forall j. j -> Type +data T @k (a :: k) @(j :: Type) (b :: j) diff --git a/data/examples/declaration/data/invisible-binders.hs b/data/examples/declaration/data/invisible-binders.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/invisible-binders.hs @@ -0,0 +1,2 @@ +type T :: forall k. k -> forall j. j -> Type +data T @k (a :: k) @(j :: Type) (b :: j) diff --git a/data/examples/declaration/signature/fixity/infix-out.hs b/data/examples/declaration/signature/fixity/infix-out.hs --- a/data/examples/declaration/signature/fixity/infix-out.hs +++ b/data/examples/declaration/signature/fixity/infix-out.hs @@ -1,3 +1,5 @@ infix 0 infix 9 <^-^> + +infix 2 -> diff --git a/data/examples/declaration/signature/fixity/infix.hs b/data/examples/declaration/signature/fixity/infix.hs --- a/data/examples/declaration/signature/fixity/infix.hs +++ b/data/examples/declaration/signature/fixity/infix.hs @@ -1,2 +1,4 @@ infix 0 infix 9 <^-^> + +infix 2 -> diff --git a/data/examples/declaration/value/function/primitive-literals-out.hs b/data/examples/declaration/value/function/primitive-literals-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/primitive-literals-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExtendedLiterals #-} +{-# LANGUAGE MagicHash #-} + +foo = 1# + +bar = 2## + +baz = 3#Word32 + +baz = 0b1010#Int64 diff --git a/data/examples/declaration/value/function/primitive-literals.hs b/data/examples/declaration/value/function/primitive-literals.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/primitive-literals.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ExtendedLiterals, MagicHash #-} + +foo = 1# + +bar = 2## + +baz = 3#Word32 + +baz = 0b1010#Int64 diff --git a/data/examples/declaration/warning/warning-single-line-out.hs b/data/examples/declaration/warning/warning-single-line-out.hs --- a/data/examples/declaration/warning/warning-single-line-out.hs +++ b/data/examples/declaration/warning/warning-single-line-out.hs @@ -11,3 +11,6 @@ data Number = Number Dobule {-# DEPRECATED Number "Use Scientific instead." #-} + +head (a : _) = a +{-# WARNING in "x-partial" head "This function is partial..." #-} diff --git a/data/examples/declaration/warning/warning-single-line.hs b/data/examples/declaration/warning/warning-single-line.hs --- a/data/examples/declaration/warning/warning-single-line.hs +++ b/data/examples/declaration/warning/warning-single-line.hs @@ -13,3 +13,6 @@ data Number = Number Dobule {-# DEPRECATED Number "Use Scientific instead." #-} + +head (a:_) = a +{-# WARNING in "x-partial" head "This function is partial..." #-} diff --git a/data/examples/import/deprecated-export-multi-line-out.hs b/data/examples/import/deprecated-export-multi-line-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-multi-line-out.hs @@ -0,0 +1,7 @@ +module X + ( {-# DEPRECATE D(D1) "D1 will not be exposed in a version 0.2 and later" #-} + D (D1, D2), + ) +where + +data D = D1 | D2 diff --git a/data/examples/import/deprecated-export-multi-line.hs b/data/examples/import/deprecated-export-multi-line.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-multi-line.hs @@ -0,0 +1,5 @@ +module X + ( {-# DEPRECATE D(D1) "D1 will not be exposed in a version 0.2 and later" #-} + D(D1, D2) + ) where +data D = D1 | D2 diff --git a/data/examples/import/deprecated-export-single-line-out.hs b/data/examples/import/deprecated-export-single-line-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-single-line-out.hs @@ -0,0 +1,3 @@ +module A ({-# DEPRECATED "blah" #-} x) where + +x = True diff --git a/data/examples/import/deprecated-export-single-line.hs b/data/examples/import/deprecated-export-single-line.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-single-line.hs @@ -0,0 +1,1 @@ +module A ( {-# DEPRECATED "blah" #-} x ) where { x = True } diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,10 +1,10 @@ cabal-version: 2.4 name: ormolu -version: 0.7.2.0 +version: 0.7.3.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov -tested-with: ghc ==9.2.8 ghc ==9.4.5 ghc ==9.6.2 +tested-with: ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1 homepage: https://github.com/tweag/ormolu bug-reports: https://github.com/tweag/ormolu/issues synopsis: A formatter for Haskell source code @@ -98,23 +98,23 @@ default-language: GHC2021 build-depends: Cabal-syntax >=3.10 && <3.11, - Diff >=0.4 && <1.0, + Diff >=0.4 && <1, MemoTrie >=0.6 && <0.7, ansi-terminal >=0.10 && <1.1, array >=0.5 && <0.6, - base >=4.14 && <5.0, + base >=4.14 && <5, binary >=0.8 && <0.9, bytestring >=0.2 && <0.13, - containers >=0.5 && <0.7, + containers >=0.5 && <0.8, deepseq >=1.4 && <1.6, directory ^>=1.3, file-embed >=0.0.15 && <0.1, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.6 && <9.7, - megaparsec >=9.0, - mtl >=2.0 && <3.0, + ghc-lib-parser >=9.8 && <9.9, + megaparsec >=9, + mtl >=2 && <3, syb >=0.7 && <0.8, - text >=2.0 && <3.0 + text >=2 && <3 if flag(dev) ghc-options: @@ -135,14 +135,14 @@ default-language: GHC2021 build-depends: Cabal-syntax >=3.10 && <3.11, - base >=4.12 && <5.0, + base >=4.12 && <5, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.6 && <9.7, + ghc-lib-parser >=9.8 && <9.9, optparse-applicative >=0.14 && <0.19, ormolu, - text >=2.0 && <3.0, + text >=2 && <3, th-env >=0.1.1 && <0.2 if flag(dev) @@ -156,7 +156,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover >=2.0 && <3.0 + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 hs-source-dirs: tests other-modules: Ormolu.CabalInfoSpec @@ -174,19 +174,19 @@ build-depends: Cabal-syntax >=3.10 && <3.11, QuickCheck >=2.14, - base >=4.14 && <5.0, + base >=4.14 && <5, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.6 && <9.7, - hspec >=2.0 && <3.0, + ghc-lib-parser >=9.8 && <9.9, + hspec >=2 && <3, hspec-megaparsec >=2.2, - megaparsec >=9.0, + megaparsec >=9, ormolu, path >=0.6 && <0.10, - path-io >=1.4.2 && <2.0, + path-io >=1.4.2 && <2, temporary ^>=1.3, - text >=2.0 && <3.0 + text >=2 && <3 if flag(dev) ghc-options: diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -46,8 +46,10 @@ import Data.Text (Text) import Data.Text qualified as T import Debug.Trace -import GHC.Driver.CmdLine qualified as GHC +import GHC.Driver.Errors.Types +import GHC.Types.Error import GHC.Types.SrcLoc +import GHC.Utils.Error import Ormolu.Config import Ormolu.Diff.ParseResult import Ormolu.Diff.Text @@ -96,8 +98,9 @@ (warnings, result0) <- parseModule' cfg fixityMap OrmoluParsingFailed path originalInput when (cfgDebug cfg) $ do - forM_ warnings $ \(GHC.Warn reason (L loc msg)) -> - traceM $ unwords ["*** WARNING ***", showOutputable loc, msg, showOutputable reason] + forM_ warnings $ \driverMsg -> do + let driverMsgSDoc = formatBulleted $ diagnosticMessage defaultOpts driverMsg + traceM $ unwords ["*** WARNING ***", showOutputable driverMsgSDoc] forM_ result0 $ \case ParsedSnippet r -> do let CommentStream comments = prCommentStream r @@ -244,7 +247,7 @@ FilePath -> -- | Actual input for the parser Text -> - m ([GHC.Warn], [SourceSnippet]) + m (DriverMessages, [SourceSnippet]) parseModule' cfg fixityMap mkException path str = do (warnings, r) <- parseModule cfg fixityMap path str case r of diff --git a/src/Ormolu/Fixity/Imports.hs b/src/Ormolu/Fixity/Imports.hs --- a/src/Ormolu/Fixity/Imports.hs +++ b/src/Ormolu/Fixity/Imports.hs @@ -16,7 +16,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.Types.PackageName import GHC.Data.FastString qualified as GHC -import GHC.Hs hiding (ModuleName) +import GHC.Hs hiding (ModuleName, OpName) import GHC.Types.Name.Occurrence import GHC.Types.PkgQual (RawPkgQual (..)) import GHC.Types.SourceText (StringLiteral (..)) diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -123,7 +123,7 @@ isPrelude = moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName --- | Normalize a collection of import\/export items. +-- | Normalize a collection of import items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty where @@ -139,21 +139,21 @@ Nothing -> Just . L new_l $ case new of IEThingWith _ n wildcard g -> - IEThingWith EpAnnNotUsed n wildcard (normalizeWNames g) + IEThingWith (Nothing, EpAnnNotUsed) n wildcard (normalizeWNames g) other -> other Just old -> let f = \case - IEVar _ n -> IEVar NoExtField n + IEVar _ n -> IEVar Nothing n IEThingAbs _ _ -> new - IEThingAll _ n -> IEThingAll EpAnnNotUsed n + IEThingAll _ n -> IEThingAll (Nothing, EpAnnNotUsed) n IEThingWith _ n wildcard g -> case new of - IEVar NoExtField _ -> + IEVar _ _ -> error "Ormolu.Imports broken presupposition" IEThingAbs _ _ -> - IEThingWith EpAnnNotUsed n wildcard g + IEThingWith (Nothing, EpAnnNotUsed) n wildcard g IEThingAll _ n' -> - IEThingAll EpAnnNotUsed n' + IEThingAll (Nothing, EpAnnNotUsed) n' IEThingWith _ n' wildcard' g' -> let combinedWildcard = case (wildcard, wildcard') of @@ -161,7 +161,7 @@ (_, IEWildcard _) -> IEWildcard 0 _ -> NoIEWildcard in IEThingWith - EpAnnNotUsed + (Nothing, EpAnnNotUsed) n' combinedWildcard (normalizeWNames (g <> g')) @@ -187,7 +187,7 @@ -- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case - IEVar NoExtField x -> IEWrappedNameOrd (unLoc x) + IEVar _ x -> IEWrappedNameOrd (unLoc x) IEThingAbs _ x -> IEWrappedNameOrd (unLoc x) IEThingAll _ x -> IEWrappedNameOrd (unLoc x) IEThingWith _ x _ _ -> IEWrappedNameOrd (unLoc x) diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -28,7 +28,6 @@ import GHC.Data.FastString qualified as GHC import GHC.Data.Maybe (orElse) import GHC.Data.StringBuffer (StringBuffer) -import GHC.Driver.CmdLine qualified as GHC import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Errors.Types qualified as GHC import GHC.Driver.Session as GHC @@ -44,7 +43,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Error import GHC.Utils.Exception (ExceptionMonad) -import GHC.Utils.Outputable (defaultSDocContext) import GHC.Utils.Panic qualified as GHC import Ormolu.Config import Ormolu.Exception @@ -70,7 +68,7 @@ -- | Input for parser Text -> m - ( [GHC.Warn], + ( GHC.DriverMessages, Either (SrcSpan, String) [SourceSnippet] ) parseModule config@Config {..} packageFixityMap path rawInput = liftIO $ do @@ -134,7 +132,7 @@ Nothing -> "" msg = showOutputable - . formatBulleted defaultSDocContext + . formatBulleted . diagnosticMessage GHC.NoDiagnosticOpts $ err in case L.sortOn (rateSeverity . errMsgSeverity) errs of @@ -254,7 +252,8 @@ LinearTypes, -- steals the (%) type operator in some cases OverloadedRecordDot, -- f.g parses differently OverloadedRecordUpdate, -- qualified fields are not supported - OverloadedLabels -- a#b is parsed differently + OverloadedLabels, -- a#b is parsed differently + ExtendedLiterals -- 1#Word32 is parsed differently ] -- | Run a 'GHC.P' computation. @@ -289,7 +288,7 @@ FilePath -> -- | Input for parser StringBuffer -> - IO (Either String ([GHC.Warn], DynFlags)) + IO (Either String (GHC.DriverMessages, DynFlags)) parsePragmasIntoDynFlags flags extraOpts filepath input = catchGhcErrors $ do let (_warnings, fileOpts) = diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -18,6 +18,7 @@ import Control.Monad import Data.Text qualified as T +import GHC.Data.FastString import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp @@ -71,6 +72,8 @@ NameAnn {nann_adornment = NameParens} -> parens N . handleUnboxedSumsAndHashInteraction NameAnn {nann_adornment = NameBackquotes} -> backticks + -- whether the `->` identifier is parenthesized + NameAnnRArrow {nann_mopen = Just _} -> parens N -- special case for unboxed unit tuples NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)" _ -> id @@ -188,4 +191,4 @@ p_sourceText :: SourceText -> R () p_sourceText = \case NoSourceText -> pure () - SourceText s -> txt (T.pack s) + SourceText s -> atom @FastString s diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -139,7 +139,9 @@ p_dataDecl Associated tcdLName - (tyVarsToTyPats tcdTyVars) + (hsq_explicit tcdTyVars) + getLocA + (located' p_hsTyVarBndr) tcdFixity tcdDataDefn ClassDecl {..} -> diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -24,21 +24,25 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type -import Ormolu.Utils (matchAddEpAnn) +import Ormolu.Utils p_dataDecl :: -- | Whether to format as data family FamilyStyle -> -- | Type constructor LocatedN RdrName -> - -- | Type patterns - HsTyPats GhcPs -> + -- | Type variables + [tyVar] -> + -- | Get location information for type variables + (tyVar -> SrcSpan) -> + -- | How to print type variables + (tyVar -> R ()) -> -- | Lexical fixity LexicalFixity -> -- | Data definition HsDataDefn GhcPs -> R () -p_dataDecl style name tpats fixity HsDataDefn {..} = do +p_dataDecl style name tyVars getTyVarLoc p_tyVar fixity HsDataDefn {..} = do txt $ case dd_cons of NewTypeCon _ -> "newtype" DataTypeCons False _ -> "data" @@ -57,7 +61,7 @@ space p_sourceText type_ txt " #-}" - let constructorSpans = getLocA name : fmap lhsTypeArgSrcSpan tpats + let constructorSpans = getLocA name : fmap getTyVarLoc tyVars sigSpans = maybeToList . fmap getLocA $ dd_kindSig declHeaderSpans = maybeToList (getLocA <$> dd_ctxt) ++ constructorSpans ++ sigSpans @@ -76,7 +80,7 @@ (isInfix fixity) True (p_rdrName name) - (p_lhsTypeArg <$> tpats) + (p_tyVar <$> tyVars) forM_ dd_kindSig $ \k -> do space txt "::" diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -97,7 +97,14 @@ p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R () p_dataFamInstDecl style (DataFamInstDecl {dfid_eqn = FamEqn {..}}) = - p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs + p_dataDecl + style + feqn_tycon + feqn_pats + lhsTypeArgSrcSpan + p_lhsTypeArg + feqn_fixity + feqn_rhs match_overlap_mode :: Maybe (LocatedP OverlapMode) -> R () -> R () match_overlap_mode overlap_mode layoutStrategy = diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -15,6 +15,8 @@ where import Data.Functor ((<&>)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import GHC.Hs import GHC.Types.Fixity import GHC.Types.Name (occNameString) @@ -81,7 +83,7 @@ -- | Convert a 'LHsExpr' containing an operator tree to the 'OpTree' -- intermediate representation. exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -exprOpTree (L _ (OpApp _ x op y)) = OpBranches [exprOpTree x, exprOpTree y] [op] +exprOpTree (L _ (OpApp _ x op y)) = BinaryOpBranches (exprOpTree x) op (exprOpTree y) exprOpTree n = OpNode n -- | Print an operator tree where leaves are values. @@ -93,17 +95,15 @@ OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) -> R () p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s) -p_exprOpTree s t@(OpBranches exprs ops) = do - let firstExpr = head exprs - otherExprs = tail exprs - placement = +p_exprOpTree s t@(OpBranches exprs@(firstExpr :| otherExprs) ops) = do + let placement = opBranchPlacement exprPlacement firstExpr (last otherExprs) rightMostNode = \case n@(OpNode _) -> n - OpBranches exprs'' _ -> rightMostNode (last exprs'') + OpBranches exprs'' _ -> rightMostNode (NE.last exprs'') isDoBlock = \case OpNode (L _ (HsDo _ ctx _)) -> case ctx of DoExpr _ -> True @@ -127,7 +127,7 @@ && not (isDoBlock $ rightMostNode prevExpr) -- If all operators at the current level match the conditions to be -- trailing, then put them in a trailing position - isTrailing = all couldBeTrailing $ zip exprs ops + isTrailing = all couldBeTrailing $ zip (NE.toList exprs) ops ub <- if isTrailing then return useBraces else opBranchBraceStyle placement let p_x = ub $ p_exprOpTree s firstExpr putOpsExprs prevExpr (opi : ops') (expr : exprs') = do @@ -171,7 +171,7 @@ cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) cmdOpTree = \case (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix _ [x, y])))) -> - OpBranches [cmdOpTree x, cmdOpTree y] [op] + BinaryOpBranches (cmdOpTree x) op (cmdOpTree y) n -> OpNode n -- | Print an operator tree where leaves are commands. @@ -183,10 +183,8 @@ OpTree (LHsCmdTop GhcPs) (OpInfo (LHsExpr GhcPs)) -> R () p_cmdOpTree s (OpNode x) = located x (p_hsCmdTop s) -p_cmdOpTree s t@(OpBranches exprs ops) = do - let firstExpr = head exprs - otherExprs = tail exprs - placement = +p_cmdOpTree s t@(OpBranches (firstExpr :| otherExprs) ops) = do + let placement = opBranchPlacement cmdTopPlacement firstExpr @@ -218,7 +216,7 @@ -- intermediate representation. tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) tyOpTree (L _ (HsOpTy _ _ l op r)) = - OpBranches [tyOpTree l, tyOpTree r] [op] + BinaryOpBranches (tyOpTree l) op (tyOpTree r) tyOpTree n = OpNode n -- | Print an operator tree where leaves are types. @@ -228,10 +226,8 @@ OpTree (LHsType GhcPs) (OpInfo (LocatedN RdrName)) -> R () p_tyOpTree (OpNode n) = located n p_hsType -p_tyOpTree t@(OpBranches exprs ops) = do - let firstExpr = head exprs - otherExprs = tail exprs - placement = +p_tyOpTree t@(OpBranches (firstExpr :| otherExprs) ops) = do + let placement = opBranchPlacement tyOpPlacement firstExpr diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -33,6 +33,7 @@ import Data.Text qualified as Text import Data.Void import GHC.Data.Bag (bagToList) +import GHC.Data.FastString import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) @@ -347,7 +348,7 @@ inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds))) HsCmdArrForm _ form Infix _ [left, right] -> do modFixityMap <- askModuleFixityMap - let opTree = OpBranches [cmdOpTree left, cmdOpTree right] [form] + let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right) p_cmdOpTree s (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) @@ -678,7 +679,7 @@ located (hswc_body a) p_hsType OpApp _ x op y -> do modFixityMap <- askModuleFixityMap - let opTree = OpBranches [exprOpTree x, exprOpTree y] [op] + let opTree = BinaryOpBranches (exprOpTree x) op (exprOpTree y) p_exprOpTree s (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) @@ -791,11 +792,11 @@ Ambiguous NoExtField n -> n p_recFields p_lbl = sep commaDel (sitcc . located' (p_hsFieldBind p_lbl)) - inci . braces N $ - either - (p_recFields p_updLbl) - (p_recFields $ located' $ coerce p_ldotFieldOccs) - rupd_flds + inci . braces N $ case rupd_flds of + RegularRecUpdFields {..} -> + p_recFields p_updLbl recUpdFields + OverloadedRecUpdFields {..} -> + p_recFields (located' (coerce p_ldotFieldOccs)) olRecUpdFields HsGetField {..} -> do located gf_expr p_hsExpr txt "." @@ -1184,9 +1185,9 @@ _ -> False -- | Print the source text of a string literal while indenting gaps correctly. -p_stringLit :: String -> R () +p_stringLit :: FastString -> R () p_stringLit src = - let s = splitGaps src + let s = splitGaps (unpackFS src) singleLine = txt $ Text.pack (mconcat s) multiLine = @@ -1221,11 +1222,7 @@ -- Attaches previous and next items to each list element zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)] zipPrevNext xs = - let z = - zip - (zip (Nothing : map Just xs) xs) - (map Just (tail xs) ++ repeat Nothing) - in map (\((p, x), n) -> (p, x, n)) z + zip3 (Nothing : map Just xs) xs (map Just (drop 1 xs) ++ [Nothing]) orig (_, x, _) = x ---------------------------------------------------------------------------- diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -11,6 +11,7 @@ ) where +import GHC.Data.FastString import GHC.Hs import Ormolu.Printer.Combinators @@ -18,7 +19,7 @@ p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () -p_stringLit :: String -> R () +p_stringLit :: FastString -> R () data IsApplicand diff --git a/src/Ormolu/Printer/Meat/Declaration/Warning.hs b/src/Ormolu/Printer/Meat/Declaration/Warning.hs --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -1,14 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ormolu.Printer.Meat.Declaration.Warning ( p_warnDecls, - p_moduleWarning, + p_warningTxt, ) where import Data.Foldable import Data.Text (Text) +import Data.Text qualified as T import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.SourceText @@ -16,6 +18,7 @@ import GHC.Unit.Module.Warnings import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Utils p_warnDecls :: WarnDecls GhcPs -> R () p_warnDecls (Warnings _ warnings) = @@ -25,8 +28,8 @@ p_warnDecl (Warning _ functions warningTxt) = p_topLevelWarning functions warningTxt -p_moduleWarning :: WarningTxt GhcPs -> R () -p_moduleWarning wtxt = do +p_warningTxt :: WarningTxt GhcPs -> R () +p_warningTxt wtxt = do let (pragmaText, lits) = warningText wtxt inci $ pragma pragmaText $ inci $ p_lits lits @@ -41,7 +44,12 @@ warningText :: WarningTxt GhcPs -> (Text, [Located StringLiteral]) warningText = \case - WarningTxt _ lits -> ("WARNING", fmap hsDocString <$> lits) + WarningTxt mcat _ lits -> ("WARNING" <> T.pack cat, fmap hsDocString <$> lits) + where + cat = case unLoc <$> mcat of + Just InWarningCategory {..} -> + " in " <> show (showOutputable @WarningCategory (unLoc iwc_wc)) + Nothing -> "" DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) p_lits :: [Located StringLiteral] -> R () diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -10,12 +10,14 @@ where import Control.Monad +import Data.Foldable (for_) import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.PkgQual import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Utils (RelativePos (..), attachRelativePos) p_hsmodExports :: [LIE GhcPs] -> R () @@ -74,7 +76,10 @@ p_lie :: Layout -> RelativePos -> IE GhcPs -> R () p_lie encLayout relativePos = \case - IEVar NoExtField l1 -> do + IEVar mwarn l1 -> do + for_ mwarn $ \warnTxt -> do + located warnTxt p_warningTxt + breakpoint located l1 p_ieWrappedName p_comma IEThingAbs _ l1 -> do diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -49,7 +49,7 @@ p_hsmodName name breakpoint forM_ hsmodDeprecMessage $ \w -> do - located' p_moduleWarning w + located' p_warningTxt w breakpoint case hsmodExports of Nothing -> return () diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -14,7 +14,6 @@ p_conDeclFields, p_lhsTypeArg, p_hsSigType, - tyVarsToTyPats, hsOuterTyVarBndrsToHsType, lhsTypeToSigType, ) @@ -74,7 +73,7 @@ breakpoint inci $ sep breakpoint (located' p_hsType) args - HsAppKindTy _ ty kd -> sitcc $ do + HsAppKindTy _ ty _ kd -> sitcc $ do -- The first argument is the location of the "@..." part. Not 100% sure, -- but I think we can ignore it as long as we use 'located' on both the -- type and the kind. @@ -111,7 +110,7 @@ sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs HsOpTy _ _ x op y -> do modFixityMap <- askModuleFixityMap - let opTree = OpBranches [tyOpTree x, tyOpTree y] [op] + let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y) p_tyOpTree (reassociateOpTree (Just . unLoc) modFixityMap opTree) HsParTy _ t -> @@ -199,27 +198,38 @@ [x] -> located x p_hsType xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs -class IsInferredTyVarBndr flag where +class IsTyVarBndrFlag flag where isInferred :: flag -> Bool + p_tyVarBndrFlag :: flag -> R () + p_tyVarBndrFlag _ = pure () -instance IsInferredTyVarBndr () where +instance IsTyVarBndrFlag () where isInferred () = False -instance IsInferredTyVarBndr Specificity where +instance IsTyVarBndrFlag Specificity where isInferred = \case InferredSpec -> True SpecifiedSpec -> False -p_hsTyVarBndr :: (IsInferredTyVarBndr flag) => HsTyVarBndr flag GhcPs -> R () +instance IsTyVarBndrFlag (HsBndrVis GhcPs) where + isInferred _ = False + p_tyVarBndrFlag = \case + HsBndrRequired -> pure () + HsBndrInvisible _ -> txt "@" + +p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr = \case - UserTyVar _ flag x -> + UserTyVar _ flag x -> do + p_tyVarBndrFlag flag (if isInferred flag then braces N else id) $ p_rdrName x - KindedTyVar _ flag l k -> (if isInferred flag then braces else parens) N $ do - located l atom - space - txt "::" - breakpoint - inci (located k p_hsType) + KindedTyVar _ flag l k -> do + p_tyVarBndrFlag flag + (if isInferred flag then braces else parens) N $ do + located l atom + space + txt "::" + breakpoint + inci (located k p_hsType) data ForAllVisibility = ForAllInvis | ForAllVis @@ -274,21 +284,6 @@ ---------------------------------------------------------------------------- -- Conversion functions - -tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs -tyVarToType = \case - UserTyVar _ () tvar -> HsTyVar EpAnnNotUsed NotPromoted tvar - KindedTyVar _ () tvar kind -> - -- Note: we always add parentheses because for whatever reason GHC does - -- not use HsParTy for left-hand sides of declarations. Please see - -- . This is fine as - -- long as 'tyVarToType' does not get applied to right-hand sides of - -- declarations. - HsParTy EpAnnNotUsed . noLocA $ - HsKindSig EpAnnNotUsed (noLocA (HsTyVar EpAnnNotUsed NotPromoted tvar)) kind - -tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs -tyVarsToTyPats HsQTvs {..} = HsValArg . fmap tyVarToType <$> hsq_explicit -- could be generalized to also handle () instead of Specificity hsOuterTyVarBndrsToHsType :: diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -1,9 +1,11 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} -- | This module helps handle operator chains composed of different -- operators that may have different precedence and fixities. module Ormolu.Printer.Operators ( OpTree (..), + pattern BinaryOpBranches, OpInfo (..), opTreeLoc, reassociateOpTree, @@ -11,6 +13,7 @@ ) where +import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import GHC.Types.Name.Reader import GHC.Types.SrcLoc @@ -31,9 +34,12 @@ | -- | A subtree of operator application(s); the invariant is: @length -- exprs == length ops + 1@. @OpBranches [x, y, z] [op1, op2]@ -- represents the expression @x op1 y op2 z@. - OpBranches [OpTree ty op] [op] + OpBranches (NonEmpty (OpTree ty op)) [op] deriving (Eq, Show) +pattern BinaryOpBranches :: OpTree ty op -> op -> OpTree ty op -> OpTree ty op +pattern BinaryOpBranches x op y = OpBranches (x :| [y]) [op] + -- | Wrapper for an operator, carrying information about its name and -- fixity. data OpInfo op = OpInfo @@ -78,7 +84,7 @@ opTreeLoc :: (HasSrcSpan l) => OpTree (GenLocated l a) b -> SrcSpan opTreeLoc (OpNode n) = getLoc' n opTreeLoc (OpBranches exprs _) = - combineSrcSpans' . NE.fromList . fmap opTreeLoc $ exprs + combineSrcSpans' . fmap opTreeLoc $ exprs -- | Re-associate an 'OpTree' taking into account precedence of operators. -- Users are expected to first construct an initial 'OpTree', then @@ -129,11 +135,11 @@ OpBranches rExprs rOps where makeFlatOpTree' expr = case makeFlatOpTree expr of - OpNode n -> ([OpNode n], []) + OpNode n -> (NE.singleton (OpNode n), []) OpBranches noptExprs noptOps -> (noptExprs, noptOps) flattenedSubTrees = makeFlatOpTree' <$> exprs - rExprs = concatMap fst flattenedSubTrees - rOps = concat $ interleave (snd <$> flattenedSubTrees) (pure <$> ops) + rExprs = fst =<< flattenedSubTrees + rOps = concat $ interleave (snd <$> NE.toList flattenedSubTrees) (pure <$> ops) interleave (x : xs) (y : ys) = x : y : interleave xs ys interleave [] ys = ys interleave xs [] = xs @@ -239,7 +245,7 @@ -- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] -- into -- [ex0 op0 [ex1 op1 ex2] op2 [ex3 op3 ex4 op4 ex5] op5 [ex6 op6 ex7]] - splitTree nExprs nOps indices = go nExprs nOps indices 0 [] [] [] [] + splitTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] [] where go :: -- Remaining exprs to look up @@ -267,15 +273,15 @@ -- expr in the subExprs bag, so we build a subtree (if necessary) -- with sub-bags, add the node/subtree to the result bag, and then -- emit the result tree - let resExpr = buildFromSub subExprs subOps - in OpBranches (reverse (resExpr : resExprs)) (reverse resOps) + let resExpr = buildFromSub (NE.fromList subExprs) subOps + in OpBranches (NE.reverse (resExpr :| resExprs)) (reverse resOps) go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps | i == idx = -- The op we are looking at is one on which we need to split. -- So we build a subtree from the sub-bags and the current -- expr, append it to the result exprs, and continue with -- cleared sub-bags - let resExpr = buildFromSub (x : subExprs) subOps + let resExpr = buildFromSub (x :| subExprs) subOps in go xs os idxs (i + 1) [] [] (resExpr : resExprs) (o : resOps) go (x : xs) ops idxs i subExprs subOps resExprs resOps = -- Either there is no op left, or the op we are looking at is not @@ -288,7 +294,7 @@ -- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] -- into -- [[ex0 op0 ex1 op1 ex2] op2 ex3 op3 [ex4 op4 ex5] op5 ex6 op6 ex7] - groupTree nExprs nOps indices = go nExprs nOps indices 0 [] [] [] [] + groupTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] [] where go :: -- remaining exprs to look up @@ -316,11 +322,10 @@ -- empty. If it is not, we build a subtree (if necessary) with -- sub-bags and add the resulting node/subtree to the result bag. -- In any case, we then emit the result tree - let resExprs' = - if null subExprs - then resExprs - else buildFromSub subExprs subOps : resExprs - in OpBranches (reverse resExprs') (reverse resOps) + let resExprs' = case NE.nonEmpty subExprs of + Nothing -> NE.fromList resExprs + Just subExprs' -> buildFromSub subExprs' subOps :| resExprs + in OpBranches (NE.reverse resExprs') (reverse resOps) go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps | i == idx = -- The op we are looking at is one on which we need to group. @@ -333,7 +338,7 @@ -- the current expr, to form a subtree which is then added to the -- result bag. let (ops', resOps') = moveOneIfPossible ops resOps - resExpr = buildFromSub (x : subExprs) subOps + resExpr = buildFromSub (x :| subExprs) subOps in go xs ops' idxs (i + 1) [] [] (resExpr : resExprs) resOps' go (x : xs) ops idxs i [] subOps resExprs resOps = -- Either there is no op left, or the op we are looking at is not @@ -349,8 +354,8 @@ buildFromSub subExprs subOps = reassociateFlatOpTree $ case subExprs of -- Do not build a subtree when the potential subtree would have -- 1 expr(s) and 0 op(s) - [x] -> x - _ -> OpBranches (reverse subExprs) (reverse subOps) + x :| [] -> x + _ -> OpBranches (NE.reverse subExprs) (reverse subOps) -- | Indicate if an operator has @'InfixR' 0@ fixity. We special-case this -- class of operators because they often have, like ('$'), a specific diff --git a/tests/Ormolu/OpTreeSpec.hs b/tests/Ormolu/OpTreeSpec.hs --- a/tests/Ormolu/OpTreeSpec.hs +++ b/tests/Ormolu/OpTreeSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Ormolu.OpTreeSpec (spec) where