Add NamedThing instance to HoleFitCandidates, remove hfName
authorMatthías Páll Gissurarson <pallm@chalmers.se>
Thu, 23 May 2019 17:27:28 +0000 (19:27 +0200)
committerMatthías Páll Gissurarson <pallm@chalmers.se>
Fri, 31 May 2019 17:15:26 +0000 (19:15 +0200)
compiler/typecheck/TcHoleErrors.hs
compiler/typecheck/TcRnTypes.hs

index 7f11c2d..be7f51c 100644 (file)
@@ -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) $
index 22fb6f7..e555572 100644 (file)
@@ -3955,14 +3955,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`,
@@ -3991,7 +3998,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
@@ -4004,7 +4011,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