diff --git a/demo/Cube.hs b/demo/Cube.hs --- a/demo/Cube.hs +++ b/demo/Cube.hs @@ -5,6 +5,7 @@ import Linear import Data.Foldable import Shader +import Control.Monad.Trans newtype VertexArrayObject = VertexArrayObject { unVertexArrayObject :: GLuint } @@ -19,14 +20,14 @@ -- Make Cube ---------------------------------------------------------- -renderCube :: Cube -> M44 GLfloat -> IO () +renderCube :: MonadIO m => Cube -> M44 GLfloat -> m () renderCube cube mvp = do useProgram (cubeShader cube) let mvpUniformLoc = fromIntegral (unUniformLocation (cubeUniformMVP cube)) - - withArray (concatMap toList (transpose mvp)) (\mvpPointer -> + + liftIO $ withArray (concatMap toList (transpose mvp)) (\mvpPointer -> glUniformMatrix4fv mvpUniformLoc 1 GL_FALSE mvpPointer) glBindVertexArray (unVertexArrayObject (cubeVAO cube)) @@ -53,19 +54,19 @@ ----------------- -- Cube Positions ----------------- - + -- Buffer the cube vertices - let cubeVertices = + let cubeVertices = --- front [ -1.0 , -1.0 , 1.0 - , 1.0 , -1.0 , 1.0 - , 1.0 , 1.0 , 1.0 - , -1.0 , 1.0 , 1.0 + , 1.0 , -1.0 , 1.0 + , 1.0 , 1.0 , 1.0 + , -1.0 , 1.0 , 1.0 --- back - , -1.0 , -1.0 , -1.0 - , 1.0 , -1.0 , -1.0 - , 1.0 , 1.0 , -1.0 + , -1.0 , -1.0 , -1.0 + , 1.0 , -1.0 , -1.0 + , 1.0 , 1.0 , -1.0 , -1.0 , 1.0 , -1.0 ] :: [GLfloat] @@ -73,12 +74,12 @@ vaoCubeVertices <- overPtr (glGenBuffers 1) glBindBuffer GL_ARRAY_BUFFER vaoCubeVertices - + let cubeVerticesSize = fromIntegral (sizeOf (undefined :: GLfloat) * length cubeVertices) - withArray cubeVertices $ + withArray cubeVertices $ \cubeVerticesPtr -> - glBufferData GL_ARRAY_BUFFER cubeVerticesSize (castPtr cubeVerticesPtr) GL_STATIC_DRAW + glBufferData GL_ARRAY_BUFFER cubeVerticesSize (castPtr cubeVerticesPtr) GL_STATIC_DRAW -- Describe our vertices array to OpenGL glEnableVertexAttribArray (fromIntegral (unAttributeLocation aVertex)) @@ -96,7 +97,7 @@ -------------- -- Buffer the cube colors - let cubeColors = + let cubeColors = -- front colors [ 1.0, 0.0, 0.0 , 0.0, 1.0, 0.0 @@ -118,7 +119,7 @@ \cubeColorsPtr -> glBufferData GL_ARRAY_BUFFER cubeColorsSize (castPtr cubeColorsPtr) GL_STATIC_DRAW - + glEnableVertexAttribArray (fromIntegral (unAttributeLocation aColor)) glVertexAttribPointer @@ -134,9 +135,9 @@ ----------- -- Buffer the cube ids - let cubeIDs = + let cubeIDs = [ 0 - , 1 + , 1 , 2 , 3 , 4 @@ -152,7 +153,7 @@ \cubeIDsPtr -> glBufferData GL_ARRAY_BUFFER cubeIDsSize (castPtr cubeIDsPtr) GL_STATIC_DRAW - + glEnableVertexAttribArray (fromIntegral (unAttributeLocation aID)) glVertexAttribPointer @@ -170,7 +171,7 @@ ---------------- -- Buffer the cube indices - let cubeIndices = + let cubeIndices = -- front [ 0, 1, 2 , 2, 3, 0 @@ -189,24 +190,24 @@ -- right , 3, 2, 6 , 6, 7, 3 ] :: [GLuint] - + iboCubeElements <- overPtr (glGenBuffers 1) - + glBindBuffer GL_ELEMENT_ARRAY_BUFFER iboCubeElements let cubeElementsSize = fromIntegral (sizeOf (undefined :: GLuint) * length cubeIndices) - - withArray cubeIndices $ + + withArray cubeIndices $ \cubeIndicesPtr -> glBufferData GL_ELEMENT_ARRAY_BUFFER cubeElementsSize (castPtr cubeIndicesPtr) GL_STATIC_DRAW - + glBindVertexArray 0 - return $ Cube + return $ Cube { cubeVAO = VertexArrayObject vaoCube , cubeShader = program , cubeIndexCount = fromIntegral (length cubeIndices) , cubeUniformMVP = uMVP - } + } diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -5,14 +5,18 @@ import System.Random import Data.Time import Control.Monad +import Control.Monad.State import Data.Bits +import Text.Show.Pretty +import Data.Maybe import Halive.Utils import Cube import Shader import Window -import SDL +import SDL hiding (get) +import qualified SDL as SDL import qualified Green as Green -- Try changing the green amount @@ -31,7 +35,7 @@ -- (Our window stays persistent as well thanks to this, -- so it would probably be a good idea anyway!) - (win, _ctx) <- reacquire 0 $ createGLWindow "Hot SDL" + (win, _ctx) <- reacquire "win" $ createGLWindow "Hot SDL" -- You can change the window title here. --GLFW.setWindowTitle win "Hot Swap!" @@ -46,9 +50,20 @@ -- Sometimes it's useful to know if we're running under Halive or not putStrLn . ("Running under Halive: " ++ ) . show =<< isHaliveActive - -- do -- swap this with the next line to test immediately-returning mains - whileWindow win $ \events -> do - now <- realToFrac . utctDayTime <$> getCurrentTime + -- Reacquire our state from the last run, if any - otherwise create a new state + initialState <- reacquire "state" (return ([]::[V3 GLfloat])) + void . flip runStateT initialState . whileWindow win $ \events -> do + -- Store our state persistently in a named slot + persistState "state" + + + + -- Try turning on a stream of events + -- unless (null events) $ + -- liftIO $ pPrint events + + winSize@(V2 w h) <- fmap realToFrac <$> SDL.get (SDL.windowSize win) + now <- realToFrac . utctDayTime <$> liftIO getCurrentTime -- print now -- Try turning on a stream of now logs let redFreq = 0.6 * pi -- Try changing the red and blue frequencies. red = sin (now * redFreq) @@ -60,13 +75,40 @@ glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT) -- Render our scene --putStrLn "getWinSize" - V2 w h <- get (SDL.windowSize win) - let projection = perspective 45 (fromIntegral w / fromIntegral h) 0.01 1000 + + let projection = perspective 45 (w / h) 0.01 1000 model = mkTransformation (axisAngle (V3 0 1 1) now) (V3 (sin now) 0 (-4)) view = lookAt (V3 0 2 5) (V3 0 0 (-4)) (V3 0 1 0) - mvp = projection !*! view !*! model + projView = projection !*! view + mvp = projView !*! model --putStrLn "renderCube" renderCube cube mvp + + -- Accumulate mouse drags as cube trails + forM_ (catMaybes $ map matchMouse events) $ \cursorPos -> do + isMouseDown <- SDL.getMouseButtons + when (isMouseDown ButtonLeft) $ do + let worldPos = windowPosToWorldPos winSize projView cursorPos 20 + modify' ((worldPos :) . take 40) + + positions <- get + forM_ positions $ \cursorPos -> do + let model = mkTransformation (axisAngle (V3 0 1 1) now) cursorPos + mvp = projView !*! model + renderCube cube mvp --putStrLn "glSwapWindow" SDL.glSwapWindow win + + +matchMouse Event + { eventPayload = + MouseMotionEvent + MouseMotionEventData + { mouseMotionEventWhich = Mouse 0 + , mouseMotionEventPos = P pos + } + } + = Just (fromIntegral <$> pos) +matchMouse _ + = Nothing diff --git a/demo/Shader.hs b/demo/Shader.hs --- a/demo/Shader.hs +++ b/demo/Shader.hs @@ -39,7 +39,7 @@ createShaderProgram :: FilePath -> FilePath -> IO GLProgram createShaderProgram vertexShaderPath fragmentShaderPath = - + do vertexShader <- glCreateShader GL_VERTEX_SHADER compileShader vertexShaderPath vertexShader fragmentShader <- glCreateShader GL_FRAGMENT_SHADER @@ -49,7 +49,7 @@ glAttachShader shaderProg fragmentShader glLinkProgram shaderProg linked <- overPtr (glGetProgramiv shaderProg GL_LINK_STATUS) - when (linked == GL_FALSE) + when (linked == fromIntegral GL_FALSE) (do maxLength <- overPtr (glGetProgramiv shaderProg GL_INFO_LOG_LENGTH) logLines <- allocaArray (fromIntegral maxLength) @@ -86,16 +86,16 @@ getShaderAttribute :: GLProgram -> String -> IO AttributeLocation getShaderAttribute (GLProgram prog) attributeName = do - location <- withCString attributeName $ \attributeNameCString -> + location <- withCString attributeName $ \attributeNameCString -> glGetAttribLocation prog attributeNameCString - when (location == -1) $ error $ "Coudn't bind attribute: " ++ attributeName + when (location == -1) $ error $ "Coudn't bind attribute: " ++ attributeName return (AttributeLocation location) getShaderUniform :: GLProgram -> String -> IO UniformLocation getShaderUniform (GLProgram prog) uniformName = do - location <- withCString uniformName $ \uniformNameCString -> + location <- withCString uniformName $ \uniformNameCString -> glGetUniformLocation prog uniformNameCString - when (location == -1) $ error $ "Coudn't bind uniform: " ++ uniformName + when (location == -1) $ error $ "Coudn't bind uniform: " ++ uniformName return (UniformLocation location) glGetErrors :: IO () diff --git a/demo/Window.hs b/demo/Window.hs --- a/demo/Window.hs +++ b/demo/Window.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} module Window where @@ -8,6 +9,7 @@ import Linear import Linear.Affine import Data.Text (Text) +import Control.Lens createGLWindow :: MonadIO m => Text -> m (Window, GLContext) createGLWindow windowName = do @@ -47,3 +49,28 @@ unless shouldQuit loop loop destroyWindow window + + +windowPosToWorldPos :: (Epsilon a, Real a, Floating a) + => V2 a + -> M44 a + -> V2 a + -> a + -> V3 a +windowPosToWorldPos winSize viewProj coord depth = rayStart + rayDir * realToFrac depth + where + V2 xNDC yNDC = win2Ndc coord winSize + rayStart = ndc2Wld (V4 xNDC yNDC (-1.0) 1.0) + rayEnd = ndc2Wld (V4 xNDC yNDC 0.0 1.0) + rayDir = normalize (rayEnd ^-^ rayStart) + -- Converts from window coordinates (origin top-left) to normalized device coordinates + win2Ndc (V2 x y) (V2 w h) = + V2 ((x / w - 0.5) * 2) + ((((h - y) / h) - 0.5) * 2) + -- Converts from normalized device coordinates to world coordinates + ndc2Wld i = hom2Euc (invViewProj !* i) + -- Converts from homogeneous coordinates to Euclidean coordinates + hom2Euc v = (v ^/ (v ^. _w)) ^. _xyz + invViewProj = inv44 viewProj + + diff --git a/exec/HaliveMain.hs b/exec/HaliveMain.hs --- a/exec/HaliveMain.hs +++ b/exec/HaliveMain.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} #if !MIN_VERSION_base(4,8,0) import Control.Applicative @@ -14,44 +15,42 @@ import Control.Concurrent.STM import Halive.SubHalive import Halive.Recompiler +import Halive.Args import System.FilePath - -separateArgs :: [String] -> ([String], [String]) -separateArgs args = (haliveArgs, drop 1 targetArgs) - where (haliveArgs, targetArgs) = break (== "--") args - main :: IO () main = do - (args, targetArgs) <- separateArgs <$> getArgs + args <- parseArgs <$> getArgs case args of - [] -> putStrLn "Usage: halive [-- ]" - (mainFileName:includeDirs) -> do + Nothing -> putStrLn usage + Just Args {..} -> do let mainFilePath = dropFileName mainFileName setEnv "Halive Active" "Yes" putStrLn banner - withArgs targetArgs $ startRecompiler mainFileName (mainFilePath:includeDirs) + withArgs targetArgs $ + startRecompiler (fileTypes ++ defaultFileTypes) mainFileName + (mainFilePath:includeDirs) + shouldCompile +defaultFileTypes :: [FileType] +defaultFileTypes = ["hs", "pd", "frag", "vert"] + printBanner :: String -> IO () printBanner title = putStrLn $ ribbon ++ " " ++ title ++ " " ++ ribbon where ribbon = replicate 25 '*' -startRecompiler :: FilePath -> [FilePath] -> IO b -startRecompiler mainFileName includeDirs = do +startRecompiler :: [FileType] -> FilePath -> [FilePath] -> Bool -> IO b +startRecompiler fileTypes mainFileName includeDirs shouldCompile = do ghc <- startGHC (defaultGHCSessionConfig { gscImportPaths = includeDirs - -- , gscCompilationMode = Compiled - , gscCompilationMode = Interpreted + , gscCompilationMode = if shouldCompile then Compiled else Interpreted }) - let fileTypes = ["hs", "pd", "frag", "vert"] - recompiler <- recompilerWithConfig ghc RecompilerConfig { rccWatchAll = Just (".", fileTypes) - , rccExpression = "main" + , rccExpressions = ["main"] , rccFilePath = mainFileName - , rccCompileImmediately = True } mainThreadId <- myThreadId @@ -63,12 +62,16 @@ case result of Left errors -> do printBanner "Compilation Errors, Waiting... " - putStrLn (concat errors) - Right newCode -> do + putStrLn errors + Right values -> do printBanner "Compilation Success, Relaunching..." - atomically $ writeTChan newCodeTChan newCode - mainIsRunning <- readIORef isMainRunning - when mainIsRunning $ killThread mainThreadId + case values of + [newCode] -> do + atomically $ writeTChan newCodeTChan newCode + mainIsRunning <- readIORef isMainRunning + when mainIsRunning $ killThread mainThreadId + _ -> + error "Unexpected number of values received on recResultTChan" forever $ do newCode <- atomically $ readTChan newCodeTChan @@ -80,4 +83,3 @@ writeIORef isMainRunning False Nothing -> do putStrLn "main was not of type IO ()" - diff --git a/halive.cabal b/halive.cabal --- a/halive.cabal +++ b/halive.cabal @@ -1,8 +1,5 @@ --- Initial halive.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: halive -version: 0.1.3 +version: 0.1.5 synopsis: A live recompiler description: Live recompiler for Haskell @@ -11,8 +8,13 @@ . /Usage:/ . - > halive path/to/myfile.hs [optionally any/extra include/dirs ..] -- [args to app] + > halive path/to/myfile.hs [optionally any/extra include/dirs ..] [-f|--file-type additional file type] -- [args to app] . + Available options: + . + @-f, --file-type @ - Custom file type to watch for changes (e.g. @-f html@) + @-c, --compiled@ - Use faster compiled code at the expense of recompilation speed + . See homepage: https://github.com/lukexi/halive bug-reports: https://github.com/lukexi/halive/issues @@ -32,6 +34,8 @@ library hs-source-dirs: src exposed-modules: + Halive + Halive.Args Halive.Utils Halive.Concurrent Halive.FindPackageDBs @@ -40,22 +44,23 @@ Halive.FileListener default-language: Haskell2010 ghc-prof-options: -Wall -O2 -fprof-auto - ghc-options: -Wall -O2 + ghc-options: -Wall -O2 -optP-Wno-nonportable-include-path build-depends: - base>=4.7 && <5, - foreign-store, - containers, - mtl, - ghc, - ghc-paths, - filepath, - fsnotify, - process, - transformers, - directory, - stm, - time, - signal + base >=4.7 && <5 + , foreign-store + , containers + , mtl + , ghc + , ghc-paths + , filepath + , fsnotify + , process + , transformers + , directory + , stm + , time + , signal + , text if impl(ghc >= 8) build-depends: ghc-boot @@ -64,34 +69,47 @@ main-is: HaliveMain.hs hs-source-dirs: exec default-language: Haskell2010 - ghc-prof-options: -Wall -O2 -threaded -fprof-auto - ghc-options: -Wall -O2 -threaded + ghc-prof-options: -dynamic -Wall -O2 -threaded -fprof-auto + ghc-options: -dynamic -Wall -O2 -threaded -optP-Wno-nonportable-include-path -- This strangely enables "-dynamic" for all dependent libraries, -- so I need to comment this during profiling?!? -- Shouldn't ghc-prof-options override it anyway? Who knows. - if !os(windows) - ghc-options: -dynamic + -- if !os(windows) + -- ghc-options: -dynamic -- This overrides -dynamic when building for profiling, -- probably breaking the executable but at least it lets us build -- halive as a dependency. - ghc-prof-options: -static + -- ghc-prof-options: -static -- ^ Required on Mac due to https://ghc.haskell.org/trac/ghc/ticket/9278 -- (does GHCi use this??) other-modules: Banner -- other-extensions: build-depends: - base, - ghc, - ghc-paths, - transformers, - directory, - filepath, - fsnotify, - process, - stm, - halive + base + , ghc + , ghc-paths + , transformers + , directory + , filepath + , fsnotify + , process + , stm + , halive + +test-suite unit + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Spec.hs + hs-source-dirs: test/unit + other-modules: + Halive.ArgsSpec + build-depends: + base + , halive + , hspec + test-suite demo type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -113,13 +131,15 @@ text, bytestring, mtl, - time + time, + lens, + pretty-show test-suite subhalive type: exitcode-stdio-1.0 main-is: TestSubhalive.hs hs-source-dirs: test - ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -dynamic build-depends: base , halive , mtl @@ -129,3 +149,33 @@ , filepath , stm default-language: Haskell2010 + +test-suite compileexpr + type: exitcode-stdio-1.0 + main-is: TestCompileExpr.hs + hs-source-dirs: test + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -dynamic + build-depends: base + , halive + , mtl + , random + , containers + , time + , filepath + , stm + default-language: Haskell2010 + + +test-suite testghc + type: exitcode-stdio-1.0 + main-is: TestGHC.hs + hs-source-dirs: test + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , time + , filepath + , ghc + , ghc-paths + , directory + default-language: Haskell2010 + diff --git a/src/Halive.hs b/src/Halive.hs new file mode 100644 --- /dev/null +++ b/src/Halive.hs @@ -0,0 +1,4 @@ +module Halive (module Exports) where + +import Halive.Recompiler as Exports +import Halive.SubHalive as Exports diff --git a/src/Halive/Args.hs b/src/Halive/Args.hs new file mode 100644 --- /dev/null +++ b/src/Halive/Args.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RecordWildCards #-} + +module Halive.Args + ( Args(..) + , FileType + , parseArgs + , usage) where + +type FileType = String + +data Args = Args + { mainFileName :: String + , includeDirs :: [String] + , fileTypes :: [FileType] + , targetArgs :: [String] + , shouldCompile :: Bool + } + +data PartialArgs = PartialArgs + { mainFileName' :: Maybe String + , includeDirs' :: [String] + , fileTypes' :: [FileType] + , targetArgs' :: [String] + , shouldCompile' :: Bool + } + +usage :: String +usage = "Usage: halive [] [-f|--file-type ] [-- ]\n\ + \\n\ + \Available options:\n\ + \ -f, --file-type Custom file type to watch for changes (e.g. \"-f html\")\n\ + \ -c, --compiled Faster code (but slower compilation)" + + +parseArgs :: [String] -> Maybe Args +parseArgs args = go args (PartialArgs Nothing [] [] [] False) >>= fromPartial + where + go :: [String] -> PartialArgs -> Maybe PartialArgs + go [] partial = Just partial + go (x : xs) partial + | x == "--" = Just partial { targetArgs' = xs } + | x == "-f" || x == "--file-type" = + case xs of + [] -> Nothing + ("--" : _) -> Nothing + (fileType : xs') -> go xs' $ partial { fileTypes' = fileType : fileTypes' partial } + | x == "-c" || x == "--compiled" = + go xs $ partial { shouldCompile' = True } + | otherwise = + case mainFileName' partial of + Nothing -> go xs $ partial { mainFileName' = Just x } + Just _ -> go xs $ partial { includeDirs' = x : includeDirs' partial} + +fromPartial :: PartialArgs -> Maybe Args +fromPartial PartialArgs {..} = + case mainFileName' of + Nothing -> Nothing + Just mfn -> Just Args + { mainFileName = mfn + , includeDirs = includeDirs' + , fileTypes = fileTypes' + , targetArgs = targetArgs' + , shouldCompile = shouldCompile' + } + diff --git a/src/Halive/FileListener.hs b/src/Halive/FileListener.hs --- a/src/Halive/FileListener.hs +++ b/src/Halive/FileListener.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} module Halive.FileListener where -import Control.Concurrent -import Control.Concurrent.STM -import qualified System.FSNotify as FSNotify -import System.FSNotify hiding (Event) -import System.Directory -import System.FilePath -import Control.Monad.Trans -import Control.Monad -import Data.Time -import Control.Exception -import Data.IORef +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Data.IORef +import Data.List (isInfixOf) +import Data.Time +import System.Directory +import System.FilePath +import System.FSNotify hiding (Event) +import qualified System.FSNotify as FSNotify type FileEventChan = TChan FSNotify.Event @@ -38,11 +39,42 @@ tryReadTChanIO :: MonadIO m => TChan a -> m (Maybe a) tryReadTChanIO = atomicallyIO . tryReadTChan +peekTChanIO :: MonadIO m => TChan a -> m a +peekTChanIO = atomicallyIO . peekTChan + +exhaustTChan :: TChan a -> STM [a] +exhaustTChan chan = unfoldM (tryReadTChan chan) + +exhaustTChanIO :: MonadIO m => TChan a -> m [a] +exhaustTChanIO = atomicallyIO . exhaustTChan + +-- A version of exhaustTChan that blocks until there is something to read +waitExhaustTChan :: TChan a -> STM [a] +waitExhaustTChan chan = peekTChan chan >> exhaustTChan chan + +waitExhaustTChanIO :: MonadIO m => TChan a -> m [a] +waitExhaustTChanIO = atomicallyIO . waitExhaustTChan + +-- | Take a monadic stream returning Maybes and +-- pull a list from it until it returns Nothing +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM f = f >>= \case + Just a -> (a:) <$> unfoldM f + Nothing -> return [] + fileModifiedPredicate :: FilePath -> FSNotify.Event -> Bool fileModifiedPredicate fileName event = case event of - Modified path _ -> path == fileName - _ -> False + Modified path _ _ -> path == fileName + Added path _ _ -> path == fileName + _ -> False +-- Returns True if the event filepath is a common editor file +isACommonEditorFile :: FSNotify.Event -> Bool +isACommonEditorFile event = case event of + Modified path _ _ -> any (`isInfixOf` path) emacsFragments + _ -> False + where emacsFragments = ["#", "flymake", "flycheck"] + eventListenerForFile :: MonadIO m => FilePath -> ShouldReadFile -> m FileEventListener eventListenerForFile fileName shouldReadFile = liftIO $ do eventChan <- newTChanIO @@ -76,15 +108,16 @@ -- or an empty list to match all modifiedWithExtensionPredicate :: [String] -> FSNotify.Event -> Bool modifiedWithExtensionPredicate fileTypes event = case event of - Modified path _ -> null fileTypes || drop 1 (takeExtension path) `elem` fileTypes - _ -> False + Modified path _ _ -> null fileTypes || drop 1 (takeExtension path) `elem` fileTypes + _ -> False forkDirectoryListenerThread :: FilePath -> [String] -> TChan (Either FSNotify.Event String) -> IO (MVar ()) forkDirectoryListenerThread watchDirectory fileTypes eventChan = do - let predicate = modifiedWithExtensionPredicate fileTypes + let predicate e = modifiedWithExtensionPredicate fileTypes e + && not (isACommonEditorFile e) -- Configures debounce time for fsnotify let watchConfig = defaultConfig @@ -92,7 +125,7 @@ stopMVar <- newEmptyMVar _ <- forkIO . withManagerConf watchConfig $ \manager -> do - stop <- watchTree manager watchDirectory predicate $ \e -> do + stop <- watchTree manager watchDirectory predicate $ \e -> writeTChanIO eventChan (Left e) () <- takeMVar stopMVar stop @@ -104,19 +137,19 @@ -> TVar (Maybe UTCTime) -> IO (MVar ()) forkFileListenerThread fileName shouldReadFile eventChan ignoreEventsNear = do - predicate <- fileModifiedPredicate <$> canonicalizePath fileName + leftPredicate <- fileModifiedPredicate <$> canonicalizePath fileName + let predicate e = leftPredicate e && not (isACommonEditorFile e) -- If an ignore time is set, ignore file changes for the next 100 ms - let ignoreTime = 0.1 - + ignoreTime = 0.1 -- Configures debounce time for fsnotify - let watchConfig = defaultConfig + watchConfig = defaultConfig { confDebounce = Debounce 0.1 } + stopMVar <- newEmptyMVar _ <- forkIO . withManagerConf watchConfig $ \manager -> do let watchDirectory = takeDirectory fileName stop <- watchTree manager watchDirectory predicate $ \e -> do - print e mTimeToIgnore <- atomically $ readTVar ignoreEventsNear let timeOfEvent = eventTime e shouldIgnore = case mTimeToIgnore of diff --git a/src/Halive/FindPackageDBs.hs b/src/Halive/FindPackageDBs.hs --- a/src/Halive/FindPackageDBs.hs +++ b/src/Halive/FindPackageDBs.hs @@ -11,7 +11,6 @@ import System.Process import Control.Exception import DynFlags -import GHC -- | Extract the sandbox package db directory from the cabal.sandbox.config file. -- Exception is thrown if the sandbox config file is broken. @@ -28,11 +27,11 @@ exists <- doesFileExist f return $ if exists then (Just f) else (Nothing) -addExtraPkgConfs :: DynFlags -> [FilePath] -> DynFlags -addExtraPkgConfs dflags pkgConfs = dflags - { extraPkgConfs = - let newPkgConfs = map PkgConfFile pkgConfs - in (newPkgConfs ++) . extraPkgConfs dflags +addExtraPkgConfs :: [FilePath] -> DynFlags -> DynFlags +addExtraPkgConfs pkgConfs dflags = dflags + { packageDBFlags = + let newPkgConfs = map (PackageDB . PkgConfFile) pkgConfs + in newPkgConfs ++ packageDBFlags dflags } @@ -52,8 +51,8 @@ liftIO getSandboxDb >>= \case Nothing -> return dflags Just sandboxDB -> do - let pkgs = map PkgConfFile [sandboxDB] - return dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags } + let pkgs = map (PackageDB . PkgConfFile) [sandboxDB] + return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags } ------------------------ ---------- Stack project @@ -62,25 +61,24 @@ -- | Get path to the project's snapshot and local package DBs via 'stack path' getStackDb :: IO (Maybe [FilePath]) getStackDb = do - exists <- doesFileExist "stack.yaml" - if not exists - then return Nothing - else do - pathInfo <- readProcess "stack" ["path"] "" - return . Just . catMaybes $ map (flip extractKey pathInfo) ["local-pkg-db:", "snapshot-pkg-db:"] + pathInfo <- readProcess "stack" ["path"] "" `catch` (\(_e::IOException) -> return []) + return . Just . catMaybes $ map (flip extractKey pathInfo) + ["global-pkg-db:", "local-pkg-db:", "snapshot-pkg-db:"] updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags updateDynFlagsWithStackDB dflags = liftIO getStackDb >>= \case Nothing -> return dflags Just stackDBs -> do - let pkgs = map PkgConfFile stackDBs - return dflags { extraPkgConfs = (pkgs ++) . extraPkgConfs dflags } + let pkgs = map (PackageDB . PkgConfFile) stackDBs + return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags } updateDynFlagsWithGlobalDB :: MonadIO m => DynFlags -> m DynFlags updateDynFlagsWithGlobalDB dflags = do xs <- liftIO $ lines <$> readProcess "ghc" ["--print-global-package-db"] "" - `catch` (\(e :: SomeException) -> return []) + `catch` (\(_e :: SomeException) -> return []) case xs of - [pkgconf] -> return dflags { extraPkgConfs = (PkgConfFile pkgconf :) . extraPkgConfs dflags } + [pkgconf] -> do + let flgs = PackageDB (PkgConfFile pkgconf) : packageDBFlags dflags + return dflags { packageDBFlags = flgs } _ -> return dflags diff --git a/src/Halive/Recompiler.hs b/src/Halive/Recompiler.hs --- a/src/Halive/Recompiler.hs +++ b/src/Halive/Recompiler.hs @@ -3,24 +3,28 @@ module Halive.Recompiler where import Halive.SubHalive import Halive.FileListener - +import System.Mem import Control.Concurrent.STM import Control.Concurrent import Control.Monad.Trans import Control.Monad - +import Data.Text (Text) +import qualified Data.Text as Text +import Data.IORef +import Data.Typeable +import GHC data CompilationRequest = CompilationRequest - { crFilePath :: FilePath - , crExpressionString :: String - , crResultTChan :: TChan CompilationResult - , crFileContents :: Maybe String + { crFilePath :: FilePath + , crExpressionStrings :: [String] + , crResultTChan :: TChan CompilationResult + , crFileContents :: Maybe String -- ^ This is intentionally lazy, since we want to evaluate the string on -- the SubHalive thread (as it may be e.g. a TextSeq that needs conversion) -- In the future, we may want to pass GHC's StringBuffer type here instead, -- and construct those in a smarter way. } -type CompilationResult = Either [String] CompiledValue +type CompilationResult = Either String [CompiledValue] -- This is used to implement a workaround for the GHC API crashing -- when used after application startup, when it tries to load libraries @@ -34,6 +38,8 @@ ghcChan <- startGHC ghcSessionConfig action ghcChan +startGHCDefault :: MonadIO m => m (TChan CompilationRequest) +startGHCDefault = startGHC defaultGHCSessionConfig startGHC :: MonadIO m => GHCSessionConfig -> m (TChan CompilationRequest) startGHC ghcSessionConfig = liftIO $ do @@ -45,54 +51,79 @@ Nothing -> myThreadId initialFileLock <- liftIO newEmptyMVar + _ <- forkIO . void $ do - _ <- forkIO . void . withGHCSession mainThreadID ghcSessionConfig $ do + case gscKeepLibsInMemory ghcSessionConfig of - -- See SubHalive.hs:GHCSessionConfig - forM_ (gscStartupFile ghcSessionConfig) $ - \(startupFile, startupExpr) -> - recompileExpressionInFile startupFile Nothing startupExpr + -- In this mode we keep the ghc session alive continuously, + -- and process all compilation requests in it. + -- This trades possibly high memory usage for very fast compilation, + -- since libraries don't have to be loaded in repeatedly. + Always -> do - liftIO $ putMVar initialFileLock () - forever $ do - CompilationRequest{..} <- readTChanIO ghcChan - liftIO . putStrLn $ "SubHalive recompiling: " - ++ show (crFilePath, crExpressionString) + -- See SubHalive.hs:GHCSessionConfig + withGHCSession mainThreadID ghcSessionConfig $ do + compileInitialFile ghcSessionConfig + liftIO $ putMVar initialFileLock () - result <- recompileExpressionInFile - crFilePath crFileContents crExpressionString - writeTChanIO crResultTChan result + forever $ do + CompilationRequest{..} <- readTChanIO ghcChan - () <- liftIO $ takeMVar initialFileLock + result <- recompileExpressionsInFile + crFilePath crFileContents crExpressionStrings + writeTChanIO crResultTChan result + -- In this mode we create a fresh GHC session for each set of compilation + -- requests. This trades slower compilations for lower memory usage + -- when not compiling. + Opportunistic -> do + withGHCSession mainThreadID ghcSessionConfig $ + compileInitialFile ghcSessionConfig + liftIO $ putMVar initialFileLock () + + forever $ do + requests <- waitExhaustTChanIO ghcChan + + withGHCSession mainThreadID ghcSessionConfig $ + forM_ requests $ \CompilationRequest{..} -> do + result <- recompileExpressionsInFile + crFilePath crFileContents crExpressionStrings + writeTChanIO crResultTChan result + liftIO performGC + + -- Wait for the initial file to complete + () <- liftIO (takeMVar initialFileLock) + return ghcChan +compileInitialFile :: GHCSessionConfig -> Ghc () +compileInitialFile ghcSessionConfig = + forM_ (gscStartupFile ghcSessionConfig) $ + \(startupFile, startupExpr) -> + recompileExpressionsInFile startupFile Nothing [startupExpr] data Recompiler = Recompiler - { recResultTChan :: TChan CompilationResult + { recResultTChan :: TChan CompilationResult , recFileEventListener :: FileEventListener - , recListenerThread :: ThreadId + , recListenerThread :: ThreadId } recompilerForExpression :: MonadIO m => TChan CompilationRequest -> FilePath -> String - -> Bool -> m Recompiler -recompilerForExpression ghcChan filePath expressionString compileImmediately = +recompilerForExpression ghcChan filePath expressionString = recompilerWithConfig ghcChan RecompilerConfig { rccWatchAll = Nothing - , rccExpression = expressionString + , rccExpressions = [expressionString] , rccFilePath = filePath - , rccCompileImmediately = compileImmediately } data RecompilerConfig = RecompilerConfig { rccWatchAll :: Maybe (FilePath, [String]) -- if Nothing, just watch given file - , rccExpression :: String + , rccExpressions :: [String] , rccFilePath :: FilePath - , rccCompileImmediately :: Bool } recompilerWithConfig :: MonadIO m @@ -102,17 +133,12 @@ recompilerWithConfig ghcChan RecompilerConfig{..} = liftIO $ do resultTChan <- newTChanIO let compilationRequest = CompilationRequest - { crFilePath = rccFilePath - , crExpressionString = rccExpression - , crResultTChan = resultTChan - , crFileContents = Nothing + { crFilePath = rccFilePath + , crExpressionStrings = rccExpressions + , crResultTChan = resultTChan + , crFileContents = Nothing } - - -- Compile for the first time immediately - when rccCompileImmediately $ - writeTChanIO ghcChan compilationRequest - -- Recompile on file event notifications fileEventListener <- case rccWatchAll of Nothing -> eventListenerForFile rccFilePath JustReportEvents @@ -121,10 +147,13 @@ _ <- readFileEvent fileEventListener writeTChanIO ghcChan compilationRequest + -- Compile for the first time immediately + writeTChanIO ghcChan compilationRequest + return Recompiler - { recResultTChan = resultTChan + { recResultTChan = resultTChan , recFileEventListener = fileEventListener - , recListenerThread = listenerThread + , recListenerThread = listenerThread } killRecompiler :: MonadIO m => Recompiler -> m () @@ -138,4 +167,70 @@ -> m Recompiler renameRecompilerForExpression recompiler ghcChan filePath expressionString = do killRecompiler recompiler - recompilerForExpression ghcChan filePath expressionString False + recompilerForExpression ghcChan filePath expressionString + +compileExpressions :: MonadIO m + => TChan CompilationRequest + -> Text + -> [String] + -> m (TChan CompilationResult) +compileExpressions ghcChan code expressionStrings = do + resultTChan <- liftIO newTChanIO + liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest + { crFilePath = "" + , crExpressionStrings = expressionStrings + , crResultTChan = resultTChan + , crFileContents = Just $ Text.unpack code + } + return resultTChan + +compileExpression :: MonadIO m + => TChan CompilationRequest + -> Text + -> String + -> m (TChan CompilationResult) +compileExpression ghcChan code expressionString = + compileExpressions ghcChan code [expressionString] + +compileExpressionInFile :: MonadIO m + => TChan CompilationRequest + -> FilePath + -> String + -> m (TChan CompilationResult) +compileExpressionInFile ghcChan fileName expressionString = do + resultTChan <- liftIO newTChanIO + liftIO $ atomically $ writeTChan ghcChan $ CompilationRequest + { crFilePath = fileName + , crExpressionStrings = [expressionString] + , crResultTChan = resultTChan + , crFileContents = Nothing + } + return resultTChan + +-- | liveExpression returns an action to get to the latest version of the expression, +-- updating it whenever the code changes (unless there is an error). +-- It also takes a default argument to use until the first compilation completes. +-- The action is meant to be called before each use of the value. +liveExpression :: Typeable a + => TChan CompilationRequest + -> FilePath + -> String + -> a + -> IO (IO a) +liveExpression ghcChan fileName expression defaultVal = do + recompiler <- recompilerForExpression ghcChan fileName expression + valueRef <- newIORef defaultVal + _ <- forkIO . forever $ do + result <- atomically (readTChan (recResultTChan recompiler)) + case result of + Left errors -> putStrLn errors + Right values -> + case values of + [value] -> + case getCompiledValue value of + Just newVal -> writeIORef valueRef newVal + Nothing -> putStrLn ("Got incorrect type for " ++ fileName ++ ":" ++ expression) + _ -> + error "Unexpected number of values received on recResultTChan" + + return (readIORef valueRef) diff --git a/src/Halive/SubHalive.hs b/src/Halive/SubHalive.hs --- a/src/Halive/SubHalive.hs +++ b/src/Halive/SubHalive.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Halive.SubHalive ( @@ -25,10 +28,12 @@ import Outputable import StringBuffer ---import Packages +-- import Packages import Linker +#if __GLASGOW_HASKELL__ < 800 import Control.Monad +#endif import Control.Monad.IO.Class import Data.IORef import Data.Time @@ -38,10 +43,18 @@ import System.Signal import Data.Dynamic +import System.Directory +import System.FilePath +import Data.Time.Clock.POSIX + +import qualified Data.Text as Text + data FixDebounce = DebounceFix | NoDebounceFix deriving Eq data CompliationMode = Interpreted | Compiled deriving Eq +data KeepLibsInMemory = Always | Opportunistic + data GHCSessionConfig = GHCSessionConfig { gscFixDebounce :: FixDebounce , gscImportPaths :: [FilePath] @@ -49,215 +62,226 @@ , gscLibDir :: FilePath #if __GLASGOW_HASKELL__ >= 800 , gscLanguageExtensions :: [Extension] + , gscNoLanguageExtensions :: [Extension] #else , gscLanguageExtensions :: [ExtensionFlag] + , gscNoLanguageExtensions :: [ExtensionFlag] #endif , gscCompilationMode :: CompliationMode , gscStartupFile :: Maybe (FilePath, String) -- ^ Allow API users to block until a given file is compiled, - -- to work around a bug where the GHC API crashes while loading libraries - -- if the main thread is doing work (possibly due to accessing said libraries in some way) + -- to work around a bug where the GHC API crashes while + -- loading libraries if the main thread is doing work + -- (possibly due to accessing said libraries in some way) , gscVerbosity :: Int , gscMainThreadID :: Maybe ThreadId + , gscKeepLibsInMemory :: KeepLibsInMemory + -- ^ Chooses between keeping the GHC session alive continuously + -- (which uses a lot of memory but makes compilation fast) + -- or disposing of it between compilations + -- (which saves memory but slows compilation) + -- or keeping it around for sequences of compilations + -- (which lies in-between these) } - - defaultGHCSessionConfig :: GHCSessionConfig defaultGHCSessionConfig = GHCSessionConfig { gscFixDebounce = DebounceFix , gscImportPaths = [] , gscPackageDBs = [] , gscLanguageExtensions = [] + , gscNoLanguageExtensions = [] , gscLibDir = libdir , gscCompilationMode = Interpreted , gscStartupFile = Nothing , gscVerbosity = 0 , gscMainThreadID = Nothing + , gscKeepLibsInMemory = Always } ---pkgConfRefToString = \case --- GlobalPkgConf -> "GlobalPkgConf" --- UserPkgConf -> "UserPkgConf" --- PkgConfFile file -> "PkgConfFile " ++ show file - ---extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ [] - -logIO :: MonadIO m => String -> m () -logIO = liftIO . putStrLn - -- Starts up a GHC session and then runs the given action within it withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a withGHCSession mainThreadID GHCSessionConfig{..} action = do -- Work around https://ghc.haskell.org/trac/ghc/ticket/4162 - let - restoreControlC f = do - liftIO $ installHandler sigINT (\_signal -> killThread mainThreadID) + let restoreControlC f = do + liftIO $ installHandler sigINT + (\_signal -> killThread mainThreadID) f -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do runGhc (Just gscLibDir) . restoreControlC $ do - -- Get the default dynFlags - dflags0 <- getSessionDynFlags - -- Add passed-in package DBs - let dflags1 = addExtraPkgConfs dflags0 gscPackageDBs - -- If there's a sandbox, add its package DB - dflags2 <- updateDynFlagsWithCabalSandbox dflags1 - -- If this is a stack project, add its package DBs - dflags3 <- updateDynFlagsWithStackDB dflags2 - dflags4 <- updateDynFlagsWithGlobalDB dflags3 - -- Make sure we're configured for live-reload - let dflags5 = dflags4 { hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted - , optLevel = if gscCompilationMode == Compiled then 2 else 0 - , ghcLink = LinkInMemory - , ghcMode = CompManager - , importPaths = gscImportPaths - , objectDir = Just ".halive" - , hiDir = Just ".halive" - , stubDir = Just ".halive" - , dumpDir = Just ".halive" - , verbosity = gscVerbosity - } - -- turn off the GHCi sandbox - -- since it breaks OpenGL/GUI usage - `gopt_unset` Opt_GhciSandbox + -- initialFlags <- getSessionDynFlags + -- (newFlags, leftovers, warnings) <- parseDynamicFlagsCmdLine initialFlags [noLoc "-prof"] + -- setSessionDynFlags newFlags + -- liftIO $ print (compilerInfo newFlags) + + packageIDs <- + getSessionDynFlags + >>= updateDynFlagsWithGlobalDB + -- If this is a stack project, add its package DBs + >>= updateDynFlagsWithStackDB + -- If there's a sandbox, add its package DB + >>= updateDynFlagsWithCabalSandbox + -- Add passed-in package DBs + >>= (pure . addExtraPkgConfs gscPackageDBs) + -- Make sure we're configured for live-reload + >>= (\d -> pure d + { hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted + , optLevel = if gscCompilationMode == Compiled then 2 else 0 + , ghcLink = LinkInMemory + , ghcMode = CompManager + , importPaths = gscImportPaths + , objectDir = Just ".halive" + , hiDir = Just ".halive" + , stubDir = Just ".halive" + , dumpDir = Just ".halive" + , verbosity = gscVerbosity + }) + -- turn off the GHCi sandbox + -- since it breaks OpenGL/GUI usage + >>= (pure . (`gopt_unset` Opt_GhciSandbox)) + -- Allows us to work in dynamic executables + -- >>= (pure . (if dynamicGhc then addWay' WayDyn else id)) + -- >>= (pure . (addWay' WayProf)) + -- >>= (pure . (if rtsIsProfiled then addWay' WayProf else id)) + -- >>= (pure . (addWay' WayDyn)) -- GHC seems to try to "debounce" compilations within -- about a half second (i.e., it won't recompile) -- This fixes that, but probably isn't quite what we want -- since it will cause extra files to be recompiled... - dflags6 = if gscFixDebounce == DebounceFix - then dflags5 `gopt_set` Opt_ForceRecomp - else dflags5 - dflags7 = foldl xopt_set dflags6 gscLanguageExtensions + >>= (pure . (if gscFixDebounce == DebounceFix + then (`gopt_set` Opt_ForceRecomp) + else id)) + >>= (pure . flip (foldl xopt_unset) gscNoLanguageExtensions + . flip (foldl xopt_set) gscLanguageExtensions) + -- We must call setSessionDynFlags before calling initPackages or any other GHC API + >>= setSessionDynFlags - -- We must call setSessionDynFlags before calling initPackages or any other GHC API - packageIDs <- setSessionDynFlags dflags7 + -- Initialize the package database and dynamic linker. + -- Explicitly calling these avoids crashes on some of my machines. +#if __GLASGOW_HASKELL__ >= 800 + -- (dflags,_pkgs) <- liftIO . initPackages =<< getSessionDynFlags + -- setSessionDynFlags dflags + getSession >>= \hscEnv -> + liftIO $ linkPackages hscEnv packageIDs + liftIO . initDynLinker =<< getSession +#else + getSessionDynFlags >>= \dflags -> + liftIO $ linkPackages dflags packageIDs + liftIO . initDynLinker =<< getSessionDynFlags +#endif - -- Works around a yet-unidentified segfault when loading - -- 5/1/2016: I've implemented this in a different way, - -- (by just passing in a file to compile that will trigger - -- loads of all its dependencies) - -- but this is still a viable approach... not quite as convenient though! - --let gscPreloadPackagesForModules = ["Sound.Pd"] - --preloadPackageKeys <- forM gscPreloadPackagesForModules $ \modName -> - -- modulePackageKey <$> findModule (mkModuleName modName) Nothing - --let finalPackageIDs = preloadPackageKeys ++ packageIDs - let finalPackageIDs = packageIDs - --logIO $ "linkPackages: " ++ show (map packageKeyString finalPackageIDs) + result <- action - -- Initialize the package database and dynamic linker. - -- Explicitly calling these avoids crashes on some of my machines. + -- Unload libraries to keep from leaking memory & overloading the GC + getSession >>= \hscEnv -> + liftIO (unload hscEnv []) -#if __GLASGOW_HASKELL__ >= 800 - hscEnv1 <- getSession - liftIO $ linkPackages hscEnv1 finalPackageIDs - hscEnv2 <- getSession - liftIO (initDynLinker hscEnv2) -#else - dflags7 <- getSessionDynFlags - liftIO $ linkPackages dflags7 finalPackageIDs - dflags8 <- getSessionDynFlags - liftIO (initDynLinker dflags8) -#endif + return result - action --- See note below - this isn't actually called right now -gatherErrors :: GhcMonad m => SourceError -> m [String] -gatherErrors sourceError = do - printException sourceError - dflags <- getSessionDynFlags - let errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError) - errorStrings = map (showSDoc dflags) errorSDocs - return errorStrings ---newtype CompiledValue = CompiledValue HValue newtype CompiledValue = CompiledValue Dynamic deriving Show ---getCompiledValue :: CompiledValue -> a ---getCompiledValue (CompiledValue r) = unsafeCoerce r getCompiledValue :: Typeable a => CompiledValue -> Maybe a getCompiledValue (CompiledValue r) = fromDynamic r -fileContentsStringToBuffer :: (MonadIO m) => Maybe String -> m (Maybe (StringBuffer, UTCTime)) -fileContentsStringToBuffer mFileContents = forM mFileContents $ \fileContents -> do +fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime) +fileContentsStringToBuffer fileContents = do now <- liftIO getCurrentTime return (stringToStringBuffer fileContents, now) --- | We return the uncoerced HValue, which lets us send polymorphic values back through channels -recompileExpressionInFile :: FilePath -> Maybe String -> String -> Ghc (Either [String] CompiledValue) -recompileExpressionInFile fileName mFileContents expression = - -- NOTE: handleSourceError doesn't actually seem to do anything, and we use - -- the IORef + log_action solution instead. The API docs claim 'load' should - -- throw SourceErrors but it doesn't afaict. +createTempFile :: MonadIO m => m FilePath +createTempFile = liftIO $ do + tempDir <- getTemporaryDirectory + now <- show . diffTimeToPicoseconds . realToFrac <$> getPOSIXTime + let tempFile = tempDir "halive_" ++ now <.> "hs" + writeFile tempFile "" + return tempFile + +-- | Takes a filename, optionally its contents, and a list of expressions. +-- Returns a list of errors or a list of Dynamic compiled values +recompileExpressionsInFile :: FilePath + -> Maybe String + -> [String] + -> Ghc (Either String [CompiledValue]) +recompileExpressionsInFile fileName mFileContents expressions = + catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do - --logIO $ "Recompiling " ++ show (fileName, expression) - -- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files - -- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile - --logIO "guessTarget" - target <- guessTarget ('*':fileName) Nothing - mFileContentsBuffer <- fileContentsStringToBuffer mFileContents - --logIO "setTargets" - setTargets [target { targetContents = mFileContentsBuffer }] + -- Set up an error accumulator errorsRef <- liftIO (newIORef "") - dflags <- getSessionDynFlags - --logIO "setSessionDynFlags" - _ <- setSessionDynFlags dflags { log_action = logHandler errorsRef } + _ <- getSessionDynFlags >>= + \dflags -> setSessionDynFlags dflags + { log_action = logHandler errorsRef } - -- Get the dependencies of the main target - --logIO "depanal" - graph <- depanal [] False + mFileContentsBuffer <- mapM fileContentsStringToBuffer mFileContents - --logIO $ "Loading " ++ show (fileName, expression) + -- Set the target + (tempFileName, target) <- case fileName of + -- We'd like to just use a Module name for the target, + -- but load/depanal fails with "Foo is a package module" + -- We use a blank temp file as a workaround. + "" -> do + tempFileName <- createTempFile + (tempFileName,) <$> guessTarget' tempFileName + other -> ("",) <$> guessTarget' other + + -- logIO "Setting targets..." + setTargets [target { targetContents = mFileContentsBuffer }] + -- Reload the main target - --logIO "load LoadAllTargets" + -- logIO "Loading..." loadSuccess <- load LoadAllTargets - --logIO $ "Done loading " ++ show (fileName, expression) - if failed loadSuccess + if succeeded loadSuccess then do - errors <- liftIO (readIORef errorsRef) - return (Left [errors]) - else do - --logIO "typecheckModule" - -- We must parse and typecheck modules before they'll be available for usage - forM_ graph (typecheckModule <=< parseModule) - -- Load the dependencies of the main target + -- logIO "Analyzing deps..." + -- Get the dependencies of the main target (and update the session with them) + graph <- depanal [] False - -- This brings all top-level definitions into scope (whether exported or not), - -- but only works on interpreted modules - --setContext (IIModule . ms_mod_name <$> graph) + #if __GLASGOW_HASKELL__ >= 804 + let modSummaries = mgModSummaries graph + #else + let modSummaries = graph + #endif - setContext (IIDecl . simpleImportDecl . ms_mod_name <$> graph) + -- Load the dependencies of the main target + setContext + (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries) - --logIO $ "Compiling " ++ show (fileName, expression) - --result <- compileExpr expression - --logIO "dynCompileExpr" - result <- dynCompileExpr expression - --logIO $ "Done compiling " ++ show (fileName, expression) + -- Compile the expressions and return the results + results <- mapM dynCompileExpr expressions - return (Right (CompiledValue result)) + return (Right (CompiledValue <$> results)) + else do + -- Extract the errors from the accumulator + errors <- liftIO (readIORef errorsRef) + -- Strip out the temp file name when using anonymous code + let cleanErrors = if null tempFileName then errors + else Text.unpack $ + Text.replace + (Text.pack tempFileName) + "" + (Text.pack errors) + return (Left cleanErrors) -catchExceptions :: ExceptionMonad m => m (Either [String] a) -> m (Either [String] a) +-- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files +-- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile +guessTarget' :: GhcMonad m => String -> m Target +guessTarget' fileName = guessTarget ('*':fileName) Nothing + +catchExceptions :: ExceptionMonad m => m (Either String a) -> m (Either String a) catchExceptions a = gcatch a (\(_x :: SomeException) -> do liftIO (putStrLn ("Caught exception during recompileExpressionInFile: " ++ show _x)) - return (Left [show _x])) + return (Left (show _x)) + ) --- A helper from interactive-diagrams to print out GHC API values, --- useful while debugging the API. --- | Outputs any value that can be pretty-printed using the default style -output :: (GhcMonad m, Outputable a) => a -> m () -output a = do - dfs <- getSessionDynFlags - let style = defaultUserStyle - let cntx = initSDocContext dfs style - liftIO $ print $ runSDoc (ppr a) cntx logHandler :: IORef String -> LogAction #if __GLASGOW_HASKELL__ >= 800 @@ -276,3 +300,40 @@ locMsg = mkLocMessage severity srcSpan msg messageWithLocation = show (runSDoc locMsg cntx) messageOther = show (runSDoc msg cntx) + + + +-- A helper from interactive-diagrams to print out GHC API values, +-- useful while debugging the API. +-- | Outputs any value that can be pretty-printed using the default style +output :: (GhcMonad m, Outputable a) => a -> m () +output a = do + dfs <- getSessionDynFlags + let style = defaultUserStyle dfs + let cntx = initSDocContext dfs style + liftIO $ print $ runSDoc (ppr a) cntx + + +-- NOTE: handleSourceError (which calls gatherErrors above) +-- doesn't actually seem to do anything, so we use +-- the IORef + log_action solution instead. +-- The API docs claim 'load' should +-- throw SourceErrors but it doesn't afaict. +gatherErrors :: GhcMonad m => SourceError -> m String +gatherErrors sourceError = do + printException sourceError + dflags <- getSessionDynFlags + let errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError) + errorStrings = map (showSDoc dflags) errorSDocs + return (concat errorStrings) + + +--pkgConfRefToString = \case +-- GlobalPkgConf -> "GlobalPkgConf" +-- UserPkgConf -> "UserPkgConf" +-- PkgConfFile file -> "PkgConfFile " ++ show file + +--extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ [] + +logIO :: MonadIO m => String -> m () +logIO = liftIO . putStrLn diff --git a/src/Halive/Utils.hs b/src/Halive/Utils.hs --- a/src/Halive/Utils.hs +++ b/src/Halive/Utils.hs @@ -6,6 +6,13 @@ import Control.Monad.State import System.Environment +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Typeable +import Data.Dynamic + +type StoreMap = Map String Dynamic + isHaliveActive :: MonadIO m => m Bool isHaliveActive = liftIO $ do r <- lookupEnv "Halive Active" @@ -13,24 +20,49 @@ Just "Yes" -> return True _ -> return False --- | Takes a unique integer representing your value, +-- | Takes a unique name representing your value, -- along with an IO action to create the first instance -- of your value to be used on subsequent recompilations. -reacquire :: forall a m. (MonadIO m) => Word32 -> m a -> m a -reacquire storeID create = do - -- See if an existing store exists. - maybeStore <- liftIO (lookupStore storeID) :: m (Maybe (Store a)) - case maybeStore of +reacquire :: (Typeable a, MonadIO m) => String -> m a -> m a +reacquire name create = do + -- See if the value exists already + storeMap <- getStoreMap + case fromDynamic =<< Map.lookup name storeMap of -- If so, return the value inside - Just store -> liftIO (readStore store) + Just value -> return value -- Otherwise, create the value, store it, and return it. Nothing -> do value <- create - persist storeID value + persist name value return value -persist :: MonadIO m => Word32 -> a -> m () -persist storeID value = liftIO (writeStore (Store storeID) value) +persistState :: (MonadState s m, MonadIO m, Typeable s) => String -> m () +persistState name = persist name =<< get -persistState :: (MonadState s m, MonadIO m) => Word32 -> m () -persistState storeID = persist storeID =<< get +storeMapID :: Word32 +storeMapID = 0 + +getStoreMap :: MonadIO m => m StoreMap +getStoreMap = do + -- See if we've created the storeMap already + maybeStore <- liftIO (lookupStore storeMapID) + case maybeStore of + -- If so, return the existing storeMap inside + Just store -> liftIO (readStore store) + -- Otherwise, create the value, store it, and return it. + Nothing -> do + let storeMap = mempty + writeStoreMap storeMap + return storeMap + +modifyStoreMap :: MonadIO m => (StoreMap -> StoreMap) -> m () +modifyStoreMap f = do + storeMap <- getStoreMap + writeStoreMap (f storeMap) + +writeStoreMap :: MonadIO m => StoreMap -> m () +writeStoreMap = liftIO . writeStore (Store storeMapID) + +persist :: (Typeable a, MonadIO m) => String -> a -> m () +persist name value = + modifyStoreMap (Map.insert name (toDyn value)) diff --git a/test/TestCompileExpr.hs b/test/TestCompileExpr.hs new file mode 100644 --- /dev/null +++ b/test/TestCompileExpr.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Concurrent.STM +import Halive + +main :: IO () +main = do + + ghc <- startGHC defaultGHCSessionConfig + resultChan <- compileExpression ghc + "main = print 123456789" + "main" + result <- atomically (readTChan resultChan) + putStrLn "Got result:" + print result diff --git a/test/TestGHC.hs b/test/TestGHC.hs new file mode 100644 --- /dev/null +++ b/test/TestGHC.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +import GHC.Paths +import GHC +import DynFlags +import Linker +import Control.Monad.IO.Class +import Data.Time.Clock.POSIX +import Data.Time +import StringBuffer +import Data.Dynamic +import System.Directory +import System.FilePath + +logIO :: MonadIO m => String -> m () +logIO = liftIO . putStrLn + +withGHC :: Ghc a -> IO a +withGHC action = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do + + packageIDs <- + getSessionDynFlags + >>= (\d -> pure d + { ghcLink = LinkInMemory + , ghcMode = CompManager + , hscTarget = HscAsm + , optLevel = 2 + , verbosity = 0 + }) + -- turn off the GHCi sandbox + -- since it breaks OpenGL/GUI usage + >>= (pure . (`gopt_unset` Opt_GhciSandbox)) + >>= (pure . (if dynamicGhc then addWay' WayDyn else id)) + -- We must call setSessionDynFlags before calling initPackages or any other GHC API + >>= setSessionDynFlags + + getSession >>= \hscEnv -> + liftIO $ linkPackages hscEnv packageIDs + liftIO . initDynLinker =<< getSession + + action + +fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime) +fileContentsStringToBuffer fileContents = do + now <- liftIO getCurrentTime + return (stringToStringBuffer fileContents, now) + +ourFile :: String +ourFile = unlines + [ "main = print $ 123456789" + ] + +main :: IO () +main = withGHC $ do + logIO "" + logIO "Starting..." + + let expression = "main" + fileContents <- fileContentsStringToBuffer ourFile + + -- Set the target + + -- Create a dummy temporary file to sate GHC's desires for one, + -- even though we're passing it the text as a buffer. + tempDir <- liftIO $ getTemporaryDirectory + now <- show . diffTimeToPicoseconds . realToFrac <$> liftIO getPOSIXTime + let tempFile = tempDir "halive_" ++ now <.> "hs" + liftIO $ writeFile tempFile "" + + target <- guessTarget tempFile Nothing + + logIO "Setting targets..." + setTargets [target { targetContents = Just fileContents }] + + -- logIO "Dep analysis..." + -- graph <- depanal [mkModuleName "Main"] False + + -- Reload the main target + logIO "Loading..." + -- setContext $ [ IIModule . mkModuleName $ "Main" ] + loadSuccess <- load LoadAllTargets + + if succeeded loadSuccess + then do + + logIO "Analyzing deps..." + -- Get the dependencies of the main target (and update the session with them) + graph <- depanal [] False + -- -- We must parse and typecheck modules before they'll be available for usage + -- forM_ graph (typecheckModule <=< parseModule) + + #if __GLASGOW_HASKELL__ >= 804 + let modSummaries = mgModSummaries graph + #else + let modSummaries = graph + #endif + + -- Load the dependencies of the main target + setContext + (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries) + + -- Compile the expression and return the result + result <- dynCompileExpr expression + + case fromDynamic result of + Just a -> liftIO (a :: IO ()) + Nothing -> return () + -- liftIO (print result) + else do + return () + diff --git a/test/TestSubhalive.hs b/test/TestSubhalive.hs --- a/test/TestSubhalive.hs +++ b/test/TestSubhalive.hs @@ -7,8 +7,8 @@ main = do ghc <- startGHC defaultGHCSessionConfig - fooRecompiler <- recompilerForExpression ghc "test/TestFileFoo.hs" "foo" True - barRecompiler <- recompilerForExpression ghc "test/TestFileBar.hs" "bar" True + fooRecompiler <- recompilerForExpression ghc "test/TestFileFoo.hs" "foo" + barRecompiler <- recompilerForExpression ghc "test/TestFileBar.hs" "bar" forever $ do result <- atomically @@ -16,9 +16,10 @@ `orElse` readTChan (recResultTChan barRecompiler)) case result of - Left errors -> putStrLn (concat errors) - Right value -> case getCompiledValue value of - Just value -> do - putStrLn value - Nothing -> do - putStrLn "Error: foo or bar was not of type String" + Left errors -> putStrLn errors + Right values -> forM_ values $ \value -> + case getCompiledValue value of + Just v -> + putStrLn v + Nothing -> + putStrLn "Error: foo or bar was not of type String" diff --git a/test/unit/Halive/ArgsSpec.hs b/test/unit/Halive/ArgsSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Halive/ArgsSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Halive.ArgsSpec where + +import Test.Hspec +import Halive.Args +import Data.Maybe +import Data.Foldable + +deriving instance Show Args + +spec :: Spec +spec = + describe "Args.parseArgs" $ do + + describe "mainfile" $ do + it "is required" $ + forM_ + [ "" + , "-f filetype" + , "-f filetype -- targetArg" + , "-- targetArg" + ] $ \args -> parseArgs (words args) `shouldSatisfy` isNothing + + it "can be parsed" $ + case parseArgs (words "mainfile") of + Just Args {..} -> mainFileName `shouldBe` "mainfile" + + describe "include dirs" $ do + it "are optional" $ + forM_ + [ "mainfile" + , "mainfile -f filetype" + , "mainfile -- targetArg" + ] $ \args -> case parseArgs (words args) of + Just Args {..} -> includeDirs `shouldBe` [] + + it "can be parsed" $ + forM_ + [ "mainfile include1 include2" + , "mainfile include1 -f filetype include2" + , "mainfile include1 include2 -- targerArg" + ] $ \args -> case parseArgs (words args) of + Just Args {..} -> includeDirs `shouldMatchList` ["include1", "include2"] + + describe "file types" $ do + it "are optional" $ + case parseArgs (words "mainfile") of + Just Args {..} -> fileTypes `shouldBe` [] + + it "can be specified in any position" $ + case parseArgs (words "-f 1 mainfile -f 2 includedir -f 3") of + Just Args {..} -> fileTypes `shouldMatchList` ["1", "2", "3"] + + it "can be parsed using -f" $ + case parseArgs (words "mainfile -f filetype") of + Just Args {..} -> fileTypes `shouldBe` ["filetype"] + + it "can be parsed using --file-type" $ + case parseArgs (words "mainfile --file-type filetype") of + Just Args {..} -> fileTypes `shouldBe` ["filetype"] + + it "can't be parsed when flag is misused" $ + forM_ + [ "mainfile -f" + , "mainfile -f --" + , "mainfile -f -- x" + ] $ \args -> parseArgs (words args) `shouldSatisfy` isNothing + + describe "target args" $ do + it "are optional" $ + case parseArgs (words "mainfile") of + Just Args {..} -> targetArgs `shouldBe` [] + + it "capture everything after `--`" $ + case parseArgs (words "mainfile -- -f a b c") of + Just Args {..} -> targetArgs `shouldBe` ["-f", "a", "b", "c"] diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Spec.hs @@ -0,0 +1,2 @@ +-- preprocessor for discovering spec files +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}