module Control.Super.Plugin.Prototype
( pluginPrototype
) where
import Data.Maybe ( isJust, isNothing, fromJust, catMaybes )
import Data.Foldable ( foldrM )
import Control.Monad ( forM )
import Plugins ( Plugin(tcPlugin), defaultPlugin )
import TcRnTypes
( Ct(..)
, TcPlugin(..), TcPluginResult(..) )
import TcPluginM ( TcPluginM )
import Outputable ( hang, text, vcat )
import qualified Outputable as O
import Control.Super.Plugin.Utils ( errIndent )
import Control.Super.Plugin.InstanceDict ( InstanceDict )
import Control.Super.Plugin.ClassDict ( ClassDict )
import Control.Super.Plugin.Solving
( solveConstraints )
import Control.Super.Plugin.Environment
( SupermonadPluginM
, runSupermonadPluginAndReturn, runTcPlugin
, getWantedConstraints
, getClass, getClassDictionary
, isOptionalClass
, throwPluginErrorSDoc
, printMsg
)
import Control.Super.Plugin.Environment.Lift
( findClassesAndInstancesInScope )
import Control.Super.Plugin.Detect
( ModuleQuery(..)
, ClassQuery(..)
, moduleQueryOf, isOptionalClassQuery
, InstanceImplication
, checkInstances
, findModuleByQuery
, findMonoTopTyConInstances )
import Control.Super.Plugin.Names ( PluginClassName )
type SupermonadState = ()
pluginPrototype :: [ClassQuery]
-> [[PluginClassName]]
-> (ClassDict -> [InstanceImplication])
-> Plugin
pluginPrototype clsQueries solvingGroups instImps =
defaultPlugin { tcPlugin = \_clOpts -> Just plugin }
where
plugin :: TcPlugin
plugin = TcPlugin
{ tcPluginInit = pluginInit
, tcPluginSolve = pluginSolve
, tcPluginStop = pluginStop
}
pluginInit :: TcPluginM SupermonadState
pluginInit = return ()
pluginStop :: SupermonadState -> TcPluginM ()
pluginStop _s = return ()
pluginSolve :: SupermonadState -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult
pluginSolve _s given derived wanted = do
runSupermonadPluginAndReturn (given ++ derived) wanted initSupermonadPlugin $ do
printMsg "Invoke (super) plugin..."
forM solvingGroups $ \solvingGroup -> do
mClss <- fmap catMaybes $ forM solvingGroup $ \clsName -> do
mCls <- getClass clsName
opt <- isOptionalClass clsName
return $ if opt && isNothing mCls then
Nothing
else
Just (clsName, mCls)
if all (isJust . snd) mClss then do
wantedCts <- getWantedConstraints
solveConstraints (fmap (fromJust . snd) mClss) wantedCts
else do
throwPluginErrorSDoc $ O.hang (O.text "Missing classes:") errIndent
$ O.hcat $ O.punctuate (O.text ", ")
$ fmap (O.quotes . O.text . fst)
$ filter (isNothing . snd) mClss
initSupermonadPlugin :: SupermonadPluginM () (ClassDict, InstanceDict)
initSupermonadPlugin = do
let getMandMdlQ :: ClassQuery -> Maybe ModuleQuery
getMandMdlQ clsQ = if isOptionalClassQuery clsQ then Nothing else Just (moduleQueryOf clsQ)
let mandMdlQs = catMaybes $ fmap getMandMdlQ clsQueries
_foundMandMdls <- forM mandMdlQs $ \mdlQ -> do
eMandMdl <- runTcPlugin $ findModuleByQuery mdlQ
case eMandMdl of
Right mandMdl -> return mandMdl
Left mdlErrMsg -> throwPluginErrorSDoc mdlErrMsg
oldClsDict <- getClassDictionary
newClsDict <- foldrM findClassesAndInstancesInScope oldClsDict clsQueries
let smInsts = findMonoTopTyConInstances newClsDict
let smErrors = fmap snd $ checkInstances newClsDict smInsts (instImps newClsDict)
case smErrors of
[] -> return (newClsDict, smInsts)
_ -> do
throwPluginErrorSDoc $ hang (text "Problems when finding instances:") errIndent $ vcat smErrors