reanimate 1.1.2.1 → 1.1.3.0
raw patch · 14 files changed
+596/−368 lines, 14 filesdep +networkdep +unixdep −ghcidPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: network, unix
Dependencies removed: ghcid
API changes (from Hackage documentation)
+ Reanimate: reanimateLive :: IO String
+ Reanimate: reanimateLiveEntry :: String -> IO String
+ Reanimate.LaTeX: latexCfgChunks :: Traversable t => TexConfig -> t Text -> t Tree
+ Reanimate.LaTeX: latexCfgChunksTrans :: Traversable t => TexConfig -> (Text -> Text) -> t Text -> t Tree
+ Reanimate.LaTeX: mathChunks :: Traversable t => t Text -> t Tree
+ Reanimate.Render: renderSvgs_ :: Animation -> (Int -> FilePath -> IO ()) -> IO ()
- Reanimate.LaTeX: latexChunks :: [Text] -> [Tree]
+ Reanimate.LaTeX: latexChunks :: Traversable t => t Text -> t Tree
Files
- examples/decompose.hs +69/−0
- examples/expression.hs +101/−0
- reanimate.cabal +11/−4
- src/Reanimate.hs +3/−0
- src/Reanimate/Animation.hs +1/−1
- src/Reanimate/Driver.hs +44/−48
- src/Reanimate/Driver/CLI.hs +2/−14
- src/Reanimate/Driver/Compile.hs +0/−35
- src/Reanimate/Driver/Daemon.hs +182/−0
- src/Reanimate/Driver/Server.hs +100/−255
- src/Reanimate/LaTeX.hs +30/−11
- src/Reanimate/Render.hs +24/−0
- unix/Detach.hs +19/−0
- windows/Detach.hs +10/−0
+ examples/decompose.hs view
@@ -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
+ examples/expression.hs view
@@ -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
reanimate.cabal view
@@ -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
src/Reanimate.hs view
@@ -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
src/Reanimate/Animation.hs view
@@ -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'@ -- -- <<docs/gifs/doc_parDropA.gif>> parDropA :: Animation -> Animation -> Animation
src/Reanimate/Driver.hs view
@@ -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))+
src/Reanimate/Driver/CLI.hs view
@@ -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
− src/Reanimate/Driver/Compile.hs
@@ -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)
+ src/Reanimate/Driver/Daemon.hs view
@@ -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+
src/Reanimate/Driver/Server.hs view
@@ -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
src/Reanimate/LaTeX.hs view
@@ -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.
src/Reanimate/Render.hs view
@@ -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
+ unix/Detach.hs view
@@ -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
+ windows/Detach.hs view
@@ -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