From 06d6961c32e638302677eed7459778ac1bfd0ea1 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 9 Jan 2016 21:16:53 -0500 Subject: [PATCH 1/3] update to stackage lts-4.0 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From c1a7b09b29eb34115bb3893a3bb829a1b1b1eacd Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 9 Jan 2016 21:22:51 -0500 Subject: [PATCH 2/3] demo: provide error messages on initialization failure --- demo/SetupGLFW.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) 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 From a33483229aa5cf4f1a6a37f4992624a5e6163d45 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 10 Jan 2016 02:25:38 -0500 Subject: [PATCH 3/3] (Optionally) copy '-package-id' args from 'stack' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If the environment variable 'HALIVE_STACK_COMPONENT' is set, its value will be passed to 'stack ghci' as the component to use. The command line used to launch 'ghci' is extracted from 'stack' log output, and the '-package-id=<...>' arguments used to configure the 'DynFlags' passed to 'runGhc'. This is necessary when the stack package dbs contain multiple packages that provide the same module. Without it, 'runGhc' will not be able to know which package should be used to provide the module, producing an error such as this: demo/Shader.hs:3:8: Ambiguous module name ‘Graphics.GL’: it was found in multiple packages: gl-0.7.7@gl_8feL1KNX30C7cRvC5KMerD OpenGLRaw-3.0.0.0@OpenG_2ifknuoKtb4Jnk98tmsl6Y This is very slow, since it has to compile the project with 'ghci' just to get the arguments -- only to be used to compile it again! But it does make 'halive' work in situations where, without it, there would only be failure. (A proper solution would involve modifying 'stack' to provide this information more efficiently.) --- README.md | 7 +++++++ exec/FindPackageDBs.hs | 15 +++++++++++++-- 2 files changed, 20 insertions(+), 2 deletions(-) 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/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