{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Copilot.Visualize.Live
( visualize
, visualizeWith
, VisualSettings(..)
, mkDefaultVisualSettings
, SimulationSettings(..)
, mkDefaultSimulationSettings
)
where
import Control.Exception (SomeException (..), handle)
import Data.Aeson (ToJSON (..), encode)
import qualified Data.Text as T
import qualified Network.WebSockets as WS
import Prelude hiding (div, not, (++), (<), (>))
import qualified Prelude
import Text.Read (readMaybe)
import qualified Copilot.Core as Core
import Copilot.Interpret.Eval (ShowType (Haskell), eval)
import Copilot.Language hiding (interpret, typeOf)
import Copilot.Visualize.UntypedTrace (AppData, makeTraceEval)
import Copilot.Visualize.Dynamic
visualize :: String -> IO ()
visualize :: String -> IO ()
visualize = VisualSettings -> String -> IO ()
visualizeWith VisualSettings
mkDefaultVisualSettings
visualizeWith :: VisualSettings -> String -> IO ()
visualizeWith :: VisualSettings -> String -> IO ()
visualizeWith VisualSettings
settings String
spec = do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"WebSocket server starting on port "
, Int -> String
forall a. Show a => a -> String
show (VisualSettings -> Int
visualSettingsPort VisualSettings
settings)
, String
"..."
]
String -> Int -> ServerApp -> IO ()
WS.runServer
(VisualSettings -> String
visualSettingsHost VisualSettings
settings)
(VisualSettings -> Int
visualSettingsPort VisualSettings
settings)
(VisualSettings -> String -> ServerApp
app VisualSettings
settings String
spec)
data VisualSettings = VisualSettings
{ VisualSettings -> String
visualSettingsHost :: String
, VisualSettings -> Int
visualSettingsPort :: Int
, VisualSettings -> SimulationSettings
visualSettingsSimulation :: SimulationSettings
}
mkDefaultVisualSettings :: VisualSettings
mkDefaultVisualSettings :: VisualSettings
mkDefaultVisualSettings = VisualSettings
{ visualSettingsHost :: String
visualSettingsHost = String
"127.0.0.1"
, visualSettingsPort :: Int
visualSettingsPort = Int
9160
, visualSettingsSimulation :: SimulationSettings
visualSettingsSimulation = SimulationSettings
mkDefaultSimulationSettings
}
app :: VisualSettings -> String -> WS.ServerApp
app :: VisualSettings -> String -> ServerApp
app VisualSettings
settings String
spec PendingConnection
pending = do
Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pending
Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Int
30 (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ VisualSettings -> String -> Connection -> IO ()
appInit VisualSettings
settings String
spec Connection
conn
appInit :: VisualSettings -> String -> WS.Connection -> IO ()
appInit :: VisualSettings -> String -> Connection -> IO ()
appInit VisualSettings
settings String
spec Connection
conn = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
appException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
SimData
simData <- SimulationSettings -> String -> IO SimData
simInit (VisualSettings -> SimulationSettings
visualSettingsSimulation VisualSettings
settings) String
spec
let appData :: AppData
appData = Int -> Spec -> AppData
mkAppData (SimData -> Int
simSteps SimData
simData) (SimData -> Spec
simSpec SimData
simData)
let samples :: ByteString
samples = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ AppData -> Value
forall a. ToJSON a => a -> Value
toJSON AppData
appData
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn ByteString
samples
VisualSettings -> Connection -> SimData -> IO ()
appMainLoop VisualSettings
settings Connection
conn SimData
simData
where
appException :: SomeException -> IO ()
appException :: SomeException -> IO ()
appException SomeException
e = do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error:" String -> String -> String
forall a. [a] -> [a] -> [a]
Prelude.++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
appMainLoop :: VisualSettings
-> WS.Connection
-> SimData
-> IO ()
appMainLoop :: VisualSettings -> Connection -> SimData -> IO ()
appMainLoop VisualSettings
settings Connection
conn SimData
simData = do
Maybe (Command, String)
cmdM <- String -> Maybe (Command, String)
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe (Command, String))
-> (Text -> String) -> Text -> Maybe (Command, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe (Command, String))
-> IO Text -> IO (Maybe (Command, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn
let simulationSettings :: SimulationSettings
simulationSettings = VisualSettings -> SimulationSettings
visualSettingsSimulation VisualSettings
settings
SimData
simData' <- IO SimData
-> ((Command, String) -> IO SimData)
-> Maybe (Command, String)
-> IO SimData
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SimData -> IO SimData
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SimData
simData) (SimulationSettings -> SimData -> (Command, String) -> IO SimData
simStep SimulationSettings
simulationSettings SimData
simData) Maybe (Command, String)
cmdM
let appData :: AppData
appData = Int -> Spec -> AppData
mkAppData (SimData -> Int
simSteps SimData
simData') (SimData -> Spec
simSpec SimData
simData')
samples :: ByteString
samples = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ AppData -> Value
forall a. ToJSON a => a -> Value
toJSON AppData
appData
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn ByteString
samples
VisualSettings -> Connection -> SimData -> IO ()
appMainLoop VisualSettings
settings Connection
conn SimData
simData'
mkAppData :: Int -> Core.Spec -> AppData
mkAppData :: Int -> Spec -> AppData
mkAppData Int
numSteps Spec
spec' =
Int -> Spec -> ExecTrace -> AppData
makeTraceEval Int
numSteps Spec
spec' (ShowType -> Int -> Spec -> ExecTrace
eval ShowType
Haskell Int
numSteps Spec
spec')