module GHC.Tc.Errors.Hole.FitTypes (
TypedHole (..), HoleFit (..), HoleFitCandidate (..),
CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),
hfIsLcl, pprHoleFitCand
) where
import GHC.Prelude
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.TcType
import GHC.Types.Name.Reader
import GHC.Hs.Doc
import GHC.Types.Id
import GHC.Utils.Outputable
import GHC.Types.Name
import Data.Function ( on )
data TypedHole = TypedHole { th_relevant_cts :: Cts
, th_implics :: [Implication]
, th_hole :: Maybe Hole
}
instance Outputable TypedHole where
ppr (TypedHole { th_relevant_cts = rels
, th_implics = implics
, th_hole = hole })
= hang (text "TypedHole") 2
(ppr rels $+$ ppr implics $+$ ppr hole)
data HoleFitCandidate = IdHFCand Id
| NameHFCand Name
| GreHFCand GlobalRdrElt
deriving (Eq)
instance Outputable HoleFitCandidate where
ppr = pprHoleFitCand
pprHoleFitCand :: HoleFitCandidate -> SDoc
pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid
pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname
pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre
instance NamedThing HoleFitCandidate where
getName hfc = case hfc of
IdHFCand cid -> idName cid
NameHFCand cname -> cname
GreHFCand cgre -> greMangledName cgre
getOccName hfc = case hfc of
IdHFCand cid -> occName cid
NameHFCand cname -> occName cname
GreHFCand cgre -> occName (greMangledName cgre)
instance HasOccName HoleFitCandidate where
occName = getOccName
instance Ord HoleFitCandidate where
compare = compare `on` getName
data HoleFit =
HoleFit { hfId :: Id
, hfCand :: HoleFitCandidate
, hfType :: TcType
, hfRefLvl :: Int
, hfWrap :: [TcType]
, hfMatches :: [TcType]
, hfDoc :: Maybe HsDocString
}
| RawHoleFit SDoc
instance Eq HoleFit where
(==) = (==) `on` hfId
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 $ getName cand
holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
instance Ord HoleFit where
compare (RawHoleFit _) (RawHoleFit _) = EQ
compare (RawHoleFit _) _ = LT
compare _ (RawHoleFit _) = GT
compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
where cmp = if hfRefLvl a == hfRefLvl b
then compare `on` (getName . hfCand)
else compare `on` hfRefLvl
hfIsLcl :: HoleFit -> Bool
hfIsLcl hf@(HoleFit {}) = case hfCand hf of
IdHFCand _ -> True
NameHFCand _ -> False
GreHFCand gre -> gre_lcl gre
hfIsLcl _ = False
type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit]
data HoleFitPlugin = HoleFitPlugin
{ candPlugin :: CandPlugin
, fitPlugin :: FitPlugin }
data HoleFitPluginR = forall s. HoleFitPluginR
{ hfPluginInit :: TcM (TcRef s)
, hfPluginRun :: TcRef s -> HoleFitPlugin
, hfPluginStop :: TcRef s -> TcM ()
}