[Git][ghc/ghc][wip/ani/hie-spans] fixes for check-exact

23 Dec 2025


      Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC


Commits:
22ebe332 by Apoorv Ingle at 2025-12-22T16:35:40-06:00
fixes for check-exact

- - - - -


5 changed files:

- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/Do.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs


Changes:

=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -612,59 +612,39 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
 instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where
   toHie (C c (L l a)) = toHie (C c (L (locA l) a))
 
-instance ToHie (Context (Located Var)) where
-  toHie c = case c of
-      C context (L (RealSrcSpan span _) name')
-        | varUnique name' == mkBuiltinUnique 1 -> pure []
-          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
-        | otherwise -> do
-          m <- lift $ gets name_remapping
-          org <- ask
-          let name = case lookupNameEnv m (varName name') of
-                Just var -> var
-                Nothing-> name'
-              ty = case isDataConId_maybe name' of
-                      Nothing -> varType name'
-                      Just dc -> dataConWrapperType dc
-          -- insert the entity info for the name into the entity_infos map
-          insertEntityInfo (varName name) $ idEntityInfo name
-          insertEntityInfo (varName name') $ idEntityInfo name'
-          pure
-            [Node
-              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
-                M.singleton (Right $ varName name)
-                            (IdentifierDetails (Just ty)
-                                               (S.singleton context)))
-              span
-              []]
-      C context (L (GeneratedSrcSpan span) name')
-        | varUnique name' == mkBuiltinUnique 1 -> pure []
-          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
-        | otherwise -> do
-          m <- lift $ gets name_remapping
-          org <- ask
-          let name = case lookupNameEnv m (varName name') of
-                Just var -> var
-                Nothing-> name'
-              ty = case isDataConId_maybe name' of
+toHieCtxLocVar :: ContextInfo -> RealSrcSpan -> Var -> HieM [HieAST Type]
+toHieCtxLocVar context span name'
+  | varUnique name' == mkBuiltinUnique 1 = pure []
+  -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+  | otherwise = do
+      m <- lift $ gets name_remapping
+      org <- ask
+      let name = case lookupNameEnv m (varName name') of
+                   Just var -> var
+                   Nothing-> name'
+          ty = case isDataConId_maybe name' of
                       Nothing -> varType name'
                       Just dc -> dataConWrapperType dc
           -- insert the entity info for the name into the entity_infos map
-          insertEntityInfo (varName name) $ idEntityInfo name
-          insertEntityInfo (varName name') $ idEntityInfo name'
-          pure
-            [Node
-              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
-                M.singleton (Right $ varName name)
+      insertEntityInfo (varName name) $ idEntityInfo name
+      insertEntityInfo (varName name') $ idEntityInfo name'
+      pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+                   M.singleton (Right $ varName name)
                             (IdentifierDetails (Just ty)
                                                (S.singleton context)))
-              span
-              []]
+                 span
+                 []]
+
+instance ToHie (Context (Located Var)) where
+  toHie c = case c of
+      C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name'
+      C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name'
       C (EvidenceVarBind i _ sp)  (L _ name) -> do
         addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
         pure []
       _ -> pure []
 
+
 instance ToHie (Context (Located Name)) where
   toHie c = case c of
       C context (L (RealSrcSpan span _) name')
@@ -687,26 +667,6 @@ instance ToHie (Context (Located Name)) where
                                                (S.singleton context)))
               span
               []]
-      -- C context (L (GeneratedSrcSpan span) name')
-      --   | nameUnique name' == mkBuiltinUnique 1 -> pure []
-      --     -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
-      --   | otherwise -> do
-      --     m <- lift $ gets name_remapping
-      --     org <- ask
-      --     let name = case lookupNameEnv m name' of
-      --           Just var -> varName var
-      --           Nothing -> name'
-      --     -- insert the entity info for the name into the entity_infos map
-      --     lookupAndInsertEntityName name
-      --     lookupAndInsertEntityName name'
-      --     pure
-      --       [Node
-      --         (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
-      --           M.singleton (Right name)
-      --                       (IdentifierDetails Nothing
-      --                                          (S.singleton context)))
-      --         span
-      --         []]
       _ -> pure []
 
 instance ToHie (Context (Located (WithUserRdr Name))) where


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -114,20 +114,12 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
   | otherwise
   = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr  stmt)
 
-expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts)
+expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) =
 -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
 --              stmts ~~> stmts'
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
-  | RealSrcSpan sp _ <- locA loc =
-      do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
-         let expansion = mkHsApps (wrapGenSpan' sp then_op)  -- (>>)
-                         [ wrapGenSpan e
-                         , expand_stmts_expr ]
-         return $ L loc (mkExpandedStmt stmt doFlavour (unLoc $ expansion))
-
-  | otherwise =
     do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
        let expansion = genHsExpApps then_op  -- (>>)
                        [ wrapGenSpan e


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -477,6 +477,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
             dp = adjustDeltaForOffset
                    off (ss2delta priorEndAfterComments r)
         Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r
+        Just (EpaSpan (GeneratedSrcSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r
   when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp)
   when (isJust medr) $ setExtraDPReturn medr
   -- ---------------------------------------------
@@ -737,7 +738,7 @@ printStringAtNC el str = do
 printStringAtAAC :: (Monad m, Monoid w)
   => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
 printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s
-printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss
+printStringAtAAC _capture (EpaSpan ss) _s = error $ "printStringAtAAC:ss=" ++ show ss
 printStringAtAAC capture (EpaDelta ss d cs) s = do
   mapM_ printOneComment $ concatMap tokComment cs
   pe1 <- getPriorEndD
@@ -1356,7 +1357,7 @@ printOneComment c@(Comment _str loc _r _mo) = do
         let dp = ss2delta pe r
         debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)
         adjustDeltaForOffsetM dp
-    EpaSpan (UnhelpfulSpan _) -> return (SameLine 0)
+    EpaSpan _ -> return (SameLine 0)
   mep <- getExtraDP
   dp' <- case mep of
     Just (EpaDelta _ edp _) -> do


=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -305,8 +305,6 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p'
   where
     moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments
                  -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments)
-    moveComments GHC.EpaDelta{} dd cs = (dd,cs)
-    moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs)
     moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css)
       where
         -- Move any comments on the decl that occur prior to the location
@@ -318,12 +316,14 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p'
 
         dd = GHC.L (GHC.EpAnn anc an csd') a
         css = cs <> GHC.EpaComments move
+    moveComments _ dd cs = (dd,cs)
 
     (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p)
     p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' },
              GHC.hsmodDecls = ds'
            }
 
+
     rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
               -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
     rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs')


=====================================
utils/check-exact/Transform.hs
=====================================
@@ -255,6 +255,8 @@ setEntryDPDecl d dp = setEntryDP d dp
 setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a
 setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp
   = L (EpAnn (EpaDelta ss dp []) an cs) a
+setEntryDP (L (EpAnn (EpaSpan ss@(GeneratedSrcSpan _)) an cs) a) dp
+  = L (EpAnn (EpaDelta ss dp []) an cs) a
 setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp
   = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a
 setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp
@@ -320,14 +322,12 @@ getEntryDP _ = SameLine 1
 
 addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
 addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs
-addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) []
 addEpaLocationDelta  off  anc (EpaSpan ss@(RealSrcSpan r _))
   = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
+addEpaLocationDelta _off _anc (EpaSpan ss) = EpaDelta ss (SameLine 0) []
 
 -- Set the entry DP for an element coming after an existing keyword annotation
 setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
-setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a
-setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a
 setEntryDPFromAnchor  off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp'
   where
     dp' = case la of
@@ -335,6 +335,8 @@ setEntryDPFromAnchor  off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP
       (EpAnn (EpaSpan _) _ _)                  -> adjustDeltaForOffset off (SameLine 0)
       (EpAnn (EpaDelta _ dp _) _ _)            -> adjustDeltaForOffset off dp
 
+setEntryDPFromAnchor _off _ ll = ll
+
 -- ---------------------------------------------------------------------
 
 -- |Take the annEntryDelta associated with the first item and
@@ -902,7 +904,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
             let
               off = case l of
                       (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r
-                      (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0
+                      (EpaSpan _)                 -> LayoutStartCol 0
                       (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0
                       (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c
               ex'' = setEntryDPFromAnchor off i ex



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22ebe33299bea806c4b5cabf4fa298ad...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22ebe33299bea806c4b5cabf4fa298ad...
You're receiving this email because of your account on gitlab.haskell.org.

    

Apoorv Ingle (＠ani)

tags

participants (1)