GHC.hs

module Language.Haskell.HBB.Internal.GHC where

import DynFlags (parseDynamicFlagsCmdLine)
import GhcMonad (liftIO)
import Bag (bagToList)
import GHC

-- | This is a wrapper around runGhc which allows to pass some command line
-- options.
--
-- This function takes ghc-specific command line flags and inserts them into
-- the GHC monad. The passed Ghc action is then executed in an environment
-- where these flags have been applied. Principally there are 3 types of
-- flags for GHC:
--
--  - dynamic flags
--
--  - static  flags (they may change during one compiler run)
--
--  - mode    flags (e.g. @--make@)
--
-- This function only processes dynamic and static flags. They should be passed
-- as specified on the command line:
--
-- @
-- runGhcWithCmdLineFlags ["-isrc","-XDeriveDataTypeable"] (Just libdir) someAction
-- @
--
-- This function will throw an exception if any of the specified options leads
-- to a warning or cannot be parsed.
runGhcWithCmdLineFlags :: [String] -> Maybe FilePath -> Ghc a -> IO a
runGhcWithCmdLineFlags cmdLineFlags mbLibDir ghcAction = do
    -- The static GHC flags are somehow rembembered in the Monad (IO in
    -- this case) and therefore need not to be passed explicitely to
    -- runGhc...
    _ <- do (_,warns) <- parseStaticFlags (map (mkGeneralLocated "on the command line") cmdLineFlags)
            case warns of []          -> return ()
                          ((L _ x):_) -> error $ "Warnings at parsing (static) GHC flags: " ++ x
    runGhc mbLibDir $ do
        basicDFlags <- getSessionDynFlags
        let str2locStr :: String -> Located String
            str2locStr = (mkGeneralLocated "on the command line")
        dynFlags <- do
            (newDFlags,restArgs,errMsgs) <- parseDynamicFlagsCmdLine basicDFlags (map str2locStr cmdLineFlags)
            _ <- case restArgs of
                 []          -> return ()
                 ((L _ x):_) -> error $ "Unable to parse all GHC flags. E.g.: " ++ x
            _ <- case errMsgs of
                 []          -> return ()
                 ((L _ x):_) -> error $ "An error occured parsing the GHC flags at: " ++ x
            return newDFlags
        _ <- setSessionDynFlags dynFlags
        ghcAction

-- | Takes a module summary and returnes the renamed abstract syntax tree.
--
-- This is a small auxiliary function that takes a module summary and extracts
-- the renamed abstract syntax tree from it. The syntax tree is represented by
-- the data structure HsGroup in GHC.
extractRenamedAST :: GhcMonad m => ModSummary -> m RenamedSource
extractRenamedAST modSum = do
    t <- (parseModule modSum >>= typecheckModule)
    case tm_renamed_source t of Nothing -> error "internal failure (no hsgroup)"
                                Just x  -> return x

-- | A small auxiliary function that updates the dynamic flags to suppress file
-- output.
updateDynFlagsToSuppressFileOutput :: GhcMonad m => m ()
updateDynFlagsToSuppressFileOutput = do
    dflags <- getSessionDynFlags
    setSessionDynFlags dflags { 
        hscTarget = HscInterpreted , -- HscNothing disables the output of intermediate (*.o) files
        ghcLink   = LinkInMemory     -- NoLink disables linking (is required when using HscNothing)
        } 
    return ()

-- | This function takes a file name or a module and searches the
-- module-summary which is based on this source file out of the module graph.
searchModGraphFor :: GhcMonad m => Either FilePath Module -> m (ModuleName,ModSummary)
searchModGraphFor what = do
    modGraph <- getModuleGraph
    return $ case what of
        Left filename -> searchModGraphInternalFi filename modGraph
        Right mod     -> searchModGraphInternalMo mod      modGraph
    where
        searchModGraphInternalMo mo [] = error $ "Internal error (module isn't part of the module graph)"
        searchModGraphInternalMo mo (x:rest) | (ms_mod x) == mo = (ms_mod_name x,x)
        searchModGraphInternalMo mo (_:rest)                    = searchModGraphInternalMo mo rest

        searchModGraphInternalFi fn [] = error $ "Internal error (module for source file " ++ 
                                                  fn ++ " isn't part of the module graph)"
        searchModGraphInternalFi fn (x:rest) = 
            case ml_hs_file (ms_location x) of
            Nothing -> searchModGraphInternalFi fn rest
            Just hs -> if fn == hs then (ms_mod_name x,x)
                                   else searchModGraphInternalFi fn rest

-- | This function creates a target from the passed file name by applying to
-- most common used settings.
fileToTarget :: FilePath -> Target
fileToTarget filename = Target { targetId           = (TargetFile filename Nothing),
                                 targetAllowObjCode = False,
                                 targetContents     = Nothing }

-- | Wrapper around 'setTargets' and 'load' that treats the common case of a
-- one-file-target.
loadTargetsFromFilename :: GhcMonad m => FilePath -> m ()
loadTargetsFromFilename filename = do
    setTargets [fileToTarget filename]
    _ <- load LoadAllTargets -- Depending on the HscTarget this will create
                             -- intermediate files (set HscNothing to
                             -- suppress)
    return ()