module Main (main) where

import GHC hiding (loadModule)
import GHC.Data.IOEnv
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Make
import GHC.Driver.Main (hscSimplify)
import GHC.Unit.Module.ModDetails
import GHC.Unit.Types
import GHC.Types.Error
import GHC.Driver.Errors.Types
import GHC.Types.SourceError
import GHC.Iface.Tidy (tidyProgram)
import GHC.Driver.Config.Tidy (initTidyOpts)
import GHC.Iface.Make
import GHC.Driver.Env
import GHC.Unit.Env
import GHC.Unit.Home.ModInfo
-- import GHC.Utils.Trace
-- import GHC.Utils.Outputable

import Control.Monad
import Data.Maybe
import System.FilePath

libdir = "/home/mi/prog/ghc/_build/stage1/lib"
pkgdir = libdir

main :: IO ()
main = do
    runGhc (Just libdir) $ do
        setup
        compileAndRegister "MiniMonad"
        compileAndRegister "SpecMain"
    putStrLn "All done."

compileAndRegister :: (GhcMonad m) => String -> m ()
compileAndRegister s = do
    ms <- prepareModule $ mkModule mainUnit $ mkModuleName s
    tmod <- prepareSource ms
    (details, iface) <- compileModule tmod
    registerModule iface details

prepareModule :: (GhcMonad m) => Module -> m ModSummary
prepareModule mod = do
    liftIO . putStrLn $ unwords ["Processing module", moduleNameString . moduleName $ mod]
    target <- liftIO $ resolveTarget mod
    setTargets [target]

    (errs, nodes) <- do
        env <- getSession
        liftIO $ downsweep env [] [] False
    let mg = mkModuleGraph nodes
    reportErrors $ fmap GhcDriverMessage <$> errs
    return $ fromMaybe (error "prepareModule") $ mgLookupModule mg mod

compileModule
    :: (GhcMonad m)
    => TypecheckedModule
    -> m (ModDetails, ModIface)
compileModule tmod = do
    dmod <- desugarModule tmod
    let mguts = coreModule dmod

    env <- getSession
    mguts' <- liftIO $ hscSimplify env [] mguts
    (cg_guts, details) <- liftIO $ do
        tidy_opts <- initTidyOpts env
        tidyProgram tidy_opts mguts'

    let partial_iface = mkPartialIface env [] details ms mguts'
    iface <- liftIO $ mkFullIface env partial_iface Nothing
    return (details, iface)
  where
    ms = pm_mod_summary . tm_parsed_module $ tmod

prepareSource
    :: (GhcMonad m)
    => ModSummary
    -> m TypecheckedModule
prepareSource = parseModule >=> typecheckModule

setup :: (GhcMonad m) => m ()
setup = do
    let pkgDb = pkgdir </> "package.conf.d"

    dflags <- getSessionDynFlags

    dflags <- return $ updOptLevel 0 dflags

    dflags <- return $ foldl gopt_set dflags
        [ Opt_NoTypeableBinds
        ]
    dflags <- return $ foldl gopt_unset dflags
        [ Opt_OmitInterfacePragmas
        , Opt_IgnoreInterfacePragmas
        ]

    dflags <- return $ foldl dopt_set dflags
        [ Opt_D_dump_rule_rewrites
        ]

    dflags <- return $ foldl gopt_set dflags
        [ Opt_SuppressIdInfo
        , Opt_SuppressTypeSignatures
        , Opt_SuppressCoercions
        , Opt_SuppressVarKinds
        ]

    dflags <- return $ dflags{ backend = noBackend }
    dflags <- return $ dflags{ packageDBFlags = [PackageDB $ PkgDbPath pkgDb, ClearPackageDBs] }
    setSessionDynFlags dflags

reportErrors :: (GhcMonad m) => [ErrorMessages] -> m ()
reportErrors errs = do
    errs <- return $ unionManyMessages errs
    unless (isEmptyMessages errs) $ throwErrors errs

resolveTarget :: Module -> IO Target
resolveTarget mod = do
    -- Pretend this does something more interesting
    return $ Target
        { targetId = TargetFile ("input" </> moduleNameSlashes (moduleName mod) <.> "hs") Nothing
        , targetAllowObjCode = False
        , targetContents = Nothing
        , targetUnitId = moduleUnitId mod
        }

registerModule :: (GhcMonad m) => ModIface -> ModDetails -> m ()
registerModule iface details = modifySession extendHUG
  where
    hmi = HomeModInfo iface details emptyHomeModInfoLinkable
    extendHUG = hscUpdateHUG $ addHomeModInfoToHug hmi