halive 0.1.0.7 → 0.1.1

raw patch · 16 files changed

+1269/−259 lines, 16 filesdep +bytestringdep +ghc-bootdep +gldep −bin-package-dbdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, ghc-boot, gl, linear, mtl, random, sdl2, signal, stm, text, time

Dependencies removed: bin-package-db

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• demo/Cube.hs +212/−0
• demo/Green.hs +4/−0
• demo/Main.hs +72/−0
• demo/Shader.hs +119/−0
• demo/Window.hs +49/−0
• exec/FindPackageDBs.hs +0/−59
• exec/Halive.hs +0/−153
• exec/HaliveMain.hs +75/−0
• exec/main.hs +0/−21
• halive.cabal +80/−22
• src/Halive/FileListener.hs +146/−0
• src/Halive/FindPackageDBs.hs +78/−0
• src/Halive/Recompiler.hs +118/−0
• src/Halive/SubHalive.hs +273/−0
• src/Halive/Utils.hs +19/−4
• test/TestSubhalive.hs +24/−0

@@ -0,0 +1,212 @@+module Cube where++import Graphics.GL+import Foreign+import Linear+import Data.Foldable+import Shader++newtype VertexArrayObject = VertexArrayObject   { unVertexArrayObject   :: GLuint }++data Cube = Cube+        { cubeVAO        :: VertexArrayObject+        , cubeShader     :: GLProgram+        , cubeIndexCount :: GLsizei+        , cubeUniformMVP :: UniformLocation+        }++----------------------------------------------------------+-- Make Cube+----------------------------------------------------------++renderCube :: Cube -> M44 GLfloat -> IO ()+renderCube cube mvp = do++    useProgram (cubeShader cube)++    let mvpUniformLoc = fromIntegral (unUniformLocation (cubeUniformMVP cube))+    +    withArray (concatMap toList (transpose mvp)) (\mvpPointer ->+        glUniformMatrix4fv mvpUniformLoc 1 GL_FALSE mvpPointer)++    glBindVertexArray (unVertexArrayObject (cubeVAO cube))++    glDrawElements GL_TRIANGLES (cubeIndexCount cube) GL_UNSIGNED_INT nullPtr++    glBindVertexArray 0+++makeCube :: GLProgram -> IO Cube+makeCube program = do++    aVertex   <- getShaderAttribute program "aVertex"+    aColor    <- getShaderAttribute program "aColor"+    aID       <- getShaderAttribute program "aID"+    uMVP      <- getShaderUniform   program "uMVP"++    -- Setup a VAO+    vaoCube <- overPtr (glGenVertexArrays 1)++    glBindVertexArray vaoCube+++    -----------------+    -- Cube Positions+    -----------------+    +    -- Buffer the cube vertices+    let cubeVertices = +            --- front+            [ -1.0 , -1.0 ,  1.0+            ,  1.0 , -1.0 ,  1.0  +            ,  1.0 ,  1.0 ,  1.0  +            , -1.0 ,  1.0 ,  1.0  ++            --- back+            , -1.0 , -1.0 , -1.0  +            ,  1.0 , -1.0 , -1.0  +            ,  1.0 ,  1.0 , -1.0  +            , -1.0 ,  1.0 , -1.0 ] :: [GLfloat]++++    vaoCubeVertices <- overPtr (glGenBuffers 1)++    glBindBuffer GL_ARRAY_BUFFER vaoCubeVertices+    +    let cubeVerticesSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeVertices)++    withArray cubeVertices $ +        \cubeVerticesPtr ->+            glBufferData GL_ARRAY_BUFFER cubeVerticesSize (castPtr cubeVerticesPtr) GL_STATIC_DRAW ++    -- Describe our vertices array to OpenGL+    glEnableVertexAttribArray (fromIntegral (unAttributeLocation aVertex))++    glVertexAttribPointer+        (fromIntegral (unAttributeLocation aVertex)) -- attribute+        3                 -- number of elements per vertex, here (x,y,z)+        GL_FLOAT          -- the type of each element+        GL_FALSE          -- don't normalize+        0                 -- no extra data between each position+        nullPtr           -- offset of first element++    --------------+    -- Cube Colors+    --------------++    -- Buffer the cube colors+    let cubeColors = +            -- front colors+            [ 1.0, 0.0, 0.0+            , 0.0, 1.0, 0.0+            , 0.0, 0.0, 1.0+            , 1.0, 1.0, 1.0+              -- back colors+            , 1.0, 0.0, 0.0+            , 0.0, 1.0, 0.0+            , 0.0, 0.0, 1.0+            , 1.0, 1.0, 1.0 ] :: [GLfloat]++    vboCubeColors <- overPtr (glGenBuffers 1)++    glBindBuffer GL_ARRAY_BUFFER vboCubeColors+++    let cubeColorsSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeColors)+    withArray cubeColors $+        \cubeColorsPtr ->+            glBufferData GL_ARRAY_BUFFER cubeColorsSize (castPtr cubeColorsPtr) GL_STATIC_DRAW++    +    glEnableVertexAttribArray (fromIntegral (unAttributeLocation aColor))++    glVertexAttribPointer+        (fromIntegral (unAttributeLocation aColor)) -- attribute+        3                 -- number of elements per vertex, here (R,G,B)+        GL_FLOAT          -- the type of each element+        GL_FALSE          -- don't normalize+        0                 -- no extra data between each position+        nullPtr           -- offset of first element++    -----------+    -- Cube IDs+    -----------++    -- Buffer the cube ids+    let cubeIDs = +            [ 0+            , 1 +            , 2+            , 3+            , 4+            , 5 ] :: [GLfloat]++    vboCubeIDs <- overPtr (glGenBuffers 1)++    glBindBuffer GL_ARRAY_BUFFER vboCubeIDs++    let cubeIDsSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeIDs)++    withArray cubeIDs $+        \cubeIDsPtr ->+            glBufferData GL_ARRAY_BUFFER cubeIDsSize (castPtr cubeIDsPtr) GL_STATIC_DRAW++    +    glEnableVertexAttribArray (fromIntegral (unAttributeLocation aID))++    glVertexAttribPointer+        (fromIntegral (unAttributeLocation aID)) -- attribute+        1                 -- number of elements per vertex, here (R,G,B)+        GL_FLOAT          -- the type of each element+        GL_FALSE          -- don't normalize+        0                 -- no extra data between each position+        nullPtr           -- offset of first element++++    ----------------+    -- Cube Indicies+    ----------------++    -- Buffer the cube indices+    let cubeIndices = +            -- front+            [ 0, 1, 2+            , 2, 3, 0+            -- top+            , 1, 5, 6+            , 6, 2, 1+            -- back+            , 7, 6, 5+            , 5, 4, 7+            -- bottom+            , 4, 0, 3+            , 3, 7, 4+            -- left+            , 4, 5, 1+            , 1, 0, 4+            -- right+            , 3, 2, 6+            , 6, 7, 3 ] :: [GLuint]+    +    iboCubeElements <- overPtr (glGenBuffers 1)+    +    glBindBuffer GL_ELEMENT_ARRAY_BUFFER iboCubeElements++    let cubeElementsSize = fromIntegral (sizeOf (undefined :: GLuint) * length cubeIndices)+    +    withArray cubeIndices $ +        \cubeIndicesPtr ->+            glBufferData GL_ELEMENT_ARRAY_BUFFER cubeElementsSize (castPtr cubeIndicesPtr) GL_STATIC_DRAW+    +    glBindVertexArray 0++    return $ Cube +        { cubeVAO        = VertexArrayObject vaoCube+        , cubeShader     = program+        , cubeIndexCount = fromIntegral (length cubeIndices)+        , cubeUniformMVP = uMVP+        } ++

@@ -0,0 +1,4 @@+module Green where++green :: Fractional a => a+green = 0.7

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Concurrent+import Graphics.GL+import Linear+import System.Random+import Data.Time+import Control.Monad+import Data.Bits++import Halive.Utils+import Cube+import Shader+import Window++import SDL+++import qualified Green as Green -- Try changing the green amount+                                -- while the program is running++main :: IO ()+main = do+    putStrLn "MAIN BEGIN"+    -- error "DANG!" -- It's ok if your program crashes, it shouldn't crash Halive++    -- Wrap any persistent state in 'reacquire' plus a unique asset ID.+    -- Reacquire uses foreign-store to only run your setup function once,+    -- and then return it again on subsequent recompilations.+    -- In this case, GLFW doesn't like being initialized more than once+    -- per process, so this solves the problem handily.+    -- (Our window stays persistent as well thanks to this,+    -- so it would probably be a good idea anyway!)++    (win, _ctx) <- reacquire 0 $ createGLWindow "Hot SDL"++    -- You can change the window title here.+    --GLFW.setWindowTitle win "Hot Swap!"++    -- Changing the shaders' contents will trigger Halive as well!+    program <- createShaderProgram "demo/cube.vert" "demo/cube.frag"+    cube <- makeCube program++    -- Any GL state will stick around, so be aware of that.+    glEnable GL_DEPTH_TEST++    -- Sometimes it's useful to know if we're running under Halive or not+    putStrLn . ("Running under Halive: " ++ ) . show =<< isHaliveActive++    -- do -- swap this with the next line to test immediately-returning mains+    whileWindow win $ \events -> do+        now <- realToFrac . utctDayTime <$> getCurrentTime+        -- print now -- Try turning on a stream of now logs+        let redFreq  = 0.6 * pi -- Try changing the red and blue frequencies.+            red      = sin (now * redFreq)+            blueFreq = 0.5 * pi+            blue     = sin (now * blueFreq)+        --putStrLn "glClearColor"+        glClearColor red 0.3 blue 1+        --putStrLn "glClear"+        glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT)+        -- Render our scene+        --putStrLn "getWinSize"+        V2 w h <- get (SDL.windowSize win)+        let projection = perspective 45 (fromIntegral w / fromIntegral h) 0.01 1000+            model      = mkTransformation (axisAngle (V3 0 1 1) now) (V3 (sin now) 0 (-4))+            view       = lookAt (V3 0 2 5) (V3 0 0 (-4)) (V3 0 1 0)+            mvp        = projection !*! view !*! model++        --putStrLn "renderCube"+        renderCube cube mvp+        --putStrLn "glSwapWindow"+        SDL.glSwapWindow win

@@ -0,0 +1,119 @@+module Shader where++import Graphics.GL++import Control.Monad+import Control.Monad.Trans+import Foreign++import Foreign.C.String++import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text++import Linear+import Data.Foldable++newtype GLProgram         = GLProgram           { unGLProgram           :: GLuint }++newtype AttributeLocation = AttributeLocation   { unAttributeLocation   :: GLint  }+newtype UniformLocation   = UniformLocation     { unUniformLocation     :: GLint  }++overPtr :: (MonadIO m, Storable a) => (Ptr a -> IO b) -> m a+overPtr f = liftIO (alloca (\p -> f p >> peek p))+++useProgram :: MonadIO m => GLProgram -> m ()+useProgram (GLProgram program) = glUseProgram (fromIntegral program)++uniformM44 :: UniformLocation -> M44 GLfloat -> IO ()+uniformM44 uniform matrix = do+    let mvpUniformLoc = fromIntegral (unUniformLocation uniform)+    withArray (concatMap toList (transpose matrix)) (\matrixPtr ->+        glUniformMatrix4fv mvpUniformLoc 1 GL_FALSE matrixPtr)++---------------+-- Load shaders+---------------++createShaderProgram :: FilePath -> FilePath -> IO GLProgram+createShaderProgram vertexShaderPath fragmentShaderPath =+   +    do vertexShader <- glCreateShader GL_VERTEX_SHADER+       compileShader vertexShaderPath vertexShader+       fragmentShader <- glCreateShader GL_FRAGMENT_SHADER+       compileShader fragmentShaderPath fragmentShader+       shaderProg <- glCreateProgram+       glAttachShader shaderProg vertexShader+       glAttachShader shaderProg fragmentShader+       glLinkProgram shaderProg+       linked <- overPtr (glGetProgramiv shaderProg GL_LINK_STATUS)+       when (linked == GL_FALSE)+            (do maxLength <- overPtr (glGetProgramiv shaderProg GL_INFO_LOG_LENGTH)+                logLines <- allocaArray+                              (fromIntegral maxLength)+                              (\p ->+                                 alloca (\lenP ->+                                           do glGetProgramInfoLog shaderProg maxLength lenP p+                                              len <- peek lenP+                                              peekCStringLen (p,fromIntegral len)))+                putStrLn logLines)+       return (GLProgram shaderProg)+    where compileShader path shader =+            do src <- Text.readFile path+               BS.useAsCString+                 (Text.encodeUtf8 src)+                 (\ptr ->+                    withArray [ptr]+                              (\srcs ->+                                 glShaderSource shader 1 srcs nullPtr))+               glCompileShader shader+               when True+                    (do maxLength <- overPtr (glGetShaderiv shader GL_INFO_LOG_LENGTH)+                        logLines <- allocaArray+                                      (fromIntegral maxLength)+                                      (\p ->+                                         alloca (\lenP ->+                                                   do glGetShaderInfoLog shader maxLength lenP p+                                                      len <- peek lenP+                                                      peekCStringLen (p,fromIntegral len)))+                        when (length logLines > 0)+                            (do putStrLn ("In " ++ path ++ ":")+                                putStrLn logLines)+                        )+++getShaderAttribute :: GLProgram -> String -> IO AttributeLocation+getShaderAttribute (GLProgram prog) attributeName = do+    location <- withCString attributeName $ \attributeNameCString -> +        glGetAttribLocation prog attributeNameCString+    when (location == -1) $ error $ "Coudn't bind attribute: " ++ attributeName +    return (AttributeLocation location)++getShaderUniform :: GLProgram -> String -> IO UniformLocation+getShaderUniform (GLProgram prog) uniformName = do+    location <- withCString uniformName $ \uniformNameCString -> +        glGetUniformLocation prog uniformNameCString+    when (location == -1) $ error $ "Coudn't bind uniform: " ++ uniformName +    return (UniformLocation location)++glGetErrors :: IO ()+glGetErrors = do+  code <- glGetError+  case code of+    GL_NO_ERROR -> return ()+    e -> do+      case e of+        GL_INVALID_ENUM -> putStrLn "* Invalid Enum"+        GL_INVALID_VALUE -> putStrLn "* Invalid Value"+        GL_INVALID_OPERATION -> putStrLn "* Invalid Operation"+        GL_INVALID_FRAMEBUFFER_OPERATION -> putStrLn "* Invalid Framebuffer Operation"+        GL_OUT_OF_MEMORY -> putStrLn "* OOM"+        GL_STACK_UNDERFLOW -> putStrLn "* Stack underflow"+        GL_STACK_OVERFLOW -> putStrLn "* Stack overflow"+        _ -> return ()+      glGetErrors+++

@@ -0,0 +1,49 @@+module Window where+++import Control.Monad+import SDL+import Control.Monad.Trans+import Control.Exception+import Linear+import Linear.Affine+import Data.Text (Text)++createGLWindow :: MonadIO m => Text -> m (Window, GLContext)+createGLWindow windowName = do+    initialize+        [ InitVideo+        , InitEvents+        -- , InitJoystick , InitGameController+        ]+    window <- createWindow windowName defaultWindow+        { windowOpenGL = Just $ defaultOpenGL+            { glProfile = Core Normal 4 1+            }+        , windowHighDPI = True+        , windowInitialSize = V2 640 480+        --, windowPosition = Centered+        , windowPosition = Absolute (P (V2 100 100))+        , windowResizable = True+        }+    glContext <- glCreateContext window+    glMakeCurrent window glContext+    swapInterval $= ImmediateUpdates+    return (window, glContext)++withWindow windowName = bracket (createGLWindow windowName)+    (\(win, ctx) -> do+        destroyWindow win+        glDeleteContext ctx)++whileWindow :: MonadIO m => Window -> ([Event] -> m a) -> m ()+whileWindow window action = do+    let loop = do+            --liftIO (putStrLn "pollEvents")+            events <- pollEvents+            --liftIO (putStrLn "action")+            _ <- action events+            let shouldQuit = (QuitEvent `elem`) $ map eventPayload events+            unless shouldQuit loop+    loop+    destroyWindow window

@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}-module FindPackageDBs where-import Data.Maybe--import System.Directory-import System.FilePath-import System.Process-import Data.List-import Data.Char--#if !MIN_VERSION_base(4,8,0)-import Data.Traversable (traverse)-import Control.Applicative ((<$>))-#endif---- | Extract the sandbox package db directory from the cabal.sandbox.config file.---   Exception is thrown if the sandbox config file is broken.-extractKey :: String -> String -> Maybe FilePath-extractKey key conf = extractValue <$> parse conf-  where-    keyLen = length key--    parse = listToMaybe . filter (key `isPrefixOf`) . lines-    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen--- From ghc-mod-mightExist :: FilePath -> IO (Maybe FilePath)-mightExist f = do-    exists <- doesFileExist f-    return $ if exists then (Just f) else (Nothing)------------------------------------- Cabal Sandbox----------------------------- | Get path to sandbox's package DB via the cabal.sandbox.config file-getSandboxDb :: IO (Maybe FilePath)-getSandboxDb = do-    currentDir <- getCurrentDirectory-    config <- traverse readFile =<< mightExist (currentDir </> "cabal.sandbox.config")-    return $ (extractKey "package-db:" =<< config)-------------------------------------- Stack project----------------------------- | Get path to the project's snapshot and local package DBs via 'stack path'-getStackDb :: IO (Maybe [FilePath])-getStackDb = do-    exists <- doesFileExist "stack.yaml"-    if not exists-        then return Nothing-        else do-            pathInfo <- readProcess "stack" ["path"] ""-            return . Just . catMaybes $ map (flip extractKey pathInfo) ["snapshot-pkg-db:", "local-pkg-db:"]----

@@ -1,153 +0,0 @@-{-# LANGUAGE OverloadedStrings, LambdaCase #-}-module Halive where--import GHC-import Linker-import Packages-import DynFlags-import GHC.Paths-import Outputable-import Data.IORef-import Control.Monad-import Control.Concurrent-import Control.Monad.IO.Class--import System.FSNotify-import System.FilePath--import FindPackageDBs--directoryWatcher :: IO (Chan Event)-directoryWatcher = do-    let predicate event = case event of-            Modified path _ -> takeExtension path `elem` [".hs", ".vert", ".frag", ".pd"]-            _               -> False-    eventChan <- newChan-    _ <- forkIO $ withManager $ \manager -> do-        -- start a watching job (in the background)-        let watchDirectory = "."-        _stopListening <- watchTreeChan-            manager-            watchDirectory-            predicate-            eventChan-        -- Keep the watcher alive forever-        forever $ threadDelay 10000000--    return eventChan----recompiler :: FilePath -> [FilePath] -> IO ()-recompiler mainFileName importPaths' = withGHCSession mainFileName importPaths' $ do-    mainThreadId <- liftIO myThreadId--    {--    Watcher:-        Tell the main thread to recompile.-        If the main thread isn't done yet, kill it.-    Compiler:-        Wait for the signal to recompile.-        Before recompiling & running, mark that we've started,-        and after we're done running, mark that we're done.-    -}--    mainDone  <- liftIO $ newIORef False-    -- Start with a full MVar so we recompile right away.-    recompile <- liftIO $ newMVar ()--    -- Watch for changes and recompile whenever they occur-    watcher <- liftIO directoryWatcher-    _ <- liftIO . forkIO . forever $ do-        _ <- readChan watcher-        putMVar recompile ()-        mainIsDone <- readIORef mainDone-        unless mainIsDone $ killThread mainThreadId-    -    -- Start up the app-    forever $ do-        _ <- liftIO $ takeMVar recompile-        liftIO $ writeIORef mainDone False-        recompileTargets-        liftIO $ writeIORef mainDone True-        ---withGHCSession :: FilePath -> [FilePath] -> Ghc () -> IO ()-withGHCSession mainFileName extraImportPaths action = do-    defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do-        -- Add the main file's path to the import path list-        let mainFilePath   = dropFileName mainFileName-            allImportPaths = mainFilePath:extraImportPaths--        -- Get the default dynFlags-        dflags0 <- getSessionDynFlags-        -        -- If there's a sandbox, add its package DB-        dflags1 <- liftIO getSandboxDb >>= \case-            Nothing -> return dflags0-            Just sandboxDB -> do-                let pkgs = map PkgConfFile [sandboxDB]-                return dflags0 { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags0 }--        -- If this is a stack project, add its package DBs-        dflags2 <- liftIO getStackDb >>= \case-            Nothing -> return dflags1-            Just stackDBs -> do-                let pkgs = map PkgConfFile stackDBs-                return dflags1 { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags1 }--        -- Make sure we're configured for live-reload, and turn off the GHCi sandbox-        -- since it breaks OpenGL/GUI usage-        let dflags3 = dflags2 { hscTarget = HscInterpreted-                              , ghcLink   = LinkInMemory-                              , ghcMode   = CompManager-                              , importPaths = allImportPaths-                              } `gopt_unset` Opt_GhciSandbox-        -        -- We must set dynflags before calling initPackages or any other GHC API-        _ <- setSessionDynFlags dflags3--        -- Initialize the package database-        (dflags4, _) <- liftIO $ initPackages dflags3--        -- Initialize the dynamic linker-        liftIO $ initDynLinker dflags4 --        -- Set the given filename as a compilation target-        setTargets =<< sequence [guessTarget mainFileName Nothing]--        action---- Recompiles the current targets-recompileTargets :: Ghc ()-recompileTargets = handleSourceError printException $ do-    -- Get the dependencies of the main target-    graph <- depanal [] False--    -- Reload the main target-    loadSuccess <- load LoadAllTargets-    unless (failed loadSuccess) $ do-        -- We must parse and typecheck modules before they'll be available for usage-        forM_ graph (typecheckModule <=< parseModule)-        -        -- Load the dependencies of the main target-        setContext $ map (IIModule . ms_mod_name) graph--        -- Run the target file's "main" function-        rr <- runStmt "main" RunToCompletion-        case rr of-            RunOk _ -> liftIO $ putStrLn "OK"-            RunException exception -> liftIO $ print exception-            RunBreak _ _ _ -> liftIO $ putStrLn "Breakpoint"----- 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, MonadIO m) => Outputable a => a -> m ()-output a = do-    dfs <- getSessionDynFlags-    let style = defaultUserStyle-    let cntx  = initSDocContext dfs style-    liftIO $ print $ runSDoc (ppr a) cntx

@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Banner+import System.Environment+import Control.Exception+import Control.Monad+import Control.Concurrent+import Data.IORef+import Control.Concurrent.STM+import Halive.SubHalive+import Halive.Recompiler+import System.FilePath+++separateArgs :: [String] -> ([String], [String])+separateArgs args = (haliveArgs, drop 1 targetArgs)+    where (haliveArgs, targetArgs) = break (== "--") args++main :: IO ()+main = do+    (args, targetArgs) <- separateArgs <$> getArgs+    case args of+        [] -> putStrLn "Usage: halive <main.hs> <include dir> [-- <args to myapp>]"+        (mainFileName:includeDirs) -> do+            let mainFilePath = dropFileName mainFileName+            setEnv "Halive Active" "Yes"+            putStrLn banner+            withArgs targetArgs $ startRecompiler mainFileName (mainFilePath:includeDirs)++printBanner :: String -> IO ()+printBanner title = putStrLn $ ribbon ++ " " ++ title ++ " " ++ ribbon+    where ribbon = replicate 25 '*'++startRecompiler :: FilePath -> [FilePath] -> IO b+startRecompiler mainFileName includeDirs = do+    ghc <- startGHC+        (defaultGHCSessionConfig+            { gscImportPaths = includeDirs+            -- , gscCompilationMode = Compiled+            , gscCompilationMode = Interpreted+            })+    recompiler <- recompilerForExpression ghc mainFileName "main" True++    mainThreadId <- myThreadId++    newCodeTChan <- newTChanIO+    isMainRunning <- newIORef False+    _ <- forkIO $ forever $ do+        result <- atomically $ readTChan (recResultTChan recompiler)+        case result of+            Left errors -> do+                printBanner "Compilation Errors, Waiting...     "+                putStrLn (concat errors)+            Right newCode -> do+                printBanner "Compilation Success, Relaunching..."+                atomically $ writeTChan newCodeTChan newCode+                mainIsRunning <- readIORef isMainRunning+                when mainIsRunning $ killThread mainThreadId++    forever $ do+        newCode <- atomically $ readTChan newCodeTChan+        case getCompiledValue newCode of+            Just (mainFunc :: IO ()) -> do+                writeIORef isMainRunning True+                mainFunc `catch` (\x ->+                    putStrLn ("App killed: " ++ show (x :: SomeException)))+                writeIORef isMainRunning False+            Nothing -> do+                putStrLn "main was not of type IO ()"+

@@ -1,21 +0,0 @@-{-# LANGUAGE CPP #-}--import Halive-import Banner-import System.Environment-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--separateArgs :: [String] -> ([String], [String])-separateArgs args = (haliveArgs, drop 1 targetArgs)-  where (haliveArgs, targetArgs) = break (== "--") args--main :: IO ()-main = do-  (args, targetArgs) <- separateArgs <$> getArgs-  case args of-    [] -> putStrLn "Usage: halive <main.hs> <include dir> [-- <args to myapp>]"-    (mainName:includeDirs) -> do-      putStrLn banner-      withArgs targetArgs $ recompiler mainName includeDirs

@@ -1,10 +1,10 @@--- Initial halive.cabal generated by cabal init.  For further +-- Initial halive.cabal generated by cabal init.  For further -- documentation, see http://haskell.org/cabal/users-guide/  name:                halive-version:             0.1.0.7+version:             0.1.1 synopsis:            A live recompiler-description:         +description:   Live recompiler for Haskell   .   <<http://lukexi.github.io/HaliveDemo.gif>>@@ -20,7 +20,7 @@ license-file:        LICENSE author:              Luke Iannini maintainer:          lukexi@me.com--- copyright:           +-- copyright: category:            Development build-type:          Simple cabal-version:       >=1.10@@ -34,36 +34,94 @@   exposed-modules:     Halive.Utils     Halive.Concurrent+    Halive.FindPackageDBs+    Halive.SubHalive+    Halive.Recompiler+    Halive.FileListener   default-language:    Haskell2010-  ghc-options:         -Wall+  ghc-prof-options:    -Wall -O2 -fprof-auto+  ghc-options:         -Wall -O2   build-depends:-    base,+    base>=4.7 && <5,     foreign-store,-    containers-  +    containers,+    mtl,+    ghc,+    ghc-paths,+    filepath,+    fsnotify,+    process,+    transformers,+    directory,+    stm,+    time,+    signal+  if impl(ghc >= 8)+    build-depends:+      ghc-boot  executable halive-  main-is:             main.hs+  main-is:             HaliveMain.hs   hs-source-dirs:      exec   default-language:    Haskell2010-  ghc-options:         -Wall -threaded+  ghc-prof-options:    -Wall -O2 -threaded -fprof-auto+  ghc-options:         -Wall -O2 -threaded+  -- This strangely enables "-dynamic" for all dependent libraries,+  -- so I need to comment this during profiling?!?+  -- Shouldn't ghc-prof-options override it anyway? Who knows.   if !os(windows)     ghc-options:         -dynamic-  other-modules:       +  -- ^ Required on Mac due to https://ghc.haskell.org/trac/ghc/ticket/9278+  -- (does GHCi use this??)+  other-modules:     Banner-    Halive-    FindPackageDBs-  -- other-extensions:    +  -- other-extensions:   build-depends:-    base >=4.7 && <4.9,-    ghc, -    ghc-paths, -    bin-package-db,+    base,+    ghc,+    ghc-paths,     transformers,-    directory, -    filepath, +    directory,+    filepath,     fsnotify,     process,+    stm,     halive--- ^ we don't actually depend on halive, but this seems to work around a bug when running stack install:--- "Setup.hs: Error: Could not find module: Halive.Utils with any suffix: ["hi"]"++test-suite demo+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  main-is: Main.hs+  other-modules:+    Cube+    Green+    Window+    Shader+  hs-source-dirs: demo+  build-depends:+    base,+    gl,+    sdl2,+    halive,+    linear,+    foreign-store,+    random,+    text,+    bytestring,+    mtl,+    time++test-suite subhalive+  type:                exitcode-stdio-1.0+  main-is:             TestSubhalive.hs+  hs-source-dirs:      test+  ghc-options:         -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , halive+                     , mtl+                     , random+                     , containers+                     , time+                     , filepath+                     , stm+  default-language:    Haskell2010

@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++module Halive.FileListener where++import Control.Concurrent+import Control.Concurrent.STM+import qualified System.FSNotify as FSNotify+import System.FSNotify hiding (Event)+import System.Directory+import System.FilePath+import Control.Monad.Trans+import Control.Monad+import Data.Time+import Control.Exception+import Data.IORef++type FileEventChan = TChan FSNotify.Event++data ShouldReadFile = ReadFileOnEvents | JustReportEvents deriving (Eq, Show)++data FileEventListener = FileEventListener+    { felEventTChan           :: TChan (Either FSNotify.Event String)+    , felIgnoreNextEventsNear :: TVar (Maybe UTCTime)+    , felStopMVar             :: MVar ()+    }++atomicallyIO :: MonadIO m => STM a -> m a+atomicallyIO = liftIO . atomically++readTChanIO :: MonadIO m => TChan a -> m a+readTChanIO = atomicallyIO . readTChan++writeTChanIO :: MonadIO m => TChan a -> a -> m ()+writeTChanIO chan = atomicallyIO . writeTChan chan++tryReadTChanIO :: MonadIO m => TChan a -> m (Maybe a)+tryReadTChanIO = atomicallyIO . tryReadTChan++fileModifiedPredicate :: FilePath -> FSNotify.Event -> Bool+fileModifiedPredicate fileName event = case event of+    Modified path _ -> path == fileName+    _               -> False++eventListenerForFile :: (MonadIO m) => FilePath -> ShouldReadFile -> m FileEventListener+eventListenerForFile fileName shouldReadFile = liftIO $ do+    eventChan        <- newTChanIO+    ignoreEventsNear <- newTVarIO Nothing++    stopMVar <- forkEventListenerThread fileName shouldReadFile eventChan ignoreEventsNear++    return FileEventListener+        { felEventTChan = eventChan+        , felIgnoreNextEventsNear = ignoreEventsNear+        , felStopMVar = stopMVar+        }++killFileEventListener :: (MonadIO m) => FileEventListener -> m ()+killFileEventListener eventListener = liftIO $ putMVar (felStopMVar eventListener) ()++forkEventListenerThread :: FilePath+                        -> ShouldReadFile+                        -> TChan (Either FSNotify.Event String)+                        -> TVar (Maybe UTCTime)+                        -> IO (MVar ())+forkEventListenerThread fileName shouldReadFile eventChan ignoreEventsNear = do+    predicate        <- fileModifiedPredicate <$> canonicalizePath fileName+    -- If an ignore time is set, ignore file changes for the next 100 ms+    let ignoreTime = 0.1++    -- Configures debounce time for fsnotify+    let watchConfig = defaultConfig+            { confDebounce = Debounce 0.1 }+    stopMVar <- newEmptyMVar+    _ <- forkIO . withManagerConf watchConfig $ \manager -> do+        let watchDirectory = takeDirectory fileName++        stop <- watchTree manager watchDirectory predicate $ \e -> do+            print e+            mTimeToIgnore <- atomically $ readTVar ignoreEventsNear+            let timeOfEvent = eventTime e+                shouldIgnore = case mTimeToIgnore of+                    Nothing -> False+                    Just timeToIgnore -> abs (timeOfEvent `diffUTCTime` timeToIgnore) < ignoreTime+            unless shouldIgnore $ do+                if (shouldReadFile == ReadFileOnEvents)+                    then do+                        fileContents <- readFile fileName+                            `catch` (\err -> do+                                putStrLn $+                                    "Event listener failed to read " ++ fileName +++                                    ": " ++ show (err::SomeException)+                                return "")+                        let !_len = length fileContents+                        writeTChanIO eventChan (Right fileContents)+                    else writeTChanIO eventChan (Left e)++        () <- takeMVar stopMVar+        stop+    return stopMVar++setIgnoreTimeNow :: MonadIO m => FileEventListener -> m ()+setIgnoreTimeNow fileEventListener = setIgnoreTime fileEventListener =<< liftIO getCurrentTime++setIgnoreTime :: MonadIO m => FileEventListener -> UTCTime -> m ()+setIgnoreTime FileEventListener{..} time = void . liftIO . atomically $ writeTVar felIgnoreNextEventsNear (Just time)++readFileEvent :: MonadIO m => FileEventListener -> m (Either FSNotify.Event String)+readFileEvent FileEventListener{..} = readTChanIO felEventTChan++onFileEvent :: MonadIO m => FileEventListener -> m () -> m ()+onFileEvent FileEventListener{..} = onTChanRead felEventTChan++onTChanRead :: MonadIO m => TChan a -> m () -> m ()+onTChanRead eventChan action =+    tryReadTChanIO eventChan >>= \case+        Just _  -> action+        Nothing -> return ()++-- | Creates a getter for a set of resources that will be rebuilt whenever the file changes.+-- Takes a filename and an action to create a resource based on that file.+-- getWatchedResource <- makeWatchedResource "resources/shapes.frag" $ do+--        shader <- createShaderProgram "resources/shapes.vert" "resources/shapes.frag"+--        useProgram shader+--+--        uTime       <- getShaderUniform shader "uTime"+--+--        (quadVAO, quadVertCount) <- makeScreenSpaceQuad shader+--        return (quadVAO, quadVertCount, uTime)+-- Then use+-- (quadVAO, quadVertCount, uResolution, uMouse, uTime) <- getWatchedResource+-- in main loop+makeWatchedResource :: FilePath -> IO a -> IO (IO a)+makeWatchedResource fileName action = do+    absFileName <- makeAbsolute fileName+    listener <- eventListenerForFile absFileName JustReportEvents++    resourceRef <- newIORef =<< action++    -- Checks event listener, rebuilds resource if needed,+    -- then returns newest version of resource+    let getWatchedResource = do+            onFileEvent listener $ writeIORef resourceRef =<< action+            readIORef resourceRef+    return getWatchedResource

@@ -0,0 +1,78 @@++{-# LANGUAGE LambdaCase #-}+module Halive.FindPackageDBs where+import Data.Maybe++import System.Directory+import System.FilePath+import System.Process+import Data.List+import Data.Char+import Control.Monad.IO.Class++import GHC+import DynFlags++-- | Extract the sandbox package db directory from the cabal.sandbox.config file.+--   Exception is thrown if the sandbox config file is broken.+extractKey :: String -> String -> Maybe FilePath+extractKey key conf = extractValue <$> parse conf+  where+    keyLen = length key++    parse = listToMaybe . filter (key `isPrefixOf`) . lines+    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen+-- From ghc-mod+mightExist :: FilePath -> IO (Maybe FilePath)+mightExist f = do+    exists <- doesFileExist f+    return $ if exists then (Just f) else (Nothing)++addExtraPkgConfs :: DynFlags -> [FilePath] -> DynFlags+addExtraPkgConfs dflags pkgConfs = dflags +    { extraPkgConfs = +        let newPkgConfs = map PkgConfFile pkgConfs+        in (newPkgConfs ++) . extraPkgConfs dflags +    }+++------------------------+---------- Cabal Sandbox+------------------------++-- | Get path to sandbox's package DB via the cabal.sandbox.config file+getSandboxDb :: IO (Maybe FilePath)+getSandboxDb = do+    currentDir <- getCurrentDirectory+    config <- traverse readFile =<< mightExist (currentDir </> "cabal.sandbox.config")+    return $ (extractKey "package-db:" =<< config)++updateDynFlagsWithCabalSandbox :: MonadIO m => DynFlags -> m DynFlags+updateDynFlagsWithCabalSandbox dflags = +    liftIO getSandboxDb >>= \case+        Nothing -> return dflags+        Just sandboxDB -> do+            let pkgs = map PkgConfFile [sandboxDB]+            return dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags }++------------------------+---------- Stack project+------------------------++-- | Get path to the project's snapshot and local package DBs via 'stack path'+getStackDb :: IO (Maybe [FilePath])+getStackDb = do+    exists <- doesFileExist "stack.yaml"+    if not exists+        then return Nothing+        else do+            pathInfo <- readProcess "stack" ["path"] ""+            return . Just . catMaybes $ map (flip extractKey pathInfo) ["local-pkg-db:", "snapshot-pkg-db:"]++updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags+updateDynFlagsWithStackDB dflags = +    liftIO getStackDb >>= \case+        Nothing -> return dflags+        Just stackDBs -> do+            let pkgs = map PkgConfFile stackDBs+            return dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags }

@@ -0,0 +1,118 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+module Halive.Recompiler where+import Halive.SubHalive+import Halive.FileListener++import Control.Concurrent.STM+import Control.Concurrent+import Control.Monad.Trans+import Control.Monad++data CompilationRequest = CompilationRequest+    { crFilePath         :: FilePath+    , crExpressionString :: 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+++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 <- myThreadId++    initialFileLock <- liftIO newEmptyMVar++    _ <- forkIO . void . withGHCSession mainThreadID ghcSessionConfig $ do++        -- See SubHalive.hs:GHCSessionConfig+        forM_ (gscStartupFile ghcSessionConfig) $+            \(startupFile, startupExpr) ->+                recompileExpressionInFile startupFile Nothing startupExpr++        liftIO $ putMVar initialFileLock ()+        forever $ do+            CompilationRequest{..} <- readTChanIO ghcChan+            liftIO . putStrLn $ "SubHalive recompiling: "+                ++ show (crFilePath, crExpressionString)++            result <- recompileExpressionInFile+                crFilePath crFileContents crExpressionString+            writeTChanIO crResultTChan result++    () <- liftIO $ takeMVar initialFileLock++    return ghcChan+++data Recompiler = Recompiler+    { recResultTChan :: TChan CompilationResult+    , recFileEventListener :: FileEventListener+    , recListenerThread :: ThreadId+    }++recompilerForExpression :: MonadIO m+                        => TChan CompilationRequest+                        -> FilePath+                        -> String+                        -> Bool+                        -> m Recompiler+recompilerForExpression ghcChan filePath expressionString compileOnce = liftIO $ do+    resultTChan <- newTChanIO+    let compilationRequest = CompilationRequest+            { crFilePath         = filePath+            , crExpressionString = expressionString+            , crResultTChan      = resultTChan+            , crFileContents     = Nothing+            }+++    -- Compile for the first time immediately+    when compileOnce $+        writeTChanIO ghcChan compilationRequest++    -- Recompile on file event notifications+    fileEventListener <- eventListenerForFile filePath JustReportEvents+    listenerThread <- forkIO . forever $ do+        _ <- readFileEvent fileEventListener+        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 False

@@ -0,0 +1,273 @@+{-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-}+{-# 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 Packages+import Linker++import Control.Monad+import Control.Monad.IO.Class+import Data.IORef+import Data.Time+import Halive.FindPackageDBs++import Control.Concurrent+import System.Signal+import Data.Dynamic++data FixDebounce = DebounceFix | NoDebounceFix deriving Eq++data CompliationMode = Interpreted | Compiled deriving Eq++data GHCSessionConfig = GHCSessionConfig+    { gscFixDebounce        :: FixDebounce+    , gscImportPaths        :: [FilePath]+    , gscPackageDBs         :: [FilePath]+    , gscLibDir             :: FilePath+#if __GLASGOW_HASKELL__ >= 800+    , gscLanguageExtensions :: [Extension]+#else+    , gscLanguageExtensions :: [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+    }++++defaultGHCSessionConfig :: GHCSessionConfig+defaultGHCSessionConfig = GHCSessionConfig+    { gscFixDebounce = DebounceFix+    , gscImportPaths = []+    , gscPackageDBs  = []+    , gscLanguageExtensions = []+    , gscLibDir = libdir+    , gscCompilationMode = Interpreted+    , gscStartupFile = Nothing+    , gscVerbosity = 0+    }++--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++-- 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+        -- Get the default dynFlags+        dflags0 <- getSessionDynFlags+        -- Add passed-in package DBs+        let dflags1 = addExtraPkgConfs dflags0 gscPackageDBs+        -- If there's a sandbox, add its package DB+        dflags2 <- updateDynFlagsWithCabalSandbox dflags1+        -- If this is a stack project, add its package DBs+        dflags3 <- updateDynFlagsWithStackDB dflags2++        -- Make sure we're configured for live-reload+        let dflags4 = dflags3 { hscTarget   = if gscCompilationMode == Compiled then HscAsm else HscInterpreted+                              , optLevel    = if gscCompilationMode == Compiled then 2 else 0+                              , ghcLink     = LinkInMemory+                              , ghcMode     = CompManager+                              , importPaths = gscImportPaths+                              , objectDir = Just ".halive"+                              , hiDir     = Just ".halive"+                              , stubDir   = Just ".halive"+                              , dumpDir   = Just ".halive"+                              , verbosity = gscVerbosity+                              }+                              -- turn off the GHCi sandbox+                              -- since it breaks OpenGL/GUI usage+                              `gopt_unset` Opt_GhciSandbox+            -- 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...+            dflags5 = if gscFixDebounce == DebounceFix+                        then dflags4 `gopt_set` Opt_ForceRecomp+                        else dflags4+            dflags6 = foldl xopt_set dflags5 gscLanguageExtensions++        -- We must call setSessionDynFlags before calling initPackages or any other GHC API+        packageIDs <- setSessionDynFlags dflags6+++        -- Works around a yet-unidentified segfault when loading+        -- 5/1/2016: I've implemented this in a different way,+        -- (by just passing in a file to compile that will trigger+        -- loads of all its dependencies)+        -- but this is still a viable approach... not quite as convenient though!+        --let gscPreloadPackagesForModules = ["Sound.Pd"]+        --preloadPackageKeys <- forM gscPreloadPackagesForModules $ \modName ->+        --    modulePackageKey <$> findModule (mkModuleName modName) Nothing+        --let finalPackageIDs = preloadPackageKeys ++ packageIDs+        let finalPackageIDs = packageIDs+        --logIO $ "linkPackages: " ++ show (map packageKeyString finalPackageIDs)++         -- Initialize the package database and dynamic linker.+         -- Explicitly calling these avoids crashes on some of my machines.++#if __GLASGOW_HASKELL__ >= 800+        hscEnv1 <- getSession+        liftIO $ linkPackages hscEnv1 finalPackageIDs+        hscEnv2 <- getSession+        liftIO (initDynLinker hscEnv2)+#else+        dflags7 <- getSessionDynFlags+        liftIO $ linkPackages dflags7 finalPackageIDs+        dflags8 <- getSessionDynFlags+        liftIO (initDynLinker dflags8)+#endif++        action++-- See note below - this isn't actually called right now+gatherErrors :: GhcMonad m => SourceError -> m [String]+gatherErrors sourceError = do+    printException sourceError+    dflags <- getSessionDynFlags+    let errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError)+        errorStrings = map (showSDoc dflags) errorSDocs+    return errorStrings++--newtype CompiledValue = CompiledValue HValue+newtype CompiledValue = CompiledValue Dynamic deriving Show++--getCompiledValue :: CompiledValue -> a+--getCompiledValue (CompiledValue r) = unsafeCoerce r+getCompiledValue :: Typeable a => CompiledValue -> Maybe a+getCompiledValue (CompiledValue r) = fromDynamic r++fileContentsStringToBuffer :: (MonadIO m) => Maybe String -> m (Maybe (StringBuffer, UTCTime))+fileContentsStringToBuffer mFileContents = forM mFileContents $ \fileContents -> do+    now <- liftIO getCurrentTime+    return (stringToStringBuffer fileContents, now)++-- | We return the uncoerced HValue, which lets us send polymorphic values back through channels+recompileExpressionInFile :: FilePath -> Maybe String -> String -> Ghc (Either [String] CompiledValue)+recompileExpressionInFile fileName mFileContents expression =+    -- NOTE: handleSourceError doesn't actually seem to do anything, and we use+    -- the IORef + log_action solution instead. The API docs claim 'load' should+    -- throw SourceErrors but it doesn't afaict.+    catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do+        --logIO $ "Recompiling " ++ show (fileName, expression)+        -- 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+        --logIO "guessTarget"+        target <- guessTarget ('*':fileName) Nothing+        mFileContentsBuffer <- fileContentsStringToBuffer mFileContents+        --logIO "setTargets"+        setTargets [target { targetContents = mFileContentsBuffer }]++        errorsRef <- liftIO (newIORef "")+        dflags <- getSessionDynFlags+        --logIO "setSessionDynFlags"+        _ <- setSessionDynFlags dflags { log_action = logHandler errorsRef }++        -- Get the dependencies of the main target+        --logIO "depanal"+        graph <- depanal [] False++        --logIO $ "Loading " ++ show (fileName, expression)+        -- Reload the main target+        --logIO "load LoadAllTargets"+        loadSuccess <- load LoadAllTargets+        --logIO $ "Done loading " ++ show (fileName, expression)++        if failed loadSuccess+            then do+                errors <- liftIO (readIORef errorsRef)+                return (Left [errors])+            else do+                --logIO "typecheckModule"+                -- We must parse and typecheck modules before they'll be available for usage+                forM_ graph (typecheckModule <=< parseModule)++                -- Load the dependencies of the main target++                -- This brings all top-level definitions into scope (whether exported or not),+                -- but only works on interpreted modules+                --setContext (IIModule . ms_mod_name <$> graph)++                setContext (IIDecl . simpleImportDecl . ms_mod_name <$> graph)++                --logIO $ "Compiling " ++ show (fileName, expression)+                --result <- compileExpr expression+                --logIO "dynCompileExpr"+                result <- dynCompileExpr expression+                --logIO $ "Done compiling " ++ show (fileName, expression)++                return (Right (CompiledValue result))++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]))+++-- 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+    let cntx  = initSDocContext dfs style+    liftIO $ print $ runSDoc (ppr a) cntx++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+    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+    where cntx = initSDocContext dflags style+          locMsg = mkLocMessage severity srcSpan msg+          messageWithLocation = show (runSDoc locMsg cntx)+          messageOther = show (runSDoc msg cntx)

@@ -3,19 +3,34 @@ import Foreign.Store import Data.Word +import Control.Monad.State+import System.Environment++isHaliveActive :: MonadIO m => m Bool+isHaliveActive = liftIO $ do+    r <- lookupEnv "Halive Active"+    case r of+        Just "Yes" -> return True+        _          -> return False+ -- | Takes a unique integer representing your value, -- along with an IO action to create the first instance -- of your value to be used on subsequent recompilations.-reacquire :: forall a. Word32 -> IO a -> IO a+reacquire :: forall a m. (MonadIO m) => Word32 -> m a -> m a reacquire storeID create = do     -- See if an existing store exists.-    maybeStore <- lookupStore storeID :: IO (Maybe (Store a))+    maybeStore <- liftIO (lookupStore storeID) :: m (Maybe (Store a))     case maybeStore of         -- If so, return the value inside-        Just store -> readStore store+        Just store -> liftIO (readStore store)         -- Otherwise, create the value, store it, and return it.         Nothing -> do             value <- create-            writeStore (Store storeID) value+            persist storeID value             return value +persist :: MonadIO m => Word32 -> a -> m ()+persist storeID value = liftIO (writeStore (Store storeID) value)++persistState :: (MonadState s m, MonadIO m) => Word32 -> m ()+persistState storeID = persist storeID =<< get

@@ -0,0 +1,24 @@+import Halive.Recompiler+import Halive.SubHalive+import Control.Concurrent.STM+import Control.Monad++main :: IO a+main = do+    ghc <- startGHC defaultGHCSessionConfig++    fooRecompiler <- recompilerForExpression ghc "test/TestFileFoo.hs" "foo" True+    barRecompiler <- recompilerForExpression ghc "test/TestFileBar.hs" "bar" True++    forever $ do+        result <- atomically+            (readTChan (recResultTChan fooRecompiler)+            `orElse`+             readTChan (recResultTChan barRecompiler))+        case result of+            Left errors -> putStrLn (concat errors)+            Right value -> case getCompiledValue value of+                Just value -> do+                    putStrLn value+                Nothing -> do+                    putStrLn "Error: foo or bar was not of type String"