halive 0.1.3 → 0.1.5
raw patch · 18 files changed
+959/−343 lines, 18 filesdep +hspecdep +lensdep +pretty-showdep ~base
Dependencies added: hspec, lens, pretty-show
Dependency ranges changed: base
Files
- demo/Cube.hs +28/−27
- demo/Main.hs +50/−8
- demo/Shader.hs +6/−6
- demo/Window.hs +27/−0
- exec/HaliveMain.hs +25/−23
- halive.cabal +87/−37
- src/Halive.hs +4/−0
- src/Halive/Args.hs +65/−0
- src/Halive/FileListener.hs +57/−24
- src/Halive/FindPackageDBs.hs +16/−18
- src/Halive/Recompiler.hs +136/−41
- src/Halive/SubHalive.hs +200/−139
- src/Halive/Utils.hs +44/−12
- test/TestCompileExpr.hs +14/−0
- test/TestGHC.hs +110/−0
- test/TestSubhalive.hs +9/−8
- test/unit/Halive/ArgsSpec.hs +79/−0
- test/unit/Spec.hs +2/−0
demo/Cube.hs view
@@ -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- } + }
demo/Main.hs view
@@ -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
demo/Shader.hs view
@@ -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 ()
demo/Window.hs view
@@ -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++
exec/HaliveMain.hs view
@@ -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 <main.hs> <include dir> [-- <args to myapp>]"- (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 ()"-
halive.cabal view
@@ -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 <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 <https://github.com/lukexi/halive/blob/master/README.md README> 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+
+ src/Halive.hs view
@@ -0,0 +1,4 @@+module Halive (module Exports) where++import Halive.Recompiler as Exports+import Halive.SubHalive as Exports
+ src/Halive/Args.hs view
@@ -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 <main.hs> [<include dir>] [-f|--file-type <file type>] [-- <args to myapp>]\n\+ \\n\+ \Available options:\n\+ \ -f, --file-type <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'+ }+
src/Halive/FileListener.hs view
@@ -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
src/Halive/FindPackageDBs.hs view
@@ -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
src/Halive/Recompiler.hs view
@@ -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)
src/Halive/SubHalive.hs view
@@ -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)+ "<anonymous code>"+ (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
src/Halive/Utils.hs view
@@ -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))
+ test/TestCompileExpr.hs view
@@ -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
+ test/TestGHC.hs view
@@ -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 ()+
test/TestSubhalive.hs view
@@ -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"
+ test/unit/Halive/ArgsSpec.hs view
@@ -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"]
+ test/unit/Spec.hs view
@@ -0,0 +1,2 @@+-- preprocessor for discovering spec files+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}