{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Reanimate.Debug
  ( traceSVG
  , traceA
  , playTraces
  )
where

import           Control.Exception   (evaluate)
import           Data.IORef          (IORef, atomicModifyIORef', modifyIORef', newIORef)
import qualified Data.Text           as T
import           Reanimate.Animation (Animation, SVG, duration, parA, pause, seqA, staticFrame)
import           Reanimate.Constants (defaultStrokeWidth)
import           Reanimate.LaTeX     (latex)
import           Reanimate.Svg       (center, mkGroup, translate, withFillColor, withStrokeColor,
                                      withStrokeWidth)
import           System.IO.Unsafe    (unsafePerformIO)
import           Text.Printf         (printf)

{-# NOINLINE traceBuffer #-}
traceBuffer :: IORef [Animation]
traceBuffer :: IORef [Animation]
traceBuffer = IO (IORef [Animation]) -> IORef [Animation]
forall a. IO a -> a
unsafePerformIO ([Animation] -> IO (IORef [Animation])
forall a. a -> IO (IORef a)
newIORef [])

{-# NOINLINE traceSVG #-}
-- | Add SVG image to trace stack.
traceSVG :: SVG -> a -> a
traceSVG :: SVG -> a -> a
traceSVG = Animation -> a -> a
forall a. Animation -> a -> a
traceA (Animation -> a -> a) -> (SVG -> Animation) -> SVG -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duration -> SVG -> Animation
staticFrame (Duration -> Duration
forall a. Fractional a => a -> a
recip Duration
60)

{-# NOINLINE traceA #-}
-- | Add animation to trace stack.
traceA :: Animation -> a -> a
traceA :: Animation -> a -> a
traceA Animation
a a
v = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
  IORef [Animation] -> ([Animation] -> [Animation]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Animation]
traceBuffer (Animation
a Animation -> [Animation] -> [Animation]
forall a. a -> [a] -> [a]
:)
  a -> IO a
forall a. a -> IO a
evaluate a
v

{-# NOINLINE playTraces #-}
-- | Evaluate argument and play back the trace stack.
playTraces :: a -> Animation
playTraces :: a -> Animation
playTraces a
v = IO Animation -> Animation
forall a. IO a -> a
unsafePerformIO (IO Animation -> Animation) -> IO Animation -> Animation
forall a b. (a -> b) -> a -> b
$ do
  a
_   <- a -> IO a
forall a. a -> IO a
evaluate a
v
  [Animation]
lst <- IORef [Animation]
-> ([Animation] -> ([Animation], [Animation])) -> IO [Animation]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Animation]
traceBuffer (\[Animation]
x -> ([], [Animation] -> [Animation]
forall a. [a] -> [a]
reverse [Animation]
x))
  let n :: Int
n = [Animation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Animation]
lst :: Int
  Animation -> IO Animation
forall (m :: * -> *) a. Monad m => a -> m a
return (Animation -> IO Animation) -> Animation -> IO Animation
forall a b. (a -> b) -> a -> b
$ (Animation -> Animation -> Animation)
-> Animation -> [Animation] -> Animation
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    Animation -> Animation -> Animation
seqA
    (Duration -> Animation
pause Duration
0)
    [ Animation
f Animation -> Animation -> Animation
`parA` Duration -> SVG -> Animation
staticFrame (Animation -> Duration
duration Animation
f) (Int -> Int -> SVG
forall t t. (PrintfArg t, PrintfArg t) => t -> t -> SVG
counter Int
i Int
n) | (Int
i, Animation
f) <- [Int] -> [Animation] -> [(Int, Animation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Animation]
lst ]
 where
  counter :: t -> t -> SVG
counter t
a t
b = [SVG] -> SVG
mkGroup
    [ Duration -> SVG -> SVG
withStrokeWidth Duration
defaultStrokeWidth
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ String -> SVG -> SVG
withStrokeColor String
"black"
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ Duration -> Duration -> SVG -> SVG
translate Duration
6.5 Duration
4
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
center
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ Text -> SVG
latex
    (Text -> SVG) -> Text -> SVG
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
    (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> t -> t -> String
forall r. PrintfType r => String -> r
printf String
"%d/%d" t
a t
b
    , Duration -> SVG -> SVG
withStrokeWidth Duration
0
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ String -> SVG -> SVG
withFillColor String
"white"
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ Duration -> Duration -> SVG -> SVG
translate Duration
6.5 Duration
4
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
center
    (SVG -> SVG) -> SVG -> SVG
forall a b. (a -> b) -> a -> b
$ Text -> SVG
latex
    (Text -> SVG) -> Text -> SVG
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
    (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> t -> t -> String
forall r. PrintfType r => String -> r
printf String
"%d/%d" t
a t
b
    ]