[Git][ghc/ghc][wip/D5373] Add NamedThing instance to HoleFitCandidates, remove hfName

[Matthías Páll Gissurarson]

Matthías Páll Gissurarson pushed to branch wip/D5373 at Glasgow Haskell Compiler / GHC


Commits:
0acced34 by Matthías Páll Gissurarson at 2019-05-23T17:27:28Z
Add NamedThing instance to HoleFitCandidates, remove hfName

- - - - -


2 changed files:

- compiler/typecheck/TcHoleErrors.hs
- compiler/typecheck/TcRnTypes.hs


Changes:

=====================================
compiler/typecheck/TcHoleErrors.hs
=====================================
@@ -5,7 +5,7 @@ module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
                     , withoutUnification
                     , fromPureHFPlugin
                     -- Re-exports for convenience
-                    , hfName, hfIsLcl
+                    , hfIsLcl
                     , pprHoleFit, debugHoleFitDispConfig
 
                     -- Re-exported from TcRnTypes
@@ -430,13 +430,6 @@ getSortingAlg =
                               then BySize
                               else NoSorting }
 
-hfName :: HoleFit -> Maybe Name
-hfName hf@(HoleFit {}) = Just $ case hfCand hf of
-                                  IdHFCand id -> idName id
-                                  NameHFCand name -> name
-                                  GreHFCand gre -> gre_name gre
-hfName _ = Nothing
-
 hfIsLcl :: HoleFit -> Bool
 hfIsLcl hf@(HoleFit {}) = case hfCand hf of
                             IdHFCand _    -> True
@@ -457,15 +450,14 @@ addDocs fits =
    msg = text "TcHoleErrors addDocs"
    lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
      = Map.lookup name dmap
-   upd lclDocs fit =
-    case hfName fit of
-     Just name ->
-        do { doc <- if hfIsLcl fit
+   upd lclDocs fit@(HoleFit {hfCand = cand}) =
+        do { let name = getName cand
+           ; doc <- if hfIsLcl fit
                     then pure (Map.lookup name lclDocs)
                     else do { mbIface <- loadInterfaceForNameMaybe msg name
                             ; return $ mbIface >>= lookupInIface name }
-        ; return $ fit {hfDoc = doc} }
-     Nothing -> return fit
+           ; return $ fit {hfDoc = doc} }
+   upd _ fit = return fit
 
 -- For pretty printing hole fits, we display the name and type of the fit,
 -- with added '_' to represent any extra arguments in case of a non-zero
@@ -474,7 +466,7 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
 pprHoleFit _ (RawHoleFit sd) = sd
 pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf@(HoleFit {..}) =
  hang display 2 provenance
- where name = fromJust (hfName hf)
+ where name =  getName hfCand
        tyApp = sep $ map ((text "@" <>) . pprParendType) hfWrap
        tyAppVars = sep $ punctuate comma $
            map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $


=====================================
compiler/typecheck/TcRnTypes.hs
=====================================
@@ -3959,14 +3959,21 @@ pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
 pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
 pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
 
+instance NamedThing HoleFitCandidate where
+  getName hfc = case hfc of
+                     IdHFCand id -> idName id
+                     NameHFCand name -> name
+                     GreHFCand gre -> gre_name gre
+  getOccName hfc = case hfc of
+                     IdHFCand id -> occName id
+                     NameHFCand name -> occName name
+                     GreHFCand gre -> occName (gre_name gre)
+
 instance HasOccName HoleFitCandidate where
-  occName hfc = case hfc of
-                  IdHFCand id -> occName id
-                  NameHFCand name -> occName name
-                  GreHFCand gre -> occName (gre_name gre)
+  occName = getOccName
 
 instance Ord HoleFitCandidate where
-  compare = compare `on` occName
+  compare = compare `on` getName
 
 -- | HoleFit is the type we use for valid hole fits. It contains the
 -- element that was checked, the Id of that element as found by `tcLookup`,
@@ -3995,7 +4002,7 @@ instance Outputable HoleFit where
   ppr (RawHoleFit sd) = sd
   ppr (HoleFit _ cand ty _ _ mtchs _) =
     hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
-    where name = ppr $ occName cand
+    where name = ppr $ getName cand
           holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
 
 -- We compare HoleFits by their name instead of their Id, since we don't
@@ -4008,7 +4015,7 @@ instance Ord HoleFit where
   compare _ (RawHoleFit _) = GT
   compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
     where cmp  = if hfRefLvl a == hfRefLvl b
-                 then compare `on` hfCand
+                 then compare `on` (getName . hfCand)
                  else compare `on` hfRefLvl
 
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/0acced348f696ebed0d76b5c1c80fe109c4cc8dc

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


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190523/7f3502dd/attachment-0001.html>