live-reload a file containing a (Float -> Picture) expression

GhcidForGloss.hs

-- in response to https://www.reddit.com/r/haskell/comments/e3mm0k/options_for_interactive_haskell/

-- gloss can be used to interactively define animations, but you have to jump
-- through a number of hoops. Usually, interactively defining haskell programs
-- is easy: run @ghcid --test=main@ in a different terminal, and it will
-- re-compile and re-run (if there are no parse/type errors) your program
-- everytime you save the source file. Unfortunately, ghci and ghcid run their
-- expressions in a separate thread, but on some platforms such as macOS, gloss
-- can only run from the main thread! So we have to write a simple variant of
-- ghcid which runs gloss on the main thread and only reloads the portion of the
-- code which defines the animation. If you want to make a change to the gloss
-- part, e.g. change the size of the window, you have to turn the program off
-- and on again.
--
-- For the same reason, this program must be compiled, it cannot run in
-- interpreted mode. I tested it with stack's lts-11.22:
--   * base-4.10.1.0
--   * directory-1.3.0.2
--   * fsnotify-0.2.1.1
--   * gloss-1.11.1.1
--   * hint-0.7.0
--
-- You also need a file called "Animation.hs" in the current folder:
--
--     $ cat Animation.hs
--     \t -> let secondsPerCycle = 2
--               wave = sin (2 * pi * t / secondsPerCycle)
--               wave01 = (wave + 1) / 2
--               picture = circle (10 + 90 * wave01)
--           in picture
-- 
-- It doesn't have to be exactly this contents, it can be any expression of
-- type (Float -> Picture). The point of the demo is that you can edit this
-- file and the window will live-reload its animation to match.
{-# LANGUAGE RecursiveDo #-}
module Main where

import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Graphics.Gloss (Picture, Display(InWindow), white)
import Graphics.Gloss.Interface.IO.Animate (animateIO)
import Language.Haskell.Interpreter (runInterpreter, setImports, interpret, as)
import System.FSNotify (WatchManager, Event(Modified), withManager, watchDir)
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>), takeDirectory)


-- fsnotify's API only supports watching folders for some reason.
watchFile :: WatchManager -> FilePath -> IO () -> IO ()
watchFile watchManager watchedFile action = mdo
  stopListening <- watchDir watchManager watchedDir isWatchedFile $ \_ -> do
    stopListening
    action

    -- After running the action a few times, 'watchDir' mysteriously stops
    -- calling it even though 'isWatchedFile' returns True. I managed to work
    -- around this bug by calling 'stopListening' and starting 'watchDir' anew
    -- every time.
    watchFile watchManager watchedFile action
  pure ()
  where
    watchedDir :: FilePath
    watchedDir = takeDirectory watchedFile

    isWatchedFile :: Event -> Bool
    isWatchedFile (Modified modifiedFile _) = modifiedFile == watchedFile
    isWatchedFile _                         = False


type Animation = Float -> Picture

-- Using the "hint" library to interpret the contents of "Animation.hs" as an
-- expression of type (Float -> Picture). Parse errors and type errors are
-- printed to stdout.
load :: FilePath -> IO (Maybe Animation)
load animationFile = do
  putStrLn $ "Loading " ++ animationFile
  animationSource <- readFile animationFile
  result <- runInterpreter $ do
    setImports ["Prelude", "Graphics.Gloss"]
    interpret animationSource (as :: Animation)
  case result of
    Left err -> do
      print err
      pure Nothing
    Right animation -> do
      pure (Just animation)

-- Only change the animation if "Animation.hs" has no parse/type errors.
reload :: IORef Animation -> FilePath -> IO ()
reload animationRef animationFile = do
  maybeAnimation <- load animationFile
  mapM_ (writeIORef animationRef) maybeAnimation

-- Draw the current frame of the current animation. Note that time does _not_
-- reset when we reload, so if you're animating, say, a planet which orbits
-- around a sun and you change the color of the planet, the planet will simply
-- change its color, it won't also reset to the position it had at t0.
render :: IORef Animation -> Float -> IO Picture
render animationRef t = do
  animation <- readIORef animationRef
  pure (animation t)

main :: IO ()
main = do
  pwd <- getCurrentDirectory
  let animationFile = pwd </> "Animation.hs"

  initialAnimation <- fromMaybe mempty <$> load animationFile
  animationRef <- newIORef initialAnimation

  withManager $ \watchManager -> do
    watchFile
      watchManager
      animationFile
      (reload animationRef animationFile)

    animateIO
      (InWindow "" (320,240) (0,0))
      white
      (render animationRef)
      mempty