content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE CPP #-}
  module Halive.SubHalive (
      module Halive.SubHalive
  #if __GLASGOW_HASKELL__ >= 800
      , module GHC.LanguageExtensions
  #else
      , ExtensionFlag(..)
  #endif
  
      ) where
  
  import GHC
  #if __GLASGOW_HASKELL__ >= 800
  import GHC.LanguageExtensions
  #else
  import Module
  #endif
  import DynFlags
  import Exception
  import ErrUtils
  import HscTypes
  import GHC.Paths
  import Outputable
  import StringBuffer
  import PprColour
  import qualified Util
  
  -- import Packages
  import Linker
  
  #if __GLASGOW_HASKELL__ < 800
  import Control.Monad
  #endif
  import Control.Monad.IO.Class
  import Data.IORef
  import Data.Time
  import Halive.FindPackageDBs
  
  import Control.Concurrent
  import System.Signal
  import Data.Dynamic
  
  import System.Directory
  import System.FilePath
  import Data.Time.Clock.POSIX
  
  import qualified Data.Text as Text
  
  data FixDebounce = DebounceFix | NoDebounceFix deriving Eq
  
  data CompliationMode = Interpreted | Compiled deriving Eq
  
  data KeepLibsInMemory = Always | Opportunistic
  
  data GHCSessionConfig = GHCSessionConfig
      { gscFixDebounce        :: FixDebounce
      , gscImportPaths        :: [FilePath]
      , gscPackageDBs         :: [FilePath]
      , gscLibDir             :: FilePath
  #if __GLASGOW_HASKELL__ >= 800
      , gscLanguageExtensions :: [Extension]
      , gscNoLanguageExtensions :: [Extension]
  #else
      , gscLanguageExtensions :: [ExtensionFlag]
      , gscNoLanguageExtensions :: [ExtensionFlag]
  #endif
      , gscCompilationMode    :: CompliationMode
      , gscStartupFile        :: Maybe (FilePath, String)
          -- ^ Allow API users to block until a given file is compiled,
          -- to work around a bug where the GHC API crashes while
          -- loading libraries if the main thread is doing work
          -- (possibly due to accessing said libraries in some way)
      , gscVerbosity          :: Int
      , gscMainThreadID       :: Maybe ThreadId
      , gscKeepLibsInMemory   :: KeepLibsInMemory
          -- ^ Chooses between keeping the GHC session alive continuously
          -- (which uses a lot of memory but makes compilation fast)
          -- or disposing of it between compilations
          -- (which saves memory but slows compilation)
          -- or keeping it around for sequences of compilations
          -- (which lies in-between these)
      , gscUseColor        :: Bool
      }
  
  defaultGHCSessionConfig :: GHCSessionConfig
  defaultGHCSessionConfig = GHCSessionConfig
      { gscFixDebounce = DebounceFix
      , gscImportPaths = []
      , gscPackageDBs  = []
      , gscLanguageExtensions = []
      , gscNoLanguageExtensions = []
      , gscLibDir = libdir
      , gscCompilationMode = Interpreted
      , gscStartupFile = Nothing
      , gscVerbosity = 0
      , gscMainThreadID = Nothing
      , gscKeepLibsInMemory = Always
      , gscUseColor = False
      }
  
  -- Starts up a GHC session and then runs the given action within it
  withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a
  withGHCSession mainThreadID GHCSessionConfig{..} action = do
      -- Work around https://ghc.haskell.org/trac/ghc/ticket/4162
      let restoreControlC f = do
              liftIO $ installHandler sigINT
                  (\_signal -> killThread mainThreadID)
              f
  
      -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do
      runGhc (Just gscLibDir) . restoreControlC $ do
  
          -- initialFlags <- getSessionDynFlags
          -- (newFlags, leftovers, warnings) <- parseDynamicFlagsCmdLine initialFlags [noLoc "-prof"]
          -- setSessionDynFlags newFlags
          -- liftIO $ print (compilerInfo newFlags)
  
          packageIDs <-
                  getSessionDynFlags
              >>= updateDynFlagsWithGlobalDB
              -- If this is a stack project, add its package DBs
              >>= updateDynFlagsWithStackDB
              -- If there's a sandbox, add its package DB
              >>= updateDynFlagsWithCabalSandbox
              -- Add passed-in package DBs
              >>= (pure . addExtraPkgConfs gscPackageDBs)
              -- Make sure we're configured for live-reload
              >>= (\d -> pure d
                  { hscTarget   = if gscCompilationMode == Compiled then HscAsm else HscInterpreted
                  , optLevel    = if gscCompilationMode == Compiled then 1 else 0
                  , ghcLink     = LinkInMemory
                  , ghcMode     = CompManager
                  , importPaths = gscImportPaths
                  , objectDir   = Just ".halive"
                  , hiDir       = Just ".halive"
                  , stubDir     = Just ".halive"
                  , dumpDir     = Just ".halive"
                  , verbosity   = gscVerbosity
                  , useColor    = if gscUseColor then Util.Always else Util.Never
                  , canUseColor = gscUseColor
                  , colScheme   = defaultScheme
                  })
              >>= (pure . (`gopt_set` Opt_DiagnosticsShowCaret))
              -- turn off the GHCi sandbox
              -- since it breaks OpenGL/GUI usage
              >>= (pure . (`gopt_unset` Opt_GhciSandbox))
              -- Allows us to work in dynamic executables
              -- >>= (pure . (if dynamicGhc then addWay' WayDyn else id))
              -- >>= (pure . (addWay' WayProf))
              -- >>= (pure . (if rtsIsProfiled then addWay' WayProf else id))
              -- >>= (pure . (addWay' WayDyn))
              -- GHC seems to try to "debounce" compilations within
              -- about a half second (i.e., it won't recompile)
              -- This fixes that, but probably isn't quite what we want
              -- since it will cause extra files to be recompiled...
              >>= (pure . (if gscFixDebounce == DebounceFix
                              then (`gopt_set` Opt_ForceRecomp)
                              else id))
              >>= (pure . flip (foldl xopt_unset) gscNoLanguageExtensions
                        . flip (foldl xopt_set) gscLanguageExtensions)
              -- We must call setSessionDynFlags before calling initPackages or any other GHC API
              >>= setSessionDynFlags
  
          -- Initialize the package database and dynamic linker.
          -- Explicitly calling these avoids crashes on some of my machines.
  #if __GLASGOW_HASKELL__ >= 800
          -- (dflags,_pkgs) <- liftIO . initPackages =<< getSessionDynFlags
          -- setSessionDynFlags dflags
  
          getSession >>= \hscEnv ->
              liftIO $ linkPackages hscEnv packageIDs
          liftIO . initDynLinker =<< getSession
  #else
          getSessionDynFlags >>= \dflags ->
              liftIO $ linkPackages dflags packageIDs
          liftIO . initDynLinker =<< getSessionDynFlags
  #endif
  
          result <- action
  
          -- Unload libraries to keep from leaking memory & overloading the GC
          getSession >>= \hscEnv ->
              liftIO (unload hscEnv [])
  
          return result
  
  
  
  newtype CompiledValue = CompiledValue Dynamic deriving Show
  
  getCompiledValue :: Typeable a => CompiledValue -> Maybe a
  getCompiledValue (CompiledValue r) = fromDynamic r
  
  fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime)
  fileContentsStringToBuffer fileContents = do
      now <- liftIO getCurrentTime
      return (stringToStringBuffer fileContents, now)
  
  createTempFile :: MonadIO m => m FilePath
  createTempFile = liftIO $ do
      tempDir <- getTemporaryDirectory
      now <- show . diffTimeToPicoseconds . realToFrac <$> getPOSIXTime
      let tempFile = tempDir </> "halive_" ++ now <.> "hs"
      writeFile tempFile ""
      return tempFile
  
  -- | Takes a filename, optionally its contents, and a list of expressions.
  -- Returns a list of errors or a list of Dynamic compiled values
  recompileExpressionsInFile :: FilePath
                             -> Maybe String
                             -> [String]
                             -> Ghc (Either String [CompiledValue])
  recompileExpressionsInFile fileName mFileContents expressions =
  
      catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do
  
          -- Set up an error accumulator
          errorsRef <- liftIO (newIORef "")
          _ <- getSessionDynFlags >>=
              \dflags -> setSessionDynFlags dflags
                  { log_action = logHandler errorsRef }
  
          mFileContentsBuffer <- mapM fileContentsStringToBuffer mFileContents
  
          -- Set the target
          (tempFileName, target) <- case fileName of
              -- We'd like to just use a Module name for the target,
              -- but load/depanal fails with "Foo is a package module"
              -- We use a blank temp file as a workaround.
              ""    -> do
                  tempFileName <- createTempFile
                  (tempFileName,) <$> guessTarget' tempFileName
              other -> ("",) <$> guessTarget' other
  
          -- logIO "Setting targets..."
          setTargets [target { targetContents = mFileContentsBuffer }]
  
          -- Reload the main target
          -- logIO "Loading..."
          loadSuccess <- load LoadAllTargets
  
          if succeeded loadSuccess
              then do
  
                  -- logIO "Analyzing deps..."
                  -- Get the dependencies of the main target (and update the session with them)
                  graph <- depanal [] False
  
                  #if __GLASGOW_HASKELL__ >= 804
                  let modSummaries = mgModSummaries graph
                  #else
                  let modSummaries = graph
                  #endif
  
                  -- Load the dependencies of the main target
                  setContext
                      (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries)
  
                  -- Compile the expressions and return the results
                  results <- mapM dynCompileExpr expressions
  
                  return (Right (CompiledValue <$> results))
              else do
                  -- Extract the errors from the accumulator
                  errors <- liftIO (readIORef errorsRef)
                  -- Strip out the temp file name when using anonymous code
                  let cleanErrors = if null tempFileName then errors
                          else Text.unpack $
                              Text.replace
                              (Text.pack tempFileName)
                              "<anonymous code>"
                              (Text.pack errors)
                  return (Left cleanErrors)
  
  -- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files
  -- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile
  guessTarget' :: GhcMonad m => String -> m Target
  guessTarget' fileName = guessTarget ('*':fileName) Nothing
  
  catchExceptions :: ExceptionMonad m => m (Either String a) -> m (Either String a)
  catchExceptions a = gcatch a
      (\(_x :: SomeException) -> do
          liftIO (putStrLn ("Caught exception during recompileExpressionInFile: " ++ show _x))
          return (Left (show _x))
          )
  
  -- Adapted from 
  -- https://hackage.haskell.org/package/ghc-8.2.1/docs/src/DynFlags.html#defaultLogAction
  logHandler :: IORef String -> LogAction
  logHandler errorIORef dflags reason severity srcSpan style msg
      = case severity of
        SevOutput      -> printOut msg style
        SevDump        -> printOut (msg $$ blankLine) style
        SevInteractive -> putStrSDoc msg style
        SevInfo        -> printErrs msg style
        SevFatal       -> printErrs msg style
        _              -> do -- otherwise (i.e. SevError or SevWarning)
                             caretDiagnostic <-
                                 if gopt Opt_DiagnosticsShowCaret dflags
                                 then getCaretDiagnostic severity srcSpan
                                 else pure empty
                             writeToErrorIORef (message $+$ caretDiagnostic)
                                 (setStyleColoured True style)
                             -- careful (#2302): printErrs prints in UTF-8,
                             -- whereas converting to string first and using
                             -- hPutStr would just emit the low 8 bits of
                             -- each unicode char.
      where printOut   = writeToErrorIORef
            printErrs  = writeToErrorIORef
            putStrSDoc = writeToErrorIORef
            -- Pretty print the warning flag, if any (#10752)
            message = mkLocMessageAnn Nothing severity srcSpan msg
            writeToErrorIORef message style = 
              modifyIORef' errorIORef 
                  (++ ('\n':renderWithStyle dflags message style))
  
  -- logHandler :: IORef String -> LogAction
  -- #if __GLASGOW_HASKELL__ >= 800
  -- logHandler ref dflags _warnReason severity srcSpan style msg =
  -- #else
  -- logHandler ref dflags severity srcSpan style msg =
  -- #endif
  --     caretDiagnostic <- getCaretDiagnostic dflags srcSpan
  --     let cntx                = initSDocContext dflags style
  --         locMsg              = mkLocMessage severity srcSpan msg
  --         messageWithLocation = show (runSDoc locMsg cntx)
  --         messageOther        = show (runSDoc msg cntx)
  --         renderWithStyle dflags (msg $+$ caretDiagnostic) 
  --         (setStyleColoured True style)
  
  --     case severity of
  --        SevError   -> modifyIORef' ref (++ ('\n':messageWithLocation))
  --        SevFatal   -> modifyIORef' ref (++ ('\n':messageWithLocation))
  --        SevWarning -> modifyIORef' ref (++ ('\n':messageWithLocation))
  --        _          -> do
  --             putStr messageOther
  --             return () -- ignore the rest
  
  -- A helper from interactive-diagrams to print out GHC API values,
  -- useful while debugging the API.
  -- | Outputs any value that can be pretty-printed using the default style
  output :: (GhcMonad m, Outputable a) => a -> m ()
  output a = do
      dfs <- getSessionDynFlags
      let style = defaultUserStyle dfs
      let cntx  = initSDocContext dfs style
      liftIO $ print $ runSDoc (ppr a) cntx
  
  
  -- NOTE: handleSourceError (which calls gatherErrors above)
  -- doesn't actually seem to do anything, so we use
  -- the IORef + log_action solution instead.
  -- The API docs claim 'load' should
  -- throw SourceErrors but it doesn't afaict.
  gatherErrors :: GhcMonad m => SourceError -> m String
  gatherErrors sourceError = do
      printException sourceError
      dflags <- getSessionDynFlags
      let style = mkUserStyle dflags neverQualify AllTheWay
          errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError)
          errorStrings = map (showSDocForUser dflags neverQualify) errorSDocs
      return (concat errorStrings)
  
  
  --pkgConfRefToString = \case
  --    GlobalPkgConf -> "GlobalPkgConf"
  --    UserPkgConf -> "UserPkgConf"
  --    PkgConfFile file -> "PkgConfFile " ++ show file
  
  --extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ []
  
  logIO :: MonadIO m => String -> m ()
  logIO = liftIO . putStrLn
  