diff --git a/exec/Banner.hs b/exec/Banner.hs new file mode 100644 --- /dev/null +++ b/exec/Banner.hs @@ -0,0 +1,11 @@ +module Banner where + +banner :: String +banner = + "██╗ ██╗ █████╗ ██╗ ██╗██╗ ██╗███████╗\n\ + \██║ ██║██╔══██╗██║ ██║██║ ██║██╔════╝\n\ + \███████║███████║██║ ██║██║ ██║█████╗ \n\ + \██╔══██║██╔══██║██║ ██║╚██╗ ██╔╝██╔══╝ \n\ + \██║ ██║██║ ██║███████╗██║ ╚████╔╝ ███████╗\n\ + \╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚═╝ ╚═══╝ ╚══════╝\n\ + \ engaged" diff --git a/exec/Halive.hs b/exec/Halive.hs new file mode 100644 --- /dev/null +++ b/exec/Halive.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase #-} +module Halive where + +import GHC +import Linker +import Packages +import DynFlags +import GHC.Paths +import Outputable +import Data.IORef +import Control.Monad +import Control.Concurrent +import Control.Monad.IO.Class + +import System.FSNotify +import System.FilePath +import qualified Filesystem.Path as FSP + +import SandboxPath + +directoryWatcher :: IO (Chan Event) +directoryWatcher = do + let predicate event = case event of + Modified path _ -> FSP.extension path `elem` map Just ["hs", "vert", "frag", "pd"] + _ -> False + eventChan <- newChan + _ <- forkIO $ withManager $ \manager -> do + -- start a watching job (in the background) + let watchDirectory = "." + _stopListening <- watchTreeChan + manager + watchDirectory + predicate + eventChan + -- Keep the watcher alive forever + forever $ threadDelay 10000000 + + return eventChan + + + +recompiler :: FilePath -> [FilePath] -> IO () +recompiler mainFileName importPaths' = withGHCSession mainFileName importPaths' $ do + mainThreadId <- liftIO myThreadId + + {- + Watcher: + Tell the main thread to recompile. + If the main thread isn't done yet, kill it. + Compiler: + Wait for the signal to recompile. + Before recompiling & running, mark that we've started, + and after we're done running, mark that we're done. + -} + + mainDone <- liftIO $ newIORef False + -- Start with a full MVar so we recompile right away. + recompile <- liftIO $ newMVar () + + -- Watch for changes and recompile whenever they occur + watcher <- liftIO directoryWatcher + _ <- liftIO . forkIO . forever $ do + _ <- readChan watcher + putMVar recompile () + mainIsDone <- readIORef mainDone + unless mainIsDone $ killThread mainThreadId + + -- Start up the app + forever $ do + _ <- liftIO $ takeMVar recompile + liftIO $ writeIORef mainDone False + recompileTargets + liftIO $ writeIORef mainDone True + + + +withGHCSession :: FilePath -> [FilePath] -> Ghc () -> IO () +withGHCSession mainFileName importPaths' action = do + defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do + -- Add the main file's path to the import path list + let mainFilePath = dropFileName mainFileName + importPaths'' = mainFilePath:importPaths' + + -- Get the default dynFlags + dflags0 <- getSessionDynFlags + + -- If there's a sandbox, add its package DB + dflags1 <- liftIO getSandboxDb >>= \case + Nothing -> return dflags0 + Just sandboxDB -> do + let pkgs = map PkgConfFile [sandboxDB] + return dflags0 { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags0 } + + -- Make sure we're configured for live-reload, and turn off the GHCi sandbox + -- since it breaks OpenGL/GUI usage + let dflags2 = dflags1 { hscTarget = HscInterpreted + , ghcLink = LinkInMemory + , ghcMode = CompManager + , importPaths = importPaths'' + } `gopt_unset` Opt_GhciSandbox + + -- We must set dynflags before calling initPackages or any other GHC API + _ <- setSessionDynFlags dflags2 + + -- Initialize the package database + (dflags3, _) <- liftIO $ initPackages dflags2 + + -- Initialize the dynamic linker + liftIO $ initDynLinker dflags3 + + -- Set the given filename as a compilation target + setTargets =<< sequence [guessTarget mainFileName Nothing] + + action + +-- Recompiles the current targets +recompileTargets :: Ghc () +recompileTargets = handleSourceError printException $ do + -- Get the dependencies of the main target + graph <- depanal [] False + + -- Reload the main target + loadSuccess <- load LoadAllTargets + unless (failed loadSuccess) $ do + -- We must parse and typecheck modules before they'll be available for usage + forM_ graph (typecheckModule <=< parseModule) + + -- Load the dependencies of the main target + setContext $ map (IIModule . ms_mod_name) graph + + -- Run the target file's "main" function + rr <- runStmt "main" RunToCompletion + case rr of + RunOk _ -> liftIO $ putStrLn "OK" + RunException exception -> liftIO $ print exception + RunBreak _ _ _ -> liftIO $ putStrLn "Breakpoint" + + +-- A helper from interactive-diagrams to print out GHC API values, +-- useful while debugging the API. +-- | Outputs any value that can be pretty-printed using the default style +output :: (GhcMonad m, MonadIO m) => Outputable a => a -> m () +output a = do + dfs <- getSessionDynFlags + let style = defaultUserStyle + let cntx = initSDocContext dfs style + liftIO $ print $ runSDoc (ppr a) cntx diff --git a/exec/SandboxPath.hs b/exec/SandboxPath.hs new file mode 100644 --- /dev/null +++ b/exec/SandboxPath.hs @@ -0,0 +1,34 @@ +module SandboxPath where +import Data.Maybe +import Data.Traversable (traverse) +import Control.Applicative ((<$>)) +import System.Directory +import System.FilePath +import Data.List +import Data.Char + +-- From ghc-mod +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + +-- | Get path to sandbox config file +getSandboxDb :: IO (Maybe FilePath) +getSandboxDb = do + currentDir <- getCurrentDirectory + config <- traverse readFile =<< mightExist (currentDir "cabal.sandbox.config") + return $ (extractSandboxDbDir =<< config) + +-- | Extract the sandbox package db directory from the cabal.sandbox.config file. +-- Exception is thrown if the sandbox config file is broken. +extractSandboxDbDir :: String -> Maybe FilePath +extractSandboxDbDir conf = extractValue <$> parse conf + where + key = "package-db:" + keyLen = length key + + parse = listToMaybe . filter (key `isPrefixOf`) . lines + extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen + +-- main = print =<< getSandboxDb diff --git a/halive.cabal b/halive.cabal --- a/halive.cabal +++ b/halive.cabal @@ -2,81 +2,20 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: halive -version: 0.1.0.0 +version: 0.1.0.1 synopsis: A live recompiler description: - > ██╗ ██╗ █████╗ ██╗ ██╗██╗ ██╗███████╗ - > ██║ ██║██╔══██╗██║ ██║██║ ██║██╔════╝ - > ███████║███████║██║ ██║██║ ██║█████╗ - > ██╔══██║██╔══██║██║ ██║╚██╗ ██╔╝██╔══╝ - > ██║ ██║██║ ██║███████╗██║ ╚████╔╝ ███████╗ - > ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚═╝ ╚═══╝ ╚══════╝ - Live recompiler for Haskell - - <> - - Halive uses the GHC API to instantly recompile - and reload your code any time you change it. - - Usage: - @cabal install@ - - and then - - @halive \ \@ - - Any time you change a file in the current directory or its - subdirectories, - halive will recompile and rerun the @main@ function in the file you gave - it. - - If the program is long-running (e.g. a daemon, GUI or game loop) it will - be - killed and restarted. Learn how to maintain state in the next section. - - Try a live-coding GL demo by running @halive demo\/Main.hs@ (in the - source package) - and changing values in @Main.hs@ and @Green.hs@ - (requires @gl@, @GLFW-b@, @foreign-store@, @linear@, and @random@). - - == Keeping values alive - #keeping-values-alive# - - To keep state alive, import @Halive.Utils@ and wrap - your value in @reacquire@ along with a unique identifier, like: - - @win \<- reacquire 0 (setupGLFW \"HotGLFW\" 640 480)@ - - to only create the resource the first time you run the program, and then - reuse it on subsequent recompilations. - - You can see this in action in @test\/glfw.hs@. - - Thanks to Chris Done\'s - - library for enabling this. - - == Notes - #notes# - - Creating, updating, and deleting modules in the include path should - work fine during a Halive session. - - Halive also supports Cabal sandboxes; - if run within a directory containing a cabal.sandbox.config file it will - use the package database defined therein. - - Halive also works nicely with either batch-processing or run-loop type - programs — if the program finishes, it will be restarted on next save, - and if it\'s still running, it will be killed and restarted on save. - - To kill Halive during run-loop type programs, you may need to hold down - Ctrl-C - to get GHC to recognize the double-Control-C-kill sequence. - - -homepage: tree.is + . + <> + . + /Usage:/ + . + > halive path/to/myfile.hs [optionally any/extra include/dirs ..] + . + See +homepage: https://github.com/lukexi/halive +bug-reports: https://github.com/lukexi/halive/issues license: BSD2 license-file: LICENSE author: Luke Iannini @@ -84,7 +23,6 @@ -- copyright: category: Development build-type: Simple --- extra-source-files: cabal-version: >=1.10 source-repository head @@ -107,7 +45,10 @@ hs-source-dirs: exec default-language: Haskell2010 ghc-options: -Wall -threaded -dynamic - -- other-modules: + other-modules: + Banner + Halive + SandboxPath -- other-extensions: build-depends: base >=4.7 && <4.9,