Plugin.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  PluginImportId.Plugin
-- Copyright   :  (c) 2013 Tabula, Inc.
--
-- Maintainer  :  [email protected]
-- Stability   :  experimental
--
-- Try importing a name in a GHC plugin
----------------------------------------------------------------------

module PluginImportId.Plugin (plugin) where

import Data.Maybe (fromMaybe)

import GhcPlugins
import IfaceEnv (lookupOrigNameCache)
import qualified OccName as ON
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.PprLib (pprName)
import qualified Outputable
import qualified DynFlags
import TcEnv ( tcLookupGlobal )
import TcRnTypes (TcM)
import HscTypes (tyThingId)
import TcRnMonad (initTc)
import PrelNames (iNTERACTIVE)
import Bag (bagToList)

type X a = a -> CoreM a

plugin :: Plugin
plugin = defaultPlugin { installCoreToDos = install }

install :: [CommandLineOption] -> X [CoreToDo]
install _ todo = do
  reinitializeGlobals
  return (CoreDoPluginPass "PluginImportId" (bindsOnlyPass pass) : todo)

showPprN :: Outputable a => a -> String
showPprN = Outputable.showPpr DynFlags.tracingDynFlags

pass :: X CoreProgram
pass prog = do v <- makePrelVar ON.varName 'id
               liftIO $ print $ "found name: " ++ showPprN v
               return prog

prelMod :: Module
prelMod = mkModule
            (stringToPackageId "base-4.6.0.1")  -- How to determine version number?
            (mkModuleName "GHC.Base")

makePrelVar :: NameSpace -> TH.Name -> CoreM Var
makePrelVar ns str =
  do nsc  <- getOrigNameCache
     name <- fmap (fromMaybe (error ("mkPrelVar: Didn't find " ++ show (pprName str)))) $
                  thNameToGhcName str
     errorMsg (Outputable.ppr name)
     lookupIdN name

lookupIdN :: Name -> CoreM Var
lookupIdN name = do
  hsc_env <- getHscEnv
  tyThing <- liftIO $ initTcForLookupN hsc_env (tcLookupGlobal name)
  return $ tyThingId tyThing

initTcForLookupN :: HscEnv -> TcM a -> IO a
initTcForLookupN hsc_env = fmap expectJust . initTc hsc_env HsSrcFile False iNTERACTIVE

expectJust (_,Just a)                  = a
expectJust ((warnings,errors),Nothing) = error $ "\nWarnings: " ++ show (bagToList warnings) ++
                                                 "\nErrors: " ++ show (bagToList errors)