diff --git a/examples/decompose.hs b/examples/decompose.hs new file mode 100644 --- /dev/null +++ b/examples/decompose.hs @@ -0,0 +1,69 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Main(main) where + +import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate') +import Control.Lens +import Control.Monad +import qualified Data.CircularSeq as C +import qualified Data.Geometry as Geo +import Data.Geometry.PlanarSubdivision (PolygonFaceData (..)) +import qualified Data.Geometry.Point as Geo +import qualified Data.Geometry.Polygon as Geo +import qualified Data.PlaneGraph as Geo +import Data.Proxy +import Graphics.SvgTree.Types +import Linear.V2 +import Reanimate +import Reanimate.Builtin.Documentation +import Reanimate.PolyShape + +import Data.Ext +import Data.List +import qualified Data.Vector as V + +scaleP n = lowerTransformations . scale n + +env = addStatic (mkBackground "white") . + mapA (withFillOpacity 0 . withStrokeColor "black" . withStrokeWidth (defaultStrokeWidth*0.1)) + +main :: IO () +main = reanimate $ env $ scene $ do + let --svg = scaleP 4 $ center $ latex "$F=ma$" + svg = scaleP 4 $ center $ latex "$\\infty$" + withHoles :: [PolyShapeWithHoles] + withHoles = plGroupShapes . unionPolyShapes $ svgToPolyShapes svg + hpoly = map toPoly withHoles + rects :: [[RPoint]] + rects = concatMap decomposeP hpoly + -- newSpriteSVG_ $ scaleP 4 $ center $ latex "$F=ma$" + forM_ rects $ \rect -> do + newSpriteSVG_ $ mkLinePathClosed [ (x, y) | V2 x y <- rect ] + wait (1/60) + wait 1 + + +-- map (decomposePolygon . plPolygonify 1 . mergePolyShapeHoles) $ plGroupShapes $ unionPolyShapes $ svgToPolyShapes $ latex "I" + +toPoly :: PolyShapeWithHoles -> Geo.Polygon Geo.Multi () Double +toPoly (PolyShapeWithHoles outer holes) = Geo.MultiPolygon + (toSeq outer) + (map (Geo.SimplePolygon . toSeq) holes) + where + tol = 0.001 + toSeq p = C.fromList $ + [ Geo.Point2 x y :+ () + | V2 x y <- init $ plPolygonify tol p ] + + +decomposeP :: Geo.Polygon Geo.Multi () Double -> [[RPoint]] +decomposeP poly = + [ [ V2 x y + | v <- V.toList (Geo.boundaryVertices f pg) + , let Geo.Point2 x y = pg^.Geo.vertexDataOf v . Geo.location ] + | (f, Inside) <- V.toList (Geo.internalFaces pg) ] + + where + pg = triangulate' Proxy poly diff --git a/examples/expression.hs b/examples/expression.hs new file mode 100644 --- /dev/null +++ b/examples/expression.hs @@ -0,0 +1,101 @@ +#!/usr/bin/env stack +-- stack runghc --package reanimate +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Picture (PixelRGBA8 (PixelRGBA8)) +import Control.Arrow ((&&&)) +import Control.Lens ((.~)) +import Control.Monad (when) +import Data.Foldable (forM_) +import qualified Data.Text as T +import Reanimate +import Reanimate.Builtin.Documentation (docEnv) +import Reanimate.LaTeX (mathChunks) +import Reanimate.Scene + +import Data.Bifoldable (Bifoldable (..), biforM_) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bitraversable (Bitraversable (..)) + +data Expr op v + = Var v + | BinOp (Expr op v) op (Expr op v) + | Paren op (Expr op v) op + deriving (Show, Eq) + +data Op = Add | Minus | LeftParen | RightParen deriving (Show, Eq) + +oNewExpr :: Scene s (Expr (Op, Object s SVG) (T.Text, Object s SVG)) +oNewExpr = bothAlongside (mapM (oNew . translate (-4) 0 . scale 2) . mathChunks) + $ bimap (id &&& op2LaTeX) (id &&& id) expr + where bothAlongside f = fmap runBiAlongside . fmap runBoth . f . Both . BiAlongside + expr = Var "x" `minus` paren (Var "y" `add` Var "x") + +main :: IO () +main = reanimate $ docEnv $ mapA (withFillOpacity 1 . withStrokeWidth 0) $ scene $ do + expr <- oNewExpr + forM_ (Both $ BiAlongside expr) (`oShowWith` oDraw) + let changeColor t = oContext .~ withFillColorPixel (PixelRGBA8 (round (t * 255)) 0 0 255) + let changeColorRev t = changeColor (1 - t) + waitOn $ biforM_ expr pure $ \(x, o) -> + when (x == "x") $ fork $ do + oTween o 1 changeColor + oTween o 1 changeColorRev + forM_ (Both $ BiAlongside expr) (fork . (`oHideWith` oFadeOut)) + +-- Some supportive functions. + +add, minus :: Expr Op v -> Expr Op v -> Expr Op v +add x y = BinOp x Add y +minus x y = BinOp x Minus y + +paren :: Expr Op v -> Expr Op v +paren x = Paren LeftParen x RightParen + +op2LaTeX :: Op -> T.Text +op2LaTeX Add = "+" +op2LaTeX Minus = "-" +op2LaTeX LeftParen = "(" +op2LaTeX RightParen = ")" + +-- Some supportive types and instances. + +instance Bifunctor Expr where + bimap _ g (Var x) = Var (g x) + bimap f g (BinOp x op y) = BinOp (bimap f g x) (f op) (bimap f g y) + bimap f g (Paren l x r) = Paren (f l) (bimap f g x) (f r) + +instance Bifoldable Expr where + bifoldMap _ g (Var x) = g x + bifoldMap f g (BinOp x op y) = bifoldMap f g x <> f op <> bifoldMap f g y + bifoldMap f g (Paren l x r) = f l <> bifoldMap f g x <> f r + +instance Bitraversable Expr where + bitraverse _ g (Var x) = Var <$> g x + bitraverse f g (BinOp x op y) = BinOp <$> bitraverse f g x <*> f op <*> bitraverse f g y + bitraverse f g (Paren l x r) = Paren <$> f l <*> bitraverse f g x <*> f r + +-- | Given a bifunctor @f@, make a functor @Both f@ where @Both f a ~ f a a@. +newtype Both f a = Both { runBoth :: f a a } + +instance Bifunctor p => Functor (Both p) where + fmap f = Both . bimap f f . runBoth + +instance Bifoldable p => Foldable (Both p) where + foldMap f = bifoldMap f f . runBoth + +instance Bitraversable p => Traversable (Both p) where + traverse f = fmap Both . bitraverse f f . runBoth + +-- | Make a bifunctor @f (a, -) (b, -)@ (namely @BiAlongside a b f@) out of @f@. +newtype BiAlongside a b f x y = BiAlongside { runBiAlongside :: f (a, x) (b, y) } + +instance Bifunctor p => Bifunctor (BiAlongside a b p) where + bimap f g = BiAlongside . bimap (second f) (second g) . runBiAlongside + +instance Bifoldable p => Bifoldable (BiAlongside a b p) where + bifoldMap f g = bifoldMap (f . snd) (g . snd) . runBiAlongside + +instance Bitraversable p => Bitraversable (BiAlongside a b p) where + bitraverse f g = fmap BiAlongside . bitraverse (traverse f) (traverse g) . runBiAlongside diff --git a/reanimate.cabal b/reanimate.cabal --- a/reanimate.cabal +++ b/reanimate.cabal @@ -3,7 +3,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate -version: 1.1.2.1 +version: 1.1.3.0 -- synopsis: -- description: license: PublicDomain @@ -39,6 +39,11 @@ library hs-source-dirs: src + if os(windows) + hs-source-dirs: windows + else + hs-source-dirs: unix + build-depends: unix default-language: Haskell2010 default-extensions: PackageImports, PatternSynonyms exposed-modules: Reanimate @@ -91,13 +96,14 @@ Reanimate.Driver.CLI Reanimate.Driver.Magick Reanimate.Driver.Server - Reanimate.Driver.Compile + Reanimate.Driver.Daemon Reanimate.Misc Paths_reanimate Reanimate.Scene.Core Reanimate.Scene.Var Reanimate.Scene.Sprite Reanimate.Scene.Object + Detach autogen-modules: Paths_reanimate build-depends: base >=4.10 && <5, @@ -119,7 +125,6 @@ fingertree >=0.1.0.0, fsnotify >=0.3.0.1, geojson >=3.0.4, - ghcid >=0.7, hashable >=1.3.0.0, hgeometry >=0.11.0.0, hgeometry-combinatorial >=0.11.0.0, @@ -145,8 +150,10 @@ websockets >=0.12.7.0, xml >=1.3.14, cryptohash-sha256, - base64-bytestring + base64-bytestring, + network >=3.1.0.0 ghc-options: -Wall -fno-ignore-asserts + test-suite spec type: exitcode-stdio-1.0 diff --git a/src/Reanimate.hs b/src/Reanimate.hs --- a/src/Reanimate.hs +++ b/src/Reanimate.hs @@ -35,6 +35,8 @@ -} module Reanimate ( reanimate, + reanimateLive, + reanimateLiveEntry, -- * Animations SVG, Time, @@ -196,6 +198,7 @@ import Reanimate.ColorMap import Reanimate.Constants import Reanimate.Driver +import Reanimate.Driver.Daemon import Reanimate.LaTeX import Reanimate.Parameters import Reanimate.Povray diff --git a/src/Reanimate/Animation.hs b/src/Reanimate/Animation.hs --- a/src/Reanimate/Animation.hs +++ b/src/Reanimate/Animation.hs @@ -148,7 +148,7 @@ -- -- Example: -- --- @'Reanimate.Builtin.Documentation.drawBox' `'parLoopA'` 'adjustDuration' (*2) 'Reanimate.Builtin.Documentation.drawCircle'@ +-- @'Reanimate.Builtin.Documentation.drawBox' `'parDropA'` 'adjustDuration' (*2) 'Reanimate.Builtin.Documentation.drawCircle'@ -- -- <> parDropA :: Animation -> Animation -> Animation diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -5,16 +5,16 @@ where import Control.Applicative ((<|>)) +import Control.Concurrent import Control.Monad -import Data.Maybe import Data.Either -import Reanimate.Animation (Animation) -import Reanimate.Driver.Check +import Data.Maybe +import Reanimate.Animation (Animation, duration) import Reanimate.Driver.CLI -import Reanimate.Driver.Compile -import Reanimate.Driver.Server +import Reanimate.Driver.Check +import Reanimate.Driver.Daemon import Reanimate.Parameters -import Reanimate.Render (render, renderSnippets, renderSvgs, +import Reanimate.Render (render, renderSnippets, renderSvgs, renderSvgs_, selectRaster) import System.Directory import System.Exit @@ -116,7 +116,7 @@ -- hSetBinaryMode stdout True renderSnippets animation Check -> checkEnvironment - View {..} -> serve viewVerbose viewGHCPath viewGHCOpts viewOrigin + View {..} -> viewAnimation viewDetach animation Render {..} -> do let fmt = guessParameter renderFormat (fmap presetFormat renderPreset) @@ -132,7 +132,7 @@ target <- case renderTarget of Nothing -> do - mbSelf <- findOwnSource + mbSelf <- pure Nothing let ext = formatExtension fmt self = fromMaybe "output" mbSelf pure $ replaceExtension self ext @@ -161,47 +161,26 @@ exitWith (ExitFailure 1) return raster else selectRaster renderRaster - - if renderCompile - then compile $ - [ "render" - , "--fps" - , show fps - , "--width" - , show width - , "--height" - , show height - , "--format" - , showFormat fmt - , "--raster" - , showRaster raster - , "--target" - , target - , "+RTS" - , "-N" - , "-RTS" - ] ++ [ "--partial" | renderPartial ] - else do - setRaster raster - setFPS fps - setWidth width - setHeight height - printf - "Animation options:\n\ - \ fps: %d\n\ - \ width: %d\n\ - \ height: %d\n\ - \ fmt: %s\n\ - \ target: %s\n\ - \ raster: %s\n" - fps - width - height - (showFormat fmt) - target - (show raster) + setRaster raster + setFPS fps + setWidth width + setHeight height + printf + "Animation options:\n\ + \ fps: %d\n\ + \ width: %d\n\ + \ height: %d\n\ + \ fmt: %s\n\ + \ target: %s\n\ + \ raster: %s\n" + fps + width + height + (showFormat fmt) + target + (show raster) - render animation target raster fmt width height fps renderPartial + render animation target raster fmt width height fps renderPartial guessParameter :: Maybe a -> Maybe a -> a -> a guessParameter a b def = fromMaybe def (a <|> b) @@ -220,3 +199,20 @@ makeEven :: Int -> Int makeEven x | even x = x | otherwise = x - 1 + + +-- serve viewVerbose viewGHCPath viewGHCOpts viewOrigin +viewAnimation :: Bool -> Animation -> IO () +viewAnimation _detach animation = do + detached <- ensureDaemon + + let rate = 60 + count = round (duration animation * rate) :: Int + sendCommand $ DaemonCount count + renderSvgs_ animation $ \nth path -> do + sendCommand $ DaemonFrame nth path + + unless detached $ do + putStrLn "Daemon mode. Hit ctrl-c to terminate." + forever $ threadDelay (10^(6::Int)) + diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -27,10 +27,7 @@ | Test | Check | View - { viewVerbose :: Bool - , viewGHCPath :: Maybe FilePath - , viewGHCOpts :: [String] - , viewOrigin :: Maybe FilePath + { viewDetach :: Bool } | Render { renderTarget :: Maybe String @@ -154,16 +151,7 @@ where parse = View <$> switch - (long "verbose" <> short 'v') - <*> optional (strOption (long "ghc" - <> metavar "PATH" - <> help "Path to GHC binary")) - <*> many (strOption (long "ghc-opt" - <> short 'G' - <> help "Additional option to pass to ghc")) - <*> optional (strOption (long "self" - <> metavar "PATH" - <> help "Source file used for live-reloading")) + (long "detach" <> short 'd') renderCommand :: ParserInfo Command renderCommand = info parse diff --git a/src/Reanimate/Driver/Compile.hs b/src/Reanimate/Driver/Compile.hs deleted file mode 100644 --- a/src/Reanimate/Driver/Compile.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Reanimate.Driver.Compile ( compile ) where - -import Reanimate.Driver.Server (findOwnSource) -import System.Directory -import System.Exit -import System.FilePath -import System.Process -import System.IO - -compile :: [String] -> IO () -compile opts = do - mbSelf <- findOwnSource - case mbSelf of - Nothing -> do - hPutStrLn stderr - "Failed to find source code. Did you already compile the animations?\n\ - \Try running again without the --compile flag." - exitFailure - Just self -> do - let selfDir = takeDirectory self - selfName = takeBaseName self - outDir = selfDir ".reanimate" selfName - target = outDir selfName - ghcOptions = - ["-rtsopts", "--make", "-threaded", "-O2"] ++ - ["-odir", outDir, "-hidir", outDir] ++ - [self, "-o", target] - createDirectoryIfMissing True outDir - withCurrentDirectory selfDir $ do - checkExitCode =<< rawSystem "stack" (["ghc", "--"] ++ ghcOptions) - checkExitCode =<< rawSystem target opts - -checkExitCode :: ExitCode -> IO () -checkExitCode ExitSuccess = return () -checkExitCode (ExitFailure n) = exitWith (ExitFailure n) diff --git a/src/Reanimate/Driver/Daemon.hs b/src/Reanimate/Driver/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Reanimate/Driver/Daemon.hs @@ -0,0 +1,182 @@ +module Reanimate.Driver.Daemon where + +import Control.Concurrent +import Control.Exception as E +import Control.Monad +import qualified Data.ByteString.Char8 as BS +import Network.Socket +import Network.Socket.ByteString +import qualified Reanimate.Driver.Server as Server +import System.FSNotify +import System.FilePath +import System.Environment + +import Detach + +{- +Main run message: + + Reanimate has gone into daemon mode and will block until you hit + ctrl-c. While Reanimate is in daemon mode, you can open a new + console or terminal and execute your animation code again. It'll + automatically send the new animation to the browser window. + + Linux users can pass --daemon to reanimate to run the process in + the background. Windows users have to use PowerShell and explicitly + fork the process: + Start-Process -NoNewWindow ./reanimate_exe + + Connection to the browser window will be lost if you hit ctrl-c. + + +Executing with daemon: + Send animation to daemon and exit. +Executing without daemon: + Run daemon locally. + Render animation once. + Wait without exiting. + Detach if given --daemon flag. Only for Linux. + +Executing on Linux: + Running 'main' will start the daemon if it isn't already running. + Then it'll render the animation and send it to the daemon. + The daemon will open a browser window. + Daemon stops after 30 minutes of inactivity. + +Executing on Windows: + 'main' will act as daemon and not return. + Powershell command for running in the background: + Start-Process -NoNewWindow ./reanimate_exe + + Subsequent runs will send animation to daemon and quit. + +In GHCi: + Start local daemon thread if necessary. + :cmd reanimateLive + 1. wait for changes + 2. ":r" + 3. ":main" + 4. ":cmd Reanimate.reanimateLive" + + + +Web port: 9161 +Daemon port: 9162? + +-} + +{- + Improvements over previous infrastructure: + - Multiple browser windows can be open. + - Browser window won't get stuck trying to open a connection. + - GHCi is robust and works with both cabal and stack. + - Refreshing the code will re-open closed browser windows. +-} + +-- | Load a reanimate program in GHCi and make sure 'main' is available. +-- Then run: +-- @ +-- :cmd reanimateLive +-- @ +-- +-- This works by sending the commands ':r' and ':main' to your GHCi instance +-- when any source file is changed. +reanimateLive :: IO String +reanimateLive = do + void ensureDaemon + args <- getArgs + case args of + ["primed"] -> waitForChanges + _ -> return () + return $ unlines + [ ":r" + , ":main" + , ":cmd System.Environment.withArgs [\"primed\"] Reanimate.reanimateLive" ] + +-- | Load an animation in GHCi. Anything of type 'Animation' can be live reloaded. +-- +-- @ +-- :cmd reanimateLiveEntry "drawCircle" +-- @ +-- +-- This works by sending the commands ':r' and 'Reanimate.reanimate {entry}' to your +-- GHCi instance when any source file is changed. +reanimateLiveEntry :: String -> IO String +reanimateLiveEntry animation = do + void ensureDaemon + args <- getArgs + case args of + ["primed"] -> waitForChanges + _ -> return () + return $ unlines + [ ":r" + , "Reanimate.reanimate (" ++ animation ++ ")" + , ":cmd System.Environment.withArgs [\"primed\"] Reanimate.reanimateLive" ] + +waitForChanges :: IO () +waitForChanges = withManager $ \mgr -> do + lock <- newEmptyMVar + stop <- watchTree mgr "." check (const $ putMVar lock ()) + takeMVar lock + stop + where + check event = + takeExtension (eventPath event) `elem` sourceExtensions || + takeExtension (eventPath event) `elem` dataExtensions + sourceExtensions = [".hs", ".lhs"] + dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"] + + +data DaemonCommand + = DaemonCount Int + | DaemonFrame Int FilePath + | DaemonStop + deriving (Show) + +sendCommand :: DaemonCommand -> IO () +sendCommand cmd = withSocketsDo $ handle (\SomeException{} -> return ()) $ do + addr <- resolve + E.bracket (open addr) close $ \sock -> do + void $ send sock $ case cmd of + DaemonCount count -> BS.pack $ unwords ["frame_count", show count] + DaemonFrame nth path -> BS.pack $ unwords ["frame", show nth, path] + DaemonStop -> BS.pack $ unwords ["stop"] + return () + where + resolve = do + let hints = defaultHints { addrSocketType = Stream } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + connect sock $ addrAddress addr + return sock + +hasDaemon :: IO Bool +hasDaemon = withSocketsDo $ handle (\SomeException{} -> return False) $ do + addr <- resolve + E.bracket (open addr) close (const $ return True) + where + resolve = do + let hints = defaultHints { addrSocketType = Stream } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + connect sock $ addrAddress addr + return sock + +oSocket :: AddrInfo -> IO Socket +oSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + +ensureDaemon :: IO Bool +ensureDaemon = do + daemon <- hasDaemon + if daemon + then pure True + else localDaemon + +killDaemon :: IO () +killDaemon = sendCommand DaemonStop + +localDaemon :: IO Bool +localDaemon = do + killDaemon + detach Server.daemon + diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -1,286 +1,131 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.Driver.Server - ( serve - , findOwnSource + ( daemon ) where import Control.Concurrent -import Control.Exception (SomeException, catch, finally) -import Control.Monad -import Data.IORef -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.Time -import GHC.Environment (getFullArgs) -import Language.Haskell.Ghcid +import Control.Exception (finally) +import qualified Control.Exception as E +import Control.Monad (forM_, forever, unless, void, when) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Foldable as F +import qualified Data.Map as Map +import qualified Data.Text as T +import Network.Socket (AddrInfo (..), AddrInfoFlag (..), SocketOption (..), + SocketType (Stream), accept, bind, close, defaultHints, + getAddrInfo, gracefulClose, listen, socket, + setCloseOnExecIfNeeded, setSocketOption, withFdSocket, + withSocketsDo) +import Network.Socket.ByteString (recv) import Network.WebSockets -import Paths_reanimate -import Reanimate.Misc (runCmdLazy, runCmd_) -import System.Directory (createDirectoryIfMissing, - doesFileExist, findFile, listDirectory, - makeAbsolute, - withCurrentDirectory) -import System.Environment (getProgName) -import System.Exit -import System.FilePath -import System.FSNotify -import System.IO -import System.IO.Temp -import System.Process -import Web.Browser (openBrowser) +import Paths_reanimate (getDataFileName) +import System.IO (hPutStrLn, stderr) +import Web.Browser (openBrowser) opts :: ConnectionOptions opts = defaultConnectionOptions { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate } -serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO () -serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do - hSetBuffering stdin NoBuffering - self <- maybe requireOwnSource pure mbSelfPath - when verbose $ - logMsg $ "Found own source code at: " ++ self - hasConnectionVar <- newMVar False - ghci <- ghciBackend mbGHCPath self - -- There might already browser window open. Wait 2s to see if that window - -- connects to us. If not, open a new window. - _ <- forkIO $ do - threadDelay (2*10^(6::Int)) - hasConn <- readMVar hasConnectionVar - unless hasConn openViewer - logMsg "Listening..." +daemon :: IO () +daemon = do + state <- newMVar (0, Map.empty) + connsRef <- newMVar Map.empty + + self <- myThreadId + + dTid <- daemonReceive self $ \msg -> + case msg of + WebStatus _status -> return () + WebError _err -> return () + WebFrameCount count -> do + void $ swapMVar state (count, Map.empty) + conns <- readMVar connsRef + F.forM_ conns $ \(conn) -> do + sendWebMessage conn (WebFrameCount count) + when (Map.null conns) openViewer + WebFrame nth path -> do + modifyMVar_ state $ \(count, frames) -> + pure (count, Map.insert nth path frames) + conns <- readMVar connsRef + F.forM_ conns $ \conn -> do + sendWebMessage conn (WebFrame nth path) + + openViewer + let options = ServerOptions { serverHost = "127.0.0.1" , serverPort = 9161 , serverConnectionOptions = opts , serverRequirePong = Nothing } - withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> - runServerWithOptions options $ \pending -> do - logMsg "New connection received." - hasConn <- swapMVar hasConnectionVar True - if hasConn - then do - logMsg "Already connected to browser. Rejecting." - rejectRequestWith pending defaultRejectRequest - else do - createDirectoryIfMissing True tmpDir - conn <- acceptRequest pending - slave <- newEmptyMVar - let handler = modifyMVar_ slave $ \tid -> do - logMsg "Reloading code..." - killThread tid - forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir - killSlave = do - tid <- takeMVar slave - killThread tid - stop <- watchFile watch self handler - putMVar slave =<< forkIO (return ()) - handler - let loop = do - -- FIXME: We don't use msg here. - _msg <- receiveData conn :: IO T.Text - handler - loop - cleanup = do - stop - killSlave - _ <- swapMVar hasConnectionVar False - return () - loop `finally` cleanup -ignoreErrors :: IO () -> IO () -ignoreErrors action = action `catch` \(_::SomeException) -> return () - -openViewer :: IO () -openViewer = do - url <- getDataFileName "viewer-elm/dist/index.html" - logMsg "Opening browser..." - bSucc <- openBrowser url - if bSucc - then logMsg "Browser opened." - else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url - -slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend - -> FilePath -> FilePath -> IO () -slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir = - withCurrentDirectory (takeDirectory self) $ - withSystemTempDirectory "reanimate" $ \tmpDir -> - withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do - outputFolder <- createTempDirectory svgDir "svgs" - let frameFileName frameIdx = - outputFolder show frameIdx <.> "svg" - - sentFrameCount <- newMVar False - hClose handle - lock <- newMVar () - sendWebMessage conn $ WebStatus "Compiling" - ghciThread <- forkIO $ do - firstFrame <- newIORef True - ghciReload ghci - logMsg "GHCi reload done." - ghciGenerate ghci outputFolder $ \frameIdx -> do - first <- readIORef firstFrame - writeIORef firstFrame False - if first - then - modifyMVar_ sentFrameCount $ \sent -> do - unless sent $ - sendWebMessage conn $ WebFrameCount frameIdx - logMsg "Framecount sent." - return True - else - withMVar lock $ \_ -> - sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) - logMsg "GHCi render done." - ret <- case mbGHCPath of - Nothing -> do - let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] - when verbose $ - logMsg $ "Running: " ++ showCommandForUser "stack" args - runCmd_ "stack" args - Just ghc -> do - let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] - when verbose $ - logMsg $ "Running: " ++ showCommandForUser ghc args - runCmd_ ghc args - logMsg "Compile done." - case ret of - Left err -> - sendWebMessage conn $ WebError $ unlines (lines err) - Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do - frameCount <- expectFrame =<< getFrame - modifyMVar_ sentFrameCount $ \sent -> do - unless sent $ - sendWebMessage conn $ WebFrameCount frameCount - return True - replicateM_ frameCount $ do - frameIdx <- expectFrame =<< getFrame - withMVar lock $ \_ -> - sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) - logMsg "Optimized render done." - killThread ghciThread - where - execOpts output = - [ "raw", "--output", output, "--offset", "1" - , "+RTS", "-N", "-M2G", "-RTS"] - expectFrame :: Either String Text -> IO Int - expectFrame (Left "") = do - sendWebMessage conn $ WebStatus "Done" - exitSuccess - expectFrame (Left err) = do - sendWebMessage conn $ WebError err - exitWith (ExitFailure 1) - expectFrame (Right frame) = - case T.decimal frame of - Left err -> do - hPutStrLn stderr (T.unpack frame) - raiseError conn err - Right (frameNumber, "") -> - pure frameNumber - Right {} -> do - let err = "Unexpected output" - hPutStrLn stderr (T.unpack frame) - raiseError conn err - -raiseError :: Connection -> String -> IO a -raiseError conn err = do - hPutStrLn stderr $ "expectFrame: " ++ err - sendWebMessage conn $ WebError err - exitWith (ExitFailure 1) + runServerWithOptions options (\pending -> do + tid <- myThreadId -watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening -watchFile watch file action = watchTree watch (takeDirectory file) check (const action) - where - check event = - takeFileName (eventPath event) == takeFileName file || - takeExtension (eventPath event) `elem` sourceExtensions || - takeExtension (eventPath event) `elem` dataExtensions - sourceExtensions = [".hs", ".lhs"] - dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"] + conn <- acceptRequest pending -ghcOptions :: FilePath -> [String] -ghcOptions tmpDir = - ["-rtsopts", "--make", "-threaded", "-O2"] ++ - ["-odir", tmpDir, "-hidir", tmpDir] + modifyMVar_ connsRef $ pure . Map.insert tid conn --- FIXME: Move to a different module -requireOwnSource :: IO FilePath -requireOwnSource = do - mbSelf <- findOwnSource - case mbSelf of - Nothing -> do - hPutStrLn stderr - "Rendering in browser window is only available when interpreting.\n\ - \To render a video file, use the 'render' command or run again with --help\n\ - \to see all available options." - exitFailure - Just self -> pure self + (count, frames) <- readMVar state + when (count > 0) $ do + sendWebMessage conn (WebFrameCount count) + forM_ (Map.toList frames) $ \(nth, path) -> + sendWebMessage conn (WebFrame nth path) -findOwnSource :: IO (Maybe FilePath) -findOwnSource = do - fullArgs <- getFullArgs - stackSource <- makeAbsolute (last fullArgs) - exist <- doesFileExist stackSource - if exist && isHaskellFile stackSource - then return (Just stackSource) - else do - prog <- getProgName - let hsProg - | isHaskellFile prog = prog - | otherwise = replaceExtension prog "hs" - lst <- listDirectory "." - findFile ("." : lst) hsProg + let loop = do + -- FIXME: We don't use msg here. + _msg <- receiveData conn :: IO T.Text + loop + cleanup = do + modifyMVar_ connsRef $ pure . Map.delete tid + nConns <- Map.size <$> readMVar connsRef + when (nConns == 0) $ do + threadDelay (second * 5) + nConns' <- Map.size <$> readMVar connsRef + when (nConns'==0) $ killThread self + loop `finally` cleanup) + `finally` (killThread dTid) -isHaskellFile :: FilePath -> Bool -isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"] +second :: Int +second = 10^(6::Int) -logMsg :: String -> IO () -logMsg msg = do - now <- getCurrentTime - putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg +daemonReceive :: ThreadId -> (WebMessage -> IO ()) -> IO ThreadId +daemonReceive parent cb = withSocketsDo $ do + addr <- resolve + sock <- open addr + forkIO $ handler sock `finally` close sock where - fmt = "%F %T%2Q" - -------------------------------------------------------------------------------- --- Ghci interface - --- stack --- cabal --- raw --- none? -newtype GhciBackend = GhciBackend (MVar Ghci) - -ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend -ghciBackend mbGHCPath self = do - let ghciProc = - case mbGHCPath of - Just ghcPath -> - proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"] - Nothing -> - proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit] - (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return () - void $ exec ghci $ ":load " ++ self - ref <- newMVar ghci - return $ GhciBackend ref - -ghciReload :: GhciBackend -> IO () -ghciReload (GhciBackend ref) = - withMVar ref $ \ghci -> - void $ reload ghci - -ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO () -ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> - execStream ghci (":main raw --output=" ++ target ++ " --offset=1") - $ \_ msg -> - case reads msg of - [(frameIdx,"")] -> cb frameIdx - _ -> return () + handler sock = forever $ E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do + inp <- BS.unpack <$> recv conn 4096 + case words inp of + ["frame_count", n] -> cb $ WebFrameCount (read n) + ["frame", nth, path] -> cb $ WebFrame (read nth) path + ["stop"] -> killThread parent + [] -> return () + _ -> error $ "Bad message: " ++ inp + gracefulClose conn 5000 + resolve = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + oSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + setSocketOption sock ReuseAddr 1 + withFdSocket sock setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock -memoryLimit :: String -memoryLimit = "-M1G" +openViewer :: IO () +openViewer = do + url <- getDataFileName "viewer-elm/dist/index.html" + bSucc <- openBrowser url + unless bSucc $ + hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url ------------------------------------------------------------------------------- -- Websocket API diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs --- a/src/Reanimate/LaTeX.hs +++ b/src/Reanimate/LaTeX.hs @@ -16,6 +16,9 @@ latex, latexWithHeaders, latexChunks, + latexCfgChunks, + latexCfgChunksTrans, + mathChunks, xelatex, xelatexWithHeaders, ctex, @@ -35,7 +38,9 @@ where import Control.Lens ((&), (.~)) +import Control.Monad.State (runState, state) import qualified Data.ByteString as B +import Data.Foldable (Foldable (fold)) import Data.Hashable (Hashable) import Data.Monoid (Last (Last)) import Data.Text (Text) @@ -43,8 +48,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import GHC.Generics (Generic) -import Graphics.SvgTree (pattern ClipPathTree, pattern None, Tree, clipPathRef, - clipRule, mapTree, parseSvgFile, strokeColor) +import Graphics.SvgTree (Tree, clipPathRef, clipRule, mapTree, parseSvgFile, + pattern ClipPathTree, pattern None, strokeColor) import Reanimate.Animation (SVG) import Reanimate.Cache (cacheDiskSvg, cacheMem) import Reanimate.External (zipArchive) @@ -66,6 +71,9 @@ } deriving (Generic, Hashable, Read, Show, Eq, Ord) +defaultTexConfig :: TexConfig +defaultTexConfig = TexConfig LaTeX [] [] + -- | Render TeX script using a given configuration. latexCfg :: TexConfig -> T.Text -> SVG latexCfg (TexConfig engine headers postscript) = @@ -110,22 +118,33 @@ script = mkTexScript exec args headers (T.unlines (postscript ++ [tex])) -- | Invoke latex using a given configuration and separate results. -latexCfgChunks :: TexConfig -> [T.Text] -> [Tree] -latexCfgChunks _cfg chunks | pNoExternals = map mkText chunks -latexCfgChunks cfg chunks = worker chunks $ svgGlyphs $ tex $ T.concat chunks +-- Apply the transformation to the LaTeX segments. +-- See also 'mathChunks', the transformation is @(\s -> "$" <> s <> "$")@. +latexCfgChunksTrans :: Traversable t => TexConfig -> (T.Text -> T.Text) -> t T.Text -> t Tree +latexCfgChunksTrans _cfg f chunks | pNoExternals = fmap (mkText . f) chunks +latexCfgChunksTrans cfg f chunks = worker $ svgGlyphs $ tex $ f $ fold chunks where tex = latexCfg cfg merge lst = mkGroup [fmt svg | (fmt, _, svg) <- lst] - worker [] [] = [] - worker [] _ = error "latex chunk mismatch" - worker (x : xs) everything = + checkResult (r, []) = r + checkResult (_, _) = error "latex chunk mismatch" + worker = checkResult . runState (mapM (state . workerSingle) (fmap f chunks)) + workerSingle x everything = let width = length $ svgGlyphs (tex x) (first, rest) = splitAt width everything - in merge first : worker xs rest + in (merge first, rest) +-- | Render math formula and separate results. +mathChunks :: Traversable t => t T.Text -> t Tree +mathChunks = latexCfgChunksTrans defaultTexConfig (\s -> "$" <> s <> "$") + +-- | Invoke latex using a given configuration and separate results. +latexCfgChunks :: Traversable t => TexConfig -> t T.Text -> t Tree +latexCfgChunks cfg = latexCfgChunksTrans cfg id + -- | Invoke latex and separate results. -latexChunks :: [T.Text] -> [Tree] -latexChunks = latexCfgChunks (TexConfig LaTeX [] []) +latexChunks :: Traversable t => t T.Text -> t Tree +latexChunks = latexCfgChunksTrans defaultTexConfig id -- | Invoke xelatex and import the result as an SVG object. SVG objects are -- cached to improve performance. Xelatex has support for non-western scripts. diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -13,6 +13,7 @@ module Reanimate.Render ( render , renderSvgs + , renderSvgs_ , renderSnippets -- :: Animation -> IO () , renderLimitedFrames , Format(..) @@ -44,6 +45,7 @@ import System.FileLock (SharedExclusive (..), unlockFile, withTryFileLock) import System.FilePath (replaceExtension, (<.>), ()) import System.IO +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) import Text.Printf (printf) idempotentFile :: FilePath -> IO () -> IO () @@ -75,6 +77,28 @@ withMVar lock $ \_ -> do print nth hFlush stdout + where + rate = 60 + frameCount = round (duration ani * fromIntegral rate) :: Int + errHandler (ErrorCall msg) = do + hPutStrLn stderr msg + exitWith (ExitFailure 1) + +renderSvgs_ :: Animation -> (Int -> FilePath -> IO ()) -> IO () +renderSvgs_ ani cb = do + tmp <- getCanonicalTemporaryDirectory + tmpDir <- createTempDirectory tmp "reanimate" + lock <- newMVar () + handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do + let nth = (nth') `mod` frameCount + now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt (if frameCount <= 1 then 0 else now) ani + path = tmpDir show nth <.> "svg" + svg = renderSvg Nothing Nothing frame + + idempotentFile path $ + writeFile path svg + withMVar lock $ \_ -> cb nth path where rate = 60 frameCount = round (duration ani * fromIntegral rate) :: Int diff --git a/unix/Detach.hs b/unix/Detach.hs new file mode 100644 --- /dev/null +++ b/unix/Detach.hs @@ -0,0 +1,19 @@ +module Detach (detach) where + +import Control.Concurrent +import Control.Monad +import System.Posix.IO +import System.Posix.Process (createSession, forkProcess) + +detach :: IO () -> IO Bool +detach daemon = do + void $ forkProcess $ do + devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags + void $ dupTo devnull stdInput + void $ dupTo devnull stdOutput + void $ dupTo devnull stdError + closeFd devnull + void createSession + void $ forkProcess daemon + threadDelay (10^(6::Int)) + return True diff --git a/windows/Detach.hs b/windows/Detach.hs new file mode 100644 --- /dev/null +++ b/windows/Detach.hs @@ -0,0 +1,10 @@ +module Detach (detach) where + +import Control.Monad +import Control.Concurrent + +detach :: IO () -> IO Bool +detach action = do + void $ forkIO action + threadDelay (10^(6::Int)) + return False