Implement basic elm viewer

Former-commit-id: bb096343c7e818db5ac668c5666e6935c1172916

reanimate.cabal

@@ -23,12 +23,9 @@ description:
   viewer and auto-reloader.
 
 
-data-files:           viewer/build/*.js
-                      viewer/build/*.html
-                      viewer/build/static/js/2.822530b2.chunk.js
-                      viewer/build/static/js/main.b15b405f.chunk.js
-                      viewer/build/static/js/runtime~main.9eb600ee.js
-                      viewer/build/static/css/main.f7ad3e9b.chunk.css
+data-files:           viewer-elm/dist/index.html
+                      viewer-elm/dist/elm.js
+                      viewer-elm/dist/style.css
                       data/CIExyz.csv
                       data/CIE_XYZ.csv
                       data/cone_sensitivity_lms.csv

src/Reanimate/Driver/Server.hs

@@ -9,15 +9,19 @@ import           Control.Concurrent.MVar
 import           Control.Exception       (SomeException, catch, finally)
 import           Control.Monad
 import           Control.Monad.Fix       (fix)
+import           Data.Hashable           (hash)
 import           Data.Text               (Text)
 import qualified Data.Text               as T
+import qualified Data.Text.IO            as T
 import qualified Data.Text.Read          as T
 import           GHC.Environment         (getFullArgs)
 import           Network.WebSockets
 import           Paths_reanimate
 import           Reanimate.Misc          (runCmdLazy, runCmd_)
-import           System.Directory        (doesFileExist, findFile,
+import           System.Directory        (createDirectoryIfMissing,
+                                          doesFileExist, findFile,
                                           listDirectory, makeAbsolute,
+                                          removeDirectoryRecursive,
                                           withCurrentDirectory)
 import           System.Environment      (getProgName)
 import           System.Exit
@@ -52,61 +56,64 @@ serve = withManager $ \watch -> do
       then do
         putStrLn "Already connected to browser. Rejecting."
         rejectRequestWith pending defaultRejectRequest
-      else do
+      else withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> do
+        createDirectoryIfMissing True tmpDir
         conn <- acceptRequest pending
         slave <- newEmptyMVar
         let handler = modifyMVar_ slave $ \tid -> do
               putStrLn "Reloading code..."
               killThread tid
-              forkIO $ ignoreErrors $ slaveHandler conn self
+              forkIO $ ignoreErrors $ slaveHandler conn 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 fps here.
-              _fps <- receiveData conn :: IO T.Text
+              -- FIXME: We don't use msg here.
+              _msg <- receiveData conn :: IO T.Text
               handler
               loop
-        loop `finally` (swapMVar hasConnectionVar False >> stop >> killSlave)
+        loop `finally` (removeDirectoryRecursive tmpDir >> swapMVar hasConnectionVar False >> stop >> killSlave)
 
 ignoreErrors :: IO () -> IO ()
 ignoreErrors action = action `catch` \(_::SomeException) -> return ()
 
 openViewer :: IO ()
 openViewer = do
-  url <- getDataFileName "viewer/build/index.html"
+  url <- getDataFileName "viewer-elm/dist/index.html"
   putStrLn "Opening browser..."
   bSucc <- openBrowser url
   if bSucc
       then putStrLn "Browser opened."
       else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
 
-slaveHandler :: Connection -> FilePath -> IO ()
-slaveHandler conn self =
+slaveHandler :: Connection -> FilePath -> FilePath -> IO ()
+slaveHandler conn self svgDir =
   withCurrentDirectory (takeDirectory self) $
   withSystemTempDirectory "reanimate" $ \tmpDir ->
   withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
     hClose handle
-    sendTextData conn (T.pack "Compiling")
+    sendTextData conn (T.pack "status\nCompiling")
     ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable]
     case ret of
       Left err ->
-        sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
+        sendTextData conn $ T.pack $ "error\n" ++ unlines (drop 3 (lines err))
       Right{} -> runCmdLazy tmpExecutable execOpts $ \getFrame -> do
         (frameCount,_) <- expectFrame =<< getFrame
-        sendTextData conn (T.pack $ show frameCount)
+        sendTextData conn (T.pack $ "frame_count\n" ++ show frameCount)
         fix $ \loop -> do
           (frameIdx, frame) <- expectFrame =<< getFrame
-          sendTextData conn (T.pack $ show frameIdx)
-          sendTextData conn frame
+          let fileName = svgDir </> show (hash frame) <.> "svg"
+          T.writeFile fileName frame
+          sendTextData conn (T.pack $ "frame\n" ++ show frameIdx ++ "\n" ++ fileName)
           loop
   where
     execOpts = ["raw", "+RTS", "-N", "-M1G", "-RTS"]
     expectFrame :: Either String Text -> IO (Integer, Text)
     expectFrame (Left "") = do
-      sendTextData conn (T.pack "Done")
+      sendTextData conn (T.pack "status\nDone")
       exitSuccess
     expectFrame (Left err) = do
       sendTextData conn $ T.pack $ "Error" ++ err
@@ -116,7 +123,7 @@ slaveHandler conn self =
         Left err -> do
           hPutStrLn stderr (T.unpack frame)
           hPutStrLn stderr $ "expectFrame: " ++ err
-          sendTextData conn $ T.pack $ "Error" ++ err
+          sendTextData conn $ T.pack $ "error\n" ++ err
           exitWith (ExitFailure 1)
         Right (frameNumber, rest) ->
           pure (frameNumber, rest)

viewer-elm/.gitignore

@@ -0,0 +1,3 @@
+elm-stuff
+node_modules
+.idea

viewer-elm/README.md

@@ -0,0 +1,15 @@
+# Reanimate - live reload animation previewer
+
+## Build it
+```bash
+cd reanimate/elm-viewer
+npm install
+npm run build
+npm run minify
+```
+
+## Develop it
+```bash
+npm install
+npm run dev-server
+```

viewer-elm/dist/index.html

@@ -0,0 +1,56 @@
+<html>
+
+<head>
+  <title>Reanimate - viewer</title>
+  <script type="text/javascript" src="elm.js"></script>
+  <link rel="stylesheet" href="style.css">
+</head>
+
+<body>
+  <div id="elm"></div>
+  <script type="text/javascript">
+    var mySockets = {};
+
+    function sendSocketCommand(wat) {
+      if (wat.cmd == "connect") {
+        socket = new WebSocket(wat.address);
+        socket.onopen = function(event) {
+          app.ports.receiveSocketMsg.send({
+            name: wat.name,
+            msg: "data",
+            data: "connection established"
+          });
+        }
+        socket.onmessage = function(event) {
+          app.ports.receiveSocketMsg.send({
+            name: wat.name,
+            msg: "data",
+            data: event.data
+          });
+        }
+        connectionFailedHandler = function(event) {
+          app.ports.receiveSocketMsg.send({
+            name: wat.name,
+            msg: "data",
+            data: "connection failed"
+          });
+        }
+        socket.onerror = connectionFailedHandler;
+        socket.onclose = connectionFailedHandler;
+        mySockets[wat.name] = socket;
+      } else if (wat.cmd == "send") {
+        mySockets[wat.name].send(wat.content);
+      } else if (wat.cmd == "close") {
+        mySockets[wat.name].close();
+        delete mySockets[wat.name];
+      }
+    }
+
+    var app = Elm.Main.init({
+      node: document.getElementById('elm')
+    });
+    app.ports.sendSocketCommand.subscribe(sendSocketCommand);
+  </script>
+</body>
+
+</html>

viewer-elm/dist/style.css

@@ -0,0 +1,34 @@
+body {
+  padding: 0;
+  margin: 0;
+}
+
+.app {
+  height: 100vh;
+  background-color: #282c34;
+  color: white;
+  font-family: monospace;
+  overflow: hidden;
+}
+
+.viewer {
+  position: static;
+}
+
+.viewer img {
+  max-width: 100vw;
+  max-height: 100vh;
+  margin-top: auto;
+  margin-bottom: auto;
+}
+
+.bar {
+  position: fixed;
+  top: 0;
+  margin-top: 0;
+  width: 100%;
+}
+
+.media-controls {
+  display: inline-block;
+}

viewer-elm/elm.json

@@ -0,0 +1,27 @@
+{
+    "type": "application",
+    "source-directories": [
+        "src"
+    ],
+    "elm-version": "0.19.1",
+    "dependencies": {
+        "direct": {
+            "bburdette/websocket": "1.0.2",
+            "elm/browser": "1.0.2",
+            "elm/core": "1.0.4",
+            "elm/html": "1.0.0",
+            "elm/json": "1.1.3",
+            "elm/time": "1.0.0"
+        },
+        "indirect": {
+            "NoRedInk/elm-json-decode-pipeline": "1.0.0",
+            "elm/url": "1.0.0",
+            "elm/virtual-dom": "1.0.2",
+            "elm-community/list-extra": "8.2.2"
+        }
+    },
+    "test-dependencies": {
+        "direct": {},
+        "indirect": {}
+    }
+}

viewer-elm/package.json

@@ -0,0 +1,22 @@
+{
+  "name": "viewer-elm",
+  "version": "0.1.0",
+  "description": "Animation preview ui for reanimate",
+  "main": "",
+  "scripts": {
+    "build": "elm make src/Main.elm --optimize --output dist/elm.js",
+    "dev-server": "elm-live --open --dir=dist --start-page=index.html src/Main.elm -- --output dist/elm.js",
+    "format": "elm-format --yes .",
+    "minify": "uglifyjs dist/elm.js --compress \"pure_funcs='F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9',pure_getters,keep_fargs=false,unsafe_comps,unsafe\" | uglifyjs --mangle --output=dist/elm.js"
+  },
+  "author": "",
+  "license": "Unlicense",
+  "dependencies": {
+    "elm": "^0.19.1-3"
+  },
+  "devDependencies": {
+    "elm-format": "^0.8.2",
+    "elm-live": "^4.0.1",
+    "uglify-js": "^3.7.2"
+  }
+}

viewer-elm/src/Main.elm

@@ -0,0 +1,376 @@
+module Main exposing (main)
+
+import Browser
+import Browser.Events
+import Dict exposing (Dict)
+import Html exposing (Html)
+import Html.Attributes as Attr exposing (class, disabled, src, style, title, value)
+import Html.Events exposing (onClick)
+import Json.Decode
+import Platform.Sub
+import Ports
+import Time exposing (Posix, millisToPosix, posixToMillis)
+import WebSocket
+
+
+main : Program () Model Msg
+main =
+    Browser.element
+        { init = init
+        , update = update
+        , view = view
+        , subscriptions = subscriptions
+        }
+
+
+subscriptions : Model -> Sub Msg
+subscriptions model =
+    Platform.Sub.batch
+        [ Ports.receiveSocketMsg (WebSocket.receive MessageReceived)
+        , case model.status of
+            AnimationRunning _ _ ->
+                Browser.Events.onAnimationFrame TimestampReceived
+
+            ReceivingFrames _ _ ->
+                Browser.Events.onAnimationFrame TimestampReceived
+
+            SomethingWentWrong ConnectionFailed ->
+                Time.every 1000 (always AttemptReconnect)
+
+            _ ->
+                Sub.none
+        ]
+
+
+type Msg
+    = MessageReceived (Result Json.Decode.Error WebSocket.WebSocketMsg)
+    | TimestampReceived Posix
+    | AttemptReconnect
+    | PauseClicked Int
+    | PlayClicked
+    | SeekClicked Int
+
+
+type Status
+    = Disconnected
+    | Connected
+    | Compiling
+    | ReceivingFrames Int Frames
+    | AnimationRunning Int Frames
+    | AnimationPaused Int Frames Int
+    | SomethingWentWrong Problem
+
+
+type Problem
+    = CompilationError String
+    | ConnectionFailed
+    | DoneWithoutFrames
+    | FramesMissing Int
+    | PortMessageDecodeFailure Json.Decode.Error
+    | UnexpectedMessage String
+
+
+type alias Model =
+    { status : Status
+    , clock : Posix
+    }
+
+
+type alias Frames =
+    Dict Int String
+
+
+init : () -> ( Model, Cmd Msg )
+init _ =
+    ( { status = Disconnected
+      , clock = millisToPosix 0
+      }
+    , connectCommand
+    )
+
+
+connectCommand : Cmd msg
+connectCommand =
+    WebSocket.send Ports.sendSocketCommand <|
+        WebSocket.Connect
+            { name = "TheSocket"
+            , address = "ws://localhost:9161"
+            , protocol = ""
+            }
+
+
+update : Msg -> Model -> ( Model, Cmd Msg )
+update msg model =
+    case msg of
+        AttemptReconnect ->
+            ( model, connectCommand )
+
+        TimestampReceived clock ->
+            ( { model | clock = clock }, Cmd.none )
+
+        MessageReceived result ->
+            ( processResult result model, Cmd.none )
+
+        PauseClicked frameIndex ->
+            ( case model.status of
+                AnimationRunning frameCount frames ->
+                    { model | status = AnimationPaused frameCount frames frameIndex }
+
+                _ ->
+                    model
+            , Cmd.none
+            )
+
+        PlayClicked ->
+            ( case model.status of
+                AnimationPaused frameCount frames _ ->
+                    { model | status = AnimationRunning frameCount frames }
+
+                _ ->
+                    model
+            , Cmd.none
+            )
+
+        SeekClicked delta ->
+            ( case model.status of
+                AnimationPaused frameCount frames frameIndex ->
+                    { model | status = AnimationPaused frameCount frames (modBy frameCount (frameIndex + delta)) }
+
+                _ ->
+                    model
+            , Cmd.none
+            )
+
+
+processResult : Result Json.Decode.Error WebSocket.WebSocketMsg -> Model -> Model
+processResult result model =
+    case result of
+        Err decodeError ->
+            { model | status = SomethingWentWrong (PortMessageDecodeFailure decodeError) }
+
+        Ok wsMsg ->
+            case wsMsg of
+                WebSocket.Error { error } ->
+                    { model | status = SomethingWentWrong (UnexpectedMessage error) }
+
+                WebSocket.Data { data } ->
+                    processMessage data model
+
+
+processMessage : String -> Model -> Model
+processMessage data model =
+    case String.lines data of
+        [ "connection established" ] ->
+            { model | status = Connected }
+
+        [ "connection failed" ] ->
+            somethingWentWrong ConnectionFailed model
+
+        [ "status", status ] ->
+            case status of
+                "Compiling" ->
+                    { model | status = Compiling }
+
+                "Done" ->
+                    case model.status of
+                        ReceivingFrames frameCount frames ->
+                            if Dict.keys frames == List.range 0 (frameCount - 1) then
+                                { model | status = AnimationRunning frameCount frames }
+
+                            else
+                                somethingWentWrong (FramesMissing frameCount) model
+
+                        _ ->
+                            somethingWentWrong DoneWithoutFrames model
+
+                _ ->
+                    somethingWentWrong (UnexpectedMessage ("Unknown status: '" ++ status ++ "'")) model
+
+        "error" :: errorLines ->
+            somethingWentWrong (CompilationError (String.join "\n" errorLines)) model
+
+        [ "frame_count", n ] ->
+            case String.toInt n of
+                Just frameCount ->
+                    { model | status = ReceivingFrames frameCount Dict.empty }
+
+                Nothing ->
+                    somethingWentWrong (UnexpectedMessage ("frame_count wasn't number, but '" ++ n ++ "'")) model
+
+        [ "frame", n, svgUrl ] ->
+            case String.toInt n of
+                Just frameIndex ->
+                    case model.status of
+                        ReceivingFrames frameCount frames ->
+                            { model | status = ReceivingFrames frameCount (Dict.insert frameIndex svgUrl frames) }
+
+                        _ ->
+                            somethingWentWrong (UnexpectedMessage "Got 'frame' message while not ReceivingFrames") model
+
+                Nothing ->
+                    somethingWentWrong (UnexpectedMessage ("Frame index wasn't number, but '" ++ n ++ "'")) model
+
+        _ ->
+            somethingWentWrong (UnexpectedMessage data) model
+
+
+somethingWentWrong : Problem -> Model -> Model
+somethingWentWrong what model =
+    { model | status = SomethingWentWrong what }
+
+
+view : Model -> Html Msg
+view model =
+    Html.div [ class "app" ]
+        [ case model.status of
+            Disconnected ->
+                Html.text "Disconnected"
+
+            Connected ->
+                Html.text "Connected"
+
+            Compiling ->
+                Html.text "Compiling.."
+
+            SomethingWentWrong problem ->
+                problemView problem
+
+            ReceivingFrames frameCount frames ->
+                preliminaryAnimationView frameCount frames model.clock
+
+            AnimationRunning frameCount frames ->
+                animationView frameCount frames model.clock
+
+            AnimationPaused frameCount frames frameIndex ->
+                manualControlsView frameCount frames frameIndex
+        ]
+
+
+frameIndexAt : Posix -> Int -> Int
+frameIndexAt now frameCount =
+    (posixToMillis now * 60) // 1000 |> modBy frameCount
+
+
+preliminaryAnimationView : Int -> Frames -> Posix -> Html Msg
+preliminaryAnimationView frameCount frames clock =
+    let
+        frameIndex =
+            frameIndexAt clock frameCount
+
+        bestFrame =
+            List.head (List.reverse (Dict.values (Dict.filter (\x _ -> x <= frameIndex) frames)))
+
+        controls =
+            progressView (Dict.size frames) frameCount
+    in
+    frameView frameIndex frameCount controls bestFrame
+
+
+animationView : Int -> Frames -> Posix -> Html Msg
+animationView frameCount frames clock =
+    let
+        frameIndex =
+            frameIndexAt clock frameCount
+
+        controls =
+            playControls False frameIndex
+    in
+    Dict.get frameIndex frames
+        |> frameView frameIndex frameCount controls
+
+
+manualControlsView : Int -> Frames -> Int -> Html Msg
+manualControlsView frameCount frames frameIndex =
+    let
+        controls =
+            playControls True frameIndex
+    in
+    Dict.get frameIndex frames
+        |> frameView frameIndex frameCount controls
+
+
+playControls : Bool -> Int -> Html Msg
+playControls paused frameIndex =
+    Html.div [ class "media-controls" ]
+        [ Html.button [ onClick (SeekClicked -10), disabled (not paused), title "10 frames back" ] [ Html.text "<<" ]
+        , Html.button [ onClick (SeekClicked -1), disabled (not paused), title "1 frame back" ] [ Html.text "<" ]
+        , if paused then
+            Html.button [ onClick PlayClicked, disabled (not paused) ] [ Html.text "Play" ]
+
+          else
+            Html.button [ onClick (PauseClicked frameIndex), disabled paused ] [ Html.text "Pause" ]
+        , Html.button [ onClick (SeekClicked 1), disabled (not paused), title "1 frame forward" ] [ Html.text ">" ]
+        , Html.button [ onClick (SeekClicked 10), disabled (not paused), title "10 frames forward" ] [ Html.text ">>" ]
+        ]
+
+
+frameView : Int -> Int -> Html Msg -> Maybe String -> Html Msg
+frameView frameIndex frameCount controls maybeSvgUrl =
+    let
+        image =
+            case maybeSvgUrl of
+                Just svgUrl ->
+                    Html.img [ src svgUrl ] []
+
+                Nothing ->
+                    Html.text ""
+
+        frameCountStr =
+            String.fromInt frameCount
+
+        digitCount =
+            String.length frameCountStr
+
+        bar =
+            Html.pre [ class "bar" ]
+                [ Html.text ("Frame: " ++ String.padLeft digitCount '0' (String.fromInt frameIndex) ++ " / " ++ frameCountStr ++ " ")
+                , controls
+                ]
+    in
+    Html.div [ class "viewer" ]
+        [ image
+        , bar
+        ]
+
+
+progressView : Int -> Int -> Html msg
+progressView receivedFrames frameCount =
+    Html.label []
+        [ Html.text "Loading frames "
+        , Html.progress
+            [ value (String.fromInt receivedFrames)
+            , Attr.max (String.fromInt frameCount)
+            ]
+            []
+        ]
+
+
+problemView : Problem -> Html msg
+problemView problem =
+    case problem of
+        CompilationError error ->
+            Html.div []
+                [ Html.h1 [] [ Html.text "Compilation failed" ]
+                , Html.pre [] [ Html.text error ]
+                ]
+
+        ConnectionFailed ->
+            Html.div []
+                [ Html.text "Failed to establish connection. Possible causes include: "
+                , Html.ul []
+                    [ Html.li [] [ Html.text "The reanimate script is not running" ]
+                    , Html.li [] [ Html.text "At most one viewer window can connect at time. Maybe there's another browser window/tab already connected?" ]
+                    ]
+                ]
+
+        DoneWithoutFrames ->
+            Html.text "Received 'done' message, but I was not receiving frames!"
+
+        PortMessageDecodeFailure decodeError ->
+            Html.text ("Failed to decode Port message. The error was: " ++ Json.Decode.errorToString decodeError)
+
+        UnexpectedMessage problemDescription ->
+            Html.text ("Unexpected message: " ++ problemDescription)
+
+        FramesMissing frameCount ->
+            Html.text ("Frame indices were not continuous block of number from 0 to " ++ String.fromInt (frameCount - 1))

viewer-elm/src/Ports.elm

@@ -0,0 +1,9 @@
+port module Ports exposing (receiveSocketMsg, sendSocketCommand)
+
+import Json.Decode exposing (Value)
+
+
+port receiveSocketMsg : (Value -> msg) -> Sub msg
+
+
+port sendSocketCommand : Value -> Cmd msg