diff --git a/posix/Reanimate/FileWatch.hs b/posix/Reanimate/FileWatch.hs deleted file mode 100644 --- a/posix/Reanimate/FileWatch.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Reanimate.FileWatch - ( watchFile ) where - -import Control.Concurrent -import System.Directory - -watchFile :: FilePath -> IO () -> IO () -watchFile path handler = do - t0 <- getModificationTime path - forkIO $ loop t0 - return () - where - loop lastModTime = do - t1 <- getModificationTime path - if t1 /= lastModTime - then handler >> loop t1 - else threadDelay (10^3 * delay) >> loop lastModTime - delay = 1000 -- pool delay in ms. diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 0.1.4.0 +version: 0.1.4.1 -- synopsis: -- description: license: PublicDomain @@ -32,9 +32,6 @@ Type: git Location: git://github.com/lemmih/reanimate.git -Flag inotify - Description: Enable file watching using linux's inotify - library hs-source-dirs: src default-language: Haskell2010 @@ -51,7 +48,6 @@ Reanimate.Misc other-modules: Reanimate.Svg.NamedColors Reanimate.Cache - Reanimate.FileWatch Paths_reanimate build-depends: base >=4.10 && <4.13, time, text, unix, filepath, process, directory, @@ -59,13 +55,7 @@ JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg, diagrams-core, diagrams-lib, diagrams-contrib, svg-builder, matrices, cubicbezier, palette, websockets, - hashable - if os(linux) && flag(inotify) - hs-source-dirs: unix - build-depends: hinotify - else - hs-source-dirs: posix - + hashable, fsnotify Flag server Description: Enable rendering server diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -1,28 +1,31 @@ module Reanimate.Driver ( reanimate ) where -import Control.Concurrent (MVar, forkIO, killThread, modifyMVar_, - newEmptyMVar, putMVar) -import Control.Monad.Fix (fix) -import qualified Data.Text as T +import Control.Concurrent (MVar, forkIO, killThread, modifyMVar_, + newEmptyMVar, putMVar) +import Control.Exception (finally) +import Control.Monad.Fix (fix) +import qualified Data.Text as T import Network.WebSockets -import Reanimate.FileWatch (watchFile) -import System.Directory (findFile, listDirectory, findExecutable) -import System.Environment (getArgs, getProgName) -import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, - stderr, stdin) +import System.Directory (findExecutable, findFile, listDirectory) +import System.Environment (getArgs, getProgName) +import System.FilePath +import System.FSNotify +import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, + stderr, stdin) import Data.Maybe import Paths_reanimate -import Reanimate.Misc (runCmd, runCmdLazy, runCmd_, withTempDir, - withTempFile) -import Reanimate.Monad (Animation) -import Reanimate.Render (renderSvgs) +import Reanimate.Misc (runCmd, runCmdLazy, runCmd_, withTempDir, + withTempFile) +import Reanimate.Monad (Animation) +import Reanimate.Render (renderSvgs) opts = defaultConnectionOptions { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate } reanimate :: Animation -> IO () reanimate animation = do + watch <- startManager args <- getArgs hSetBuffering stdin NoBuffering case args of @@ -67,13 +70,17 @@ loop (frame : acc) return tid putStrLn "Found self. Listening." - watchFile self handler + stop <- watchFile watch self handler putMVar slave =<< forkIO (return ()) let loop = do fps <- receiveData conn :: IO T.Text handler loop - loop + loop `finally` stop + +watchFile watch file action = watchDir watch (takeDirectory file) check (const action) + where + check event = takeFileName (eventPath event) == takeFileName file ghcOptions :: FilePath -> [String] ghcOptions tmpDir = diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Reanimate.Svg where import Codec.Picture (PixelRGBA8 (..)) @@ -494,3 +495,50 @@ if n `elem` target then return $ fn t else return t + +pathify :: Tree -> Tree +pathify = mapTree worker + where + worker = + \case + RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> + PathTree $ defaultSvg + & drawAttributes .~ rect ^. drawAttributes & strokeLineCap .~ pure CapSquare + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 x y] + ,HorizontalTo OriginRelative [w] + ,VerticalTo OriginRelative [h] + ,HorizontalTo OriginRelative [-w] + ,EndPath ] + LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -> + PathTree $ defaultSvg + & drawAttributes .~ line ^. drawAttributes + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 x1 y1] + ,LineTo OriginAbsolute [V2 x2 y2] ] + CircleTree circ | Just (x, y, r) <- unpackCircle circ -> + PathTree $ defaultSvg + & drawAttributes .~ circ ^. drawAttributes + & pathDefinition .~ + [MoveTo OriginAbsolute [V2 (x-r) y] + ,EllipticalArc OriginRelative [(r, r, 0,True,False,(V2 (r*2) 0)) + ,(r, r, 0,True,False,(V2 (-r*2) 0))]] + t -> t + unpackCircle circ = do + let (x,y) = circ ^. circleCenter + liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) + unpackLine line = do + let (x1,y1) = line ^. linePoint1 + (x2,y2) = line ^. linePoint2 + liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2) + unpackRect rect = do + let (x', y') = rect ^. rectUpperLeftCorner + x <- unpackNumber x' + y <- unpackNumber y' + w <- unpackNumber =<< rect ^. rectWidth + h <- unpackNumber =<< rect ^. rectHeight + return (x,y,w,h) + unpackNumber n = + case toUserUnit defaultDPI n of + Num d -> Just d + _ -> Nothing diff --git a/unix/Reanimate/FileWatch.hs b/unix/Reanimate/FileWatch.hs deleted file mode 100644 --- a/unix/Reanimate/FileWatch.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Reanimate.FileWatch - ( watchFile ) where - -import System.INotify - -watchFile :: FilePath -> IO () -> IO () -watchFile path handler = do - notify <- initINotify - addWatch notify [Modify] path (const handler) - return ()