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

Commits:

5 changed files:

Changes:

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -612,59 +612,39 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
    612 612 
     instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where
    613 613 
       toHie (C c (L l a)) = toHie (C c (L (locA l) a))
    614 614
    615 
    -instance ToHie (Context (Located Var)) where
    616 
    -  toHie c = case c of
    617 
    -      C context (L (RealSrcSpan span _) name')
    618 
    -        | varUnique name' == mkBuiltinUnique 1 -> pure []
    619 
    -          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
    620 
    -        | otherwise -> do
    621 
    -          m <- lift $ gets name_remapping
    622 
    -          org <- ask
    623 
    -          let name = case lookupNameEnv m (varName name') of
    624 
    -                Just var -> var
    625 
    -                Nothing-> name'
    626 
    -              ty = case isDataConId_maybe name' of
    627 
    -                      Nothing -> varType name'
    628 
    -                      Just dc -> dataConWrapperType dc
    629 
    -          -- insert the entity info for the name into the entity_infos map
    630 
    -          insertEntityInfo (varName name) $ idEntityInfo name
    631 
    -          insertEntityInfo (varName name') $ idEntityInfo name'
    632 
    -          pure
    633 
    -            [Node
    634 
    -              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
    635 
    -                M.singleton (Right $ varName name)
    636 
    -                            (IdentifierDetails (Just ty)
    637 
    -                                               (S.singleton context)))
    638 
    -              span
    639 
    -              []]
    640 
    -      C context (L (GeneratedSrcSpan span) name')
    641 
    -        | varUnique name' == mkBuiltinUnique 1 -> pure []
    642 
    -          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
    643 
    -        | otherwise -> do
    644 
    -          m <- lift $ gets name_remapping
    645 
    -          org <- ask
    646 
    -          let name = case lookupNameEnv m (varName name') of
    647 
    -                Just var -> var
    648 
    -                Nothing-> name'
    649 
    -              ty = case isDataConId_maybe name' of
    615 
    +toHieCtxLocVar :: ContextInfo -> RealSrcSpan -> Var -> HieM [HieAST Type]
    616 
    +toHieCtxLocVar context span name'
    617 
    +  | varUnique name' == mkBuiltinUnique 1 = pure []
    618 
    +  -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
    619 
    +  | otherwise = do
    620 
    +      m <- lift $ gets name_remapping
    621 
    +      org <- ask
    622 
    +      let name = case lookupNameEnv m (varName name') of
    623 
    +                   Just var -> var
    624 
    +                   Nothing-> name'
    625 
    +          ty = case isDataConId_maybe name' of
    650 626 
                           Nothing -> varType name'
    651 627 
                           Just dc -> dataConWrapperType dc
    652 628 
               -- insert the entity info for the name into the entity_infos map
    653 
    -          insertEntityInfo (varName name) $ idEntityInfo name
    654 
    -          insertEntityInfo (varName name') $ idEntityInfo name'
    655 
    -          pure
    656 
    -            [Node
    657 
    -              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
    658 
    -                M.singleton (Right $ varName name)
    629 
    +      insertEntityInfo (varName name) $ idEntityInfo name
    630 
    +      insertEntityInfo (varName name') $ idEntityInfo name'
    631 
    +      pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
    632 
    +                   M.singleton (Right $ varName name)
    659 633 
                                 (IdentifierDetails (Just ty)
    660 634 
                                                    (S.singleton context)))
    661 
    -              span
    662 
    -              []]
    635 
    +                 span
    636 
    +                 []]
    637 
    +
    638 
    +instance ToHie (Context (Located Var)) where
    639 
    +  toHie c = case c of
    640 
    +      C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name'
    641 
    +      C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name'
    663 642 
           C (EvidenceVarBind i _ sp)  (L _ name) -> do
    664 643 
             addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
    665 644 
             pure []
    666 645 
           _ -> pure []
    667 646
    647 
    +
    668 648 
     instance ToHie (Context (Located Name)) where
    669 649 
       toHie c = case c of
    670 650 
           C context (L (RealSrcSpan span _) name')
    ... ... @@ -687,26 +667,6 @@ instance ToHie (Context (Located Name)) where
    687 667 
                                                    (S.singleton context)))
    688 668 
                   span
    689 669 
                   []]
    690 
    -      -- C context (L (GeneratedSrcSpan span) name')
    691 
    -      --   | nameUnique name' == mkBuiltinUnique 1 -> pure []
    692 
    -      --     -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
    693 
    -      --   | otherwise -> do
    694 
    -      --     m <- lift $ gets name_remapping
    695 
    -      --     org <- ask
    696 
    -      --     let name = case lookupNameEnv m name' of
    697 
    -      --           Just var -> varName var
    698 
    -      --           Nothing -> name'
    699 
    -      --     -- insert the entity info for the name into the entity_infos map
    700 
    -      --     lookupAndInsertEntityName name
    701 
    -      --     lookupAndInsertEntityName name'
    702 
    -      --     pure
    703 
    -      --       [Node
    704 
    -      --         (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
    705 
    -      --           M.singleton (Right name)
    706 
    -      --                       (IdentifierDetails Nothing
    707 
    -      --                                          (S.singleton context)))
    708 
    -      --         span
    709 
    -      --         []]
    710 670 
           _ -> pure []
    711 671
    712 672 
     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)
    114 114 
       | otherwise
    115 115 
       = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr  stmt)
    116 116
    117 
    -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts)
    117 
    +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) =
    118 118 
     -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
    119 119 
     -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
    120 120 
     --              stmts ~~> stmts'
    121 121 
     --    ----------------------------------------------
    122 122 
     --      e ; stmts ~~> (>>) e stmts'
    123 
    -  | RealSrcSpan sp _ <- locA loc =
    124 
    -      do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
    125 
    -         let expansion = mkHsApps (wrapGenSpan' sp then_op)  -- (>>)
    126 
    -                         [ wrapGenSpan e
    127 
    -                         , expand_stmts_expr ]
    128 
    -         return $ L loc (mkExpandedStmt stmt doFlavour (unLoc $ expansion))
    129 
    -
    130 
    -  | otherwise =
    131 123 
         do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
    132 124 
            let expansion = genHsExpApps then_op  -- (>>)
    133 125 
                            [ wrapGenSpan e

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

  • utils/check-exact/Parsers.hs
    ... ... @@ -305,8 +305,6 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p'
    305 305 
       where
    306 306 
         moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments
    307 307 
                      -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments)
    308 
    -    moveComments GHC.EpaDelta{} dd cs = (dd,cs)
    309 
    -    moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs)
    310 308 
         moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css)
    311 309 
           where
    312 310 
             -- 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'
    318 316
    319 317 
             dd = GHC.L (GHC.EpAnn anc an csd') a
    320 318 
             css = cs <> GHC.EpaComments move
    319 
    +    moveComments _ dd cs = (dd,cs)
    321 320
    322 321 
         (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p)
    323 322 
         p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' },
    324 323 
                  GHC.hsmodDecls = ds'
    325 324 
                }
    326 325
    326 
    +
    327 327 
         rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
    328 328 
                   -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
    329 329 
         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
    255 255 
     setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a
    256 256 
     setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp
    257 257 
       = L (EpAnn (EpaDelta ss dp []) an cs) a
    258 
    +setEntryDP (L (EpAnn (EpaSpan ss@(GeneratedSrcSpan _)) an cs) a) dp
    259 
    +  = L (EpAnn (EpaDelta ss dp []) an cs) a
    258 260 
     setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp
    259 261 
       = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a
    260 262 
     setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp
    ... ... @@ -320,14 +322,12 @@ getEntryDP _ = SameLine 1
    320 322
    321 323 
     addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
    322 324 
     addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs
    323 
    -addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) []
    324 325 
     addEpaLocationDelta  off  anc (EpaSpan ss@(RealSrcSpan r _))
    325 326 
       = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
    327 
    +addEpaLocationDelta _off _anc (EpaSpan ss) = EpaDelta ss (SameLine 0) []
    326 328
    327 329 
     -- Set the entry DP for an element coming after an existing keyword annotation
    328 330 
     setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
    329 
    -setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a
    330 
    -setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a
    331 331 
     setEntryDPFromAnchor  off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp'
    332 332 
       where
    333 333 
         dp' = case la of
    ... ... @@ -335,6 +335,8 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP
    335 335 
           (EpAnn (EpaSpan _) _ _)                  -> adjustDeltaForOffset off (SameLine 0)
    336 336 
           (EpAnn (EpaDelta _ dp _) _ _)            -> adjustDeltaForOffset off dp
    337 337
    338 
    +setEntryDPFromAnchor _off _ ll = ll
    339 
    +
    338 340 
     -- ---------------------------------------------------------------------
    339 341
    340 342 
     -- |Take the annEntryDelta associated with the first item and
    ... ... @@ -902,7 +904,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
    902 904 
                 let
    903 905 
                   off = case l of
    904 906 
                           (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r
    905 
    -                      (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0
    907 
    +                      (EpaSpan _)                 -> LayoutStartCol 0
    906 908 
                           (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0
    907 909 
                           (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c
    908 910 
                   ex'' = setEntryDPFromAnchor off i ex

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help