diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,32 @@ +## Ormolu 0.5.1.0 + +* Imports are now sorted by package qualifier, if one is present. + [Issue 905](https://github.com/tweag/ormolu/issues/905). + +* Extension packs like `GHC2021` and `Haskell2010` are now bumped to the top of + the list of language pragmas. [Issue + 922](https://github.com/tweag/ormolu/issues/922). + +* Fix formatting of `SCC` pragmas in `do` blocks. [Issue + 925](https://github.com/tweag/ormolu/issues/925). + +* Support type applications in patterns. [Issue + 930](https://github.com/tweag/ormolu/issues/930). + +* Handle `UnicodeSyntax` variants more consistently. [Issue + 934](https://github.com/tweag/ormolu/issues/934). + +* Fix an inconsistency in formatting of types in GADT declarations in + certain cases. [PR 932](https://github.com/tweag/ormolu/pull/932). + +* Switched to `ghc-lib-parser-9.4`, which brings support for the following new + syntactic features: + * `\cases` via `LambdaCase` + * `OPAQUE` pragmas + * Unboxed sum type constructors like `(# | #)`. + +* Updated to `Cabal-syntax-3.8`, supporting `cabal-version: 3.8`. + ## Ormolu 0.5.0.1 * Fixed a bug in the diff printing functionality. [Issue diff --git a/data/examples/declaration/data/existential-unicode-out.hs b/data/examples/declaration/data/existential-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo + = forall a. + Foo + +data Bar + = forall a. + Bar diff --git a/data/examples/declaration/data/existential-unicode.hs b/data/examples/declaration/data/existential-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo = forall + a. Foo + +data Bar = ∀ + a. Bar diff --git a/data/examples/declaration/data/gadt/multiline-out.hs b/data/examples/declaration/data/gadt/multiline-out.hs --- a/data/examples/declaration/data/gadt/multiline-out.hs +++ b/data/examples/declaration/data/gadt/multiline-out.hs @@ -14,12 +14,8 @@ Foo 'Int -- | But 'Bar' is also not too bad. Bar :: - Int -> - Maybe Text -> - Foo 'Bool + Int -> Maybe Text -> Foo 'Bool -- | So is 'Baz'. Baz :: - forall a. - a -> - Foo 'String + forall a. a -> Foo 'String (:~>) :: Foo a -> Foo a -> Foo a diff --git a/data/examples/declaration/data/gadt/multiple-declaration-out.hs b/data/examples/declaration/data/gadt/multiple-declaration-out.hs --- a/data/examples/declaration/data/gadt/multiple-declaration-out.hs +++ b/data/examples/declaration/data/gadt/multiple-declaration-out.hs @@ -4,12 +4,10 @@ data GADT1 a where GADT11, GADT12 :: - Int -> - GADT1 a + Int -> GADT1 a data GADT2 a where GADT21, GADT21, GADT22 :: - Int -> - GADT2 a + Int -> GADT2 a diff --git a/data/examples/declaration/signature/inline/noinline-out.hs b/data/examples/declaration/signature/inline/noinline-out.hs --- a/data/examples/declaration/signature/inline/noinline-out.hs +++ b/data/examples/declaration/signature/inline/noinline-out.hs @@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# OPAQUE blub #-} diff --git a/data/examples/declaration/signature/inline/noinline.hs b/data/examples/declaration/signature/inline/noinline.hs --- a/data/examples/declaration/signature/inline/noinline.hs +++ b/data/examples/declaration/signature/inline/noinline.hs @@ -11,3 +11,7 @@ baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# opaque blub #-} diff --git a/data/examples/declaration/splice/bracket-unicode-out.hs b/data/examples/declaration/splice/bracket-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = [|x|] diff --git a/data/examples/declaration/splice/bracket-unicode.hs b/data/examples/declaration/splice/bracket-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = ⟦x⟧ diff --git a/data/examples/declaration/value/function/lambda-case-out.hs b/data/examples/declaration/value/function/lambda-case-out.hs --- a/data/examples/declaration/value/function/lambda-case-out.hs +++ b/data/examples/declaration/value/function/lambda-case-out.hs @@ -7,3 +7,11 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just {} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 diff --git a/data/examples/declaration/value/function/lambda-case.hs b/data/examples/declaration/value/function/lambda-case.hs --- a/data/examples/declaration/value/function/lambda-case.hs +++ b/data/examples/declaration/value/function/lambda-case.hs @@ -7,3 +7,11 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just{} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 diff --git a/data/examples/declaration/value/function/pragmas-out.hs b/data/examples/declaration/value/function/pragmas-out.hs --- a/data/examples/declaration/value/function/pragmas-out.hs +++ b/data/examples/declaration/value/function/pragmas-out.hs @@ -4,6 +4,11 @@ {-# SCC "barbaz" #-} "hello" +foo = do + {-# SCC "foo" #-} + fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/pragmas.hs b/data/examples/declaration/value/function/pragmas.hs --- a/data/examples/declaration/value/function/pragmas.hs +++ b/data/examples/declaration/value/function/pragmas.hs @@ -2,6 +2,10 @@ sccbar = {-# SCC "barbaz"#-} "hello" +foo = do + {-# SCC "foo" #-} fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/type-applications-out.hs b/data/examples/declaration/value/function/type-applications-out.hs --- a/data/examples/declaration/value/function/type-applications-out.hs +++ b/data/examples/declaration/value/function/type-applications-out.hs @@ -14,3 +14,11 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t + @u + v -> + "" diff --git a/data/examples/declaration/value/function/type-applications.hs b/data/examples/declaration/value/function/type-applications.hs --- a/data/examples/declaration/value/function/type-applications.hs +++ b/data/examples/declaration/value/function/type-applications.hs @@ -11,3 +11,9 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t @u v + -> "" diff --git a/data/examples/declaration/value/function/unboxed-sums-out.hs b/data/examples/declaration/value/function/unboxed-sums-out.hs --- a/data/examples/declaration/value/function/unboxed-sums-out.hs +++ b/data/examples/declaration/value/function/unboxed-sums-out.hs @@ -22,3 +22,5 @@ (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/declaration/value/function/unboxed-sums.hs b/data/examples/declaration/value/function/unboxed-sums.hs --- a/data/examples/declaration/value/function/unboxed-sums.hs +++ b/data/examples/declaration/value/function/unboxed-sums.hs @@ -12,3 +12,5 @@ baz = (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/import/sorted-package-imports-out.hs b/data/examples/import/sorted-package-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import D +import "a" Ab +import "b" Aa +import "b" Bb +import "c" Ba diff --git a/data/examples/import/sorted-package-imports.hs b/data/examples/import/sorted-package-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import "b" Aa +import "a" Ab +import "c" Ba +import D +import "b" Bb diff --git a/data/examples/other/invalid-haddock-weird-out.hs b/data/examples/other/invalid-haddock-weird-out.hs --- a/data/examples/other/invalid-haddock-weird-out.hs +++ b/data/examples/other/invalid-haddock-weird-out.hs @@ -1,3 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo -- \|# ${ +foo = foo + +-- \|# ${ diff --git a/data/examples/other/pragma-sorting-out.hs b/data/examples/other/pragma-sorting-out.hs --- a/data/examples/other/pragma-sorting-out.hs +++ b/data/examples/other/pragma-sorting-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/data/examples/other/pragma-sorting.hs b/data/examples/other/pragma-sorting.hs --- a/data/examples/other/pragma-sorting.hs +++ b/data/examples/other/pragma-sorting.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NondecreasingIndentation #-} 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.5.0.1 +version: 0.5.1.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov -tested-with: ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.1 +tested-with: ghc ==9.0.2 ghc ==9.2.4 homepage: https://github.com/tweag/ormolu bug-reports: https://github.com/tweag/ormolu/issues synopsis: A formatter for Haskell source code @@ -92,7 +92,7 @@ other-modules: GHC.DynFlags default-language: Haskell2010 build-depends: - Cabal >=3.6 && <3.7, + Cabal-syntax >=3.8 && <3.9, Diff >=0.4 && <1.0, MemoTrie >=0.6 && <0.7, aeson >=1.0 && <3.0, @@ -105,7 +105,7 @@ dlist >=0.8 && <2.0, exceptions >=0.6 && <0.11, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, megaparsec >=9.0, mtl >=2.0 && <3.0, syb >=0.7 && <0.8, @@ -140,7 +140,7 @@ base >=4.12 && <5.0, containers >=0.5 && <0.7, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, gitrev >=1.3 && <1.4, optparse-applicative >=0.14 && <0.18, ormolu, @@ -179,7 +179,7 @@ containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, - ghc-lib-parser >=9.2 && <9.3, + ghc-lib-parser >=9.4 && <9.5, hspec >=2.0 && <3.0, hspec-megaparsec >=2.2, megaparsec >=9.0, diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -38,6 +38,7 @@ platformIsCrossCompiling = False, platformLeadingUnderscore = False, platformTablesNextToCode = False, + platformHasLibm = False, platform_constants = Nothing }, sPlatformMisc = PlatformMisc {}, diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -1,9 +1,13 @@ {-# LANGUAGE BangPatterns #-} --- needed on GHC 9.0 due to simplified subsumption -{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +#if !MIN_VERSION_base(4,17,0) +-- needed on GHC 9.0 and 9.2 due to simplified subsumption +{-# LANGUAGE ImpredicativeTypes #-} +#endif -- | This module allows us to diff two 'ParseResult's. module Ormolu.Diff.ParseResult @@ -143,7 +147,7 @@ -- as we normalize arrow styles (e.g. -> vs →), we consider them equal here unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff unicodeArrowStyleEq (HsUnrestrictedArrow _) (castArrow -> Just (HsUnrestrictedArrow _)) = Same - unicodeArrowStyleEq (HsLinearArrow _ _) (castArrow -> Just (HsLinearArrow _ _)) = Same + unicodeArrowStyleEq (HsLinearArrow _) (castArrow -> Just (HsLinearArrow _)) = Same unicodeArrowStyleEq (HsExplicitMult _ _ t) (castArrow -> Just (HsExplicitMult _ _ t')) = genericQuery t t' unicodeArrowStyleEq _ _ = Different [] castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs) diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -19,6 +19,7 @@ import GHC.Hs import GHC.Hs.ImpExp as GHC import GHC.Types.Name.Reader +import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Name @@ -64,8 +65,8 @@ -- the same 'ImportId' they can be merged. data ImportId = ImportId { importIsPrelude :: Bool, - importIdName :: ModuleName, importPkgQual :: Maybe LexicalFastString, + importIdName :: ModuleName, importSource :: IsBootInterface, importSafe :: Bool, importQualified :: Bool, @@ -81,7 +82,7 @@ ImportId { importIsPrelude = isPrelude, importIdName = moduleName, - importPkgQual = LexicalFastString . sl_fs <$> ideclPkgQual, + importPkgQual = rawPkgQualToLFS ideclPkgQual, importSource = ideclSource, importSafe = ideclSafe, importQualified = case ideclQualified of @@ -95,6 +96,9 @@ where isPrelude = moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName + rawPkgQualToLFS = \case + RawPkgQual fs -> Just . LexicalFastString . sl_fs $ fs + NoRawPkgQual -> Nothing -- | Normalize a collection of import\/export items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -19,23 +19,24 @@ import Data.Generics import qualified Data.List as L import qualified Data.List.NonEmpty as NE -import Data.Ord (Down (Down)) import GHC.Data.Bag (bagToList) import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.CmdLine as GHC +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Session as GHC import GHC.DynFlags (baseDynFlags) import GHC.Hs hiding (UnicodeSyntax) import GHC.LanguageExtensions.Type (Extension (..)) import qualified GHC.Parser as GHC -import GHC.Parser.Errors.Ppr (pprError) import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC +import GHC.Types.Error (getMessages) import qualified GHC.Types.SourceError as GHC (handleSourceError) import GHC.Types.SrcLoc -import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan) +import GHC.Utils.Error +import GHC.Utils.Outputable (defaultSDocContext) import qualified GHC.Utils.Panic as GHC import Ormolu.Config import Ormolu.Exception @@ -45,7 +46,7 @@ import Ormolu.Parser.Result import Ormolu.Processing.Common import Ormolu.Processing.Preprocess -import Ormolu.Utils (incSpanLine) +import Ormolu.Utils (incSpanLine, showOutputable) -- | Parse a complete module from string. parseModule :: @@ -99,13 +100,22 @@ parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput let pStateErrors pstate = - let errs = fmap pprError . bagToList $ GHC.getErrorMessages pstate + let errs = bagToList . getMessages $ GHC.getPsErrorMessages pstate fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion) - in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of + rateSeverity = \case + SevError -> 1 :: Int + SevWarning -> 2 + SevIgnore -> 3 + showErr = + showOutputable + . formatBulleted defaultSDocContext + . diagnosticMessage + . errMsgDiagnostic + in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing err : _ -> -- Show instance returns a short error message - Just (fixupErrSpan (errMsgSpan err), show err) + Just (fixupErrSpan (errMsgSpan err), showErr err) parser = case cfgSourceType of ModuleSource -> GHC.parseModule SignatureSource -> GHC.parseSignature @@ -150,12 +160,12 @@ hsmodDecls = filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod), hsmodHaddockModHeader = - mfilter (not . isBlankDocString . unLoc) (hsmodHaddockModHeader hsmod), + mfilter (not . isBlankDocString) (hsmodHaddockModHeader hsmod), hsmodExports = (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod) } where - isBlankDocString = all isSpace . unpackHDS + isBlankDocString = all isSpace . renderHsDocString . hsDocString . unLoc isBlankDocD = \case DocD _ s -> isBlankDocString $ docDeclDoc s _ -> False @@ -165,8 +175,8 @@ _ -> False dropBlankTypeHaddocks = \case - L _ (HsDocTy _ ty (L _ ds)) :: LHsType GhcPs - | isBlankDocString ds -> ty + L _ (HsDocTy _ ty s) :: LHsType GhcPs + | isBlankDocString s -> ty a -> a -- | Enable all language extensions that we think should be enabled by @@ -224,34 +234,7 @@ where location = mkRealSrcLoc (GHC.mkFastString filename) 1 1 buffer = GHC.stringToStringBuffer input - parseState = GHC.initParserState (opts flags) buffer location - opts = - GHC.mkParserOpts - <$> GHC.warningFlags - <*> GHC.extensionFlags - <*> GHC.safeImportsOn - <*> GHC.gopt GHC.Opt_Haddock - <*> GHC.gopt GHC.Opt_KeepRawTokenStream - <*> const True - --- | Wrap GHC's 'Severity' to add 'Ord' instance. -newtype SeverityOrd = SeverityOrd Severity - -instance Eq SeverityOrd where - s1 == s2 = compare s1 s2 == EQ - -instance Ord SeverityOrd where - compare (SeverityOrd s1) (SeverityOrd s2) = - compare (f s1) (f s2) - where - f :: Severity -> Int - f SevOutput = 1 - f SevFatal = 2 - f SevInteractive = 3 - f SevDump = 4 - f SevInfo = 5 - f SevWarning = 6 - f SevError = 7 + parseState = GHC.initParserState (initParserOpts flags) buffer location ---------------------------------------------------------------------------- -- Helpers taken from HLint @@ -268,7 +251,11 @@ IO (Either String ([GHC.Warn], DynFlags)) parsePragmasIntoDynFlags flags extraOpts filepath str = catchErrors $ do - let fileOpts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath + let (_warnings, fileOpts) = + GHC.getOptions + (initParserOpts flags) + (GHC.stringToStringBuffer str) + filepath (flags', leftovers, warnings) <- parseDynamicFilePragma flags (extraOpts <> fileOpts) case NE.nonEmpty leftovers of diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -29,8 +29,8 @@ import qualified Data.Map.Lazy as M import Data.Maybe import qualified Data.Set as S +import qualified GHC.Data.Strict as Strict import GHC.Hs (HsModule) -import GHC.Hs.Decls (HsDecl (..), LDocDecl, LHsDecl) import GHC.Hs.Doc import GHC.Hs.Extension import GHC.Hs.ImpExp @@ -87,22 +87,15 @@ EpaComments cs -> cs EpaCommentsBalanced pcs fcs -> pcs <> fcs -- All spans of valid Haddock comments - -- (everywhere where we use p_hsDoc{String,Name}) validHaddockCommentSpans = S.fromList . mapMaybe srcSpanToRealSrcSpan . mconcat - [ fmap getLoc . listify (only @LHsDocString), - fmap getLocA . listify (only @(LDocDecl GhcPs)), - fmap getLocA . listify isDocD, + [ fmap getLoc . listify (only @(LHsDoc GhcPs)), fmap getLocA . listify isIEDocLike ] $ hsModule where - isDocD :: LHsDecl GhcPs -> Bool - isDocD = \case - L _ DocD {} -> True - _ -> False isIEDocLike :: LIE GhcPs -> Bool isIEDocLike = \case L _ IEGroup {} -> True @@ -231,8 +224,8 @@ (y : ys) -> let (ls', y') = mkComment ls y in if onTheSameLine - (RealSrcSpan (getRealSrcSpan x) Nothing) - (RealSrcSpan (getRealSrcSpan y) Nothing) + (RealSrcSpan (getRealSrcSpan x) Strict.Nothing) + (RealSrcSpan (getRealSrcSpan y) Strict.Nothing) then go' ls' [y'] ys else go' ls [] xs @@ -240,10 +233,13 @@ unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated String) unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) = case eck of - GHC.EpaDocCommentNext s -> haddock "|" s -- @-- |@ - GHC.EpaDocCommentPrev s -> haddock "^" s -- @-- ^@ - GHC.EpaDocCommentNamed s -> haddock "$" s -- @-- $@ - GHC.EpaDocSection k s -> haddock (replicate k '*') s -- @-- *@ + GHC.EpaDocComment s -> + let trigger = case s of + MultiLineDocString t _ -> Just t + NestedDocString t _ -> Just t + -- should not occur + GeneratedDocString _ -> Nothing + in haddock trigger (renderHsDocString s) GHC.EpaDocOptions s -> mkL s GHC.EpaLineComment s -> mkL $ case take 3 s of @@ -255,9 +251,15 @@ where mkL = Just . L anchor insertAt x xs n = take (n - 1) xs ++ x ++ drop (n - 1) xs - haddock trigger = + haddock mtrigger = mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank where + trigger = case mtrigger of + Just HsDocStringNext -> "|" + Just HsDocStringPrevious -> "^" + Just (HsDocStringNamed n) -> "$" <> n + Just (HsDocStringGroup k) -> replicate k '*' + Nothing -> "" dashPrefix s = "--" <> spaceIfNecessary <> s where spaceIfNecessary = case s of diff --git a/src/Ormolu/Parser/Pragma.hs b/src/Ormolu/Parser/Pragma.hs --- a/src/Ormolu/Parser/Pragma.hs +++ b/src/Ormolu/Parser/Pragma.hs @@ -11,9 +11,10 @@ import Control.Monad import Data.Char (isSpace, toLower) import qualified Data.List as L -import qualified GHC.Data.EnumSet as ES import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Data.StringBuffer +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.DynFlags (baseDynFlags) import qualified GHC.Parser.Lexer as L import GHC.Types.SrcLoc @@ -67,14 +68,7 @@ location = mkRealSrcLoc (mkFastString "") 1 1 buffer = stringToStringBuffer input parseState = L.initParserState parserOpts buffer location - parserOpts = - L.mkParserOpts - ES.empty - ES.empty - True - True - True - True + parserOpts = initParserOpts baseDynFlags -- | Haskell lexer. pLexer :: L.P [L.Token] diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -75,6 +75,7 @@ import Control.Monad import Data.List (intersperse) import Data.Text (Text) +import qualified GHC.Data.Strict as Strict import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal @@ -109,7 +110,7 @@ RealSrcSpan l _ -> do spitPrecedingComments l withEnclosingSpan l $ - switchLayout [RealSrcSpan l Nothing] (f a) + switchLayout [RealSrcSpan l Strict.Nothing] (f a) spitFollowingComments l -- | A version of 'located' with arguments flipped. 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 @@ -10,7 +10,7 @@ p_rdrName, p_qualName, p_infixDefHelper, - p_hsDocString, + p_hsDoc, p_hsDocName, p_sourceText, ) @@ -19,6 +19,7 @@ import Control.Monad import qualified Data.Text as T import GHC.Hs.Doc +import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp import GHC.Parser.Annotation import GHC.Types.Name.Occurrence (OccName (..)) @@ -131,15 +132,15 @@ inciIf indentArgs $ sitcc (sep breakpoint sitcc args) -- | Print a Haddock. -p_hsDocString :: +p_hsDoc :: -- | Haddock style HaddockStyle -> -- | Finish the doc string with a newline Bool -> - -- | The doc string to render - LHsDocString -> + -- | The 'LHsDoc' to render + LHsDoc GhcPs -> R () -p_hsDocString hstyle needsNewline (L l str) = do +p_hsDoc hstyle needsNewline (L l str) = do let isCommentSpan = \case HaddockSpan _ _ -> True CommentSpan _ -> True @@ -147,7 +148,8 @@ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline - forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do + let docStringLines = splitDocString $ hsDocString str + forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do if isFirst then case hstyle of Pipe -> txt "-- |" 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 @@ -125,10 +125,10 @@ SpliceD _ x -> p_spliceDecl x DocD _ docDecl -> case docDecl of - DocCommentNext str -> p_hsDocString Pipe False (noLoc str) - DocCommentPrev str -> p_hsDocString Caret False (noLoc str) - DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str) - DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str) + DocCommentNext str -> p_hsDoc Pipe False str + DocCommentPrev str -> p_hsDoc Caret False str + DocCommentNamed name str -> p_hsDoc (Named name) False str + DocGroup n str -> p_hsDoc (Asterisk n) False str RoleAnnotD _ x -> p_roleAnnot x KindSigD _ s -> p_standaloneKindSig s @@ -314,7 +314,7 @@ patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p patBindNames (BangPat _ (L _ p)) = patBindNames p -patBindNames (ParPat _ (L _ p)) = patBindNames p +patBindNames (ParPat _ _ (L _ p) _) = patBindNames p patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p patBindNames (SumPat _ (L _ p) _ _) = patBindNames p 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 @@ -13,6 +13,7 @@ import Control.Monad import Data.Maybe (isJust, maybeToList) import Data.Void +import qualified GHC.Data.Strict as Strict import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall @@ -21,6 +22,7 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type +import Ormolu.Utils (matchAddEpAnn) p_dataDecl :: -- | Whether to format as data family @@ -105,7 +107,7 @@ R () p_conDecl singleConstRec = \case ConDeclGADT {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc + mapM_ (p_hsDoc Pipe True) con_doc let conDeclSpn = fmap getLocA con_names <> [getLocA con_bndrs] @@ -114,7 +116,7 @@ where conArgsSpans = case con_g_args of PrefixConGADT xs -> getLocA . hsScaledThing <$> xs - RecConGADT x -> [getLocA x] + RecConGADT x _ -> [getLocA x] switchLayout conDeclSpn $ do case con_names of [] -> return () @@ -124,37 +126,37 @@ commaDel sep commaDel p_rdrName cs inci $ do - space - txt "::" - let interArgBreak = - if hasDocStrings (unLoc con_res_ty) - then newline - else breakpoint - interArgBreak let conTy = case con_g_args of PrefixConGADT xs -> let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t) in foldr go con_res_ty xs - RecConGADT r -> + RecConGADT r _ -> addCLocAA r con_res_ty $ HsFunTy EpAnnNotUsed - (HsUnrestrictedArrow NormalSyntax) + (HsUnrestrictedArrow noHsUniTok) (la2la $ HsRecTy EpAnnNotUsed <$> r) con_res_ty qualTy = case con_mb_cxt of Nothing -> conTy Just qs -> addCLocAA qs conTy $ - HsQualTy NoExtField (Just qs) conTy + HsQualTy NoExtField qs conTy quantifiedTy = addCLocAA con_bndrs qualTy $ hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy - p_hsType (unLoc quantifiedTy) + space + txt "::" + if hasDocStrings (unLoc con_res_ty) + then newline + else breakpoint + located quantifiedTy p_hsType ConDeclH98 {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc + mapM_ (p_hsDoc Pipe True) con_doc let conDeclWithContextSpn = - [RealSrcSpan real Nothing | AddEpAnn AnnForall (EpaSpan real) <- epAnnAnns con_ext] + [ RealSrcSpan real Strict.Nothing + | Just (EpaSpan real) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext + ] <> fmap getLocA con_ex_tvs <> maybeToList (fmap getLocA con_mb_cxt) <> conDeclSpn 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 @@ -70,7 +70,7 @@ ) <$> cid_tyfam_insts dataFamInsts = - ( getLocA &&& fmap (InstD NoExtField . DataFamInstD EpAnnNotUsed) + ( getLocA &&& fmap (InstD NoExtField . DataFamInstD NoExtField) ) <$> cid_datafam_insts allDecls = 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 @@ -217,7 +217,7 @@ -- | Convert a LHsType containing an operator tree to the 'OpTree' -- intermediate representation. tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) -tyOpTree (L _ (HsOpTy NoExtField l op r)) = +tyOpTree (L _ (HsOpTy _ _ l op r)) = OpBranches [tyOpTree l, tyOpTree r] [op] tyOpTree n = OpNode n diff --git a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs --- a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +++ b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs @@ -11,14 +11,13 @@ import GHC.Core.Coercion.Axiom import GHC.Hs hiding (anns) import GHC.Types.Name.Reader -import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common p_roleAnnot :: RoleAnnotDecl GhcPs -> R () p_roleAnnot (RoleAnnotDecl _ l_name anns) = p_roleAnnot' l_name anns -p_roleAnnot' :: LocatedN RdrName -> [Located (Maybe Role)] -> R () +p_roleAnnot' :: LocatedN RdrName -> [XRec GhcPs (Maybe Role)] -> R () p_roleAnnot' l_name anns = do txt "type role" breakpoint diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -36,7 +36,7 @@ -- in the input or no forall at all. We do not want to add redundant -- foralls, so let's just skip the empty ones. unless (null ruleBndrs) $ - p_forallBndrs ForAllInvis p_ruleBndr (reLocA <$> ruleBndrs) + p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs breakpoint inci $ do located lhs p_hsExpr diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -144,9 +144,10 @@ p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case - Inline -> txt "INLINE" - Inlinable -> txt "INLINEABLE" - NoInline -> txt "NOINLINE" + Inline _ -> txt "INLINE" + Inlinable _ -> txt "INLINEABLE" + NoInline _ -> txt "NOINLINE" + Opaque _ -> txt "OPAQUE" NoUserInlinePrag -> return () p_activation :: Activation -> R () @@ -212,7 +213,7 @@ breakpoint inci (p_rdrName ty) -p_sccSig :: LocatedN RdrName -> Maybe (Located StringLiteral) -> R () +p_sccSig :: LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R () p_sccSig loc literal = pragma "SCC" . inci $ do p_rdrName loc forM_ literal $ \x -> do diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -28,7 +28,7 @@ Associated -> mempty Free -> " family" let headerSpns = getLocA fdLName : (getLocA <$> hsq_explicit) - headerAndSigSpns = getLoc fdResultSig : headerSpns + headerAndSigSpns = getLocA fdResultSig : headerSpns inci . switchLayout headerAndSigSpns $ do breakpoint switchLayout headerSpns $ do @@ -58,7 +58,7 @@ inci (sep newline (located' p_tyFamInstEqn) eqs) p_familyResultSigL :: - Located (FamilyResultSig GhcPs) -> + LFamilyResultSig GhcPs -> Maybe (R ()) p_familyResultSigL (L _ a) = case a of NoSig NoExtField -> Nothing 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 @@ -2,8 +2,10 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Printer.Meat.Declaration.Value @@ -35,6 +37,7 @@ import Data.Void import GHC.Data.Bag (bagToList) import GHC.Data.FastString (FastString, lengthFS) +import qualified GHC.Data.Strict as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) import GHC.Parser.CharClass (is_space) @@ -65,12 +68,11 @@ = EqualSign | RightArrow -p_valDecl :: HsBindLR GhcPs GhcPs -> R () +p_valDecl :: HsBind GhcPs -> R () p_valDecl = \case FunBind _ funId funMatches _ -> p_funBind funId funMatches PatBind _ pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker - AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker PatSynBind _ psb -> p_patSynBind psb p_funBind :: @@ -86,7 +88,7 @@ p_matchGroup = p_matchGroup' exprPlacement p_hsExpr p_matchGroup' :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => -- | How to get body placement @@ -155,7 +157,7 @@ p_match = p_match' exprPlacement p_hsExpr p_match' :: - (Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan) => + (Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns) => -- | How to get body placement (body -> Placement) -> -- | How to print body @@ -243,7 +245,7 @@ || not (onTheSameLine spn grhssSpan) -> Normal _ -> blockPlacement placer grhssGRHSs - guardNeedsLineBreak :: Located (GRHS GhcPs body) -> Bool + guardNeedsLineBreak :: XRec GhcPs (GRHS GhcPs body) -> Bool guardNeedsLineBreak (L _ (GRHS _ guardLStmts _)) = case guardLStmts of [] -> False [g] -> not . isOneLineSpan . getLocA $ g @@ -255,7 +257,7 @@ else EqualSign sep breakpoint - (located' (p_grhs' placement placer render groupStyle) . reLocA) + (located' (p_grhs' placement placer render groupStyle)) grhssGRHSs p_where = do unless (eqEmptyLocalBinds grhssLocalBinds) $ do @@ -353,14 +355,14 @@ space located expr p_hsExpr HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup - HsCmdPar _ c -> parens N (located c p_hsCmd) + HsCmdPar _ _ c _ -> parens N (located c p_hsCmd) HsCmdCase _ e mgroup -> p_case cmdPlacement p_hsCmd e mgroup - HsCmdLamCase _ mgroup -> - p_lamcase cmdPlacement p_hsCmd mgroup + HsCmdLamCase _ variant mgroup -> + p_lamcase variant cmdPlacement p_hsCmd mgroup HsCmdIf _ _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else' - HsCmdLet _ localBinds c -> + HsCmdLet _ _ localBinds _ c -> p_let p_hsCmd localBinds c HsCmdDo _ es -> do txt "do" @@ -522,16 +524,12 @@ sitcc $ sepSemi p_item' (attachRelativePos binds) HsValBinds _ _ -> notImplemented "HsValBinds" HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do - -- Second argument of IPBind is always Left before type-checking. - let p_ipBind (IPBind _ (Left name) expr) = do - atom name + let p_ipBind (IPBind _ (L _ name) expr) = do + atom @HsIPName name space equals breakpoint useBraces $ inci $ located expr p_hsExpr - p_ipBind (IPBind _ (Right _) _) = - -- Should only occur after the type checker - notImplemented "IPBind _ (Right _) _" sepSemi (located' p_ipBind) xs EmptyLocalBinds _ -> return () where @@ -540,13 +538,13 @@ -- depend on the layout being correctly set. pseudoLocated = \case EpAnn {anns = AnnList {al_anchor = Just Anchor {anchor}}} -> - located (L (RealSrcSpan anchor Nothing) ()) . const + located (L (RealSrcSpan anchor Strict.Nothing) ()) . const _ -> id -p_lhsFieldLabel :: Located (HsFieldLabel GhcPs) -> R () -p_lhsFieldLabel = located' $ p_lFieldLabelString . hflLabel +p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R () +p_ldotFieldOcc = located' $ p_lFieldLabelString . dfoLabel where - p_lFieldLabelString (L s fs) = parensIfOp . atom @FastString $ fs + p_lFieldLabelString (L (locA -> s) fs) = parensIfOp . atom @FastString $ fs where -- HACK For OverloadedRecordUpdate: -- In operator field updates (i.e. `f {(+) = 1}`), we don't have @@ -560,24 +558,27 @@ parens N | otherwise = id -p_fieldLabels :: [Located (HsFieldLabel GhcPs)] -> R () -p_fieldLabels flss = - sep (txt ".") p_lhsFieldLabel flss +p_ldotFieldOccs :: [XRec GhcPs (DotFieldOcc GhcPs)] -> R () +p_ldotFieldOccs = sep (txt ".") p_ldotFieldOcc -p_hsRecField :: - (id -> R ()) -> - HsRecField' id (LHsExpr GhcPs) -> +p_fieldOcc :: FieldOcc GhcPs -> R () +p_fieldOcc FieldOcc {..} = p_rdrName foLabel + +p_hsFieldBind :: + (lhs ~ GenLocated l a, HasSrcSpan l) => + (lhs -> R ()) -> + HsFieldBind lhs (LHsExpr GhcPs) -> R () -p_hsRecField p_lbl HsRecField {..} = do - located hsRecFieldLbl p_lbl - unless hsRecPun $ do +p_hsFieldBind p_lhs HsFieldBind {..} = do + p_lhs hfbLHS + unless hfbPun $ do space equals let placement = - if onTheSameLine (getLoc hsRecFieldLbl) (getLocA hsRecFieldArg) - then exprPlacement (unLoc hsRecFieldArg) + if onTheSameLine (getLoc' hfbLHS) (getLocA hfbRHS) + then exprPlacement (unLoc hfbRHS) else Normal - placeHanging placement (located hsRecFieldArg p_hsExpr) + placeHanging placement (located hfbRHS p_hsExpr) p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = p_hsExpr' N @@ -586,11 +587,7 @@ p_hsExpr' s = \case HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ - HsConLikeOut _ _ -> notImplemented "HsConLikeOut" - HsRecFld _ x -> - case x of - Unambiguous _ name -> p_rdrName name - Ambiguous _ name -> p_rdrName name + HsRecSel _ fldOcc -> p_fieldOcc fldOcc HsOverLabel _ v -> do txt "#" atom v @@ -605,8 +602,8 @@ r -> atom r HsLam _ mgroup -> p_matchGroup Lambda mgroup - HsLamCase _ mgroup -> - p_lamcase exprPlacement p_hsExpr mgroup + HsLamCase _ variant mgroup -> + p_lamcase variant exprPlacement p_hsExpr mgroup HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the @@ -696,7 +693,7 @@ -- negated literals, as `- 1` and `-1` have differing AST. when (negativeLiterals && isLiteral) space located e p_hsExpr - HsPar _ e -> + HsPar _ _ e _ -> parens s (located e (dontUseBraces . p_hsExpr)) SectionL _ x op -> do located x p_hsExpr @@ -719,7 +716,9 @@ case boxity of Boxed -> parens Unboxed -> parensHash - enclSpan <- fmap (flip RealSrcSpan Nothing) . maybeToList <$> getEnclosingSpan (const True) + enclSpan <- + fmap (flip RealSrcSpan Strict.Nothing) . maybeToList + <$> getEnclosingSpan (const True) if isSection then switchLayout [] . parens' s $ @@ -737,9 +736,9 @@ txt "if" breakpoint inci . inci $ sep newline (located' (p_grhs RightArrow)) guards - HsLet _ localBinds e -> + HsLet _ _ localBinds _ e -> p_let p_hsExpr localBinds e - HsDo _ ctx es -> do + HsDo _ doFlavor es -> do let doBody moduleName header = do forM_ moduleName $ \m -> atom m *> txt "." txt header @@ -762,52 +761,48 @@ txt "|" space p_parBody lists - case ctx of + case doFlavor of DoExpr moduleName -> doBody moduleName "do" MDoExpr moduleName -> doBody moduleName "mdo" ListComp -> compBody MonadComp -> compBody - ArrowExpr -> notImplemented "ArrowExpr" GhciStmtCtxt -> notImplemented "GhciStmtCtxt" - PatGuard _ -> notImplemented "PatGuard" - ParStmtCtxt _ -> notImplemented "ParStmtCtxt" - TransStmtCtxt _ -> notImplemented "TransStmtCtxt" ExplicitList _ xs -> brackets s $ sep commaDel (sitcc . located' p_hsExpr) xs RecordCon {..} -> do - located rcon_con atom + p_rdrName rcon_con breakpoint let HsRecFields {..} = rcon_flds - p_lbl = p_rdrName . rdrNameFieldOcc - fields = located' (p_hsRecField p_lbl) <$> rec_flds - dotdot = - case rec_dotdot of - Just {} -> [txt ".."] - Nothing -> [] + p_lhs = located' $ p_rdrName . foLabel + fields = located' (p_hsFieldBind p_lhs) <$> rec_flds + dotdot = case rec_dotdot of + Just {} -> [txt ".."] + Nothing -> [] inci . braces N $ sep commaDel sitcc (fields <> dotdot) RecordUpd {..} -> do located rupd_expr p_hsExpr breakpoint let p_updLbl = - p_rdrName . \case - Unambiguous NoExtField n -> n - Ambiguous NoExtField n -> n + located' $ + p_rdrName . \case + (Unambiguous NoExtField n :: AmbiguousFieldOcc GhcPs) -> n + Ambiguous NoExtField n -> n p_recFields p_lbl = - sep commaDel (sitcc . located' (p_hsRecField p_lbl)) + sep commaDel (sitcc . located' (p_hsFieldBind p_lbl)) inci . braces N $ either (p_recFields p_updLbl) - (p_recFields (p_fieldLabels . coerce)) + (p_recFields $ located' $ coerce p_ldotFieldOccs) rupd_flds HsGetField {..} -> do located gf_expr p_hsExpr txt "." - p_lhsFieldLabel gf_field + p_ldotFieldOcc gf_field HsProjection {..} -> parens N $ do txt "." - p_fieldLabels (NE.toList proj_flds) + p_ldotFieldOccs (NE.toList proj_flds) ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do located x p_hsExpr space @@ -836,9 +831,13 @@ txt ".." space located to p_hsExpr - HsBracket epAnn x -> p_hsBracket epAnn x - HsRnBracketOut {} -> notImplemented "HsRnBracketOut" - HsTcBracketOut {} -> notImplemented "HsTcBracketOut" + HsTypedBracket _ expr -> do + txt "[||" + breakpoint' + located expr p_hsExpr + breakpoint' + txt "||]" + HsUntypedBracket epAnn x -> p_hsQuote epAnn x HsSpliceE _ splice -> p_hsSplice splice HsProc _ p e -> do txt "proc" @@ -853,15 +852,14 @@ txt "static" breakpoint inci (located e p_hsExpr) - HsTick {} -> notImplemented "HsTick" - HsBinTick {} -> notImplemented "HsBinTick" HsPragE _ prag x -> case prag of HsPragSCC _ _ name -> do txt "{-# SCC " atom name txt " #-}" breakpoint - located x p_hsExpr + let inciIfS = case s of N -> id; S -> inci + inciIfS $ located x p_hsExpr p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do @@ -923,7 +921,7 @@ inci (rhs conSpans) p_case :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => -- | Placer @@ -945,9 +943,11 @@ inci (p_matchGroup' placer render Case mgroup) p_lamcase :: - ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan, + ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + -- | Variant (@\\case@ or @\\cases@) + LamCaseVariant -> -- | Placer (body -> Placement) -> -- | Render @@ -955,8 +955,10 @@ -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lamcase placer render mgroup = do - txt "\\case" +p_lamcase variant placer render mgroup = do + txt $ case variant of + LamCase -> "\\case" + LamCases -> "\\cases" breakpoint inci (p_matchGroup' placer render LambdaCase mgroup) @@ -1014,7 +1016,7 @@ p_rdrName name txt "@" located pat p_pat - ParPat _ pat -> + ParPat _ _ pat _ -> located pat (parens S . p_pat) BangPat _ pat -> do txt "!" @@ -1031,19 +1033,18 @@ p_unboxedSum S tag arity (located pat p_pat) ConPat _ pat details -> case details of - PrefixCon [] xs -> sitcc $ do + PrefixCon tys xs -> sitcc $ do p_rdrName pat - unless (null xs) $ do - breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs - -- The first field of PrefixCon is filled in later stages - PrefixCon {} -> notImplemented "Unexpected types in constructor pattern" + unless (null tys && null xs) breakpoint + inci . sitcc $ + sep breakpoint (sitcc . either p_hsPatSigType (located' p_pat)) $ + (Left <$> tys) <> (Right <$> xs) RecCon (HsRecFields fields dotdot) -> do p_rdrName pat breakpoint let f = \case Nothing -> txt ".." - Just x -> located x p_pat_hsRecField + Just x -> located x p_pat_hsFieldBind inci . braces N . sep commaDel f $ case dotdot of Nothing -> Just <$> fields @@ -1081,14 +1082,17 @@ located pat p_pat p_typeAscription (lhsTypeToSigType hsps_body) -p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () -p_pat_hsRecField HsRecField {..} = do - located hsRecFieldLbl $ p_rdrName . rdrNameFieldOcc - unless hsRecPun $ do +p_hsPatSigType :: HsPatSigType GhcPs -> R () +p_hsPatSigType (HsPS _ ty) = txt "@" *> located ty p_hsType + +p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () +p_pat_hsFieldBind HsFieldBind {..} = do + located hfbLHS p_fieldOcc + unless hfbPun $ do space equals breakpoint - inci (located hsRecFieldArg p_pat) + inci (located hfbRHS p_pat) p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () p_unboxedSum s tag arity m = do @@ -1136,11 +1140,11 @@ where decoSymbol = if isTyped then "$$" else "$" -p_hsBracket :: EpAnn [AddEpAnn] -> HsBracket GhcPs -> R () -p_hsBracket epAnn = \case +p_hsQuote :: EpAnn [AddEpAnn] -> HsQuote GhcPs -> R () +p_hsQuote epAnn = \case ExpBr _ expr -> do let name - | or [True | AddEpAnn AnnOpenEQ _ <- epAnnAnns epAnn] = "" + | any isJust (matchAddEpAnn AnnOpenEQ <$> epAnnAnns epAnn) = "" | otherwise = "e" quote name (located expr p_hsExpr) PatBr _ pat -> located pat (quote "p" . p_pat) @@ -1150,12 +1154,6 @@ VarBr _ isSingleQuote name -> do txt (bool "''" "'" isSingleQuote) p_rdrName name - TExpBr _ expr -> do - txt "[||" - breakpoint' - located expr p_hsExpr - breakpoint' - txt "||]" where quote :: Text -> R () -> R () quote name body = do @@ -1261,7 +1259,7 @@ cmdPlacement = \case HsCmdLam _ _ -> Hanging HsCmdCase _ _ _ -> Hanging - HsCmdLamCase _ _ -> Hanging + HsCmdLamCase _ _ _ -> Hanging HsCmdDo _ _ -> Hanging _ -> Normal @@ -1278,7 +1276,7 @@ | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> Hanging _ -> Normal - HsLamCase _ _ -> Hanging + HsLamCase _ _ _ -> Hanging HsCase _ _ _ -> Hanging HsDo _ (DoExpr _) _ -> Hanging HsDo _ (MDoExpr _) _ -> Hanging 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 @@ -25,12 +25,12 @@ p_warnDecl (Warning _ functions warningTxt) = p_topLevelWarning functions warningTxt -p_moduleWarning :: WarningTxt -> R () +p_moduleWarning :: WarningTxt GhcPs -> R () p_moduleWarning wtxt = do let (pragmaText, lits) = warningText wtxt inci $ pragma pragmaText $ inci $ p_lits lits -p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt -> R () +p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt GhcPs -> R () p_topLevelWarning fnames wtxt = do let (pragmaText, lits) = warningText wtxt switchLayout (fmap getLocA fnames ++ fmap getLoc lits) $ @@ -39,10 +39,10 @@ breakpoint p_lits lits -warningText :: WarningTxt -> (Text, [Located StringLiteral]) +warningText :: WarningTxt GhcPs -> (Text, [Located StringLiteral]) warningText = \case - WarningTxt _ lits -> ("WARNING", lits) - DeprecatedTxt _ lits -> ("DEPRECATED", lits) + WarningTxt _ lits -> ("WARNING", fmap hsDocString <$> lits) + DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) p_lits :: [Located StringLiteral] -> R () p_lits = \case 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 @@ -12,6 +12,7 @@ import Control.Monad import GHC.Hs import GHC.LanguageExtensions.Type +import GHC.Types.PkgQual import GHC.Types.SrcLoc import GHC.Unit.Types import Ormolu.Printer.Combinators @@ -45,8 +46,8 @@ (txt "qualified") space case ideclPkgQual of - Nothing -> return () - Just slit -> atom slit + NoRawPkgQual -> return () + RawPkgQual slit -> atom slit space inci $ do located ideclName atom @@ -112,9 +113,9 @@ FirstPos -> return () MiddlePos -> newline LastPos -> newline - p_hsDocString (Asterisk n) False (noLoc str) + p_hsDoc (Asterisk n) False str IEDoc NoExtField str -> - p_hsDocString Pipe False (noLoc str) + p_hsDoc Pipe False str IEDocNamed NoExtField str -> p_hsDocName str where p_comma = 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 @@ -45,7 +45,7 @@ Nothing -> return () Just hsmodName' -> do located hsmodName' $ \name -> do - forM_ hsmodHaddockModHeader (p_hsDocString Pipe True) + forM_ hsmodHaddockModHeader (p_hsDoc Pipe True) p_hsmodName name breakpoint forM_ hsmodDeprecMessage $ \w -> do diff --git a/src/Ormolu/Printer/Meat/Pragma.hs b/src/Ormolu/Printer/Meat/Pragma.hs --- a/src/Ormolu/Printer/Meat/Pragma.hs +++ b/src/Ormolu/Printer/Meat/Pragma.hs @@ -11,7 +11,10 @@ import Data.Char (isUpper) import qualified Data.List as L import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text as T +import GHC.Driver.Flags (Language) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma (..)) @@ -37,7 +40,9 @@ -- -- See also: data LanguagePragmaClass - = -- | All other extensions + = -- | A pack of extensions like @GHC2021@ or @Haskell2010@ + ExtensionPack + | -- | All other extensions Normal | -- | Extensions starting with "No" Disabling @@ -76,6 +81,7 @@ -- | Classify a 'LanguagePragma'. classifyLanguagePragma :: String -> LanguagePragmaClass classifyLanguagePragma = \case + str | str `Set.member` extensionPacks -> ExtensionPack "ImplicitPrelude" -> Final "CUSKs" -> Final str -> @@ -88,3 +94,8 @@ then Disabling else Normal _ -> Normal + +-- | Extension packs, like @GHC2021@ and @Haskell2010@. +extensionPacks :: Set String +extensionPacks = + Set.fromList $ show <$> [minBound :: Language .. maxBound] 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 @@ -22,7 +22,6 @@ ) where -import Data.Foldable (for_) import GHC.Hs import GHC.Types.Basic hiding (isPromoted) import GHC.Types.SourceText @@ -54,12 +53,11 @@ HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs interArgBreak p_hsTypeR (unLoc t) - HsQualTy _ qs' t -> do - for_ qs' $ \qs -> do - located qs p_hsContext - space - txt "=>" - interArgBreak + HsQualTy _ qs t -> do + located qs p_hsContext + space + txt "=>" + interArgBreak case unLoc t of HsQualTy {} -> p_hsTypeR (unLoc t) HsFunTy {} -> p_hsTypeR (unLoc t) @@ -101,8 +99,8 @@ space case arrow of HsUnrestrictedArrow _ -> txt "->" - HsLinearArrow _ _ -> txt "%1 ->" - HsExplicitMult _ _ mult -> do + HsLinearArrow _ -> txt "%1 ->" + HsExplicitMult _ mult _ -> do txt "%" p_hsTypeR (unLoc mult) space @@ -122,7 +120,7 @@ HsSumTy _ xs -> parensHash N $ sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs - HsOpTy _ x op y -> do + HsOpTy _ _ x op y -> do fixityOverrides <- askFixityOverrides fixityMap <- askFixityMap let opTree = OpBranches [tyOpTree x, tyOpTree y] [op] @@ -147,12 +145,12 @@ HsDocTy _ t str -> case docStyle of PipeStyle -> do - p_hsDocString Pipe True str + p_hsDoc Pipe True str located t p_hsType CaretStyle -> do located t p_hsType newline - p_hsDocString Caret False str + p_hsDoc Caret False str HsBangTy _ (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space @@ -243,11 +241,16 @@ data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. -p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R () +p_forallBndrs :: + HasSrcSpan l => + ForAllVisibility -> + (a -> R ()) -> + [GenLocated l a] -> + R () p_forallBndrs ForAllInvis _ [] = txt "forall." p_forallBndrs ForAllVis _ [] = txt "forall ->" p_forallBndrs vis p tyvars = - switchLayout (getLocA <$> tyvars) $ do + switchLayout (getLoc' <$> tyvars) $ do txt "forall" breakpoint inci $ do @@ -262,11 +265,11 @@ p_conDeclField :: ConDeclField GhcPs -> R () p_conDeclField ConDeclField {..} = do - mapM_ (p_hsDocString Pipe True) cd_fld_doc + mapM_ (p_hsDoc Pipe True) cd_fld_doc sitcc $ sep commaDel - (located' (p_rdrName . rdrNameFieldOcc)) + (located' (p_rdrName . foLabel)) cd_fld_names space txt "::" diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -16,6 +16,7 @@ onTheSameLine, HasSrcSpan (..), getLoc', + matchAddEpAnn, ) where @@ -25,6 +26,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified GHC.Data.Strict as Strict import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) import GHC.Hs @@ -76,7 +78,7 @@ . dropWhileEnd T.null . fmap (T.stripEnd . T.pack) . lines - $ unpackHDS docStr + $ renderHsDocString docStr -- We cannot have the first character to be a dollar because in that -- case it'll be a parse error (apparently collides with named docs -- syntax @-- $name@ somehow). @@ -110,7 +112,7 @@ line = srcLocLine x col = srcLocCol x in mkRealSrcLoc file (line + i) col - in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Nothing + in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Strict.Nothing UnhelpfulSpan x -> UnhelpfulSpan x -- | Do two declarations have a blank between them? @@ -141,3 +143,10 @@ getLoc' :: HasSrcSpan l => GenLocated l a -> SrcSpan getLoc' = loc' . getLoc + +-- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an +-- 'AddEpAnn', and return the 'EpaLocation' if so. +matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation +matchAddEpAnn annId (AddEpAnn annId' loc) + | annId == annId' || unicodeAnn annId == annId' = Just loc + | otherwise = Nothing diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs --- a/tests/Ormolu/CabalInfoSpec.hs +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -38,7 +38,7 @@ ciDynOpts `shouldBe` [DynOption "-XHaskell2010"] it "extracts correct dependencies from ormolu.cabal (src/Ormolu/Config.hs)" $ do CabalInfo {..} <- parseCabalInfo "ormolu.cabal" "src/Ormolu/Config.hs" - ciDependencies `shouldBe` Set.fromList ["Cabal", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "bytestring", "containers", "directory", "dlist", "exceptions", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "template-haskell", "text", "th-lift-instances"] + ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "bytestring", "containers", "directory", "dlist", "exceptions", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "template-haskell", "text", "th-lift-instances"] it "extracts correct dependencies from ormolu.cabal (tests/Ormolu/PrinterSpec.hs)" $ do CabalInfo {..} <- parseCabalInfo "ormolu.cabal" "tests/Ormolu/PrinterSpec.hs" ciDependencies `shouldBe` Set.fromList ["QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "ormolu", "path", "path-io", "temporary", "text"]