diff --git a/examples/expression.hs b/examples/expression.hs
index ed090ad..ae5f776 100644
--- a/examples/expression.hs
+++ b/examples/expression.hs
@@ -60,6 +60,10 @@ op2LaTeX LeftParen = "("
op2LaTeX RightParen = ")"
-- Some supportive types and instances.
+instance Functor (Expr a) where
+ fmap f (Var x) = Var (f x)
+ fmap f (BinOp x op y) = BinOp (fmap f x) op (fmap f y)
+ fmap f (Paren l x r) = Paren l (fmap f x) r
instance Bifunctor Expr where
bimap _ g (Var x) = Var (g x)
@@ -91,6 +95,9 @@ instance Bitraversable p => Traversable (Both p) where
-- | 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 => Functor (BiAlongside a b p c) where
+ fmap f (BiAlongside x) = BiAlongside (bimap id (fmap f) x)
+
instance Bifunctor p => Bifunctor (BiAlongside a b p) where
bimap f g = BiAlongside . bimap (second f) (second g) . runBiAlongside
diff --git a/examples/golden/doc_andThen.golden b/examples/golden/doc_andThen.golden
index 14d72ab..4972e7e 100644
--- a/examples/golden/doc_andThen.golden
+++ b/examples/golden/doc_andThen.golden
@@ -3,8 +3,8 @@
2
3
4
-5
-6
-7
-8
-9
+5
+6
+7
+8
+9
diff --git a/examples/golden/doc_applyVar.golden b/examples/golden/doc_applyVar.golden
index d67944a..189a52b 100644
--- a/examples/golden/doc_applyVar.golden
+++ b/examples/golden/doc_applyVar.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_destroySprite.golden b/examples/golden/doc_destroySprite.golden
index b90da20..3be4453 100644
--- a/examples/golden/doc_destroySprite.golden
+++ b/examples/golden/doc_destroySprite.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_drawBox.golden b/examples/golden/doc_drawBox.golden
index 77bd964..d945856 100644
--- a/examples/golden/doc_drawBox.golden
+++ b/examples/golden/doc_drawBox.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_fadeT.golden b/examples/golden/doc_fadeT.golden
index b1b1d17..3112af6 100644
--- a/examples/golden/doc_fadeT.golden
+++ b/examples/golden/doc_fadeT.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_fork.golden b/examples/golden/doc_fork.golden
index 8dd954b..841096e 100644
--- a/examples/golden/doc_fork.golden
+++ b/examples/golden/doc_fork.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_parA.golden b/examples/golden/doc_parA.golden
index efd8be2..91f320d 100644
--- a/examples/golden/doc_parA.golden
+++ b/examples/golden/doc_parA.golden
@@ -3,8 +3,8 @@
2
3
4
-5
-6
-7
-8
-9
+5
+6
+7
+8
+9
diff --git a/examples/golden/doc_pathify.golden b/examples/golden/doc_pathify.golden
index c46d978..42c0f26 100644
--- a/examples/golden/doc_pathify.golden
+++ b/examples/golden/doc_pathify.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/golden/doc_spriteVar.golden b/examples/golden/doc_spriteVar.golden
index d67944a..189a52b 100644
--- a/examples/golden/doc_spriteVar.golden
+++ b/examples/golden/doc_spriteVar.golden
@@ -7,4 +7,4 @@
6
7
8
-9
+9
diff --git a/examples/sorting.hs b/examples/sorting.hs
index 376c987..2c55fdd 100755
--- a/examples/sorting.hs
+++ b/examples/sorting.hs
@@ -6,6 +6,7 @@
module Main (main) where
import Codec.Picture
+import Control.Monad (forM_, when, zipWithM_)
import Control.Monad.ST
import Control.Monad.State.Strict
import Data.Text (Text)
diff --git a/reanimate.cabal b/reanimate.cabal
index 3b6fdb3..9567be2 100644
--- a/reanimate.cabal
+++ b/reanimate.cabal
@@ -110,7 +110,7 @@ library
build-depends:
base >=4.10 && <5,
JuicyPixels >=3.3.3,
- aeson >=1.3.0.0 && <2.2,
+ aeson >=1.3.0.0 && <2.3,
ansi-terminal >=0.8.0.4,
array >=0.5.2.0,
attoparsec >=0.13.2.0,
@@ -147,7 +147,7 @@ library
unordered-containers >=0.2.0.0,
vector >=0.12.0.0,
vector-space >=0.13,
- websockets >=0.12.7.0,
+ websockets >=0.13.0.0,
xml >=1.3.14,
cryptohash-sha256,
base64-bytestring,
diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs
index f3f8c79..7606c19 100644
--- a/src/Reanimate/Driver/Server.hs
+++ b/src/Reanimate/Driver/Server.hs
@@ -58,8 +58,7 @@ daemon = do
let options = ServerOptions
{ serverHost = "127.0.0.1"
, serverPort = 9161
- , serverConnectionOptions = opts
- , serverRequirePong = Nothing }
+ , serverConnectionOptions = opts }
runServerWithOptions options (\pending -> do
tid <- myThreadId
diff --git a/src/Reanimate/Morph/Linear.hs b/src/Reanimate/Morph/Linear.hs
index d73ea6b..0460820 100644
--- a/src/Reanimate/Morph/Linear.hs
+++ b/src/Reanimate/Morph/Linear.hs
@@ -91,5 +91,5 @@ closestLinearCorrespondenceA src' dst' =
linearTrajectory :: Trajectory
linearTrajectory (src,dst)
| pSize src == pSize dst = \t -> mkPolygon $
- V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)
+ V.zipWith (lerp $ realToFrac t) (polygonPoints src) (polygonPoints dst)
| otherwise = error $ "Invalid lengths: " ++ show (pSize src, pSize dst)
diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs
index ecddaba..a174c9f 100644
--- a/src/Reanimate/Svg.hs
+++ b/src/Reanimate/Svg.hs
@@ -264,6 +264,7 @@ pathify = mapTree worker
,HorizontalTo OriginRelative [w]
,VerticalTo OriginRelative [h]
,HorizontalTo OriginRelative [-w]
+ ,VerticalTo OriginRelative [-h]
,EndPath ]
LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
PathTree $ defaultSvg
diff --git a/test/UnitTests.hs b/test/UnitTests.hs
index ad36b0f..bbba966 100644
--- a/test/UnitTests.hs
+++ b/test/UnitTests.hs
@@ -5,9 +5,11 @@ module UnitTests
) where
import Control.Exception
+import Control.Monad (filterM)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.List (sort)
+import Data.Maybe (maybe)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Directory
@@ -23,22 +25,78 @@ import Test.Tasty.HUnit
data BuildSystem
= Cabal
| Stack
+ | NixBuild NixBuildSystem
+
+data NixBuildSystem
+ = NixCabal
+ | NixStack
+
+-- required for nix build
+nixGHCOptions :: [String]
+nixGHCOptions =
+ [ "-XPackageImports"
+ , "-XPatternSynonyms"
+ , "-Wall"
+ , "-fno-ignore-asserts"
+ , "-DNO_HGEOMETRY"
+ , "-hide-package"
+ , "matrices"
+ ]
+
+findStackAutogen :: IO (Maybe FilePath)
+findStackAutogen = do
+ let base = ".stack-work" "dist"
+ baseExists <- doesDirectoryExist base
+ if not baseExists
+ then return Nothing
+ else do
+ subDirs <- listDirectories base
+ case subDirs of
+ [] -> return Nothing
+ (arch:_) -> do
+ let archPath = base arch
+ cabalDirs <- listDirectories archPath
+ case cabalDirs of
+ [] -> return Nothing
+ (ver:_) -> return $ Just (archPath ver "build" "autogen")
+
+includeBuild :: NixBuildSystem -> IO [String]
+includeBuild NixCabal = return ["-idist/build/autogen"]
+includeBuild NixStack = do
+ mbPath <- findStackAutogen
+ case mbPath of
+ Nothing -> return []
+ Just p -> return ["-i" ++ p]
+
+listDirectories :: FilePath -> IO [FilePath]
+listDirectories path = do
+ contents <- listDirectory path
+ filterM (\f -> doesDirectoryExist (path f)) contents
{-# NOINLINE buildSystem #-}
buildSystem :: BuildSystem
buildSystem = unsafePerformIO $ do
+ exeCabal <- findExecutable "cabal"
+ exeStack <- findExecutable "stack"
+
newbuild <- doesDirectoryExist "dist-newstyle"
- stack <- doesDirectoryExist ".stack-work"
- if newbuild then pure Cabal
- else if stack then pure Stack
- else error "Unknown build system."
+ v1build <- doesDirectoryExist "dist"
+ stack <- doesDirectoryExist ".stack-work"
+
+ return $ case (exeCabal, exeStack) of
+ (Nothing, _) | v1build -> NixBuild NixCabal
+ (_, Nothing) | stack -> NixBuild NixStack
+ (Just _, _) | newbuild -> Cabal
+ (_, Just _) | stack -> Stack
+ _ -> error "Unknown build system."
{-# NOINLINE unitTestsDisabled #-}
unitTestsDisabled :: Bool
unitTestsDisabled =
case buildSystem of
- Cabal -> False
- Stack -> unsafePerformIO $ do
+ Cabal -> False
+ NixBuild _ -> False
+ Stack -> unsafePerformIO $ do
(ret, _, _) <- readProcessWithExitCode "stack" ["exec","--","ghc", "-e", "Reanimate.duration Reanimate.Builtin.Documentation.drawCircle"] ""
case ret of
ExitFailure{} -> pure True
@@ -64,16 +122,26 @@ unitTestFolder path = do
genGolden :: FilePath -> IO LBS.ByteString
genGolden path = do
(inh, outh, errh, pid) <- case buildSystem of
- Stack -> runInteractiveProcess "stack" ["runhaskell", path, "test"]
+ Stack -> runInteractiveProcess "stack" ["runhaskell", path, "test"]
Nothing Nothing
- Cabal -> runInteractiveProcess "cabal" ["v2-exec", "runhaskell", path, "test"]
+ Cabal -> runInteractiveProcess "cabal" ["v2-exec", "runhaskell", path, "test"]
Nothing Nothing
+ NixBuild nixbuild -> do
+ nixIncludeDir <- includeBuild nixbuild
+ runInteractiveProcess "ghc"
+ ( ["-isrc", "-iunix"]
+ ++ nixIncludeDir
+ ++ nixGHCOptions
+ ++ ["--run", path, "--", "test"]
+ ) Nothing Nothing
-- hSetBinaryMode outh True
- -- hSetNewlineMode outh universalNewlineMode
+ -- hSetNewlineMode outh universalNewlineMode
+
hClose inh
out <- BS.hGetContents outh
err <- T.hGetContents errh
code <- waitForProcess pid
+
case code of
ExitSuccess -> return $ LBS.fromChunks [out]
ExitFailure{} -> error $ "Failed to run: " ++ T.unpack err
@@ -87,9 +155,17 @@ compileTestFolder path = do
[ testCase file $ do
(ret, _stdout, err) <-
case buildSystem of
- Stack -> readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) ""
- Cabal -> readProcessWithExitCode "cabal"
+ Stack -> readProcessWithExitCode "stack" (["ghc","--", fullPath] ++ ghcOpts) ""
+ Cabal -> readProcessWithExitCode "cabal"
(["v2-exec","ghc","--", "-package", "reanimate", fullPath] ++ ghcOpts) ""
+ NixBuild nixbuild -> do
+ nixIncludeDir <- includeBuild nixbuild
+ readProcessWithExitCode "ghc"
+ ( ["-isrc", "-iunix"]
+ ++ nixIncludeDir
+ ++ nixGHCOptions
+ ++ [fullPath] ++ (init ghcOpts)
+ ) ""
_ <- evaluate (length err)
case ret of
ExitFailure{} -> assertFailure $ "Failed to compile:\n" ++ err
@@ -100,7 +176,7 @@ compileTestFolder path = do
, notElem (replaceExtension file "golden") goldenFiles
]
where
- ghcOpts = ["-fno-code", "-O0", "-Werror", "-Wall"]
+ ghcOpts = ["-fno-code", "-O0", "-Wall", "-Werror"]
compileVideoFolder :: FilePath -> IO TestTree
compileVideoFolder _ | unitTestsDisabled = return $ testGroup "videos (disabled)" []
@@ -113,8 +189,16 @@ compileVideoFolder path = do
[ testCase dir $ do
(ret, _stdout, err) <-
case buildSystem of
- Stack -> readProcessWithExitCode "stack" (["ghc","--", "-i"++pathdir, fullPath] ++ ghcOpts) ""
- Cabal -> readProcessWithExitCode "cabal" (["v2-exec", "ghc","--", "-package", "reanimate", "-i"++pathdir, fullPath] ++ ghcOpts) ""
+ Stack -> readProcessWithExitCode "stack" (["ghc","--", "-i"++pathdir, fullPath] ++ ghcOpts) ""
+ Cabal -> readProcessWithExitCode "cabal" (["v2-exec", "ghc","--", "-package", "reanimate", "-i"++pathdir, fullPath] ++ ghcOpts) ""
+ NixBuild nixbuild -> do
+ nixIncludeDir <- includeBuild nixbuild
+ readProcessWithExitCode "ghc"
+ ( ["-isrc", "-iunix", "-i"++pathdir]
+ ++ nixIncludeDir
+ ++ nixGHCOptions
+ ++ [fullPath] ++ ghcOpts
+ ) ""
_ <- evaluate (length err)
case ret of
ExitFailure{} -> assertFailure $ "Failed to compile:\n" ++ err
diff --git a/unix/Detach.hs b/unix/Detach.hs
index c38ba8f..f929307 100644
--- a/unix/Detach.hs
+++ b/unix/Detach.hs
@@ -8,7 +8,7 @@ import System.Posix.Process (createSession, forkProcess)
detach :: IO () -> IO Bool
detach daemon = do
void $ forkProcess $ do
- devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
+ devnull <- openFd "/dev/null" ReadWrite defaultFileFlags
void $ dupTo devnull stdInput
void $ dupTo devnull stdOutput
void $ dupTo devnull stdError