{-# LANGUAGE PatternGuards #-}

module HsDev.Tools.Ghc.Base (
        -- * Running Ghc
        ghcRun, ghcRunWith,
        -- * Commonly used DynFlags
        interpretedFlags, noLinkFlags,
        -- * Setting DynFlags
        withFlags, modifyFlags,
        -- * Loading targets
        clearTargets, makeTarget, loadTargets,
        loadInteractive, reload,
        -- * Logging messages
        collectMessages, collectMessages_,

        -- * Util
        formatType,
        spanRegion,
        withCurrentDirectory,
        logToChan, logToNull
        ) where

import Control.Lens (view, over)
import Control.Monad
import Control.Monad.Except
import Data.Time.Clock (getCurrentTime)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.FilePath

import Exception (ExceptionMonad(..))
import GHC hiding (Warning, Module)
import Outputable
import FastString (unpackFS)
import StringBuffer
import Type
import qualified Pretty

import Control.Concurrent.FiniteChan
import System.Directory.Paths
import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..))
import HsDev.Tools.Types
import HsDev.Tools.Ghc.Compat
import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle)

-- | Run ghc
ghcRun :: GhcMonad m => [String] -> m a -> m a
ghcRun = ghcRunWith interpretedFlags

-- | Run ghc
ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a
ghcRunWith onFlags opts act = do
        fs <- getSessionDynFlags
        cleanupHandler fs $ do
                (fs', _, _) <- parseDynamicFlags fs (map noLoc opts)
                void $ setSessionDynFlags $ onFlags fs'
                modifyFlags $ C.setLogAction logToNull
                act

interpretedFlags :: DynFlags -> DynFlags
interpretedFlags fs = fs {
        ghcMode = CompManager,
        ghcLink = LinkInMemory,
        hscTarget = HscInterpreted }

noLinkFlags :: DynFlags -> DynFlags
noLinkFlags fs = fs {
        ghcMode = CompManager,
        ghcLink = NoLink,
        hscTarget = HscNothing }

-- | Alter @DynFlags@ temporary
withFlags :: GhcMonad m => m a -> m a
withFlags = gbracket getSessionDynFlags (void . setSessionDynFlags) . const

-- | Update @DynFlags@
modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyFlags f = do
        fs <- getSessionDynFlags
        let
                fs' = f fs
        _ <- setSessionDynFlags fs'
        -- _ <- liftIO $ initPackages fs'
        return ()

-- | Clear loaded targets
clearTargets :: GhcMonad m => m ()
clearTargets = loadTargets []

-- | Make target with its source code optional
makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target
makeTarget name Nothing = guessTarget (T.unpack name) Nothing
makeTarget name (Just cts) = do
        t <- guessTarget (T.unpack name) Nothing
        tm <- liftIO getCurrentTime
        return t { targetContents = Just (stringToStringBuffer $ T.unpack cts, tm) }

-- | Load all targets
loadTargets :: GhcMonad m => [Target] -> m ()
loadTargets ts = setTargets ts >> load LoadAllTargets >> return ()

-- | Load and set interactive context
loadInteractive :: GhcMonad m => Path -> Maybe Text -> m ()
loadInteractive fpath mcts = do
        fpath' <- liftIO $ canonicalize fpath
        withCurrentDirectory (view path $ takeDir fpath') $ do
                t <- makeTarget (over path takeFileName fpath') mcts
                loadTargets [t]
                g <- getModuleGraph
                setContext [IIModule (ms_mod_name m) | m <- modSummaries g]

-- | Reload targets
reload :: GhcMonad m => m ()
reload = do
        ts <- getTargets
        ctx <- getContext
        setContext []
        clearTargets
        setTargets ts
        setContext ctx

-- | Collect messages from ghc for underlying computation
collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage])
collectMessages act = do
        ch <- liftIO newChan
        r <- gbracket (liftM log_action getSessionDynFlags) (\action' -> modifyFlags (\fs -> fs { log_action = action' })) $ \_ -> do
                modifyFlags (C.addLogAction $ logToChan ch)
                act
        notes <- liftIO $ stopChan ch
        return (r, notes)

-- | Same as @collectMessages@, but when no result except notes needed
collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage]
collectMessages_ = fmap snd . collectMessages

-- | Format type for output
formatType :: GHC.DynFlags -> GHC.Type -> String
formatType dflag t = showOutputable dflag (removeForAlls t)

-- | Get region of @SrcSpan@
spanRegion :: SrcSpan -> Region
spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s)
spanRegion _ = Position 0 0 `region` Position 0 0

-- | Set current directory and restore it after action
withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a
withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $
        const (liftIO (setCurrentDirectory dir) >> act)

-- | Log  ghc warnings and errors as to chan
-- You may have to apply recalcTabs on result notes
logToChan :: Chan (Note OutputMessage) -> LogAction
logToChan ch fs sev src msg
        | Just sev' <- checkSev sev = do
                src' <- canonicalize srcMod
                void $ sendChan ch Note {
                        _noteSource = src',
                        _noteRegion = spanRegion src,
                        _noteLevel = Just sev',
                        _note = OutputMessage {
                                _message = fromString $ showSDoc fs msg,
                                _messageSuggestion = Nothing } }
        | otherwise = return ()
        where
                checkSev SevWarning = Just Warning
                checkSev SevError = Just Error
                checkSev SevFatal = Just Error
                checkSev _ = Nothing
                srcMod = case src of
                        RealSrcSpan s' -> FileModule (fromFilePath $ unpackFS $ srcSpanFile s') Nothing
                        _ -> NoLocation

-- | Don't log ghc warnings and errors
logToNull :: LogAction
logToNull _ _ _ _ = return ()

-- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@

removeForAlls :: Type -> Type
removeForAlls ty = removeForAlls' ty' tty' where
        ty'  = dropForAlls ty
        tty' = splitFunTy_maybe ty'

removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' ty Nothing = ty
removeForAlls' ty (Just (pre, ftype))
        | isPredTy pre = mkFunTy pre (dropForAlls ftype)
        | otherwise = ty

showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr

showUnqualifiedPage :: DynFlags -> SDoc -> String
showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . withPprStyleDoc dflag (C.unqualStyle dflag)