Add testsuite.

Former-commit-id: bc34312dfef68bc81fc1257970786ea7b23ee99b

examples/colormaps.hs

@@ -21,8 +21,13 @@ import           Reanimate.Raster
 import           Reanimate.Signal
 import           Reanimate.Svg
 
+-- Cycle the animation if we want to upload it to youtube.
+youtube :: Animation -> Animation
+-- youtube = repeatAnimation 6
+youtube = id
+
 main :: IO ()
-main = reanimate $ repeatAnimation 6 $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnimation 5 $ do
+main = reanimate $ youtube $ pauseAtEnd 2 $ autoReverse $ pauseAtEnd 2 $ mkAnimation 5 $ do
     s <- getSignal $ signalCurve 2
     let scaleWidth = 50
         nubWidth = 2

examples/counter.hs

@@ -0,0 +1,21 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-13.14 runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Main (main) where
+
+import           Control.Lens
+import           Data.Text (pack, Text)
+import Numeric
+
+import           Graphics.SvgTree hiding (Text)
+import           Reanimate.Driver (reanimate)
+import           Reanimate.LaTeX
+import           Reanimate.Monad
+import           Reanimate.Svg
+import           Reanimate.Signal
+
+main :: IO ()
+main = reanimate $ mkAnimation 2 $ do
+  s <- getSignal $ signalFromTo 0 (2*60-1) signalLinear
+  emit $ mkCircle (Num 0, Num 0) (Num s)

reanimate.cabal

@@ -60,7 +60,7 @@ library
                       Paths_reanimate
   build-depends:       base >=4.10 && <4.13,
                        time, text, filepath, process, directory,
-                       containers, reanimate-svg >= 0.9.0.2, xml, bytestring, lens, linear, mtl, matrix,
+                       containers, reanimate-svg >= 0.9.1.1, xml, bytestring, lens, linear, mtl, matrix,
                        JuicyPixels, attoparsec, parallel, diagrams, diagrams-svg,
                        diagrams-core, diagrams-lib, diagrams-contrib,
                        svg-builder, matrices, cubicbezier, palette, websockets,
@@ -83,3 +83,19 @@ executable reanimate-server
                       Cache
   build-depends:      base >=4.10 && <4.13, text, websockets, process, filepath, directory,
                       containers, hashable, time
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+    UnitTests
+  hs-source-dirs: test
+  build-depends:
+    base,
+    directory,
+    filepath,
+    bytestring, process,
+    reanimate,
+    QuickCheck >= 2.1.0,
+    tasty, tasty-golden,
+    ansi-wl-pprint

src/Reanimate/Driver.hs

@@ -20,7 +20,7 @@ import           Paths_reanimate
 import           Reanimate.Misc     (runCmdLazy, runCmd_, withTempDir,
                                      withTempFile)
 import           Reanimate.Monad    (Animation)
-import           Reanimate.Render   (render, renderSvgs)
+import           Reanimate.Render   (render, renderSvgs, renderSnippets)
 import           Web.Browser        (openBrowser)
 
 opts = defaultConnectionOptions
@@ -33,6 +33,7 @@ reanimate animation = do
   hSetBuffering stdin NoBuffering
   case args of
     ["once"] -> renderSvgs animation
+    ["snippets"] -> renderSnippets animation
     ["render", target] ->
       render animation target
     _ -> withTempDir $ \tmpDir -> do

src/Reanimate/Render.hs

@@ -1,6 +1,7 @@
 module Reanimate.Render
   ( render
   , renderSvgs
+  , renderSnippets
   ) where
 
 import           Control.Monad               (forM_)
@@ -25,8 +26,6 @@ renderSvgs :: Animation ->  IO ()
 renderSvgs ani = do
     print frameCount
     lock <- newMVar ()
-    -- let renderedFrames = map (T.concat . T.lines . T.pack . nthFrame) frames
-    -- mapM_ T.putStrLn (renderedFrames `using` parBuffer 16 rdeepseq)
 
     concurrentForM_ (frameOrder rate frameCount) $ \nth -> do
       let -- frame = frameAt (recip (fromIntegral rate-1) * fromIntegral nth) ani
@@ -39,11 +38,22 @@ renderSvgs ani = do
         T.putStrLn $ T.concat . T.lines . T.pack $ svg
         hFlush stdout
   where
-    frames = [0..frameCount-1]
     rate = 60
-    nthFrame nth = renderSvg Nothing Nothing $ frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
     frameCount = round (duration ani * fromIntegral rate) :: Int
 
+-- XXX: Merge with 'renderSvgs'
+renderSnippets :: Animation ->  IO ()
+renderSnippets ani = do
+    print frameCount
+    forM_ [0..frameCount-1] $ \nth -> do
+      let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth
+          frame = frameAt (if frameCount<=1 then 0 else now) ani
+          svg = renderSvg Nothing Nothing frame
+      putStr (show nth)
+      T.putStrLn $ T.concat . T.lines . T.pack $ svg
+  where
+    frameCount = 50
+
 frameOrder :: Int -> Int -> [Int]
 frameOrder fps nFrames = worker [] fps
   where

stack.yaml

@@ -6,7 +6,7 @@ packages:
 - .
 
 extra-deps:
-- reanimate-svg-0.9.0.2
+- reanimate-svg-0.9.1.1
 - palette-0.3.0.2
 - diagrams-1.4@sha256:3e36369e84115b900fd9dcb570672a188339a470eb19ca62170775cd835cf8ca
 - diagrams-contrib-1.4.3@sha256:bcfa6c85f8c33b8c48c3a61b7216afdebd51cd793c50da3a2dd358827d25fc76

test/Spec.hs

@@ -0,0 +1,10 @@
+module Main (main) where
+
+import           Test.Tasty
+
+import           UnitTests
+
+main :: IO ()
+main = do
+  ts <- unitTestFolder "examples/"
+  defaultMain ts

test/UnitTests.hs

@@ -0,0 +1,64 @@
+module UnitTests (unitTestFolder) where
+
+import           Control.Monad        (forM)
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Maybe           (catMaybes)
+import           System.Directory
+import           System.FilePath
+import           System.IO
+import           System.Process
+import           Test.Tasty
+import           Test.Tasty.Golden
+import           Reanimate.Misc     (withTempDir,
+                                     withTempFile)
+
+unitTestFolder :: FilePath -> IO TestTree
+unitTestFolder path = do
+  files <- getDirectoryContents path
+  return $ testGroup "examples"
+    [ goldenVsStringDiff file (\ref new -> ["diff", ref, new]) fullPath (genGolden hsPath)
+    | file <- files
+    , let fullPath = path </> file
+          hsPath = replaceExtension fullPath "hs"
+    , takeExtension fullPath == ".golden"
+    ]
+
+genGolden :: FilePath -> IO LBS.ByteString
+genGolden path = withTempDir $ \tmpDir -> withTempFile ".exe" $ \tmpExecutable -> do
+  let ghcOpts = ["-rtsopts", "--make", "-O2"] ++
+                ["-odir", tmpDir, "-hidir", tmpDir, "-o", tmpExecutable]
+      runOpts = ["+RTS", "-M1G"]
+  -- XXX: Check for errors.
+  _ <- readProcessWithExitCode "stack" (["ghc","--", path] ++ ghcOpts) ""
+  -- ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]
+  -- ["-rtsopts", "--make", "-threaded", "-O2"] ++
+  -- ["-odir", tmpDir, "-hidir", tmpDir]
+  (inh, outh, errh, pid) <- runInteractiveProcess tmpExecutable (["snippets"] ++ runOpts)
+    Nothing Nothing
+  hClose inh
+  hClose errh
+  LBS.hGetContents outh
+
+--------------------------------------------------------------------------------
+-- Helpers
+
+-- findAnExecutable :: [String] -> IO (Maybe FilePath)
+-- findAnExecutable [] = return Nothing
+-- findAnExecutable (x:xs) = do
+--   mbExec <- findExecutable x
+--   case mbExec of
+--     Just exec -> return (Just exec)
+--     Nothing   -> findAnExecutable xs
+--
+-- readFileOptional :: FilePath -> IO String
+-- readFileOptional path = do
+--   hasFile <- doesFileExist path
+--   if hasFile then readFile path else return ""
+--
+-- assertExitCode :: String -> ExitCode -> Assertion
+-- assertExitCode _ ExitSuccess = return ()
+-- assertExitCode msg (ExitFailure code) = assertFailure (msg ++ ", code: " ++ show code)
+--
+-- assertMaybe :: String -> Maybe a -> IO a
+-- assertMaybe _ (Just a)  = return a
+-- assertMaybe msg Nothing = assertFailure msg