diff --git a/README.md b/README.md index 9990ff1..1fc3eeb 100644 --- a/README.md +++ b/README.md @@ -38,6 +38,13 @@ halive demo/Main.hs ``` Changing values in `Main.hs` or `Green.hs` and saving should live-update the program. +* Note: if you get an error about an ``Ambiguous module name``, you can use this + command line instead: + + ``HALIVE_STACK_COMPONENT=halive:test:demo halive demo/Main.hs`` + + It will be slower. + Keeping values alive -------------------- diff --git a/demo/SetupGLFW.hs b/demo/SetupGLFW.hs index 1aadca8..d6d3125 100644 --- a/demo/SetupGLFW.hs +++ b/demo/SetupGLFW.hs @@ -1,12 +1,18 @@ +{-# LANGUAGE LambdaCase #-} module SetupGLFW where import qualified Graphics.UI.GLFW as GLFW import Control.Monad +import Data.Bool +import System.Exit +import System.IO setupGLFW :: String -> Int -> Int -> IO GLFW.Window setupGLFW windowName desiredW desiredH = do - _ <- GLFW.init + + GLFW.setErrorCallback (Just (const (hPutStrLn stderr))) + GLFW.init >>= bool (bail initFailMsg) (return ()) GLFW.windowHint $ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'OpenGL GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True @@ -14,10 +20,15 @@ setupGLFW windowName desiredW desiredH = do GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 4 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 1 GLFW.windowHint $ GLFW.WindowHint'sRGBCapable True - - Just win <- GLFW.createWindow desiredW desiredH windowName Nothing Nothing - - GLFW.makeContextCurrent (Just win) - GLFW.swapInterval 1 - return win + GLFW.createWindow desiredW desiredH windowName Nothing Nothing >>= \case + Nothing -> bail cwFailMsg + Just win -> do + GLFW.makeContextCurrent (Just win) + GLFW.swapInterval 1 + return win + + where + initFailMsg = "Error: GLFW init() failed; perhaps $DISPLAY is not set." + cwFailMsg = "Error: GLFW createWindow() failed; probably your GPU is too old." + bail = hPutStrLn stderr >=> const exitFailure >=> undefined diff --git a/exec/FindPackageDBs.hs b/exec/FindPackageDBs.hs index 71a28cb..181cd46 100644 --- a/exec/FindPackageDBs.hs +++ b/exec/FindPackageDBs.hs @@ -6,6 +6,7 @@ import Data.Maybe import System.Directory import System.FilePath import System.Process +import System.Environment (lookupEnv) import Data.List import Data.Char import Control.Monad.IO.Class @@ -67,9 +68,19 @@ getStackDb = do return . Just . catMaybes $ map (flip extractKey pathInfo) ["local-pkg-db:", "snapshot-pkg-db:"] updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags -updateDynFlagsWithStackDB dflags = +updateDynFlagsWithStackDB dflags = liftIO getStackDb >>= \case Nothing -> return dflags Just stackDBs -> do let pkgs = map PkgConfFile stackDBs - return dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags } \ No newline at end of file + dflags' = dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags } + maybe (return dflags' ) (nastyHack dflags') =<< liftIO (lookupEnv "HALIVE_STACK_COMPONENT") + + where + cmd c = "echo|stack -v ghci " ++ c ++ " 2>&1 >/dev/null |sed -ne 's/ @([^)]*)$//; s/.*Run process: ghc --interactive //p'" + nastyHack :: MonadIO m => DynFlags -> String -> m DynFlags + nastyHack dflags' component = do + ghciArguments <- words <$> liftIO (readProcess "sh" ["-c", cmd component] "") + let packageIdArguments = map noLoc $ filter ("-package-id=" `isPrefixOf`) ghciArguments + fst' <$> parseDynamicFlagsCmdLine (gopt_set dflags' Opt_HideAllPackages) packageIdArguments + fst' (x, _, _) = x diff --git a/stack.yaml b/stack.yaml index 845c644..5c30577 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ flags: {} packages: - '.' -resolver: nightly-2015-12-03 +resolver: lts-4.0