Recompiler.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
module Halive.Recompiler where
import Halive.SubHalive
import Halive.FileListener
import System.Mem
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad.Trans
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as Text
import Data.IORef
import Data.Typeable
import GHC
data CompilationRequest = CompilationRequest
    { crFilePath          :: FilePath
    , crExpressionStrings :: [String]
    , crResultTChan       :: TChan CompilationResult
    , crFileContents      :: Maybe String
    -- ^ This is intentionally lazy, since we want to evaluate the string on
    -- the SubHalive thread (as it may be e.g. a TextSeq that needs conversion)
    -- In the future, we may want to pass GHC's StringBuffer type here instead,
    -- and construct those in a smarter way.
    }

type CompilationResult = Either String [CompiledValue]

-- This is used to implement a workaround for the GHC API crashing
-- when used after application startup, when it tries to load libraries
-- for the first time. By wrapping main in withGHC, startGHC will block until
-- the GHC API is initialized before allowing the application to start.
withGHC :: MonadIO m
        => GHCSessionConfig
        -> (TChan CompilationRequest -> m b)
        -> m b
withGHC ghcSessionConfig action = do
    ghcChan <- startGHC ghcSessionConfig
    action ghcChan

startGHCDefault :: MonadIO m => m (TChan CompilationRequest)
startGHCDefault = startGHC defaultGHCSessionConfig

startGHC :: MonadIO m => GHCSessionConfig -> m (TChan CompilationRequest)
startGHC ghcSessionConfig = liftIO $ do
    ghcChan <- newTChanIO

    -- Grab this thread's ID (need to run this on the main thread, of course)
    mainThreadID <- case gscMainThreadID ghcSessionConfig of
        Just threadID -> return threadID
        Nothing -> myThreadId

    initialFileLock <- liftIO newEmptyMVar
    _ <- forkIO . void $ do

        case gscKeepLibsInMemory ghcSessionConfig of

            -- In this mode we keep the ghc session alive continuously,
            -- and process all compilation requests in it.
            -- This trades possibly high memory usage for very fast compilation,
            -- since libraries don't have to be loaded in repeatedly.
            Always -> do

                -- See SubHalive.hs:GHCSessionConfig
                withGHCSession mainThreadID ghcSessionConfig $ do
                    compileInitialFile ghcSessionConfig
                    liftIO $ putMVar initialFileLock ()

                    forever $ do
                        CompilationRequest{..} <- readTChanIO ghcChan

                        result <- recompileExpressionsInFile
                            crFilePath crFileContents crExpressionStrings
                        writeTChanIO crResultTChan result

            -- In this mode we create a fresh GHC session for each set of compilation
            -- requests. This trades slower compilations for lower memory usage
            -- when not compiling.
            Opportunistic -> do
                withGHCSession mainThreadID ghcSessionConfig $
                    compileInitialFile ghcSessionConfig
                liftIO $ putMVar initialFileLock ()

                forever $ do
                    requests <- waitExhaustTChanIO ghcChan

                    withGHCSession mainThreadID ghcSessionConfig $
                        forM_ requests $ \CompilationRequest{..} -> do
                            result <- recompileExpressionsInFile
                                crFilePath crFileContents crExpressionStrings
                            writeTChanIO crResultTChan result
                    liftIO performGC

    -- Wait for the initial file to complete
    () <- liftIO (takeMVar initialFileLock)

    return ghcChan

compileInitialFile :: GHCSessionConfig -> Ghc ()
compileInitialFile ghcSessionConfig =
    forM_ (gscStartupFile ghcSessionConfig) $
        \(startupFile, startupExpr) ->
            recompileExpressionsInFile startupFile Nothing [startupExpr]

data Recompiler = Recompiler
    { recResultTChan       :: TChan CompilationResult
    , recFileEventListener :: FileEventListener
    , recListenerThread    :: ThreadId
    }

recompilerForExpression :: MonadIO m
                        => TChan CompilationRequest
                        -> FilePath
                        -> String
                        -> m Recompiler
recompilerForExpression ghcChan filePath expressionString =
    recompilerWithConfig ghcChan RecompilerConfig
        { rccWatchAll = Nothing
        , rccExpressions = [expressionString]
        , rccFilePath = filePath
        }

data RecompilerConfig = RecompilerConfig
    { rccWatchAll :: Maybe (FilePath, [String]) -- if Nothing, just watch given file
    , rccExpressions :: [String]
    , rccFilePath :: FilePath
    }

recompilerWithConfig :: MonadIO m
                     => TChan CompilationRequest
                     -> RecompilerConfig
                     -> m Recompiler
recompilerWithConfig ghcChan RecompilerConfig{..} = liftIO $ do
    resultTChan <- newTChanIO
    let compilationRequest = CompilationRequest
            { crFilePath          = rccFilePath
            , crExpressionStrings = rccExpressions
            , crResultTChan       = resultTChan
            , crFileContents      = Nothing
            }

    -- Recompile on file event notifications
    fileEventListener <- case rccWatchAll of
        Nothing -> eventListenerForFile rccFilePath JustReportEvents
        Just (watchDir, fileTypes) -> eventListenerForDirectory watchDir fileTypes
    listenerThread <- forkIO . forever $ do
        _ <- readFileEvent fileEventListener
        writeTChanIO ghcChan compilationRequest

    -- Compile for the first time immediately
    writeTChanIO ghcChan compilationRequest

    return Recompiler
        { recResultTChan       = resultTChan
        , recFileEventListener = fileEventListener
        , recListenerThread    = listenerThread
        }

killRecompiler :: MonadIO m => Recompiler -> m ()
killRecompiler recompiler = do
    liftIO $ killThread (recListenerThread recompiler)

renameRecompilerForExpression :: MonadIO m => Recompiler
                                           -> TChan CompilationRequest
                                           -> FilePath
                                           -> String
                                           -> m Recompiler
renameRecompilerForExpression recompiler ghcChan filePath expressionString = do
    killRecompiler recompiler
    recompilerForExpression ghcChan filePath expressionString

compileExpressions :: MonadIO m
                   => TChan CompilationRequest
                   -> Text
                   -> [String]
                   -> m (TChan CompilationResult)
compileExpressions ghcChan code expressionStrings = do
    resultTChan <- liftIO newTChanIO
    liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest
        { crFilePath          = ""
        , crExpressionStrings = expressionStrings
        , crResultTChan       = resultTChan
        , crFileContents      = Just $ Text.unpack code
        }
    return resultTChan

compileExpression :: MonadIO m
                  => TChan CompilationRequest
                  -> Text
                  -> String
                  -> m (TChan CompilationResult)
compileExpression ghcChan code expressionString =
    compileExpressions ghcChan code [expressionString]

compileExpressionInFile :: MonadIO m
                        => TChan CompilationRequest
                        -> FilePath
                        -> String
                        -> m (TChan CompilationResult)
compileExpressionInFile ghcChan fileName expressionString = do
    resultTChan <- liftIO newTChanIO
    liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest
        { crFilePath          = fileName
        , crExpressionStrings = [expressionString]
        , crResultTChan       = resultTChan
        , crFileContents      = Nothing
        }
    return resultTChan

-- | liveExpression returns an action to get to the latest version of the expression,
-- updating it whenever the code changes (unless there is an error).
-- It also takes a default argument to use until the first compilation completes.
-- The action is meant to be called before each use of the value.
liveExpression :: Typeable a
               => TChan CompilationRequest
               -> FilePath
               -> String
               -> a
               -> IO (IO a)
liveExpression ghcChan fileName expression defaultVal = do
    recompiler <- recompilerForExpression ghcChan fileName expression
    valueRef <- newIORef defaultVal
    _ <- forkIO . forever $ do
        result <- atomically (readTChan (recResultTChan recompiler))
        case result of
            Left errors -> putStrLn errors
            Right values ->
                case values of
                    [value] ->
                        case getCompiledValue value of
                            Just newVal -> writeIORef valueRef newVal
                            Nothing -> putStrLn ("Got incorrect type for " ++ fileName ++ ":" ++ expression)
                    _ ->
                        error "Unexpected number of values received on recResultTChan"

    return (readIORef valueRef)