{-# LANGUAGE CPP #-}
module Test.Inspection.TcPlugin (inspectionTcPlugin) where
import Module (mkModuleName)
import OccName (mkTcOcc)
import TcEvidence
import TcPluginM
import TcRnTypes
import Class
#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)
import MkCore
import TyCon
#endif
import Type
inspectionTcPlugin :: TcPlugin
inspectionTcPlugin =
TcPlugin { tcPluginInit = lookupPNLTyCon
, tcPluginSolve = solvePNL
, tcPluginStop = const (return ())
}
lookupPNLTyCon :: TcPluginM Class
lookupPNLTyCon = do
Found _ md <- findImportedModule testInspectionModule Nothing
pnlNm <- lookupOrig md (mkTcOcc "PluginNotLoaded")
tcLookupClass pnlNm
where
testInspectionModule = mkModuleName "Test.Inspection"
#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)
mkNullaryEv :: Class -> EvTerm
mkNullaryEv cls = EvExpr appDc
where
tyCon = classTyCon cls
dc = tyConSingleDataCon tyCon
appDc = mkCoreConApps dc []
# else
mkNullaryEv :: Class -> EvTerm
mkNullaryEv _ = error "Test.Inspection.TcPlugin needs GHC 8.6 or later"
#endif
findClassConstraint :: Class -> Ct -> Bool
findClassConstraint cls ct
| Just (cls', []) <- getClassPredTys_maybe (ctPred ct)
, cls' == cls
= True
| otherwise
= False
solvePNL :: Class
-> [Ct]
-> [Ct]
-> [Ct]
-> TcPluginM TcPluginResult
solvePNL inspectionTcCls _ _ wanteds =
return $ TcPluginOk [(mkNullaryEv inspectionTcCls, x)| x <- our_wanteds ] []
where
our_wanteds = filter (findClassConstraint inspectionTcCls) wanteds