{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main (main) where

import Data.List ((\\))
import Control.Monad (void)
import System.Environment

import GHC
import qualified GHC.Settings.Config as GHC
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Ppr as GHC
import GHC.Driver.Monad (liftIO)
import GHC.Utils.Outputable (PprStyle, queryQual)
import GHC.Unit.State
import GHC.Types.Error

compileInGhc :: [FilePath]          -- ^ Targets
             -> (String -> IO ())   -- ^ handler for each MCOutput message
             -> Ghc ()
compileInGhc targets handlerOutput = do
    -- Set flags
    flags0 <- getSessionDynFlags
    let flags = flags0 {verbosity = 1 }
    setSessionDynFlags flags
    let collectSrcError handlerOutput _flags MCOutput _srcspan msg
          = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg
        collectSrcError _ _ _ _ _
          = return ()
    pushLogHookM (const (collectSrcError handlerOutput))
    -- Set up targets.
    oldTargets <- getTargets
    let oldFiles = map fileFromTarget oldTargets
    mapM_ (\filename -> addSingle filename (homeUnitId_ flags)) (targets \\ oldFiles)
    mapM_ (removeTarget . targetIdFromFile) $ oldFiles \\ targets
    -- Load modules to typecheck
    void $ load LoadAllTargets
  where
    targetIdFromFile file = TargetFile file Nothing

    addSingle filename unitId =
      addTarget Target
        { targetId           = targetIdFromFile filename
        , targetAllowObjCode = True
        , targetUnitId       = unitId
        , targetContents     = Nothing
        }

    fileFromTarget Target{targetId} =
      case targetId of
        TargetFile file Nothing -> file
        _ -> error "fileFromTarget: not a known target"


main :: IO ()
main = do
  [libdir] <- getArgs
  runGhc (Just libdir) $ do

  liftIO $ putStrLn "----- 0 ------"
  compileInGhc ["A.hs", "B.hs"] $ \msg -> print (0 :: Int, msg)

  liftIO $ putStrLn "----- 1 ------"
  compileInGhc ["A.hs", "B.hs"] $ \msg -> print (1 :: Int, msg)

  liftIO $ putStrLn "----- 2 ------"
  compileInGhc ["C.hs"] $ \msg -> print (2 :: Int, msg)
