├── demo ├── Computation.hs ├── Green.hs ├── cube.frag ├── cube.vert ├── Window.hs ├── Main.hs ├── Shader.hs └── Cube.hs ├── Setup.hs ├── test ├── TestFileBar.hs ├── TestFileFoo.hs ├── unit │ ├── Spec.hs │ └── Halive │ │ └── ArgsSpec.hs ├── TestCompileExpr.hs ├── TestSubhalive.hs └── TestGHC.hs ├── testDemoWin.sh ├── stack.yaml ├── .gitignore ├── src ├── Halive.hs └── Halive │ ├── TextStringBuffer.hs │ ├── Concurrent.hs │ ├── Utils.hs │ ├── Args.hs │ ├── FindPackageDBs.hs │ ├── FileListener.hs │ ├── Recompiler.hs │ └── SubHalive.hs ├── exec ├── Banner.hs └── HaliveMain.hs ├── prepForRelease.sh ├── LICENSE ├── ChangeLog.md ├── README.md ├── halive.cabal └── Notes.txt /demo/Computation.hs: -------------------------------------------------------------------------------- 1 | main = print [1..10] -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/TestFileBar.hs: -------------------------------------------------------------------------------- 1 | module Bar where 2 | 3 | bar = "Beara" 4 | -------------------------------------------------------------------------------- /test/TestFileFoo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | foo = "Here's foo" 4 | -------------------------------------------------------------------------------- /testDemoWin.sh: -------------------------------------------------------------------------------- 1 | stack install && stack build && halive demo/Main.hs 2 | -------------------------------------------------------------------------------- /demo/Green.hs: -------------------------------------------------------------------------------- 1 | module Green where 2 | 3 | green :: Fractional a => a 4 | green = 0.7 -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | resolver: lts-13.5 5 | 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | dist 3 | *.hi 4 | *.o 5 | Main 6 | .cabal-sandbox 7 | .stack-work 8 | -------------------------------------------------------------------------------- /test/unit/Spec.hs: -------------------------------------------------------------------------------- 1 | -- preprocessor for discovering spec files 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /src/Halive.hs: -------------------------------------------------------------------------------- 1 | module Halive (module Exports) where 2 | 3 | import Halive.Recompiler as Exports 4 | import Halive.SubHalive as Exports 5 | -------------------------------------------------------------------------------- /demo/cube.frag: -------------------------------------------------------------------------------- 1 | #version 330 core 2 | 3 | in vec3 vColor; 4 | in float vID; 5 | 6 | out vec4 color; 7 | 8 | void main(void) { 9 | 10 | color = vec4( vColor * abs( sin( vID * 10. )) , 1.0 ); 11 | 12 | } -------------------------------------------------------------------------------- /demo/cube.vert: -------------------------------------------------------------------------------- 1 | #version 330 core 2 | 3 | uniform mat4 uMVP; 4 | 5 | in vec3 aVertex; 6 | in vec3 aColor; 7 | in float aID; 8 | 9 | out vec3 vColor; 10 | out float vID; 11 | 12 | void main( void ) { 13 | 14 | gl_Position = uMVP * vec4( aVertex, 1.0 ); 15 | 16 | vColor = aColor; 17 | vID = aID; 18 | 19 | } 20 | -------------------------------------------------------------------------------- /test/TestCompileExpr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Concurrent.STM 3 | import Halive 4 | 5 | main :: IO () 6 | main = do 7 | 8 | ghc <- startGHC defaultGHCSessionConfig 9 | resultChan <- compileExpression ghc 10 | "main = print 123456789" 11 | "main" 12 | result <- atomically (readTChan resultChan) 13 | putStrLn "Got result:" 14 | print result 15 | -------------------------------------------------------------------------------- /exec/Banner.hs: -------------------------------------------------------------------------------- 1 | module Banner where 2 | 3 | banner :: String 4 | banner = 5 | "██╗ ██╗ █████╗ ██╗ ██╗██╗ ██╗███████╗\n\ 6 | \██║ ██║██╔══██╗██║ ██║██║ ██║██╔════╝\n\ 7 | \███████║███████║██║ ██║██║ ██║█████╗ \n\ 8 | \██╔══██║██╔══██║██║ ██║╚██╗ ██╔╝██╔══╝ \n\ 9 | \██║ ██║██║ ██║███████╗██║ ╚████╔╝ ███████╗\n\ 10 | \╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚═╝ ╚═══╝ ╚══════╝\n\ 11 | \ engaged" 12 | -------------------------------------------------------------------------------- /prepForRelease.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | 4 | echo "Did you update the .cabal version and ChangeLog? (y/n)" 5 | read answer 6 | if [[ "$answer" != "y" ]]; then 7 | echo "Opening Changelog.md and halive.cabal..." 8 | subl ChangeLog.md 9 | subl halive.cabal 10 | exit 1 11 | fi 12 | 13 | echo "Building with 7.10..." 14 | cabal configure -w /Applications/ghc-7.10.2.app/Contents/bin/ghc 15 | cabal build 16 | echo "Building with 7.8..." 17 | cabal configure -w /Applications/ghc-7.8.4.app/Contents/bin/ghc 18 | cabal build 19 | cabal sdist 20 | 21 | echo "Restoring 7.10 config..." 22 | cabal configure -w /Applications/ghc-7.10.2.app/Contents/bin/ghc 23 | -------------------------------------------------------------------------------- /src/Halive/TextStringBuffer.hs: -------------------------------------------------------------------------------- 1 | module Halive.TextStringBuffer where 2 | 3 | import StringBuffer 4 | import Foreign.Marshal.Utils 5 | 6 | textToStringBuffer :: Text -> StringBuffer 7 | textToStringBuffer str = 8 | 9 | unsafePerformIO $ do 10 | bytes <- Text.encodeUtf8 str 11 | let size = BS.length bytes 12 | 13 | buf <- mallocForeignPtrArray (size+3) 14 | withForeignPtr buf $ \ptr -> do 15 | -- utf8EncodeString ptr str 16 | unsafeUseAsCString bytes $ \(charPtr, _) -> 17 | copyBytes ptr charPtr size 18 | pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] 19 | -- sentinels for UTF-8 decoding 20 | return (StringBuffer buf size 0) 21 | -------------------------------------------------------------------------------- /test/TestSubhalive.hs: -------------------------------------------------------------------------------- 1 | import Halive.Recompiler 2 | import Halive.SubHalive 3 | import Control.Concurrent.STM 4 | import Control.Monad 5 | 6 | main :: IO a 7 | main = do 8 | ghc <- startGHC defaultGHCSessionConfig 9 | 10 | fooRecompiler <- recompilerForExpression ghc "test/TestFileFoo.hs" "foo" 11 | barRecompiler <- recompilerForExpression ghc "test/TestFileBar.hs" "bar" 12 | 13 | forever $ do 14 | result <- atomically 15 | (readTChan (recResultTChan fooRecompiler) 16 | `orElse` 17 | readTChan (recResultTChan barRecompiler)) 18 | case result of 19 | Left errors -> putStrLn errors 20 | Right values -> forM_ values $ \value -> 21 | case getCompiledValue value of 22 | Just v -> 23 | putStrLn v 24 | Nothing -> 25 | putStrLn "Error: foo or bar was not of type String" 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Luke Iannini 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/Halive/Concurrent.hs: -------------------------------------------------------------------------------- 1 | module Halive.Concurrent ( 2 | killThreads, 3 | registerThread, 4 | forkIO', 5 | forkOS' 6 | ) where 7 | 8 | import Control.Concurrent 9 | import System.IO.Unsafe 10 | import Data.Set (Set) 11 | import qualified Data.Set as Set 12 | import Prelude hiding (mapM_) 13 | import Data.Foldable 14 | 15 | -- | A small collection of helper functions for creating threads that can be killed each time Halive re-runs your main function. 16 | -- This is helpful for programs where you control the threads, but doesn't solve the problem of libraries that use threads 17 | -- (unless you unpack them and replace all forkIO/forkOS with forkIO'/forkOS') 18 | -- It would be good to ask GHC devs about this; 19 | -- perhaps a GHC flag that registers threads similar to this module, for development use only? 20 | 21 | -- An internal global variable to hold threads that should be killed 22 | {-# NOINLINE registeredThreads #-} 23 | registeredThreads :: MVar (Set ThreadId) 24 | registeredThreads = unsafePerformIO (newMVar Set.empty) 25 | 26 | -- | Kill all threads registered to be killed. 27 | -- Meant to be called at the beginning of your program to clean up threads from the last execution before continuing 28 | killThreads :: IO () 29 | killThreads = modifyMVar_ registeredThreads $ \threadIDs -> do 30 | mapM_ killThread threadIDs 31 | return Set.empty 32 | 33 | -- | Register a thread to be killed when killThreads is called 34 | registerThread :: ThreadId -> IO () 35 | registerThread threadID = modifyMVar_ registeredThreads (return . Set.insert threadID) 36 | 37 | -- | Fork a thread and register it to be killed when killThreads is called 38 | forkIO' :: IO () -> IO ThreadId 39 | forkIO' action = do 40 | threadID <- forkIO action 41 | registerThread threadID 42 | return threadID 43 | 44 | -- | Fork an OS thread and register it to be killed when killThreads is called 45 | forkOS' :: IO () -> IO ThreadId 46 | forkOS' action = do 47 | threadID <- forkOS action 48 | registerThread threadID 49 | return threadID -------------------------------------------------------------------------------- /src/Halive/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Halive.Utils where 3 | import Foreign.Store 4 | import Data.Word 5 | 6 | import Control.Monad.State 7 | import System.Environment 8 | 9 | import Data.Map (Map) 10 | import qualified Data.Map as Map 11 | import Data.Typeable 12 | import Data.Dynamic 13 | 14 | type StoreMap = Map String Dynamic 15 | 16 | isHaliveActive :: MonadIO m => m Bool 17 | isHaliveActive = liftIO $ do 18 | r <- lookupEnv "Halive Active" 19 | case r of 20 | Just "Yes" -> return True 21 | _ -> return False 22 | 23 | -- | Takes a unique name representing your value, 24 | -- along with an IO action to create the first instance 25 | -- of your value to be used on subsequent recompilations. 26 | reacquire :: (Typeable a, MonadIO m) => String -> m a -> m a 27 | reacquire name create = do 28 | -- See if the value exists already 29 | storeMap <- getStoreMap 30 | case fromDynamic =<< Map.lookup name storeMap of 31 | -- If so, return the value inside 32 | Just value -> return value 33 | -- Otherwise, create the value, store it, and return it. 34 | Nothing -> do 35 | value <- create 36 | persist name value 37 | return value 38 | 39 | persistState :: (MonadState s m, MonadIO m, Typeable s) => String -> m () 40 | persistState name = persist name =<< get 41 | 42 | storeMapID :: Word32 43 | storeMapID = 0 44 | 45 | getStoreMap :: MonadIO m => m StoreMap 46 | getStoreMap = do 47 | -- See if we've created the storeMap already 48 | maybeStore <- liftIO (lookupStore storeMapID) 49 | case maybeStore of 50 | -- If so, return the existing storeMap inside 51 | Just store -> liftIO (readStore store) 52 | -- Otherwise, create the value, store it, and return it. 53 | Nothing -> do 54 | let storeMap = mempty 55 | writeStoreMap storeMap 56 | return storeMap 57 | 58 | modifyStoreMap :: MonadIO m => (StoreMap -> StoreMap) -> m () 59 | modifyStoreMap f = do 60 | storeMap <- getStoreMap 61 | writeStoreMap (f storeMap) 62 | 63 | writeStoreMap :: MonadIO m => StoreMap -> m () 64 | writeStoreMap = liftIO . writeStore (Store storeMapID) 65 | 66 | persist :: (Typeable a, MonadIO m) => String -> a -> m () 67 | persist name value = 68 | modifyStoreMap (Map.insert name (toDyn value)) 69 | -------------------------------------------------------------------------------- /src/Halive/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Halive.Args 4 | ( Args(..) 5 | , FileType 6 | , parseArgs 7 | , usage) where 8 | 9 | type FileType = String 10 | 11 | data Args = Args 12 | { mainFileName :: String 13 | , includeDirs :: [String] 14 | , fileTypes :: [FileType] 15 | , targetArgs :: [String] 16 | , shouldCompile :: Bool 17 | } 18 | 19 | data PartialArgs = PartialArgs 20 | { mainFileName' :: Maybe String 21 | , includeDirs' :: [String] 22 | , fileTypes' :: [FileType] 23 | , targetArgs' :: [String] 24 | , shouldCompile' :: Bool 25 | } 26 | 27 | usage :: String 28 | usage = "Usage: halive [] [-f|--file-type ] [-c|--compiled] [-- ]\n\ 29 | \\n\ 30 | \Available options:\n\ 31 | \ -f, --file-type Custom file type to watch for changes (e.g. \"-f html\")\n\ 32 | \ -c, --compiled Faster code (but slower compilation)" 33 | 34 | 35 | parseArgs :: [String] -> Maybe Args 36 | parseArgs args = go args (PartialArgs Nothing [] [] [] False) >>= fromPartial 37 | where 38 | go :: [String] -> PartialArgs -> Maybe PartialArgs 39 | go [] partial = Just partial 40 | go (x : xs) partial 41 | | x == "--" = Just partial { targetArgs' = xs } 42 | | x == "-f" || x == "--file-type" = 43 | case xs of 44 | [] -> Nothing 45 | ("--" : _) -> Nothing 46 | (fileType : xs') -> go xs' $ partial { fileTypes' = fileType : fileTypes' partial } 47 | | x == "-c" || x == "--compiled" = 48 | go xs $ partial { shouldCompile' = True } 49 | | otherwise = 50 | case mainFileName' partial of 51 | Nothing -> go xs $ partial { mainFileName' = Just x } 52 | Just _ -> go xs $ partial { includeDirs' = x : includeDirs' partial} 53 | 54 | fromPartial :: PartialArgs -> Maybe Args 55 | fromPartial PartialArgs {..} = 56 | case mainFileName' of 57 | Nothing -> Nothing 58 | Just mfn -> Just Args 59 | { mainFileName = mfn 60 | , includeDirs = includeDirs' 61 | , fileTypes = fileTypes' 62 | , targetArgs = targetArgs' 63 | , shouldCompile = shouldCompile' 64 | } 65 | 66 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for halive 2 | ## 0.1.8. -- 2021-03-26 3 | * Re-enable -dynamic to fix rogue crashes with C-linking libraries (e.g. nanovg-hs, glfw) 4 | * Add --compiled option 5 | * -c flags, fix compiling profiled 6 | * Fix CPP indentation (Manuel Bärenz) 7 | * Compatibility with sdl2-2.5.* (Manuel Bärenz) 8 | 9 | ## 0.1.7. -- 2019-03-13 10 | * Add colorized output 11 | 12 | ## 0.1.6. -- 2019-02-21 13 | * Documentation updates 14 | * O1 instead of O2 for compiled code 15 | 16 | ## 0.1.5. -- 2019-02-21 17 | * Updates for GHC 8.6 18 | * Updates for GHC 8.2 (Schell Scivally) 19 | * Add "-c/--compiled" flag for faster code (traded for slower recompilation) 20 | 21 | ## 0.1.4. -- 2017-03-23 22 | * Remove extraneous argument from compileExpression 23 | * Fix change detection for editors that delete and recreate files rather than modifying them 24 | * Ignores emacs flycheck/flymake and before-save files (Schell Scivally) 25 | * Add ability to pass just file contents rather than an actual file 26 | * Add ability to turn off language features (e.g. NoImplicitPrelude) 27 | * Add liveExpression 28 | 29 | ## 0.1.3. -- 2017-02-24 30 | * Allows Halive to be used in a nix environment (Jude Taylor) 31 | 32 | ## 0.1.2. -- 2017-01-02 33 | * Restores ability for Halive to watch surrounding files in a dir 34 | (and lays groundwork to allow configuration of which filetypes are watched) 35 | 36 | ## 0.1.1. -- 2016-12-28 37 | * GHC8 support 38 | * Windows support 39 | * Only restarts your program once all type errors are fixed. 40 | * Halive-as-a-library, aka "SubHalive" 41 | * halive exe now uses SubHalive as core. 42 | * Add persistState utility to store/restore state in a State monad, for easily preserving program state across recompilations 43 | * Prioritize stack's "local-pkg-db:" over "snapshot-pkg-db:" to allow overriding packages just as stack does 44 | * Switch to SDL for demo 45 | * Add the demo as a test-suite to manage its dependencies 46 | 47 | ## 0.1.0.7 -- 2015-08-12 48 | * Implement support for stack projects 49 | 50 | ## 0.1.0.6 -- 2015-08-07 51 | * Remove system-filepath 52 | 53 | ## 0.1.0.5 -- 2015-06-29 54 | * 7.8 compatibility fix 55 | 56 | ## 0.1.0.4 -- 2015-06-23 57 | * Add Halive.Concurrent to help with killing threads when restarting a program 58 | 59 | ## 0.1.0.2/0.1.0.3 -- 2015-06-20 60 | * Add command line argument support (Jonathan Geddes) 61 | * Fix compilation on Windows, although Halive doesn't actually work yet 62 | 63 | ## 0.1.0.1 -- 2015-05-26 64 | * Compilation fix 65 | 66 | ## 0.1.0.0 -- 2015-05-26 67 | 68 | * First version. 69 | -------------------------------------------------------------------------------- /demo/Window.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Window where 3 | 4 | 5 | import Control.Monad 6 | import SDL 7 | import Control.Monad.Trans 8 | import Control.Exception 9 | import Linear 10 | import Linear.Affine 11 | import Data.Text (Text) 12 | import Control.Lens 13 | 14 | createGLWindow :: MonadIO m => Text -> m (Window, GLContext) 15 | createGLWindow windowName = do 16 | initialize 17 | [ InitVideo 18 | , InitEvents 19 | -- , InitJoystick , InitGameController 20 | ] 21 | window <- createWindow windowName defaultWindow 22 | { windowOpenGL = Just $ defaultOpenGL 23 | { glProfile = Core Normal 4 1 24 | } 25 | , windowHighDPI = True 26 | , windowInitialSize = V2 640 480 27 | --, windowPosition = Centered 28 | , windowPosition = Absolute (P (V2 100 100)) 29 | , windowResizable = True 30 | } 31 | glContext <- glCreateContext window 32 | glMakeCurrent window glContext 33 | swapInterval $= ImmediateUpdates 34 | return (window, glContext) 35 | 36 | withWindow windowName = bracket (createGLWindow windowName) 37 | (\(win, ctx) -> do 38 | destroyWindow win 39 | glDeleteContext ctx) 40 | 41 | whileWindow :: MonadIO m => Window -> ([Event] -> m a) -> m () 42 | whileWindow window action = do 43 | let loop = do 44 | --liftIO (putStrLn "pollEvents") 45 | events <- pollEvents 46 | --liftIO (putStrLn "action") 47 | _ <- action events 48 | let shouldQuit = (QuitEvent `elem`) $ map eventPayload events 49 | unless shouldQuit loop 50 | loop 51 | destroyWindow window 52 | 53 | 54 | windowPosToWorldPos :: (Epsilon a, Real a, Floating a) 55 | => V2 a 56 | -> M44 a 57 | -> V2 a 58 | -> a 59 | -> V3 a 60 | windowPosToWorldPos winSize viewProj coord depth = rayStart + rayDir * realToFrac depth 61 | where 62 | V2 xNDC yNDC = win2Ndc coord winSize 63 | rayStart = ndc2Wld (V4 xNDC yNDC (-1.0) 1.0) 64 | rayEnd = ndc2Wld (V4 xNDC yNDC 0.0 1.0) 65 | rayDir = normalize (rayEnd ^-^ rayStart) 66 | -- Converts from window coordinates (origin top-left) to normalized device coordinates 67 | win2Ndc (V2 x y) (V2 w h) = 68 | V2 ((x / w - 0.5) * 2) 69 | ((((h - y) / h) - 0.5) * 2) 70 | -- Converts from normalized device coordinates to world coordinates 71 | ndc2Wld i = hom2Euc (invViewProj !* i) 72 | -- Converts from homogeneous coordinates to Euclidean coordinates 73 | hom2Euc v = (v ^/ (v ^. _w)) ^. _xyz 74 | invViewProj = inv44 viewProj 75 | 76 | 77 | -------------------------------------------------------------------------------- /exec/HaliveMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | #if !MIN_VERSION_base(4,8,0) 6 | import Control.Applicative 7 | #endif 8 | 9 | import Banner 10 | import System.Environment 11 | import Control.Exception 12 | import Control.Monad 13 | import Control.Concurrent 14 | import Data.IORef 15 | import Control.Concurrent.STM 16 | import Halive.SubHalive 17 | import Halive.Recompiler 18 | import Halive.Args 19 | import System.FilePath 20 | 21 | main :: IO () 22 | main = do 23 | args <- parseArgs <$> getArgs 24 | case args of 25 | Nothing -> putStrLn usage 26 | Just Args {..} -> do 27 | let mainFilePath = dropFileName mainFileName 28 | setEnv "Halive Active" "Yes" 29 | putStrLn banner 30 | withArgs targetArgs $ 31 | startRecompiler (fileTypes ++ defaultFileTypes) mainFileName 32 | (mainFilePath:includeDirs) 33 | shouldCompile 34 | 35 | defaultFileTypes :: [FileType] 36 | defaultFileTypes = ["hs", "pd", "frag", "vert"] 37 | 38 | printBanner :: String -> IO () 39 | printBanner title = putStrLn $ ribbon ++ " " ++ title ++ " " ++ ribbon 40 | where ribbon = replicate 25 '*' 41 | 42 | startRecompiler :: [FileType] -> FilePath -> [FilePath] -> Bool -> IO b 43 | startRecompiler fileTypes mainFileName includeDirs shouldCompile = do 44 | ghc <- startGHC 45 | (defaultGHCSessionConfig 46 | { gscImportPaths = includeDirs 47 | , gscCompilationMode = if shouldCompile then Compiled else Interpreted 48 | , gscUseColor = True 49 | }) 50 | 51 | recompiler <- recompilerWithConfig ghc RecompilerConfig 52 | { rccWatchAll = Just (".", fileTypes) 53 | , rccExpressions = ["main"] 54 | , rccFilePath = mainFileName 55 | } 56 | 57 | mainThreadId <- myThreadId 58 | 59 | newCodeTChan <- newTChanIO 60 | isMainRunning <- newIORef False 61 | _ <- forkIO $ forever $ do 62 | result <- atomically $ readTChan (recResultTChan recompiler) 63 | case result of 64 | Left errors -> do 65 | printBanner "Compilation Errors, Waiting... " 66 | putStrLn errors 67 | Right values -> do 68 | printBanner "Compilation Success, Relaunching..." 69 | case values of 70 | [newCode] -> do 71 | atomically $ writeTChan newCodeTChan newCode 72 | mainIsRunning <- readIORef isMainRunning 73 | when mainIsRunning $ killThread mainThreadId 74 | _ -> 75 | error "Unexpected number of values received on recResultTChan" 76 | 77 | forever $ do 78 | newCode <- atomically $ readTChan newCodeTChan 79 | case getCompiledValue newCode of 80 | Just (mainFunc :: IO ()) -> do 81 | writeIORef isMainRunning True 82 | mainFunc `catch` (\x -> 83 | putStrLn ("App killed: " ++ show (x :: SomeException))) 84 | writeIORef isMainRunning False 85 | Nothing -> do 86 | putStrLn "main was not of type IO ()" 87 | -------------------------------------------------------------------------------- /test/unit/Halive/ArgsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Halive.ArgsSpec where 6 | 7 | import Test.Hspec 8 | import Halive.Args 9 | import Data.Maybe 10 | import Data.Foldable 11 | 12 | deriving instance Show Args 13 | 14 | spec :: Spec 15 | spec = 16 | describe "Args.parseArgs" $ do 17 | 18 | describe "mainfile" $ do 19 | it "is required" $ 20 | forM_ 21 | [ "" 22 | , "-f filetype" 23 | , "-f filetype -- targetArg" 24 | , "-- targetArg" 25 | ] $ \args -> parseArgs (words args) `shouldSatisfy` isNothing 26 | 27 | it "can be parsed" $ 28 | case parseArgs (words "mainfile") of 29 | Just Args {..} -> mainFileName `shouldBe` "mainfile" 30 | 31 | describe "include dirs" $ do 32 | it "are optional" $ 33 | forM_ 34 | [ "mainfile" 35 | , "mainfile -f filetype" 36 | , "mainfile -- targetArg" 37 | ] $ \args -> case parseArgs (words args) of 38 | Just Args {..} -> includeDirs `shouldBe` [] 39 | 40 | it "can be parsed" $ 41 | forM_ 42 | [ "mainfile include1 include2" 43 | , "mainfile include1 -f filetype include2" 44 | , "mainfile include1 include2 -- targerArg" 45 | ] $ \args -> case parseArgs (words args) of 46 | Just Args {..} -> includeDirs `shouldMatchList` ["include1", "include2"] 47 | 48 | describe "file types" $ do 49 | it "are optional" $ 50 | case parseArgs (words "mainfile") of 51 | Just Args {..} -> fileTypes `shouldBe` [] 52 | 53 | it "can be specified in any position" $ 54 | case parseArgs (words "-f 1 mainfile -f 2 includedir -f 3") of 55 | Just Args {..} -> fileTypes `shouldMatchList` ["1", "2", "3"] 56 | 57 | it "can be parsed using -f" $ 58 | case parseArgs (words "mainfile -f filetype") of 59 | Just Args {..} -> fileTypes `shouldBe` ["filetype"] 60 | 61 | it "can be parsed using --file-type" $ 62 | case parseArgs (words "mainfile --file-type filetype") of 63 | Just Args {..} -> fileTypes `shouldBe` ["filetype"] 64 | 65 | it "can't be parsed when flag is misused" $ 66 | forM_ 67 | [ "mainfile -f" 68 | , "mainfile -f --" 69 | , "mainfile -f -- x" 70 | ] $ \args -> parseArgs (words args) `shouldSatisfy` isNothing 71 | 72 | describe "target args" $ do 73 | it "are optional" $ 74 | case parseArgs (words "mainfile") of 75 | Just Args {..} -> targetArgs `shouldBe` [] 76 | 77 | it "capture everything after `--`" $ 78 | case parseArgs (words "mainfile -- -f a b c") of 79 | Just Args {..} -> targetArgs `shouldBe` ["-f", "a", "b", "c"] -------------------------------------------------------------------------------- /src/Halive/FindPackageDBs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Halive.FindPackageDBs where 4 | import Data.Maybe 5 | 6 | import Control.Monad.IO.Class 7 | import Data.Char 8 | import Data.List 9 | import System.Directory 10 | import System.FilePath 11 | import System.Process 12 | import Control.Exception 13 | import DynFlags 14 | 15 | -- | Extract the sandbox package db directory from the cabal.sandbox.config file. 16 | -- Exception is thrown if the sandbox config file is broken. 17 | extractKey :: String -> String -> Maybe FilePath 18 | extractKey key conf = extractValue <$> parse conf 19 | where 20 | keyLen = length key 21 | 22 | parse = listToMaybe . filter (key `isPrefixOf`) . lines 23 | extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen 24 | -- From ghc-mod 25 | mightExist :: FilePath -> IO (Maybe FilePath) 26 | mightExist f = do 27 | exists <- doesFileExist f 28 | return $ if exists then (Just f) else (Nothing) 29 | 30 | addExtraPkgConfs :: [FilePath] -> DynFlags -> DynFlags 31 | addExtraPkgConfs pkgConfs dflags = dflags 32 | { packageDBFlags = 33 | let newPkgConfs = map (PackageDB . PkgConfFile) pkgConfs 34 | in newPkgConfs ++ packageDBFlags dflags 35 | } 36 | 37 | 38 | ------------------------ 39 | ---------- Cabal Sandbox 40 | ------------------------ 41 | 42 | -- | Get path to sandbox's package DB via the cabal.sandbox.config file 43 | getSandboxDb :: IO (Maybe FilePath) 44 | getSandboxDb = do 45 | currentDir <- getCurrentDirectory 46 | config <- traverse readFile =<< mightExist (currentDir "cabal.sandbox.config") 47 | return $ (extractKey "package-db:" =<< config) 48 | 49 | updateDynFlagsWithCabalSandbox :: MonadIO m => DynFlags -> m DynFlags 50 | updateDynFlagsWithCabalSandbox dflags = 51 | liftIO getSandboxDb >>= \case 52 | Nothing -> return dflags 53 | Just sandboxDB -> do 54 | let pkgs = map (PackageDB . PkgConfFile) [sandboxDB] 55 | return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags } 56 | 57 | ------------------------ 58 | ---------- Stack project 59 | ------------------------ 60 | 61 | -- | Get path to the project's snapshot and local package DBs via 'stack path' 62 | getStackDb :: IO (Maybe [FilePath]) 63 | getStackDb = do 64 | pathInfo <- readProcess "stack" ["path"] "" `catch` (\(_e::IOException) -> return []) 65 | return . Just . catMaybes $ map (flip extractKey pathInfo) 66 | ["global-pkg-db:", "local-pkg-db:", "snapshot-pkg-db:"] 67 | 68 | updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags 69 | updateDynFlagsWithStackDB dflags = 70 | liftIO getStackDb >>= \case 71 | Nothing -> return dflags 72 | Just stackDBs -> do 73 | let pkgs = map (PackageDB . PkgConfFile) stackDBs 74 | return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags } 75 | 76 | updateDynFlagsWithGlobalDB :: MonadIO m => DynFlags -> m DynFlags 77 | updateDynFlagsWithGlobalDB dflags = do 78 | xs <- liftIO $ lines <$> readProcess "ghc" ["--print-global-package-db"] "" 79 | `catch` (\(_e :: SomeException) -> return []) 80 | case xs of 81 | [pkgconf] -> do 82 | let flgs = PackageDB (PkgConfFile pkgconf) : packageDBFlags dflags 83 | return dflags { packageDBFlags = flgs } 84 | _ -> return dflags 85 | -------------------------------------------------------------------------------- /test/TestGHC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | import GHC.Paths 3 | import GHC 4 | import DynFlags 5 | import Linker 6 | import Control.Monad.IO.Class 7 | import Data.Time.Clock.POSIX 8 | import Data.Time 9 | import StringBuffer 10 | import Data.Dynamic 11 | import System.Directory 12 | import System.FilePath 13 | 14 | logIO :: MonadIO m => String -> m () 15 | logIO = liftIO . putStrLn 16 | 17 | withGHC :: Ghc a -> IO a 18 | withGHC action = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do 19 | 20 | packageIDs <- 21 | getSessionDynFlags 22 | >>= (\d -> pure d 23 | { ghcLink = LinkInMemory 24 | , ghcMode = CompManager 25 | , hscTarget = HscAsm 26 | , optLevel = 2 27 | , verbosity = 0 28 | }) 29 | -- turn off the GHCi sandbox 30 | -- since it breaks OpenGL/GUI usage 31 | >>= (pure . (`gopt_unset` Opt_GhciSandbox)) 32 | >>= (pure . (if dynamicGhc then addWay' WayDyn else id)) 33 | -- We must call setSessionDynFlags before calling initPackages or any other GHC API 34 | >>= setSessionDynFlags 35 | 36 | getSession >>= \hscEnv -> 37 | liftIO $ linkPackages hscEnv packageIDs 38 | liftIO . initDynLinker =<< getSession 39 | 40 | action 41 | 42 | fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime) 43 | fileContentsStringToBuffer fileContents = do 44 | now <- liftIO getCurrentTime 45 | return (stringToStringBuffer fileContents, now) 46 | 47 | ourFile :: String 48 | ourFile = unlines 49 | [ "main = print $ 123456789" 50 | ] 51 | 52 | main :: IO () 53 | main = withGHC $ do 54 | logIO "" 55 | logIO "Starting..." 56 | 57 | let expression = "main" 58 | fileContents <- fileContentsStringToBuffer ourFile 59 | 60 | -- Set the target 61 | 62 | -- Create a dummy temporary file to sate GHC's desires for one, 63 | -- even though we're passing it the text as a buffer. 64 | tempDir <- liftIO $ getTemporaryDirectory 65 | now <- show . diffTimeToPicoseconds . realToFrac <$> liftIO getPOSIXTime 66 | let tempFile = tempDir "halive_" ++ now <.> "hs" 67 | liftIO $ writeFile tempFile "" 68 | 69 | target <- guessTarget tempFile Nothing 70 | 71 | logIO "Setting targets..." 72 | setTargets [target { targetContents = Just fileContents }] 73 | 74 | -- logIO "Dep analysis..." 75 | -- graph <- depanal [mkModuleName "Main"] False 76 | 77 | -- Reload the main target 78 | logIO "Loading..." 79 | -- setContext $ [ IIModule . mkModuleName $ "Main" ] 80 | loadSuccess <- load LoadAllTargets 81 | 82 | if succeeded loadSuccess 83 | then do 84 | 85 | logIO "Analyzing deps..." 86 | -- Get the dependencies of the main target (and update the session with them) 87 | graph <- depanal [] False 88 | -- -- We must parse and typecheck modules before they'll be available for usage 89 | -- forM_ graph (typecheckModule <=< parseModule) 90 | 91 | #if __GLASGOW_HASKELL__ >= 804 92 | let modSummaries = mgModSummaries graph 93 | #else 94 | let modSummaries = graph 95 | #endif 96 | 97 | -- Load the dependencies of the main target 98 | setContext 99 | (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries) 100 | 101 | -- Compile the expression and return the result 102 | result <- dynCompileExpr expression 103 | 104 | case fromDynamic result of 105 | Just a -> liftIO (a :: IO ()) 106 | Nothing -> return () 107 | -- liftIO (print result) 108 | else do 109 | return () 110 | 111 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | ██╗ ██╗ █████╗ ██╗ ██╗██╗ ██╗███████╗ 3 | ██║ ██║██╔══██╗██║ ██║██║ ██║██╔════╝ 4 | ███████║███████║██║ ██║██║ ██║█████╗ 5 | ██╔══██║██╔══██║██║ ██║╚██╗ ██╔╝██╔══╝ 6 | ██║ ██║██║ ██║███████╗██║ ╚████╔╝ ███████╗ 7 | ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚═╝ ╚═══╝ ╚══════╝ 8 | ``` 9 | Live recompiler for Haskell 10 | 11 | ![Halive Demo](http://lukexi.github.io/HaliveDemo.gif) 12 | 13 | Halive uses the GHC API to instantly recompile 14 | and reload your code any time you change it. 15 | 16 | Usage: 17 | `stack install halive` 18 | 19 | and then 20 | 21 | `halive ` 22 | 23 | Any time you change a file in the current directory or its subdirectories, 24 | halive will recompile and rerun the `main` function in the file you gave it. 25 | 26 | If the program is long-running (e.g. a daemon, GUI or game loop) it will be 27 | killed and restarted. Learn how to maintain state in the next section. 28 | 29 | Try a live-coding GL demo by running: 30 | ``` 31 | # Grab the demo package and install the demo's dependencies - only need to do this once 32 | stack unpack halive 33 | cd halive-0.1.5 34 | stack build --test --no-run-tests 35 | 36 | # Now run Halive 37 | halive demo/Main.hs 38 | ``` 39 | Changing values in `Main.hs` or `Green.hs` and saving should live-update the program. 40 | 41 | Keeping values alive 42 | -------------------- 43 | 44 | To keep state alive, import `Halive.Utils` and wrap 45 | your value in `reacquire` along with a unique identifier, like: 46 | 47 | `win <- reacquire "win" (setupGLFW "HotGLFW" 640 480)` 48 | 49 | to only create the resource the first time you run the program, and then 50 | reuse it on subsequent recompilations. 51 | 52 | You can see this in action in `demo/Main.hs`. 53 | 54 | Thanks to Chris Done's 55 | [`foreign-store`](https://hackage.haskell.org/package/foreign-store) 56 | library for enabling this. 57 | 58 | Watch custom file types for changes 59 | ----------------------------------- 60 | 61 | By default, Halive will reload your code when files with the following extensions change: `hs`, `pd`, `frag`, `vert`. 62 | 63 | If you have any other file type that you'd like to be watched by Halive, use the `-f`/`--file-type` option. 64 | 65 | `halive app/Main.hs -f html -f hamlet` 66 | 67 | Passing command-line arguments 68 | ------------------------------ 69 | 70 | To use Halive with haskell code that is expecting command-line arguments, 71 | separate the arguments to Halive and the arguments to the app with a `--` 72 | such as: 73 | 74 | `halive -- ` 75 | 76 | Compiled Code 77 | ------------- 78 | You can pass `--compiled` (or `-c`) to Halive to compile to faster object code. 79 | 80 | This will be slower to recompile but faster to run. 81 | 82 | Notes 83 | ----- 84 | 85 | Creating, updating, and deleting modules in the include path should 86 | work fine during a Halive session. 87 | 88 | Halive supports Stack projects and Cabal sandboxes; 89 | if run within a directory containing a stack.yaml or cabal.sandbox.config 90 | file it will use the appropriate package databases when running the target. 91 | 92 | Halive works nicely with either batch-processing or run-loop type 93 | programs — if the program finishes, it will be restarted on next save, 94 | and if it's still running, it will be killed and restarted on save. 95 | 96 | To kill Halive during run-loop type programs, you may need to hold down Ctrl-C 97 | to get GHC to recognize the double-Control-C-kill sequence. 98 | 99 | Halive works on Windows, Mac, and Linux 100 | 101 | As a Library 102 | ------------ 103 | Halive can also be integrated into your own project as a library in a few lines of code. See `test/TestSubHalive.hs` for an example. 104 | IMPORTANT: You must link your binary with `ghc-options: -dynamic` for this to work! Otherwise you'll get mysterious linking errors on Mac and Linux. 105 | 106 | Troubleshooting 107 | --------------- 108 | If Halive with GLFW segfaults on windows, try `git clone -b win-halive-fix http://github.com/lukexi/bindings-GLFW` and adding the folder you cloned it to to your project's `stack.yaml` in the `packages` section 109 | 110 | [@lukexi](http://twitter.com/lukexi) 111 | -------------------------------------------------------------------------------- /demo/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Concurrent 3 | import Graphics.GL 4 | import Linear 5 | import System.Random 6 | import Data.Time 7 | import Control.Monad 8 | import Control.Monad.State 9 | import Data.Bits 10 | import Text.Show.Pretty 11 | import Data.Maybe 12 | 13 | import Halive.Utils 14 | import Cube 15 | import Shader 16 | import Window 17 | 18 | import SDL hiding (get) 19 | import qualified SDL as SDL 20 | 21 | 22 | import qualified Green as Green -- Try changing the green amount 23 | -- while the program is running 24 | 25 | main :: IO () 26 | main = do 27 | putStrLn "MAIN BEGIN" 28 | -- error "DANG!" -- It's ok if your program crashes, it shouldn't crash Halive 29 | 30 | -- Wrap any persistent state in 'reacquire' plus a unique asset ID. 31 | -- Reacquire uses foreign-store to only run your setup function once, 32 | -- and then return it again on subsequent recompilations. 33 | -- In this case, GLFW doesn't like being initialized more than once 34 | -- per process, so this solves the problem handily. 35 | -- (Our window stays persistent as well thanks to this, 36 | -- so it would probably be a good idea anyway!) 37 | 38 | (win, _ctx) <- reacquire "win" $ createGLWindow "Hot SDL" 39 | 40 | -- You can change the window title here. 41 | --GLFW.setWindowTitle win "Hot Swap!" 42 | 43 | -- Changing the shaders' contents will trigger Halive as well! 44 | program <- createShaderProgram "demo/cube.vert" "demo/cube.frag" 45 | cube <- makeCube program 46 | 47 | -- Any GL state will stick around, so be aware of that. 48 | glEnable GL_DEPTH_TEST 49 | 50 | -- Sometimes it's useful to know if we're running under Halive or not 51 | putStrLn . ("Running under Halive: " ++ ) . show =<< isHaliveActive 52 | 53 | -- Reacquire our state from the last run, if any - otherwise create a new state 54 | initialState <- reacquire "state" (return ([]::[V3 GLfloat])) 55 | void . flip runStateT initialState . whileWindow win $ \events -> do 56 | -- Store our state persistently in a named slot 57 | persistState "state" 58 | 59 | 60 | 61 | -- Try turning on a stream of events 62 | -- unless (null events) $ 63 | -- liftIO $ pPrint events 64 | 65 | winSize@(V2 w h) <- fmap realToFrac <$> SDL.get (SDL.windowSize win) 66 | now <- realToFrac . utctDayTime <$> liftIO getCurrentTime 67 | -- print now -- Try turning on a stream of now logs 68 | let redFreq = 0.6 * pi -- Try changing the red and blue frequencies. 69 | red = sin (now * redFreq) 70 | blueFreq = 0.5 * pi 71 | blue = sin (now * blueFreq) 72 | --putStrLn "glClearColor" 73 | glClearColor red 0.3 blue 1 74 | --putStrLn "glClear" 75 | glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT) 76 | -- Render our scene 77 | --putStrLn "getWinSize" 78 | 79 | let projection = perspective 45 (w / h) 0.01 1000 80 | model = mkTransformation (axisAngle (V3 0 1 1) now) (V3 (sin now) 0 (-4)) 81 | view = lookAt (V3 0 2 5) (V3 0 0 (-4)) (V3 0 1 0) 82 | projView = projection !*! view 83 | mvp = projView !*! model 84 | 85 | --putStrLn "renderCube" 86 | renderCube cube mvp 87 | 88 | -- Accumulate mouse drags as cube trails 89 | forM_ (catMaybes $ map matchMouse events) $ \cursorPos -> do 90 | isMouseDown <- SDL.getMouseButtons 91 | when (isMouseDown ButtonLeft) $ do 92 | let worldPos = windowPosToWorldPos winSize projView cursorPos 20 93 | modify' ((worldPos :) . take 40) 94 | 95 | positions <- get 96 | forM_ positions $ \cursorPos -> do 97 | let model = mkTransformation (axisAngle (V3 0 1 1) now) cursorPos 98 | mvp = projView !*! model 99 | renderCube cube mvp 100 | --putStrLn "glSwapWindow" 101 | SDL.glSwapWindow win 102 | 103 | 104 | matchMouse Event 105 | { eventPayload = 106 | MouseMotionEvent 107 | MouseMotionEventData 108 | { mouseMotionEventWhich = Mouse 0 109 | , mouseMotionEventPos = P pos 110 | } 111 | } 112 | = Just (fromIntegral <$> pos) 113 | matchMouse _ 114 | = Nothing 115 | -------------------------------------------------------------------------------- /demo/Shader.hs: -------------------------------------------------------------------------------- 1 | module Shader where 2 | 3 | import Graphics.GL 4 | 5 | import Control.Monad 6 | import Control.Monad.Trans 7 | import Foreign 8 | 9 | import Foreign.C.String 10 | 11 | import qualified Data.ByteString as BS 12 | import qualified Data.Text.Encoding as Text 13 | import qualified Data.Text.IO as Text 14 | 15 | import Linear 16 | import Data.Foldable 17 | 18 | newtype GLProgram = GLProgram { unGLProgram :: GLuint } 19 | 20 | newtype AttributeLocation = AttributeLocation { unAttributeLocation :: GLint } 21 | newtype UniformLocation = UniformLocation { unUniformLocation :: GLint } 22 | 23 | overPtr :: (MonadIO m, Storable a) => (Ptr a -> IO b) -> m a 24 | overPtr f = liftIO (alloca (\p -> f p >> peek p)) 25 | 26 | 27 | useProgram :: MonadIO m => GLProgram -> m () 28 | useProgram (GLProgram program) = glUseProgram (fromIntegral program) 29 | 30 | uniformM44 :: UniformLocation -> M44 GLfloat -> IO () 31 | uniformM44 uniform matrix = do 32 | let mvpUniformLoc = fromIntegral (unUniformLocation uniform) 33 | withArray (concatMap toList (transpose matrix)) (\matrixPtr -> 34 | glUniformMatrix4fv mvpUniformLoc 1 GL_FALSE matrixPtr) 35 | 36 | --------------- 37 | -- Load shaders 38 | --------------- 39 | 40 | createShaderProgram :: FilePath -> FilePath -> IO GLProgram 41 | createShaderProgram vertexShaderPath fragmentShaderPath = 42 | 43 | do vertexShader <- glCreateShader GL_VERTEX_SHADER 44 | compileShader vertexShaderPath vertexShader 45 | fragmentShader <- glCreateShader GL_FRAGMENT_SHADER 46 | compileShader fragmentShaderPath fragmentShader 47 | shaderProg <- glCreateProgram 48 | glAttachShader shaderProg vertexShader 49 | glAttachShader shaderProg fragmentShader 50 | glLinkProgram shaderProg 51 | linked <- overPtr (glGetProgramiv shaderProg GL_LINK_STATUS) 52 | when (linked == fromIntegral GL_FALSE) 53 | (do maxLength <- overPtr (glGetProgramiv shaderProg GL_INFO_LOG_LENGTH) 54 | logLines <- allocaArray 55 | (fromIntegral maxLength) 56 | (\p -> 57 | alloca (\lenP -> 58 | do glGetProgramInfoLog shaderProg maxLength lenP p 59 | len <- peek lenP 60 | peekCStringLen (p,fromIntegral len))) 61 | putStrLn logLines) 62 | return (GLProgram shaderProg) 63 | where compileShader path shader = 64 | do src <- Text.readFile path 65 | BS.useAsCString 66 | (Text.encodeUtf8 src) 67 | (\ptr -> 68 | withArray [ptr] 69 | (\srcs -> 70 | glShaderSource shader 1 srcs nullPtr)) 71 | glCompileShader shader 72 | when True 73 | (do maxLength <- overPtr (glGetShaderiv shader GL_INFO_LOG_LENGTH) 74 | logLines <- allocaArray 75 | (fromIntegral maxLength) 76 | (\p -> 77 | alloca (\lenP -> 78 | do glGetShaderInfoLog shader maxLength lenP p 79 | len <- peek lenP 80 | peekCStringLen (p,fromIntegral len))) 81 | when (length logLines > 0) 82 | (do putStrLn ("In " ++ path ++ ":") 83 | putStrLn logLines) 84 | ) 85 | 86 | 87 | getShaderAttribute :: GLProgram -> String -> IO AttributeLocation 88 | getShaderAttribute (GLProgram prog) attributeName = do 89 | location <- withCString attributeName $ \attributeNameCString -> 90 | glGetAttribLocation prog attributeNameCString 91 | when (location == -1) $ error $ "Coudn't bind attribute: " ++ attributeName 92 | return (AttributeLocation location) 93 | 94 | getShaderUniform :: GLProgram -> String -> IO UniformLocation 95 | getShaderUniform (GLProgram prog) uniformName = do 96 | location <- withCString uniformName $ \uniformNameCString -> 97 | glGetUniformLocation prog uniformNameCString 98 | when (location == -1) $ error $ "Coudn't bind uniform: " ++ uniformName 99 | return (UniformLocation location) 100 | 101 | glGetErrors :: IO () 102 | glGetErrors = do 103 | code <- glGetError 104 | case code of 105 | GL_NO_ERROR -> return () 106 | e -> do 107 | case e of 108 | GL_INVALID_ENUM -> putStrLn "* Invalid Enum" 109 | GL_INVALID_VALUE -> putStrLn "* Invalid Value" 110 | GL_INVALID_OPERATION -> putStrLn "* Invalid Operation" 111 | GL_INVALID_FRAMEBUFFER_OPERATION -> putStrLn "* Invalid Framebuffer Operation" 112 | GL_OUT_OF_MEMORY -> putStrLn "* OOM" 113 | GL_STACK_UNDERFLOW -> putStrLn "* Stack underflow" 114 | GL_STACK_OVERFLOW -> putStrLn "* Stack overflow" 115 | _ -> return () 116 | glGetErrors 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /halive.cabal: -------------------------------------------------------------------------------- 1 | name: halive 2 | version: 0.1.8 3 | synopsis: A live recompiler 4 | description: 5 | Live recompiler for Haskell 6 | . 7 | <> 8 | . 9 | /Usage:/ 10 | . 11 | > halive path/to/myfile.hs [optionally any/extra include/dirs ..] [-f|--file-type additional file type] [-c|--compiled] -- [args to app] 12 | . 13 | Available options: 14 | . 15 | @-f, --file-type @ - Custom file type to watch for changes (e.g. @-f html@) 16 | @-c, --compiled@ - Use faster compiled code at the expense of recompilation speed 17 | . 18 | See 19 | homepage: https://github.com/lukexi/halive 20 | bug-reports: https://github.com/lukexi/halive/issues 21 | license: BSD2 22 | license-file: LICENSE 23 | author: Luke Iannini 24 | maintainer: lukexi@me.com 25 | -- copyright: 26 | category: Development 27 | build-type: Simple 28 | cabal-version: >=1.10 29 | 30 | source-repository head 31 | type: git 32 | location: git://github.com/lukexi/halive.git 33 | 34 | library 35 | hs-source-dirs: src 36 | exposed-modules: 37 | Halive 38 | Halive.Args 39 | Halive.Utils 40 | Halive.Concurrent 41 | Halive.FindPackageDBs 42 | Halive.SubHalive 43 | Halive.Recompiler 44 | Halive.FileListener 45 | default-language: Haskell2010 46 | -- ghc-prof-options: -Wall -fprof-auto 47 | ghc-options: -Wall -optP-Wno-nonportable-include-path 48 | build-depends: 49 | base >=4.7 && <5 50 | , foreign-store 51 | , containers 52 | , mtl 53 | , ghc 54 | , ghc-paths 55 | , filepath 56 | , fsnotify 57 | , process 58 | , transformers 59 | , directory 60 | , stm 61 | , time 62 | , signal 63 | , text 64 | if impl(ghc >= 8) 65 | build-depends: 66 | ghc-boot 67 | 68 | executable halive 69 | main-is: HaliveMain.hs 70 | hs-source-dirs: exec 71 | default-language: Haskell2010 72 | ghc-prof-options: -static -Wall -threaded -fprof-auto 73 | ghc-options: -dynamic -Wall -threaded -optP-Wno-nonportable-include-path 74 | -- This strangely enables "-dynamic" for all dependent libraries, 75 | -- so I need to comment this during profiling?!? 76 | -- Shouldn't ghc-prof-options override it anyway? Who knows. 77 | -- if !os(windows) 78 | -- ghc-options: -dynamic 79 | -- This overrides -dynamic when building for profiling, 80 | -- probably breaking the executable but at least it lets us build 81 | -- halive as a dependency. 82 | -- ghc-prof-options: -static 83 | -- ^ Required on Mac due to https://ghc.haskell.org/trac/ghc/ticket/9278 84 | -- (does GHCi use this??) 85 | other-modules: 86 | Banner 87 | -- other-extensions: 88 | build-depends: 89 | base 90 | , ghc 91 | , ghc-paths 92 | , transformers 93 | , directory 94 | , filepath 95 | , fsnotify 96 | , process 97 | , stm 98 | , halive 99 | 100 | 101 | test-suite unit 102 | type: exitcode-stdio-1.0 103 | default-language: Haskell2010 104 | main-is: Spec.hs 105 | hs-source-dirs: test/unit 106 | other-modules: 107 | Halive.ArgsSpec 108 | build-depends: 109 | base 110 | , halive 111 | , hspec 112 | 113 | test-suite demo 114 | type: exitcode-stdio-1.0 115 | default-language: Haskell2010 116 | main-is: Main.hs 117 | other-modules: 118 | Cube 119 | Green 120 | Window 121 | Shader 122 | hs-source-dirs: demo 123 | build-depends: 124 | base, 125 | gl, 126 | sdl2, 127 | halive, 128 | linear, 129 | foreign-store, 130 | random, 131 | text, 132 | bytestring, 133 | mtl, 134 | time, 135 | lens, 136 | pretty-show 137 | 138 | test-suite subhalive 139 | type: exitcode-stdio-1.0 140 | main-is: TestSubhalive.hs 141 | hs-source-dirs: test 142 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -dynamic 143 | build-depends: base 144 | , halive 145 | , mtl 146 | , random 147 | , containers 148 | , time 149 | , filepath 150 | , stm 151 | default-language: Haskell2010 152 | 153 | test-suite compileexpr 154 | type: exitcode-stdio-1.0 155 | main-is: TestCompileExpr.hs 156 | hs-source-dirs: test 157 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -dynamic 158 | build-depends: base 159 | , halive 160 | , mtl 161 | , random 162 | , containers 163 | , time 164 | , filepath 165 | , stm 166 | default-language: Haskell2010 167 | 168 | 169 | test-suite testghc 170 | type: exitcode-stdio-1.0 171 | main-is: TestGHC.hs 172 | hs-source-dirs: test 173 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 174 | build-depends: base 175 | , time 176 | , filepath 177 | , ghc 178 | , ghc-paths 179 | , directory 180 | default-language: Haskell2010 181 | 182 | -------------------------------------------------------------------------------- /Notes.txt: -------------------------------------------------------------------------------- 1 | BUGS: 2 | [ ] demo/Main.hs segfaults on subsequent compilations when evaluating Green.green. 3 | 4 | http://hackage.haskell.org/package/optparse-generic 5 | 6 | TODO: 7 | [ ] Should be able to use SubHalive to slim down Halive.hs even further by 8 | using a SubHalive thread, printing exceptions, and running successful HValues 9 | as IO () actions on the main thread (rather than using runStmt) 10 | 11 | [ ] New async typechecking context would form a nice basis for a runtime query system 12 | (run over TCP, with Halive passing the port via an environment variable to Halive.Utils) 13 | 14 | [ ] Think if -fdefer-type-errors gives us anything interesting 15 | 16 | [ ] Flag handling update: 17 | The three below would be subsumed by just using the parseStaticFlags/parseDynamicFlags 18 | functions to set up DynFlags, and then parsing out the included paths from there. That way we 19 | act nearly identically to 'ghc'/'ghci'/'runhaskell'. 20 | 21 | [ ] Add -Wall support 22 | https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc/DynFlags.html#t:Settings 23 | 24 | [ ] Add general GHC flag support, which should be easy enough 25 | 26 | [ ] Watch all included path trees rather than the current directory. 27 | 28 | [ ] Create a dotfile for configuration (as an alternative to command line arguments) 29 | 30 | [ ] Bug: halive crashes if multiple files are saved/added at once 31 | 32 | [ ] Sort-of-bug: some editors do a delete/replace instead of a modify on files, so we don't see the change. Only watching for modify makes sense since creations and deletions can't affect running code until something is modified, and watching for them might unnecessarily halt your program while you're working on creating a file. So possibly make this optional. 33 | 34 | 35 | 36 | [ ] Improve Control-C handling 37 | http://neilmitchell.blogspot.fr/2015/05/handling-control-c-in-haskell.html 38 | http://stackoverflow.com/questions/2349233/catching-control-c-exception-in-ghc-haskell 39 | 40 | [ ] Try integrating different debugging workflows. 41 | putStrLn/trace debugging is already a lot nicer with Halive since you can 42 | toggle them on and off while the program is running. Expand on this 43 | to begin subsuming some of the functionality of a typical debugger, 44 | except with just plain old code. 45 | E.g., a breakpoint can just be an STM transaction that 'retry's 46 | on a global boolean TVar when it's false 47 | Re-add a REPL that can be used to query program information. 48 | Add tools to place and record state history into global variables that can be 49 | queried by the REPL. 50 | Be sure to compare these with ekg, GHC's eventlog. 51 | 52 | [ ] Check if we need foreign-store at all; it seems like global MVars would do the trick just as well. 53 | (note: I think I tried this and MVars are in fact cleared upon recompilations) 54 | 55 | [ ] Can fix Halive breaking with .o files present 56 | http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile 57 | target <- guessTarget "*Test.hs" Nothing 58 | addTarget target 59 | 60 | DONE 61 | [x] Async typechecking, and only restarting programs when they typecheck 62 | 63 | [x] Figure out how to make Halive work on windows 64 | 65 | [x] Add helpers for restarting user threads 66 | http://stackoverflow.com/questions/24999636/is-there-a-way-to-kill-all-forked-threads-in-a-ghci-session-without-restarting-i 67 | 68 | [x] Add program command line argument support. 69 | I'm guessing that programs run under Halive will currently get Halive's own command line args. 70 | We could use the -- convention to separate halive arguments from program arguments, 71 | and call withArgs before running the program's "main". 72 | 73 | Once we've got this, we should be able to live edit Halive's source with Halive which should 74 | be a fun demo. 75 | (done thanks to Jonathan Geddes @jargv !) 76 | 77 | [x] Configurable watched filetypes (with flags) 78 | 79 | NOTES: 80 | 81 | I couldn't make halive as a library due to an oddity with 82 | ghc @rpaths suddently not resolving. 83 | 84 | Should you base things off the code, be aware that executables 85 | must be built with the -dynamic flag for ghc or else strange errors 86 | may occur when interfacing with external libraries like CoreFoundation 87 | (GHCi uses this flag for its executable as well). 88 | 89 | 90 | 91 | 92 | Tried to generate the Hackage description with: 93 | pandoc -f markdown_github -t haddock README.md 94 | but it didn't seem to be quite the right format. Punted to redirecting to github for now. 95 | 96 | 97 | Reference links: 98 | 99 | GHC API Tutorial 100 | http://www.covariant.me/notes/ghcapi.html 101 | 102 | Thomas Schilling - The "new" GHC API 103 | http://sneezy.cs.nott.ac.uk/fplunch/weblog/wp-content/uploads/2008/12/ghc-api-slidesnotes.pdf 104 | 105 | https://wiki.haskell.org/GHC/As_a_library 106 | 107 | https://parenz.wordpress.com/2013/08/17/ghc-api-interpreted-compiled-and-package-modules/ 108 | 109 | https://parenz.wordpress.com/2013/07/29/ghc-packagedb/ 110 | 111 | 112 | "How to reload module that package has linked in memory?" by Andy Stewart 113 | https://mail.haskell.org/pipermail/haskell-cafe/2010-December/087684.html 114 | 115 | "Dynamically loading and unloading (C) object files" by Edsko de Vries 116 | Talks about using linkObj and unlinkObj to compile and load C code into a running program. 117 | https://mail.haskell.org/pipermail/ghc-devs/2013-November/003170.html 118 | 119 | 120 | http://bluishcoder.co.nz/2008/11/25/dynamic-compilation-and-loading-of.html 121 | 122 | 123 | See if these help with Windows 124 | "Loading of shared libraries is problematic in ghc 7.10.1" 125 | https://ghc.haskell.org/trac/ghc/ticket/10442 126 | 127 | "Need option to use system gcc and binutils on Windows/msys2" 128 | https://ghc.haskell.org/trac/ghc/ticket/9101 129 | 130 | 131 | 132 | -- Works around a yet-unidentified segfault when loading 133 | -- 5/1/2016: I've implemented this in a different way, 134 | -- (by just passing in a file to compile that will trigger 135 | -- loads of all its dependencies) 136 | -- but this is still a viable approach... not quite as convenient though! 137 | --let gscPreloadPackagesForModules = ["Sound.Pd"] 138 | --preloadPackageKeys <- forM gscPreloadPackagesForModules $ \modName -> 139 | -- modulePackageKey <$> findModule (mkModuleName modName) Nothing 140 | --let finalPackageIDs = preloadPackageKeys ++ packageIDs 141 | 142 | 143 | -- This brings all top-level definitions into scope (whether exported or not), 144 | -- but only works on interpreted modules 145 | --setContext (IIModule . ms_mod_name <$> graph) 146 | 147 | -- Use GHC.dynamicGhc to detect dynamicity of executable and respond appropriately or error out 148 | https://github.com/mvdan/hint/pull/18/files 149 | -------------------------------------------------------------------------------- /demo/Cube.hs: -------------------------------------------------------------------------------- 1 | module Cube where 2 | 3 | import Graphics.GL 4 | import Foreign 5 | import Linear 6 | import Data.Foldable 7 | import Shader 8 | import Control.Monad.Trans 9 | 10 | newtype VertexArrayObject = VertexArrayObject { unVertexArrayObject :: GLuint } 11 | 12 | data Cube = Cube 13 | { cubeVAO :: VertexArrayObject 14 | , cubeShader :: GLProgram 15 | , cubeIndexCount :: GLsizei 16 | , cubeUniformMVP :: UniformLocation 17 | } 18 | 19 | ---------------------------------------------------------- 20 | -- Make Cube 21 | ---------------------------------------------------------- 22 | 23 | renderCube :: MonadIO m => Cube -> M44 GLfloat -> m () 24 | renderCube cube mvp = do 25 | 26 | useProgram (cubeShader cube) 27 | 28 | let mvpUniformLoc = fromIntegral (unUniformLocation (cubeUniformMVP cube)) 29 | 30 | liftIO $ withArray (concatMap toList (transpose mvp)) (\mvpPointer -> 31 | glUniformMatrix4fv mvpUniformLoc 1 GL_FALSE mvpPointer) 32 | 33 | glBindVertexArray (unVertexArrayObject (cubeVAO cube)) 34 | 35 | glDrawElements GL_TRIANGLES (cubeIndexCount cube) GL_UNSIGNED_INT nullPtr 36 | 37 | glBindVertexArray 0 38 | 39 | 40 | makeCube :: GLProgram -> IO Cube 41 | makeCube program = do 42 | 43 | aVertex <- getShaderAttribute program "aVertex" 44 | aColor <- getShaderAttribute program "aColor" 45 | aID <- getShaderAttribute program "aID" 46 | uMVP <- getShaderUniform program "uMVP" 47 | 48 | -- Setup a VAO 49 | vaoCube <- overPtr (glGenVertexArrays 1) 50 | 51 | glBindVertexArray vaoCube 52 | 53 | 54 | ----------------- 55 | -- Cube Positions 56 | ----------------- 57 | 58 | -- Buffer the cube vertices 59 | let cubeVertices = 60 | --- front 61 | [ -1.0 , -1.0 , 1.0 62 | , 1.0 , -1.0 , 1.0 63 | , 1.0 , 1.0 , 1.0 64 | , -1.0 , 1.0 , 1.0 65 | 66 | --- back 67 | , -1.0 , -1.0 , -1.0 68 | , 1.0 , -1.0 , -1.0 69 | , 1.0 , 1.0 , -1.0 70 | , -1.0 , 1.0 , -1.0 ] :: [GLfloat] 71 | 72 | 73 | 74 | vaoCubeVertices <- overPtr (glGenBuffers 1) 75 | 76 | glBindBuffer GL_ARRAY_BUFFER vaoCubeVertices 77 | 78 | let cubeVerticesSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeVertices) 79 | 80 | withArray cubeVertices $ 81 | \cubeVerticesPtr -> 82 | glBufferData GL_ARRAY_BUFFER cubeVerticesSize (castPtr cubeVerticesPtr) GL_STATIC_DRAW 83 | 84 | -- Describe our vertices array to OpenGL 85 | glEnableVertexAttribArray (fromIntegral (unAttributeLocation aVertex)) 86 | 87 | glVertexAttribPointer 88 | (fromIntegral (unAttributeLocation aVertex)) -- attribute 89 | 3 -- number of elements per vertex, here (x,y,z) 90 | GL_FLOAT -- the type of each element 91 | GL_FALSE -- don't normalize 92 | 0 -- no extra data between each position 93 | nullPtr -- offset of first element 94 | 95 | -------------- 96 | -- Cube Colors 97 | -------------- 98 | 99 | -- Buffer the cube colors 100 | let cubeColors = 101 | -- front colors 102 | [ 1.0, 0.0, 0.0 103 | , 0.0, 1.0, 0.0 104 | , 0.0, 0.0, 1.0 105 | , 1.0, 1.0, 1.0 106 | -- back colors 107 | , 1.0, 0.0, 0.0 108 | , 0.0, 1.0, 0.0 109 | , 0.0, 0.0, 1.0 110 | , 1.0, 1.0, 1.0 ] :: [GLfloat] 111 | 112 | vboCubeColors <- overPtr (glGenBuffers 1) 113 | 114 | glBindBuffer GL_ARRAY_BUFFER vboCubeColors 115 | 116 | 117 | let cubeColorsSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeColors) 118 | withArray cubeColors $ 119 | \cubeColorsPtr -> 120 | glBufferData GL_ARRAY_BUFFER cubeColorsSize (castPtr cubeColorsPtr) GL_STATIC_DRAW 121 | 122 | 123 | glEnableVertexAttribArray (fromIntegral (unAttributeLocation aColor)) 124 | 125 | glVertexAttribPointer 126 | (fromIntegral (unAttributeLocation aColor)) -- attribute 127 | 3 -- number of elements per vertex, here (R,G,B) 128 | GL_FLOAT -- the type of each element 129 | GL_FALSE -- don't normalize 130 | 0 -- no extra data between each position 131 | nullPtr -- offset of first element 132 | 133 | ----------- 134 | -- Cube IDs 135 | ----------- 136 | 137 | -- Buffer the cube ids 138 | let cubeIDs = 139 | [ 0 140 | , 1 141 | , 2 142 | , 3 143 | , 4 144 | , 5 ] :: [GLfloat] 145 | 146 | vboCubeIDs <- overPtr (glGenBuffers 1) 147 | 148 | glBindBuffer GL_ARRAY_BUFFER vboCubeIDs 149 | 150 | let cubeIDsSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeIDs) 151 | 152 | withArray cubeIDs $ 153 | \cubeIDsPtr -> 154 | glBufferData GL_ARRAY_BUFFER cubeIDsSize (castPtr cubeIDsPtr) GL_STATIC_DRAW 155 | 156 | 157 | glEnableVertexAttribArray (fromIntegral (unAttributeLocation aID)) 158 | 159 | glVertexAttribPointer 160 | (fromIntegral (unAttributeLocation aID)) -- attribute 161 | 1 -- number of elements per vertex, here (R,G,B) 162 | GL_FLOAT -- the type of each element 163 | GL_FALSE -- don't normalize 164 | 0 -- no extra data between each position 165 | nullPtr -- offset of first element 166 | 167 | 168 | 169 | ---------------- 170 | -- Cube Indicies 171 | ---------------- 172 | 173 | -- Buffer the cube indices 174 | let cubeIndices = 175 | -- front 176 | [ 0, 1, 2 177 | , 2, 3, 0 178 | -- top 179 | , 1, 5, 6 180 | , 6, 2, 1 181 | -- back 182 | , 7, 6, 5 183 | , 5, 4, 7 184 | -- bottom 185 | , 4, 0, 3 186 | , 3, 7, 4 187 | -- left 188 | , 4, 5, 1 189 | , 1, 0, 4 190 | -- right 191 | , 3, 2, 6 192 | , 6, 7, 3 ] :: [GLuint] 193 | 194 | iboCubeElements <- overPtr (glGenBuffers 1) 195 | 196 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER iboCubeElements 197 | 198 | let cubeElementsSize = fromIntegral (sizeOf (undefined :: GLuint) * length cubeIndices) 199 | 200 | withArray cubeIndices $ 201 | \cubeIndicesPtr -> 202 | glBufferData GL_ELEMENT_ARRAY_BUFFER cubeElementsSize (castPtr cubeIndicesPtr) GL_STATIC_DRAW 203 | 204 | glBindVertexArray 0 205 | 206 | return $ Cube 207 | { cubeVAO = VertexArrayObject vaoCube 208 | , cubeShader = program 209 | , cubeIndexCount = fromIntegral (length cubeIndices) 210 | , cubeUniformMVP = uMVP 211 | } 212 | 213 | 214 | -------------------------------------------------------------------------------- /src/Halive/FileListener.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Halive.FileListener where 6 | 7 | import Control.Concurrent 8 | import Control.Concurrent.STM 9 | import Control.Exception 10 | import Control.Monad 11 | import Control.Monad.Trans 12 | import Data.IORef 13 | import Data.List (isInfixOf) 14 | import Data.Time 15 | import System.Directory 16 | import System.FilePath 17 | import System.FSNotify hiding (Event) 18 | import qualified System.FSNotify as FSNotify 19 | 20 | type FileEventChan = TChan FSNotify.Event 21 | 22 | data ShouldReadFile = ReadFileOnEvents | JustReportEvents deriving (Eq, Show) 23 | 24 | data FileEventListener = FileEventListener 25 | { felEventTChan :: TChan (Either FSNotify.Event String) 26 | , felIgnoreNextEventsNear :: TVar (Maybe UTCTime) 27 | , felStopMVar :: MVar () 28 | } 29 | 30 | atomicallyIO :: MonadIO m => STM a -> m a 31 | atomicallyIO = liftIO . atomically 32 | 33 | readTChanIO :: MonadIO m => TChan a -> m a 34 | readTChanIO = atomicallyIO . readTChan 35 | 36 | writeTChanIO :: MonadIO m => TChan a -> a -> m () 37 | writeTChanIO chan = atomicallyIO . writeTChan chan 38 | 39 | tryReadTChanIO :: MonadIO m => TChan a -> m (Maybe a) 40 | tryReadTChanIO = atomicallyIO . tryReadTChan 41 | 42 | peekTChanIO :: MonadIO m => TChan a -> m a 43 | peekTChanIO = atomicallyIO . peekTChan 44 | 45 | exhaustTChan :: TChan a -> STM [a] 46 | exhaustTChan chan = unfoldM (tryReadTChan chan) 47 | 48 | exhaustTChanIO :: MonadIO m => TChan a -> m [a] 49 | exhaustTChanIO = atomicallyIO . exhaustTChan 50 | 51 | -- A version of exhaustTChan that blocks until there is something to read 52 | waitExhaustTChan :: TChan a -> STM [a] 53 | waitExhaustTChan chan = peekTChan chan >> exhaustTChan chan 54 | 55 | waitExhaustTChanIO :: MonadIO m => TChan a -> m [a] 56 | waitExhaustTChanIO = atomicallyIO . waitExhaustTChan 57 | 58 | -- | Take a monadic stream returning Maybes and 59 | -- pull a list from it until it returns Nothing 60 | unfoldM :: Monad m => m (Maybe a) -> m [a] 61 | unfoldM f = f >>= \case 62 | Just a -> (a:) <$> unfoldM f 63 | Nothing -> return [] 64 | 65 | fileModifiedPredicate :: FilePath -> FSNotify.Event -> Bool 66 | fileModifiedPredicate fileName event = case event of 67 | Modified path _ _ -> path == fileName 68 | Added path _ _ -> path == fileName 69 | _ -> False 70 | 71 | -- Returns True if the event filepath is a common editor file 72 | isACommonEditorFile :: FSNotify.Event -> Bool 73 | isACommonEditorFile event = case event of 74 | Modified path _ _ -> any (`isInfixOf` path) emacsFragments 75 | _ -> False 76 | where emacsFragments = ["#", "flymake", "flycheck"] 77 | 78 | eventListenerForFile :: MonadIO m => FilePath -> ShouldReadFile -> m FileEventListener 79 | eventListenerForFile fileName shouldReadFile = liftIO $ do 80 | eventChan <- newTChanIO 81 | ignoreEventsNear <- newTVarIO Nothing 82 | 83 | stopMVar <- forkFileListenerThread fileName shouldReadFile eventChan ignoreEventsNear 84 | 85 | return FileEventListener 86 | { felEventTChan = eventChan 87 | , felIgnoreNextEventsNear = ignoreEventsNear 88 | , felStopMVar = stopMVar 89 | } 90 | 91 | eventListenerForDirectory :: MonadIO m => FilePath -> [String] -> m FileEventListener 92 | eventListenerForDirectory watchDirectory fileTypes = liftIO $ do 93 | eventChan <- newTChanIO 94 | ignoreEventsNear <- newTVarIO Nothing 95 | 96 | stopMVar <- forkDirectoryListenerThread watchDirectory fileTypes eventChan 97 | 98 | return FileEventListener 99 | { felEventTChan = eventChan 100 | , felIgnoreNextEventsNear = ignoreEventsNear 101 | , felStopMVar = stopMVar 102 | } 103 | 104 | killFileEventListener :: MonadIO m => FileEventListener -> m () 105 | killFileEventListener eventListener = liftIO $ putMVar (felStopMVar eventListener) () 106 | 107 | -- Pass a list like ["hs", "pd", "frag", "vert"] to match only those filetypes, 108 | -- or an empty list to match all 109 | modifiedWithExtensionPredicate :: [String] -> FSNotify.Event -> Bool 110 | modifiedWithExtensionPredicate fileTypes event = case event of 111 | Modified path _ _ -> null fileTypes || drop 1 (takeExtension path) `elem` fileTypes 112 | _ -> False 113 | 114 | forkDirectoryListenerThread :: FilePath 115 | -> [String] 116 | -> TChan (Either FSNotify.Event String) 117 | -> IO (MVar ()) 118 | forkDirectoryListenerThread watchDirectory fileTypes eventChan = do 119 | let predicate e = modifiedWithExtensionPredicate fileTypes e 120 | && not (isACommonEditorFile e) 121 | 122 | -- Configures debounce time for fsnotify 123 | let watchConfig = defaultConfig 124 | { confDebounce = Debounce 0.1 } 125 | stopMVar <- newEmptyMVar 126 | _ <- forkIO . withManagerConf watchConfig $ \manager -> do 127 | 128 | stop <- watchTree manager watchDirectory predicate $ \e -> 129 | writeTChanIO eventChan (Left e) 130 | () <- takeMVar stopMVar 131 | stop 132 | return stopMVar 133 | 134 | forkFileListenerThread :: FilePath 135 | -> ShouldReadFile 136 | -> TChan (Either FSNotify.Event String) 137 | -> TVar (Maybe UTCTime) 138 | -> IO (MVar ()) 139 | forkFileListenerThread fileName shouldReadFile eventChan ignoreEventsNear = do 140 | leftPredicate <- fileModifiedPredicate <$> canonicalizePath fileName 141 | let predicate e = leftPredicate e && not (isACommonEditorFile e) 142 | -- If an ignore time is set, ignore file changes for the next 100 ms 143 | ignoreTime = 0.1 144 | -- Configures debounce time for fsnotify 145 | watchConfig = defaultConfig 146 | { confDebounce = Debounce 0.1 } 147 | 148 | stopMVar <- newEmptyMVar 149 | _ <- forkIO . withManagerConf watchConfig $ \manager -> do 150 | let watchDirectory = takeDirectory fileName 151 | 152 | stop <- watchTree manager watchDirectory predicate $ \e -> do 153 | mTimeToIgnore <- atomically $ readTVar ignoreEventsNear 154 | let timeOfEvent = eventTime e 155 | shouldIgnore = case mTimeToIgnore of 156 | Nothing -> False 157 | Just timeToIgnore -> abs (timeOfEvent `diffUTCTime` timeToIgnore) < ignoreTime 158 | unless shouldIgnore $ do 159 | if (shouldReadFile == ReadFileOnEvents) 160 | then do 161 | fileContents <- readFile fileName 162 | `catch` (\err -> do 163 | putStrLn $ 164 | "Event listener failed to read " ++ fileName ++ 165 | ": " ++ show (err::SomeException) 166 | return "") 167 | let !_len = length fileContents 168 | writeTChanIO eventChan (Right fileContents) 169 | else writeTChanIO eventChan (Left e) 170 | 171 | () <- takeMVar stopMVar 172 | stop 173 | return stopMVar 174 | 175 | setIgnoreTimeNow :: MonadIO m => FileEventListener -> m () 176 | setIgnoreTimeNow fileEventListener = setIgnoreTime fileEventListener =<< liftIO getCurrentTime 177 | 178 | setIgnoreTime :: MonadIO m => FileEventListener -> UTCTime -> m () 179 | setIgnoreTime FileEventListener{..} time = void . liftIO . atomically $ writeTVar felIgnoreNextEventsNear (Just time) 180 | 181 | readFileEvent :: MonadIO m => FileEventListener -> m (Either FSNotify.Event String) 182 | readFileEvent FileEventListener{..} = readTChanIO felEventTChan 183 | 184 | onFileEvent :: MonadIO m => FileEventListener -> m () -> m () 185 | onFileEvent FileEventListener{..} = onTChanRead felEventTChan 186 | 187 | onTChanRead :: MonadIO m => TChan a -> m () -> m () 188 | onTChanRead eventChan action = 189 | tryReadTChanIO eventChan >>= \case 190 | Just _ -> action 191 | Nothing -> return () 192 | 193 | -- | Creates a getter for a set of resources that will be rebuilt whenever the file changes. 194 | -- Takes a filename and an action to create a resource based on that file. 195 | -- getWatchedResource <- makeWatchedResource "resources/shapes.frag" $ do 196 | -- shader <- createShaderProgram "resources/shapes.vert" "resources/shapes.frag" 197 | -- useProgram shader 198 | -- 199 | -- uTime <- getShaderUniform shader "uTime" 200 | -- 201 | -- (quadVAO, quadVertCount) <- makeScreenSpaceQuad shader 202 | -- return (quadVAO, quadVertCount, uTime) 203 | -- Then use 204 | -- (quadVAO, quadVertCount, uResolution, uMouse, uTime) <- getWatchedResource 205 | -- in main loop 206 | makeWatchedResource :: FilePath -> IO a -> IO (IO a) 207 | makeWatchedResource fileName action = do 208 | absFileName <- makeAbsolute fileName 209 | listener <- eventListenerForFile absFileName JustReportEvents 210 | 211 | resourceRef <- newIORef =<< action 212 | 213 | -- Checks event listener, rebuilds resource if needed, 214 | -- then returns newest version of resource 215 | let getWatchedResource = do 216 | onFileEvent listener $ writeIORef resourceRef =<< action 217 | readIORef resourceRef 218 | return getWatchedResource 219 | -------------------------------------------------------------------------------- /src/Halive/Recompiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Halive.Recompiler where 4 | import Halive.SubHalive 5 | import Halive.FileListener 6 | import System.Mem 7 | import Control.Concurrent.STM 8 | import Control.Concurrent 9 | import Control.Monad.Trans 10 | import Control.Monad 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | import Data.IORef 14 | import Data.Typeable 15 | import GHC 16 | data CompilationRequest = CompilationRequest 17 | { crFilePath :: FilePath 18 | , crExpressionStrings :: [String] 19 | , crResultTChan :: TChan CompilationResult 20 | , crFileContents :: Maybe String 21 | -- ^ This is intentionally lazy, since we want to evaluate the string on 22 | -- the SubHalive thread (as it may be e.g. a TextSeq that needs conversion) 23 | -- In the future, we may want to pass GHC's StringBuffer type here instead, 24 | -- and construct those in a smarter way. 25 | } 26 | 27 | type CompilationResult = Either String [CompiledValue] 28 | 29 | -- This is used to implement a workaround for the GHC API crashing 30 | -- when used after application startup, when it tries to load libraries 31 | -- for the first time. By wrapping main in withGHC, startGHC will block until 32 | -- the GHC API is initialized before allowing the application to start. 33 | withGHC :: MonadIO m 34 | => GHCSessionConfig 35 | -> (TChan CompilationRequest -> m b) 36 | -> m b 37 | withGHC ghcSessionConfig action = do 38 | ghcChan <- startGHC ghcSessionConfig 39 | action ghcChan 40 | 41 | startGHCDefault :: MonadIO m => m (TChan CompilationRequest) 42 | startGHCDefault = startGHC defaultGHCSessionConfig 43 | 44 | startGHC :: MonadIO m => GHCSessionConfig -> m (TChan CompilationRequest) 45 | startGHC ghcSessionConfig = liftIO $ do 46 | ghcChan <- newTChanIO 47 | 48 | -- Grab this thread's ID (need to run this on the main thread, of course) 49 | mainThreadID <- case gscMainThreadID ghcSessionConfig of 50 | Just threadID -> return threadID 51 | Nothing -> myThreadId 52 | 53 | initialFileLock <- liftIO newEmptyMVar 54 | _ <- forkIO . void $ do 55 | 56 | case gscKeepLibsInMemory ghcSessionConfig of 57 | 58 | -- In this mode we keep the ghc session alive continuously, 59 | -- and process all compilation requests in it. 60 | -- This trades possibly high memory usage for very fast compilation, 61 | -- since libraries don't have to be loaded in repeatedly. 62 | Always -> do 63 | 64 | -- See SubHalive.hs:GHCSessionConfig 65 | withGHCSession mainThreadID ghcSessionConfig $ do 66 | compileInitialFile ghcSessionConfig 67 | liftIO $ putMVar initialFileLock () 68 | 69 | forever $ do 70 | CompilationRequest{..} <- readTChanIO ghcChan 71 | 72 | result <- recompileExpressionsInFile 73 | crFilePath crFileContents crExpressionStrings 74 | writeTChanIO crResultTChan result 75 | 76 | -- In this mode we create a fresh GHC session for each set of compilation 77 | -- requests. This trades slower compilations for lower memory usage 78 | -- when not compiling. 79 | Opportunistic -> do 80 | withGHCSession mainThreadID ghcSessionConfig $ 81 | compileInitialFile ghcSessionConfig 82 | liftIO $ putMVar initialFileLock () 83 | 84 | forever $ do 85 | requests <- waitExhaustTChanIO ghcChan 86 | 87 | withGHCSession mainThreadID ghcSessionConfig $ 88 | forM_ requests $ \CompilationRequest{..} -> do 89 | result <- recompileExpressionsInFile 90 | crFilePath crFileContents crExpressionStrings 91 | writeTChanIO crResultTChan result 92 | liftIO performGC 93 | 94 | -- Wait for the initial file to complete 95 | () <- liftIO (takeMVar initialFileLock) 96 | 97 | return ghcChan 98 | 99 | compileInitialFile :: GHCSessionConfig -> Ghc () 100 | compileInitialFile ghcSessionConfig = 101 | forM_ (gscStartupFile ghcSessionConfig) $ 102 | \(startupFile, startupExpr) -> 103 | recompileExpressionsInFile startupFile Nothing [startupExpr] 104 | 105 | data Recompiler = Recompiler 106 | { recResultTChan :: TChan CompilationResult 107 | , recFileEventListener :: FileEventListener 108 | , recListenerThread :: ThreadId 109 | } 110 | 111 | recompilerForExpression :: MonadIO m 112 | => TChan CompilationRequest 113 | -> FilePath 114 | -> String 115 | -> m Recompiler 116 | recompilerForExpression ghcChan filePath expressionString = 117 | recompilerWithConfig ghcChan RecompilerConfig 118 | { rccWatchAll = Nothing 119 | , rccExpressions = [expressionString] 120 | , rccFilePath = filePath 121 | } 122 | 123 | data RecompilerConfig = RecompilerConfig 124 | { rccWatchAll :: Maybe (FilePath, [String]) -- if Nothing, just watch given file 125 | , rccExpressions :: [String] 126 | , rccFilePath :: FilePath 127 | } 128 | 129 | recompilerWithConfig :: MonadIO m 130 | => TChan CompilationRequest 131 | -> RecompilerConfig 132 | -> m Recompiler 133 | recompilerWithConfig ghcChan RecompilerConfig{..} = liftIO $ do 134 | resultTChan <- newTChanIO 135 | let compilationRequest = CompilationRequest 136 | { crFilePath = rccFilePath 137 | , crExpressionStrings = rccExpressions 138 | , crResultTChan = resultTChan 139 | , crFileContents = Nothing 140 | } 141 | 142 | -- Recompile on file event notifications 143 | fileEventListener <- case rccWatchAll of 144 | Nothing -> eventListenerForFile rccFilePath JustReportEvents 145 | Just (watchDir, fileTypes) -> eventListenerForDirectory watchDir fileTypes 146 | listenerThread <- forkIO . forever $ do 147 | _ <- readFileEvent fileEventListener 148 | writeTChanIO ghcChan compilationRequest 149 | 150 | -- Compile for the first time immediately 151 | writeTChanIO ghcChan compilationRequest 152 | 153 | return Recompiler 154 | { recResultTChan = resultTChan 155 | , recFileEventListener = fileEventListener 156 | , recListenerThread = listenerThread 157 | } 158 | 159 | killRecompiler :: MonadIO m => Recompiler -> m () 160 | killRecompiler recompiler = do 161 | liftIO $ killThread (recListenerThread recompiler) 162 | 163 | renameRecompilerForExpression :: MonadIO m => Recompiler 164 | -> TChan CompilationRequest 165 | -> FilePath 166 | -> String 167 | -> m Recompiler 168 | renameRecompilerForExpression recompiler ghcChan filePath expressionString = do 169 | killRecompiler recompiler 170 | recompilerForExpression ghcChan filePath expressionString 171 | 172 | compileExpressions :: MonadIO m 173 | => TChan CompilationRequest 174 | -> Text 175 | -> [String] 176 | -> m (TChan CompilationResult) 177 | compileExpressions ghcChan code expressionStrings = do 178 | resultTChan <- liftIO newTChanIO 179 | liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest 180 | { crFilePath = "" 181 | , crExpressionStrings = expressionStrings 182 | , crResultTChan = resultTChan 183 | , crFileContents = Just $ Text.unpack code 184 | } 185 | return resultTChan 186 | 187 | compileExpression :: MonadIO m 188 | => TChan CompilationRequest 189 | -> Text 190 | -> String 191 | -> m (TChan CompilationResult) 192 | compileExpression ghcChan code expressionString = 193 | compileExpressions ghcChan code [expressionString] 194 | 195 | compileExpressionInFile :: MonadIO m 196 | => TChan CompilationRequest 197 | -> FilePath 198 | -> String 199 | -> m (TChan CompilationResult) 200 | compileExpressionInFile ghcChan fileName expressionString = do 201 | resultTChan <- liftIO newTChanIO 202 | liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest 203 | { crFilePath = fileName 204 | , crExpressionStrings = [expressionString] 205 | , crResultTChan = resultTChan 206 | , crFileContents = Nothing 207 | } 208 | return resultTChan 209 | 210 | -- | liveExpression returns an action to get to the latest version of the expression, 211 | -- updating it whenever the code changes (unless there is an error). 212 | -- It also takes a default argument to use until the first compilation completes. 213 | -- The action is meant to be called before each use of the value. 214 | liveExpression :: Typeable a 215 | => TChan CompilationRequest 216 | -> FilePath 217 | -> String 218 | -> a 219 | -> IO (IO a) 220 | liveExpression ghcChan fileName expression defaultVal = do 221 | recompiler <- recompilerForExpression ghcChan fileName expression 222 | valueRef <- newIORef defaultVal 223 | _ <- forkIO . forever $ do 224 | result <- atomically (readTChan (recResultTChan recompiler)) 225 | case result of 226 | Left errors -> putStrLn errors 227 | Right values -> 228 | case values of 229 | [value] -> 230 | case getCompiledValue value of 231 | Just newVal -> writeIORef valueRef newVal 232 | Nothing -> putStrLn ("Got incorrect type for " ++ fileName ++ ":" ++ expression) 233 | _ -> 234 | error "Unexpected number of values received on recResultTChan" 235 | 236 | return (readIORef valueRef) 237 | -------------------------------------------------------------------------------- /src/Halive/SubHalive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE CPP #-} 7 | module Halive.SubHalive ( 8 | module Halive.SubHalive 9 | #if __GLASGOW_HASKELL__ >= 800 10 | , module GHC.LanguageExtensions 11 | #else 12 | , ExtensionFlag(..) 13 | #endif 14 | 15 | ) where 16 | 17 | import GHC 18 | #if __GLASGOW_HASKELL__ >= 800 19 | import GHC.LanguageExtensions 20 | #else 21 | import Module 22 | #endif 23 | import DynFlags 24 | import Exception 25 | import ErrUtils 26 | import HscTypes 27 | import GHC.Paths 28 | import Outputable 29 | import StringBuffer 30 | import PprColour 31 | import qualified Util 32 | 33 | -- import Packages 34 | import Linker 35 | 36 | #if __GLASGOW_HASKELL__ < 800 37 | import Control.Monad 38 | #endif 39 | import Control.Monad.IO.Class 40 | import Data.IORef 41 | import Data.Time 42 | import Halive.FindPackageDBs 43 | 44 | import Control.Concurrent 45 | import System.Signal 46 | import Data.Dynamic 47 | 48 | import System.Directory 49 | import System.FilePath 50 | import Data.Time.Clock.POSIX 51 | 52 | import qualified Data.Text as Text 53 | 54 | data FixDebounce = DebounceFix | NoDebounceFix deriving Eq 55 | 56 | data CompliationMode = Interpreted | Compiled deriving Eq 57 | 58 | data KeepLibsInMemory = Always | Opportunistic 59 | 60 | data GHCSessionConfig = GHCSessionConfig 61 | { gscFixDebounce :: FixDebounce 62 | , gscImportPaths :: [FilePath] 63 | , gscPackageDBs :: [FilePath] 64 | , gscLibDir :: FilePath 65 | #if __GLASGOW_HASKELL__ >= 800 66 | , gscLanguageExtensions :: [Extension] 67 | , gscNoLanguageExtensions :: [Extension] 68 | #else 69 | , gscLanguageExtensions :: [ExtensionFlag] 70 | , gscNoLanguageExtensions :: [ExtensionFlag] 71 | #endif 72 | , gscCompilationMode :: CompliationMode 73 | , gscStartupFile :: Maybe (FilePath, String) 74 | -- ^ Allow API users to block until a given file is compiled, 75 | -- to work around a bug where the GHC API crashes while 76 | -- loading libraries if the main thread is doing work 77 | -- (possibly due to accessing said libraries in some way) 78 | , gscVerbosity :: Int 79 | , gscMainThreadID :: Maybe ThreadId 80 | , gscKeepLibsInMemory :: KeepLibsInMemory 81 | -- ^ Chooses between keeping the GHC session alive continuously 82 | -- (which uses a lot of memory but makes compilation fast) 83 | -- or disposing of it between compilations 84 | -- (which saves memory but slows compilation) 85 | -- or keeping it around for sequences of compilations 86 | -- (which lies in-between these) 87 | , gscUseColor :: Bool 88 | } 89 | 90 | defaultGHCSessionConfig :: GHCSessionConfig 91 | defaultGHCSessionConfig = GHCSessionConfig 92 | { gscFixDebounce = DebounceFix 93 | , gscImportPaths = [] 94 | , gscPackageDBs = [] 95 | , gscLanguageExtensions = [] 96 | , gscNoLanguageExtensions = [] 97 | , gscLibDir = libdir 98 | , gscCompilationMode = Interpreted 99 | , gscStartupFile = Nothing 100 | , gscVerbosity = 0 101 | , gscMainThreadID = Nothing 102 | , gscKeepLibsInMemory = Always 103 | , gscUseColor = False 104 | } 105 | 106 | -- Starts up a GHC session and then runs the given action within it 107 | withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a 108 | withGHCSession mainThreadID GHCSessionConfig{..} action = do 109 | -- Work around https://ghc.haskell.org/trac/ghc/ticket/4162 110 | let restoreControlC f = do 111 | liftIO $ installHandler sigINT 112 | (\_signal -> killThread mainThreadID) 113 | f 114 | 115 | -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do 116 | runGhc (Just gscLibDir) . restoreControlC $ do 117 | 118 | -- initialFlags <- getSessionDynFlags 119 | -- (newFlags, leftovers, warnings) <- parseDynamicFlagsCmdLine initialFlags [noLoc "-prof"] 120 | -- setSessionDynFlags newFlags 121 | -- liftIO $ print (compilerInfo newFlags) 122 | 123 | packageIDs <- 124 | getSessionDynFlags 125 | >>= updateDynFlagsWithGlobalDB 126 | -- If this is a stack project, add its package DBs 127 | >>= updateDynFlagsWithStackDB 128 | -- If there's a sandbox, add its package DB 129 | >>= updateDynFlagsWithCabalSandbox 130 | -- Add passed-in package DBs 131 | >>= (pure . addExtraPkgConfs gscPackageDBs) 132 | -- Make sure we're configured for live-reload 133 | >>= (\d -> pure d 134 | { hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted 135 | , optLevel = if gscCompilationMode == Compiled then 1 else 0 136 | , ghcLink = LinkInMemory 137 | , ghcMode = CompManager 138 | , importPaths = gscImportPaths 139 | , objectDir = Just ".halive" 140 | , hiDir = Just ".halive" 141 | , stubDir = Just ".halive" 142 | , dumpDir = Just ".halive" 143 | , verbosity = gscVerbosity 144 | , useColor = if gscUseColor then Util.Always else Util.Never 145 | , canUseColor = gscUseColor 146 | , colScheme = defaultScheme 147 | }) 148 | >>= (pure . (`gopt_set` Opt_DiagnosticsShowCaret)) 149 | -- turn off the GHCi sandbox 150 | -- since it breaks OpenGL/GUI usage 151 | >>= (pure . (`gopt_unset` Opt_GhciSandbox)) 152 | -- Allows us to work in dynamic executables 153 | -- >>= (pure . (if dynamicGhc then addWay' WayDyn else id)) 154 | -- >>= (pure . (addWay' WayProf)) 155 | -- >>= (pure . (if rtsIsProfiled then addWay' WayProf else id)) 156 | -- >>= (pure . (addWay' WayDyn)) 157 | -- GHC seems to try to "debounce" compilations within 158 | -- about a half second (i.e., it won't recompile) 159 | -- This fixes that, but probably isn't quite what we want 160 | -- since it will cause extra files to be recompiled... 161 | >>= (pure . (if gscFixDebounce == DebounceFix 162 | then (`gopt_set` Opt_ForceRecomp) 163 | else id)) 164 | >>= (pure . flip (foldl xopt_unset) gscNoLanguageExtensions 165 | . flip (foldl xopt_set) gscLanguageExtensions) 166 | -- We must call setSessionDynFlags before calling initPackages or any other GHC API 167 | >>= setSessionDynFlags 168 | 169 | -- Initialize the package database and dynamic linker. 170 | -- Explicitly calling these avoids crashes on some of my machines. 171 | #if __GLASGOW_HASKELL__ >= 800 172 | -- (dflags,_pkgs) <- liftIO . initPackages =<< getSessionDynFlags 173 | -- setSessionDynFlags dflags 174 | 175 | getSession >>= \hscEnv -> 176 | liftIO $ linkPackages hscEnv packageIDs 177 | liftIO . initDynLinker =<< getSession 178 | #else 179 | getSessionDynFlags >>= \dflags -> 180 | liftIO $ linkPackages dflags packageIDs 181 | liftIO . initDynLinker =<< getSessionDynFlags 182 | #endif 183 | 184 | result <- action 185 | 186 | -- Unload libraries to keep from leaking memory & overloading the GC 187 | getSession >>= \hscEnv -> 188 | liftIO (unload hscEnv []) 189 | 190 | return result 191 | 192 | 193 | 194 | newtype CompiledValue = CompiledValue Dynamic deriving Show 195 | 196 | getCompiledValue :: Typeable a => CompiledValue -> Maybe a 197 | getCompiledValue (CompiledValue r) = fromDynamic r 198 | 199 | fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime) 200 | fileContentsStringToBuffer fileContents = do 201 | now <- liftIO getCurrentTime 202 | return (stringToStringBuffer fileContents, now) 203 | 204 | createTempFile :: MonadIO m => m FilePath 205 | createTempFile = liftIO $ do 206 | tempDir <- getTemporaryDirectory 207 | now <- show . diffTimeToPicoseconds . realToFrac <$> getPOSIXTime 208 | let tempFile = tempDir "halive_" ++ now <.> "hs" 209 | writeFile tempFile "" 210 | return tempFile 211 | 212 | -- | Takes a filename, optionally its contents, and a list of expressions. 213 | -- Returns a list of errors or a list of Dynamic compiled values 214 | recompileExpressionsInFile :: FilePath 215 | -> Maybe String 216 | -> [String] 217 | -> Ghc (Either String [CompiledValue]) 218 | recompileExpressionsInFile fileName mFileContents expressions = 219 | 220 | catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do 221 | 222 | -- Set up an error accumulator 223 | errorsRef <- liftIO (newIORef "") 224 | _ <- getSessionDynFlags >>= 225 | \dflags -> setSessionDynFlags dflags 226 | { log_action = logHandler errorsRef } 227 | 228 | mFileContentsBuffer <- mapM fileContentsStringToBuffer mFileContents 229 | 230 | -- Set the target 231 | (tempFileName, target) <- case fileName of 232 | -- We'd like to just use a Module name for the target, 233 | -- but load/depanal fails with "Foo is a package module" 234 | -- We use a blank temp file as a workaround. 235 | "" -> do 236 | tempFileName <- createTempFile 237 | (tempFileName,) <$> guessTarget' tempFileName 238 | other -> ("",) <$> guessTarget' other 239 | 240 | -- logIO "Setting targets..." 241 | setTargets [target { targetContents = mFileContentsBuffer }] 242 | 243 | -- Reload the main target 244 | -- logIO "Loading..." 245 | loadSuccess <- load LoadAllTargets 246 | 247 | if succeeded loadSuccess 248 | then do 249 | 250 | -- logIO "Analyzing deps..." 251 | -- Get the dependencies of the main target (and update the session with them) 252 | graph <- depanal [] False 253 | 254 | #if __GLASGOW_HASKELL__ >= 804 255 | let modSummaries = mgModSummaries graph 256 | #else 257 | let modSummaries = graph 258 | #endif 259 | 260 | -- Load the dependencies of the main target 261 | setContext 262 | (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries) 263 | 264 | -- Compile the expressions and return the results 265 | results <- mapM dynCompileExpr expressions 266 | 267 | return (Right (CompiledValue <$> results)) 268 | else do 269 | -- Extract the errors from the accumulator 270 | errors <- liftIO (readIORef errorsRef) 271 | -- Strip out the temp file name when using anonymous code 272 | let cleanErrors = if null tempFileName then errors 273 | else Text.unpack $ 274 | Text.replace 275 | (Text.pack tempFileName) 276 | "" 277 | (Text.pack errors) 278 | return (Left cleanErrors) 279 | 280 | -- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files 281 | -- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile 282 | guessTarget' :: GhcMonad m => String -> m Target 283 | guessTarget' fileName = guessTarget ('*':fileName) Nothing 284 | 285 | catchExceptions :: ExceptionMonad m => m (Either String a) -> m (Either String a) 286 | catchExceptions a = gcatch a 287 | (\(_x :: SomeException) -> do 288 | liftIO (putStrLn ("Caught exception during recompileExpressionInFile: " ++ show _x)) 289 | return (Left (show _x)) 290 | ) 291 | 292 | -- Adapted from 293 | -- https://hackage.haskell.org/package/ghc-8.2.1/docs/src/DynFlags.html#defaultLogAction 294 | logHandler :: IORef String -> LogAction 295 | logHandler errorIORef dflags reason severity srcSpan style msg 296 | = case severity of 297 | SevOutput -> printOut msg style 298 | SevDump -> printOut (msg $$ blankLine) style 299 | SevInteractive -> putStrSDoc msg style 300 | SevInfo -> printErrs msg style 301 | SevFatal -> printErrs msg style 302 | _ -> do -- otherwise (i.e. SevError or SevWarning) 303 | caretDiagnostic <- 304 | if gopt Opt_DiagnosticsShowCaret dflags 305 | then getCaretDiagnostic severity srcSpan 306 | else pure empty 307 | writeToErrorIORef (message $+$ caretDiagnostic) 308 | (setStyleColoured True style) 309 | -- careful (#2302): printErrs prints in UTF-8, 310 | -- whereas converting to string first and using 311 | -- hPutStr would just emit the low 8 bits of 312 | -- each unicode char. 313 | where printOut = writeToErrorIORef 314 | printErrs = writeToErrorIORef 315 | putStrSDoc = writeToErrorIORef 316 | -- Pretty print the warning flag, if any (#10752) 317 | message = mkLocMessageAnn Nothing severity srcSpan msg 318 | writeToErrorIORef message style = 319 | modifyIORef' errorIORef 320 | (++ ('\n':renderWithStyle dflags message style)) 321 | 322 | -- logHandler :: IORef String -> LogAction 323 | -- #if __GLASGOW_HASKELL__ >= 800 324 | -- logHandler ref dflags _warnReason severity srcSpan style msg = 325 | -- #else 326 | -- logHandler ref dflags severity srcSpan style msg = 327 | -- #endif 328 | -- caretDiagnostic <- getCaretDiagnostic dflags srcSpan 329 | -- let cntx = initSDocContext dflags style 330 | -- locMsg = mkLocMessage severity srcSpan msg 331 | -- messageWithLocation = show (runSDoc locMsg cntx) 332 | -- messageOther = show (runSDoc msg cntx) 333 | -- renderWithStyle dflags (msg $+$ caretDiagnostic) 334 | -- (setStyleColoured True style) 335 | 336 | -- case severity of 337 | -- SevError -> modifyIORef' ref (++ ('\n':messageWithLocation)) 338 | -- SevFatal -> modifyIORef' ref (++ ('\n':messageWithLocation)) 339 | -- SevWarning -> modifyIORef' ref (++ ('\n':messageWithLocation)) 340 | -- _ -> do 341 | -- putStr messageOther 342 | -- return () -- ignore the rest 343 | 344 | -- A helper from interactive-diagrams to print out GHC API values, 345 | -- useful while debugging the API. 346 | -- | Outputs any value that can be pretty-printed using the default style 347 | output :: (GhcMonad m, Outputable a) => a -> m () 348 | output a = do 349 | dfs <- getSessionDynFlags 350 | let style = defaultUserStyle dfs 351 | let cntx = initSDocContext dfs style 352 | liftIO $ print $ runSDoc (ppr a) cntx 353 | 354 | 355 | -- NOTE: handleSourceError (which calls gatherErrors above) 356 | -- doesn't actually seem to do anything, so we use 357 | -- the IORef + log_action solution instead. 358 | -- The API docs claim 'load' should 359 | -- throw SourceErrors but it doesn't afaict. 360 | gatherErrors :: GhcMonad m => SourceError -> m String 361 | gatherErrors sourceError = do 362 | printException sourceError 363 | dflags <- getSessionDynFlags 364 | let style = mkUserStyle dflags neverQualify AllTheWay 365 | errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError) 366 | errorStrings = map (showSDocForUser dflags neverQualify) errorSDocs 367 | return (concat errorStrings) 368 | 369 | 370 | --pkgConfRefToString = \case 371 | -- GlobalPkgConf -> "GlobalPkgConf" 372 | -- UserPkgConf -> "UserPkgConf" 373 | -- PkgConfFile file -> "PkgConfFile " ++ show file 374 | 375 | --extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ [] 376 | 377 | logIO :: MonadIO m => String -> m () 378 | logIO = liftIO . putStrLn 379 | --------------------------------------------------------------------------------