~jack/misc

c593536581351553a78faed85ecc7207f6d4518a — Jack Kelly 7 months ago f6ecdd0
Stop using fan to select fsnotify modification events
2 files changed, 6 insertions(+), 58 deletions(-)

M consengine/src/Reflex/FSNotify.hs
M consengine/src/Shader.hs
M consengine/src/Reflex/FSNotify.hs => consengine/src/Reflex/FSNotify.hs +1 -57
@@ 1,66 1,10 @@
{-# OPTIONS_GHC -Wno-unused-matches #-}

{-# LANGUAGE GADTs           #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE TemplateHaskell #-}

module Reflex.FSNotify
  ( FSEvent(..)
  , watchDir
  , fanFSEvent
  -- * Lenses
  , fsAdded
  , fsModified
  , fsRemoved
  , fsUnknown
  ) where
module Reflex.FSNotify (watchDir) where

import           Control.Lens.TH (makeLenses)
import qualified Data.Dependent.Map as DMap
import           Data.Dependent.Sum ((==>))
import           Data.Functor ((<&>))
import           Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
import           Data.GADT.Show.TH (deriveGShow)
import           Data.Time.Clock (UTCTime)
import           Reflex
import qualified System.FSNotify as FS

data FSEvent t = FSEvent
  { _fsAdded :: Event t (FilePath, UTCTime, Bool)
  , _fsModified :: Event t (FilePath, UTCTime, Bool)
  , _fsRemoved :: Event t (FilePath, UTCTime, Bool)
  , _fsUnknown :: Event t (FilePath, UTCTime, String)
  }

$(makeLenses ''FSEvent)

data EventTag a where
  AddedTag :: EventTag (FilePath, UTCTime, Bool)
  ModifiedTag :: EventTag (FilePath, UTCTime, Bool)
  RemovedTag :: EventTag (FilePath, UTCTime, Bool)
  UnknownTag :: EventTag (FilePath, UTCTime, String)

$(deriveGEq ''EventTag)
$(deriveGCompare ''EventTag)
$(deriveGShow ''EventTag)

fanFSEvent :: Reflex t => Event t FS.Event -> FSEvent t
fanFSEvent fsEvent =
  let
    tagged = fsEvent <&> \ev -> DMap.fromList . pure $ case ev of
      FS.Added path time isDir -> AddedTag ==> (path, time, isDir)
      FS.Modified path time isDir -> ModifiedTag ==> (path, time, isDir)
      FS.Removed path time isDir -> RemovedTag ==> (path, time, isDir)
      FS.Unknown path time msg -> UnknownTag ==> (path, time, msg)

    fanned = fan tagged
  in FSEvent
     { _fsAdded = fanned `select` AddedTag
     , _fsModified = fanned `select` ModifiedTag
     , _fsRemoved = fanned `select` RemovedTag
     , _fsUnknown = fanned `select` UnknownTag
     }

watchDir
  :: TriggerEvent t m
  => FS.WatchManager -> FilePath -> m (Event t FS.Event)

M consengine/src/Shader.hs => consengine/src/Shader.hs +5 -1
@@ 114,8 114,12 @@ watchShaderProgram manager dir vsFileRel fsFileRel = do
  fsInitial <- liftIO $ B.readFile fsFileAbs

  -- Watch the dir for changes to the file we're interested in
  eDirChanges <- fmap (view _1) . _fsModified . fanFSEvent
  let
    onlyModifications (FS.Modified path mtime isDir) = Just (path, mtime, isDir)
    onlyModifications _ = Nothing
  eDirChanges <- fmap (view _1) . mapMaybe onlyModifications
    <$> watchDir manager (toFilePath dir)

  let
    eVsChanges = filter (vsFileAbs ==) eDirChanges
    eFsChanges = filter (fsFileAbs ==) eDirChanges