ghc-lib-parser 9.10

Author: amesgen

cabal.project

@@ -1,3 +1,10 @@
 packages: . extract-hackage-info
 
 constraints: ormolu +dev
+
+source-repository-package
+  type: git
+  location: https://github.com/amesgen/stuff
+  tag: f0ef405ca08bfb3caf6562e9714f7fd51fa5f975
+  subdir: ghc-lib-parser-9.10.1-alpha1
+  --sha256: sha256-LCOIj4LDuW8JLdPRE3FXXkCwffJNao3wYzxpmKq1sT4=

flake.nix

@@ -36,7 +36,7 @@
         inherit (pkgs) lib haskell-nix;
         inherit (haskell-nix) haskellLib;
 
-        ghcVersions = [ "ghc963" "ghc947" "ghc981" ];
+        ghcVersions = [ "ghc963" "ghc981" ];
         defaultGHCVersion = builtins.head ghcVersions;
         perGHC = lib.genAttrs ghcVersions (ghcVersion:
           let
@@ -173,10 +173,12 @@
   nixConfig = {
     extra-substituters = [
       "https://cache.iog.io"
+      "https://cache.zw3rk.com"
       "https://tweag-ormolu.cachix.org"
     ];
     extra-trusted-public-keys = [
       "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ="
+      "loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk="
       "tweag-ormolu.cachix.org-1:3O4XG3o4AGquSwzzmhF6lov58PYG6j9zHcTDiROqkjM="
     ];
   };

ormolu-live/cabal.project

@@ -9,3 +9,9 @@ package ormolu
 package ghc-lib-parser
   -- The WASM backend does not support the threaded RTS.
   flags: -threaded-rts
+
+source-repository-package
+  type: git
+  location: https://github.com/amesgen/stuff
+  tag: f0ef405ca08bfb3caf6562e9714f7fd51fa5f975
+  subdir: ghc-lib-parser-9.10.1-alpha1

ormolu.cabal

@@ -110,7 +110,7 @@ library
         directory ^>=1.3,
         file-embed >=0.0.15 && <0.1,
         filepath >=1.2 && <1.5,
-        ghc-lib-parser >=9.8 && <9.9,
+        ghc-lib-parser >=9.10 && <9.11,
         megaparsec >=9,
         mtl >=2 && <3,
         syb >=0.7 && <0.8,
@@ -139,7 +139,7 @@ executable ormolu
         containers >=0.5 && <0.7,
         directory ^>=1.3,
         filepath >=1.2 && <1.5,
-        ghc-lib-parser >=9.8 && <9.9,
+        ghc-lib-parser >=9.10 && <9.11,
         optparse-applicative >=0.14 && <0.19,
         ormolu,
         text >=2 && <3,
@@ -178,7 +178,7 @@ test-suite tests
         containers >=0.5 && <0.7,
         directory ^>=1.3,
         filepath >=1.2 && <1.5,
-        ghc-lib-parser >=9.8 && <9.9,
+        ghc-lib-parser >=9.10 && <9.11,
         hspec >=2 && <3,
         hspec-megaparsec >=2.2,
         megaparsec >=9,

src/Ormolu/Diff/ParseResult.hs

@@ -93,17 +93,19 @@ diffHsModule = genericQuery
                   `extQ` considerEqual @SourceText
                   `extQ` hsDocStringEq
                   `extQ` importDeclQualifiedStyleEq
-                  `extQ` considerEqual @(LayoutInfo GhcPs)
                   `extQ` classDeclCtxEq
                   `extQ` derivedTyClsParensEq
                   `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs
                   `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token
                   `extQ` considerEqual @EpaLocation
+                  `extQ` considerEqual @EpLayout
+                  `extQ` considerEqual @[AddEpAnn]
+                  `extQ` considerEqual @AnnSig
                   `ext2Q` forLocated
                   -- unicode-related
-                  `extQ` considerEqual @(HsUniToken "->" "→")
-                  `extQ` considerEqual @(HsUniToken "::" "∷")
-                  `extQ` considerEqual @(HsLinearArrowTokens GhcPs)
+                  `extQ` considerEqual @(EpUniToken "->" "→")
+                  `extQ` considerEqual @(EpUniToken "::" "∷")
+                  `extQ` considerEqual @EpLinearArrow
               )
               x
               y
@@ -141,7 +143,10 @@ diffHsModule = genericQuery
       GenLocated e0 e1 ->
       GenericQ ParseResultDiff
     forLocated x@(L mspn _) y =
-      maybe id appendSpan (cast `ext1Q` (Just . locA) $ mspn) (genericQuery x y)
+      maybe id appendSpan (cast `ext1Q` (Just . epAnnLoc) $ mspn) (genericQuery x y)
+      where
+        epAnnLoc :: EpAnn ann -> SrcSpan
+        epAnnLoc = locA
     appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff
     appendSpan s' d@(Different ss) =
       case s' of

src/Ormolu/Fixity/Imports.hs

@@ -69,10 +69,10 @@ extractFixityImport ImportDecl {..} =
 
 ieToOccNames :: IE GhcPs -> [OccName]
 ieToOccNames = \case
-  IEVar _ (L _ x) -> [occName x]
-  IEThingAbs _ (L _ x) -> [occName x]
-  IEThingAll _ (L _ x) -> [occName x] -- TODO not quite correct, but how to do better?
-  IEThingWith _ (L _ x) _ xs -> occName x : fmap (occName . unLoc) xs
+  IEVar _ (L _ x) _ -> [occName x]
+  IEThingAbs _ (L _ x) _ -> [occName x]
+  IEThingAll _ (L _ x) _ -> [occName x] -- TODO not quite correct, but how to do better?
+  IEThingWith _ (L _ x) _ xs _ -> occName x : fmap (occName . unLoc) xs
   _ -> []
 
 -- | Apply given module re-exports.

src/Ormolu/Fixity/Parser.hs

@@ -45,6 +45,11 @@ import Text.Megaparsec.Char.Lexer qualified as L
 
 type Parser = Parsec Void Text
 
+-- TODO support fixity namespacing?
+-- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst
+-- https://github.com/tweag/ormolu/pull/1029#issue-1718217029
+-- https://github.com/tweag/ormolu/pull/994#pullrequestreview-1396958951
+
 -- | Parse textual representation of 'FixityOverrides'.
 parseDotOrmolu ::
   -- | Location of the file we are parsing (only for parse errors)

src/Ormolu/Imports.hs

@@ -138,33 +138,34 @@ normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty
           alter = \case
             Nothing -> Just . L new_l $
               case new of
-                IEThingWith _ n wildcard g ->
-                  IEThingWith (Nothing, EpAnnNotUsed) n wildcard (normalizeWNames g)
+                IEThingWith x n wildcard g _ ->
+                  IEThingWith x n wildcard (normalizeWNames g) Nothing
                 other -> other
             Just old ->
               let f = \case
-                    IEVar _ n -> IEVar Nothing n
-                    IEThingAbs _ _ -> new
-                    IEThingAll _ n -> IEThingAll (Nothing, EpAnnNotUsed) n
-                    IEThingWith _ n wildcard g ->
+                    IEVar _ n _ -> IEVar Nothing n Nothing
+                    IEThingAbs _ _ _ -> new
+                    IEThingAll x n _ -> IEThingAll x n Nothing
+                    IEThingWith _ n wildcard g _ ->
                       case new of
-                        IEVar _ _ ->
+                        IEVar _ _ _ ->
                           error "Ormolu.Imports broken presupposition"
-                        IEThingAbs _ _ ->
-                          IEThingWith (Nothing, EpAnnNotUsed) n wildcard g
-                        IEThingAll _ n' ->
-                          IEThingAll (Nothing, EpAnnNotUsed) n'
-                        IEThingWith _ n' wildcard' g' ->
+                        IEThingAbs x _ _ ->
+                          IEThingWith x n wildcard g Nothing
+                        IEThingAll x n' _ ->
+                          IEThingAll x n' Nothing
+                        IEThingWith x n' wildcard' g' _ ->
                           let combinedWildcard =
                                 case (wildcard, wildcard') of
                                   (IEWildcard _, _) -> IEWildcard 0
                                   (_, IEWildcard _) -> IEWildcard 0
                                   _ -> NoIEWildcard
                            in IEThingWith
-                                (Nothing, EpAnnNotUsed)
+                                x
                                 n'
                                 combinedWildcard
                                 (normalizeWNames (g <> g'))
+                                Nothing
                         IEModuleContents _ _ -> notImplemented "IEModuleContents"
                         IEGroup NoExtField _ _ -> notImplemented "IEGroup"
                         IEDoc NoExtField _ -> notImplemented "IEDoc"
@@ -187,10 +188,10 @@ instance Ord IEWrappedNameOrd where
 -- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@.
 getIewn :: IE GhcPs -> IEWrappedNameOrd
 getIewn = \case
-  IEVar _ x -> IEWrappedNameOrd (unLoc x)
-  IEThingAbs _ x -> IEWrappedNameOrd (unLoc x)
-  IEThingAll _ x -> IEWrappedNameOrd (unLoc x)
-  IEThingWith _ x _ _ -> IEWrappedNameOrd (unLoc x)
+  IEVar _ x _ -> IEWrappedNameOrd (unLoc x)
+  IEThingAbs _ x _ -> IEWrappedNameOrd (unLoc x)
+  IEThingAll _ x _ -> IEWrappedNameOrd (unLoc x)
+  IEThingWith _ x _ _ _ -> IEWrappedNameOrd (unLoc x)
   IEModuleContents _ _ -> notImplemented "IEModuleContents"
   IEGroup NoExtField _ _ -> notImplemented "IEGroup"
   IEDoc NoExtField _ -> notImplemented "IEDoc"

src/Ormolu/Parser.hs

@@ -212,7 +212,7 @@ normalizeModule hsmod =
     patchContext :: LHsContext GhcPs -> LHsContext GhcPs
     patchContext = fmap $ \case
       [x@(L _ (HsParTy _ _))] -> [x]
-      [x@(L lx _)] -> [L lx (HsParTy EpAnnNotUsed x)]
+      [x@(L lx _)] -> [L lx (HsParTy noAnn x)]
       xs -> xs
 
 -- | Enable all language extensions that we think should be enabled by

src/Ormolu/Parser/CommentStream.hs

@@ -223,7 +223,7 @@ extractPragmas input = go initialLs id id
 
 -- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'.
 unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)
-unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) =
+unAnnotationComment (L epaLoc (GHC.EpaComment eck _)) =
   case eck of
     GHC.EpaDocComment s ->
       let trigger = case s of
@@ -239,9 +239,11 @@ unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) =
         "---" -> s
         _ -> insertAt " " s 3
     GHC.EpaBlockComment s -> mkL (T.pack s)
-    GHC.EpaEofComment -> Nothing
   where
-    mkL = Just . L anchor
+    -- TODO mkL = L (GHC.epaLocationRealSrcSpan epaLoc)
+    mkL = case epaLoc of
+      GHC.EpaSpan (RealSrcSpan s _) -> Just . L s
+      _ -> const Nothing
     insertAt x xs n = T.take (n - 1) xs <> x <> T.drop (n - 1) xs
     haddock mtrigger =
       mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank

src/Ormolu/Printer/Combinators.hs

@@ -76,10 +76,10 @@ import Control.Monad
 import Data.List (intersperse)
 import Data.Text (Text)
 import GHC.Data.Strict qualified as Strict
+import GHC.Parser.Annotation
 import GHC.Types.SrcLoc
 import Ormolu.Printer.Comments
 import Ormolu.Printer.Internal
-import Ormolu.Utils (HasSrcSpan (..), getLoc')
 
 ----------------------------------------------------------------------------
 -- Basic
@@ -99,13 +99,13 @@ inciIf b m = if b then inci m else m
 -- 'Located' wrapper, it should be “discharged” with a corresponding
 -- 'located' invocation.
 located ::
-  (HasSrcSpan l) =>
+  (HasLoc l) =>
   -- | Thing to enter
   GenLocated l a ->
   -- | How to render inner value
   (a -> R ()) ->
   R ()
-located (L l' a) f = case loc' l' of
+located (L l' a) f = case locA l' of
   UnhelpfulSpan _ -> f a
   RealSrcSpan l _ -> do
     spitPrecedingComments l
@@ -117,7 +117,7 @@ located (L l' a) f = case loc' l' of
 -- virtual elements at the start and end of the source span to prevent comments
 -- from "floating out".
 encloseLocated ::
-  (HasSrcSpan l) =>
+  (HasLoc l) =>
   GenLocated l [a] ->
   ([a] -> R ()) ->
   R ()
@@ -126,13 +126,13 @@ encloseLocated la f = located la $ \a -> do
   f a
   when (null a) $ located (L endSpan ()) pure
   where
-    l = getLoc' la
+    l = locA la
     (startLoc, endLoc) = (srcSpanStart l, srcSpanEnd l)
     (startSpan, endSpan) = (mkSrcSpan startLoc startLoc, mkSrcSpan endLoc endLoc)
 
 -- | A version of 'located' with arguments flipped.
 located' ::
-  (HasSrcSpan l) =>
+  (HasLoc l) =>
   -- | How to render inner value
   (a -> R ()) ->
   -- | Thing to enter

src/Ormolu/Printer/Meat/Common.hs

@@ -13,12 +13,14 @@ module Ormolu.Printer.Meat.Common
     p_hsDoc,
     p_hsDocName,
     p_sourceText,
+    p_namespaceSpec,
   )
 where
 
 import Control.Monad
 import Data.Text qualified as T
 import GHC.Data.FastString
+import GHC.Hs.Binds
 import GHC.Hs.Doc
 import GHC.Hs.Extension (GhcPs)
 import GHC.Hs.ImpExp
@@ -66,18 +68,16 @@ p_ieWrappedName = \case
 p_rdrName :: LocatedN RdrName -> R ()
 p_rdrName l = located l $ \x -> do
   unboxedSums <- isExtensionEnabled UnboxedSums
-  let wrapper = \case
-        EpAnn {anns} -> case anns of
-          NameAnnQuote {nann_quoted} -> tickPrefix . wrapper (ann nann_quoted)
-          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
-        EpAnnNotUsed -> id
+  let wrapper EpAnn {anns} = case anns of
+        NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted
+        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
 
       -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to
       -- insert spaces when we have a parenthesized operator starting with `#`.
@@ -88,7 +88,7 @@ p_rdrName l = located l $ \x -> do
             \y -> space *> y <* space
         | otherwise = id
 
-  wrapper (ann . getLoc $ l) $ case x of
+  wrapper (getLoc l) $ case x of
     Unqual occName ->
       atom occName
     Qual mname occName ->
@@ -192,3 +192,9 @@ p_sourceText :: SourceText -> R ()
 p_sourceText = \case
   NoSourceText -> pure ()
   SourceText s -> atom @FastString s
+
+p_namespaceSpec :: NamespaceSpecifier -> R ()
+p_namespaceSpec = \case
+  NoNamespaceSpecifier -> pure ()
+  TypeNamespaceSpecifier _ -> txt "type" *> space
+  DataNamespaceSpecifier _ -> txt "data" *> space

src/Ormolu/Printer/Meat/Declaration.hs

@@ -260,7 +260,7 @@ pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _)
 pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _)
 pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _))
 pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _)
-pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ _ (L _ n) _ _ _ _ _ _ _ _)
+pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _)
 pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _)
 pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _))
 pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _)
@@ -296,7 +296,7 @@ defSigRdrNames _ = Nothing
 
 funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
 funRdrNames (ValD _ (FunBind _ (L _ n) _)) = Just [n]
-funRdrNames (ValD _ (PatBind _ (L _ n) _)) = Just $ patBindNames n
+funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n
 funRdrNames _ = Nothing
 
 patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
@@ -315,9 +315,9 @@ patBindNames (VarPat _ (L _ n)) = [n]
 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 (AsPat _ (L _ n) (L _ p)) = n : patBindNames p
 patBindNames (SumPat _ (L _ p) _ _) = patBindNames p
 patBindNames (ViewPat _ _ (L _ p)) = patBindNames p
 patBindNames (SplicePat _ _) = []
@@ -326,3 +326,4 @@ patBindNames (SigPat _ (L _ p) _) = patBindNames p
 patBindNames (NPat _ _ _ _) = []
 patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n]
 patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
+patBindNames (EmbTyPat _ _) = [] -- TODO