diff --git a/Estuary/RenderInfo.hs b/Estuary/RenderInfo.hs new file mode 100644 index 00000000..f10a34b8 --- /dev/null +++ b/Estuary/RenderInfo.hs @@ -0,0 +1,24 @@ +module Estuary.RenderInfo where + +import Data.IntMap.Strict + +data RenderInfo = RenderInfo { + errors :: !(IntMap String), + avgRenderLoad :: !Int, + peakRenderLoad :: !Int, + avgParseLoad :: !Int, + peakParseLoad :: !Int, + avgPatternsLoad :: !Int, + peakPatternsLoad :: !Int + } deriving (Show) + +emptyRenderInfo :: RenderInfo +emptyRenderInfo = RenderInfo { + errors = empty, + avgRenderLoad = 0, + peakRenderLoad = 0, + avgParseLoad = 0, + peakParseLoad = 0, + avgPatternsLoad = 0, + peakPatternsLoad = 0 + } diff --git a/Estuary/RenderState.hs b/Estuary/RenderState.hs index 092f8dc6..1aa4e745 100644 --- a/Estuary/RenderState.hs +++ b/Estuary/RenderState.hs @@ -5,27 +5,7 @@ import Data.IntMap.Strict import qualified Sound.Tidal.Context as Tidal import Estuary.Types.Definition - -data RenderInfo = RenderInfo { - errors :: !(IntMap String), - avgRenderLoad :: !Int, - peakRenderLoad :: !Int, - avgParseLoad :: !Int, - peakParseLoad :: !Int, - avgPatternsLoad :: !Int, - peakPatternsLoad :: !Int - } deriving (Show) - -emptyRenderInfo :: RenderInfo -emptyRenderInfo = RenderInfo { - errors = empty, - avgRenderLoad = 0, - peakRenderLoad = 0, - avgParseLoad = 0, - peakParseLoad = 0, - avgPatternsLoad = 0, - peakPatternsLoad = 0 - } +import Estuary.RenderInfo data RenderState = RenderState { logicalTime :: !UTCTime, diff --git a/Estuary/Renderer.hs b/Estuary/Renderer.hs index b54c2d68..78419fe8 100644 --- a/Estuary/Renderer.hs +++ b/Estuary/Renderer.hs @@ -18,6 +18,7 @@ import Estuary.Tidal.Types import Estuary.Types.Live import Estuary.Languages.TidalParsers import Estuary.WebDirt.SampleEngine +import Estuary.RenderInfo import Estuary.RenderState type Renderer = StateT RenderState IO () diff --git a/Estuary/Widgets/Estuary.hs b/Estuary/Widgets/Estuary.hs index fbd09947..2c48a1d9 100644 --- a/Estuary/Widgets/Estuary.hs +++ b/Estuary/Widgets/Estuary.hs @@ -29,14 +29,14 @@ import Estuary.Widgets.Terminal import Estuary.Reflex.Utility import Estuary.Types.Language import qualified Estuary.Types.Term as Term -import Estuary.RenderState +import Estuary.RenderInfo estuaryWidget :: MonadWidget t m => MVar Context -> MVar RenderInfo -> EstuaryProtocolObject -> m () estuaryWidget ctxM riM protocol = divClass "estuary" $ mdo ic <- liftIO $ readMVar ctxM renderInfo <- pollRenderInfoChanges riM headerChanges <- header ctx renderInfo - (values,deltasUp,hints) <- divClass "page" $ navigation (startTime ic) ctx commands deltasDown' + (values,deltasUp,hints) <- divClass "page" $ navigation (startTime ic) ctx renderInfo commands deltasDown' commands <- divClass "chat" $ terminalWidget ctx deltasUp deltasDown' (deltasDown,wsStatus) <- alternateWebSocket protocol (startTime ic) deltasUp let definitionChanges = fmap setDefinitions $ updated values diff --git a/Estuary/Widgets/Navigation.hs b/Estuary/Widgets/Navigation.hs index 1b5d8e59..2f8ea837 100644 --- a/Estuary/Widgets/Navigation.hs +++ b/Estuary/Widgets/Navigation.hs @@ -23,6 +23,7 @@ import Estuary.Types.Definition import Estuary.Types.Terminal import Estuary.Types.Context import Estuary.Types.Language +import Estuary.RenderInfo import Estuary.Widgets.View import Estuary.Reflex.Utility @@ -39,11 +40,10 @@ data Navigation = Collaborate String -navigation :: MonadWidget t m => UTCTime -> Dynamic t Context -> Event t Command -> Event t [ServerResponse] -> - m (Dynamic t DefinitionMap,Event t ServerRequest,Event t Hint) -navigation now ctx commands wsDown = mdo - let initialPage = page ctx commands wsDown now Splash - let rebuild = fmap (page ctx commands wsDown now) navEvents +navigation :: MonadWidget t m => UTCTime -> Dynamic t Context -> Dynamic t RenderInfo -> Event t Command -> Event t [ServerResponse] -> m (Dynamic t DefinitionMap,Event t ServerRequest,Event t Hint) +navigation now ctx renderInfo commands wsDown = mdo + let initialPage = page ctx renderInfo commands wsDown now Splash + let rebuild = fmap (page ctx renderInfo commands wsDown now) navEvents w <- widgetHold initialPage rebuild values <- liftM joinDyn $ mapDyn (\(x,_,_,_)->x) w wsUp <- liftM switchPromptlyDyn $ mapDyn (\(_,x,_,_)->x) w @@ -51,17 +51,16 @@ navigation now ctx commands wsDown = mdo navEvents <- liftM switchPromptlyDyn $ mapDyn (\(_,_,_,x)->x) w return (values,wsUp,hints) -page :: MonadWidget t m => Dynamic t Context -> Event t Command -> Event t [ServerResponse] -> UTCTime -> Navigation -> - m (Dynamic t DefinitionMap,Event t ServerRequest,Event t Hint,Event t Navigation) +page :: MonadWidget t m => Dynamic t Context -> Dynamic t RenderInfo -> Event t Command -> Event t [ServerResponse] -> UTCTime -> Navigation -> m (Dynamic t DefinitionMap,Event t ServerRequest,Event t Hint,Event t Navigation) -page ctx _ wsDown _ Splash = do +page ctx _ _ wsDown _ Splash = do x <- liftM (TutorialList <$) $ el "div" $ dynButton =<< translateDyn Term.Tutorials ctx y <- liftM (Solo <$) $ el "div" $ dynButton =<< translateDyn Term.Solo ctx z <- liftM (Lobby <$) $ el "div" $ dynButton =<< translateDyn Term.Collaborate ctx let navEvents = leftmost [x,y,z] return (constDyn empty,never,never,navEvents) -page ctx _ wsDown _ TutorialList = do +page ctx _ _ wsDown _ TutorialList = do el "div" $ text "Click on a button to select a tutorial interface:" t1 <- liftM (Tutorial "Structure editing" <$) $ el "div" $ button "Structure editing" t2 <- liftM (Tutorial "TidalCycles text editing" <$) $ el "div" $ button "TidalCycles text editing" @@ -69,27 +68,27 @@ page ctx _ wsDown _ TutorialList = do let navEvents = leftmost [t1,t2,back] return (constDyn empty,never,never,navEvents) -page ctx _ wsDown _ (Tutorial "Structure editing") = do +page ctx _ _ wsDown _ (Tutorial "Structure editing") = do text "Tutorial placeholder" x <- liftM (Splash <$) $ button "<----" return (constDyn empty,never,never,x) -page ctx _ wsDown _ (Tutorial "TidalCycles text editing") = do +page ctx _ _ wsDown _ (Tutorial "TidalCycles text editing") = do text "Tutorial placeholder" x <- liftM (Splash <$) $ button "<----" return (constDyn empty,never,never,x) -page ctx _ wsDown _ (Tutorial _) = do +page ctx _ _ wsDown _ (Tutorial _) = do text "Oops... a software error has occurred and we can't bring you to the tutorial you wanted! If you have a chance, please report this as a bug on Estuary's github site" x <- liftM (Splash <$) $ button "<----" return (constDyn empty,never,never,x) -page ctx _ wsDown _ Solo = do - (values,hints) <- viewInSoloWidget standardView +page ctx renderInfo _ wsDown _ Solo = do + (values,hints) <- viewInSoloWidget ctx renderInfo standardView x <- liftM (Splash <$) $ button "<----" return (values,never,hints,x) -page ctx _ wsDown _ Lobby = do +page ctx _ _ wsDown _ Lobby = do requestEnsembleList <- liftM (GetEnsembleList <$) getPostBuild spaceList <- holdDyn [] $ fmapMaybe justEnsembleList wsDown join <- simpleList spaceList joinButton -- m (Dynamic t [Event t Navigation]) @@ -99,7 +98,7 @@ page ctx _ wsDown _ Lobby = do back <- liftM (Splash <$) $ el "div" $ button "<----" return (constDyn empty,requestEnsembleList,never,leftmost [back,join'',create]) -page ctx _ _ _ CreateEnsemblePage = do +page ctx _ _ _ _ CreateEnsemblePage = do el "div" $ dynText =<< translateDyn Term.CreateNewEnsemble ctx el "div" $ dynText =<< translateDyn Term.CreateNewEnsembleNote ctx adminPwd <- el "div" $ do @@ -123,8 +122,8 @@ page ctx _ _ _ CreateEnsemblePage = do let navEvents = fmap (const Lobby) $ leftmost [cancel,() <$ createEnsemble] return (constDyn empty, serverRequests, never, navEvents) -page ctx commands wsDown now (Collaborate w) = do - (values,wsUp,hints) <- viewInEnsembleWidget w now commands wsDown +page ctx renderInfo commands wsDown now (Collaborate w) = do + (values,wsUp,hints) <- viewInEnsembleWidget ctx renderInfo w now commands wsDown x <- liftM (Lobby <$) $ button "<----" return (values,wsUp,hints,x) diff --git a/Estuary/Widgets/Text.hs b/Estuary/Widgets/Text.hs index 7921280c..a7be8908 100644 --- a/Estuary/Widgets/Text.hs +++ b/Estuary/Widgets/Text.hs @@ -25,6 +25,8 @@ import Estuary.Languages.TidalParsers import Estuary.Types.Live import Estuary.Types.TextNotation +import Estuary.Types.Context + textWidgetForPatternChain :: MonadWidget t m => String -> Event t String -> m (Dynamic t String, Event t String) textWidgetForPatternChain i delta = do let attrs = constDyn $ ("class" =: "textInputToEndOfLine") @@ -41,10 +43,10 @@ textAreaWidgetForPatternChain rows i delta = do let value = _textArea_value x return (value,edits) -tidalTextWidget :: forall t m. MonadWidget t m => +tidalTextWidget :: forall t m. MonadWidget t m => Dynamic t Context -> Dynamic t (Maybe String) -> Int -> Live (TextNotation,String) -> Event t (Live (TextNotation,String)) -> m (Dynamic t (Live (TextNotation,String)),Event t (Live (TextNotation,String)),Event t Hint) -tidalTextWidget rows i delta = divClass "textPatternChain" $ do -- *** TODO: css class name should be tidalTextWidget (in CSS also) +tidalTextWidget ctx e rows i delta = divClass "textPatternChain" $ do -- *** TODO: change css class to tidalTextWidget let deltaFuture = fmap forEditing delta let parserFuture = fmap fst deltaFuture let textFuture = fmap snd deltaFuture @@ -54,7 +56,10 @@ tidalTextWidget rows i delta = divClass "textPatternChain" $ do -- *** TODO: css d <- dropdown initialParser parserMap $ (def :: DropdownConfig t TidalParser) & dropdownConfig_setValue .~ parserFuture let parserValue = _dropdown_value d -- Dynamic t TidalParser let parserEvent = _dropdown_change d - b <- divClass "textInputLabel" $ button "eval" + b <- divClass "textInputLabel" $ do + x <- button "eval" + dynText =<< mapDyn (maybe "" (const "!")) (nubDyn e) + return x let initialText = snd $ forEditing i -- helpButton <- divClass "textInputLabel" $ button "?" textVisible <- toggle True never -- really: toggle True helpButton diff --git a/Estuary/Widgets/TransformedPattern.hs b/Estuary/Widgets/TransformedPattern.hs index 7465fadf..7f48133d 100644 --- a/Estuary/Widgets/TransformedPattern.hs +++ b/Estuary/Widgets/TransformedPattern.hs @@ -29,7 +29,7 @@ topLevelTransformedPatternWidget :: MonadWidget t m => Event t Hint -- hints (currently for WebDirt sample loading only) ) topLevelTransformedPatternWidget i delta = do - let updates = fmap midLevelTransformedPatternWidget $ fmapMaybe lastOrNothing delta + let updates = fmap (midLevelTransformedPatternWidget) $ fmapMaybe lastOrNothing delta w <- widgetHold (midLevelTransformedPatternWidget i) updates x <- mapDyn (\(a,_,_) -> a) w y <- mapDyn (\(_,a,_) -> a) w @@ -40,7 +40,8 @@ topLevelTransformedPatternWidget i delta = do return (x',y',z') -midLevelTransformedPatternWidget:: MonadWidget t m => TransformedPattern -> m (Dynamic t TransformedPattern, Event t TransformedPattern, Event t Hint) +midLevelTransformedPatternWidget:: MonadWidget t m => + TransformedPattern -> m (Dynamic t TransformedPattern, Event t TransformedPattern, Event t Hint) midLevelTransformedPatternWidget iTransPat = do tuple <- resettableTransformedPatternWidget iTransPat never pat <- mapDyn (\(x,_,_)->x) tuple diff --git a/Estuary/Widgets/View.hs b/Estuary/Widgets/View.hs index ae954ddb..fa2a8ab8 100644 --- a/Estuary/Widgets/View.hs +++ b/Estuary/Widgets/View.hs @@ -29,12 +29,14 @@ import Estuary.Widgets.DynSvg import Estuary.Types.TidalParser import Estuary.Types.Live import Estuary.Types.TextNotation +import Estuary.Types.Context +import Estuary.RenderInfo -viewInEnsembleWidget :: MonadWidget t m => +viewInEnsembleWidget :: MonadWidget t m => Dynamic t Context -> Dynamic t RenderInfo -> String -> UTCTime -> Event t Command -> Event t [ServerResponse] -> m (Dynamic t DefinitionMap, Event t ServerRequest, Event t Hint) -viewInEnsembleWidget ensemble now commands deltasDown = mdo +viewInEnsembleWidget ctx renderInfo ensemble now commands deltasDown = mdo -- UI for global ensemble parameters (hdl,pwdRequest,tempoRequest) <- divClass "ensembleHeader" $ do @@ -66,15 +68,15 @@ viewInEnsembleWidget ensemble now commands deltasDown = mdo let requestChanges = fmap requestsToStateChanges edits ensembleState <- foldDyn ($) initialState $ mergeWith (.) [commandChanges,responseChanges,handleChanges,requestChanges] - tempoHints <- liftM (fmap TempoHint . updated . nubDyn) $ mapDyn tempo ensembleState + tempoHints <- liftM (fmap TempoHint . updated . nubDyn) $ mapDyn Estuary.Types.EnsembleState.tempo ensembleState -- dynamic View UI - let initialWidget = viewWidget emptyView Map.empty ensembleResponses + let initialWidget = viewWidget ctx renderInfo emptyView Map.empty ensembleResponses currentView <- liftM nubDyn $ mapDyn getActiveView ensembleState let newView = updated currentView currentDefs <- mapDyn zones ensembleState let newDefsAndView = attachDyn currentDefs newView - let rebuildWidget = fmap (\(ds,v) -> viewWidget v ds ensembleResponses) newDefsAndView + let rebuildWidget = fmap (\(ds,v) -> viewWidget ctx renderInfo v ds ensembleResponses) newDefsAndView ui <- widgetHold initialWidget rebuildWidget defMap <- liftM joinDyn $ mapDyn (\(y,_,_) -> y) ui edits <- liftM switchPromptlyDyn $ mapDyn (\(_,y,_) -> y) ui @@ -89,29 +91,28 @@ viewInEnsembleWidget ensemble now commands deltasDown = mdo return (defMap,requests,hints) -viewInSoloWidget :: MonadWidget t m => View -> m (Dynamic t DefinitionMap, Event t Hint) -viewInSoloWidget view = do - (zones,edits,hints) <- viewWidget view Map.empty never +viewInSoloWidget :: MonadWidget t m => Dynamic t Context -> Dynamic t RenderInfo -> View -> m (Dynamic t DefinitionMap, Event t Hint) +viewInSoloWidget ctx renderInfo view = do + (zones,edits,hints) <- viewWidget ctx renderInfo view Map.empty never return (zones,hints) -viewWidget :: MonadWidget t m => View -> DefinitionMap -> Event t [EnsembleResponse Definition] -> - m (Dynamic t DefinitionMap, Event t (EnsembleRequest Definition), Event t Hint) +viewWidget :: MonadWidget t m => Dynamic t Context -> Dynamic t RenderInfo -> View -> DefinitionMap -> Event t [EnsembleResponse Definition] -> m (Dynamic t DefinitionMap, Event t (EnsembleRequest Definition), Event t Hint) -viewWidget (Views xs) initialDefs deltasDown = foldM f i xs +viewWidget ctx renderInfo (Views xs) initialDefs deltasDown = foldM f i xs where i = (constDyn (Map.empty :: DefinitionMap), never, never) f b a = do let (prevZoneMap,prevEdits,prevHints) = b - (zoneMap,edits,hints) <- viewWidget a initialDefs deltasDown + (zoneMap,edits,hints) <- viewWidget ctx renderInfo a initialDefs deltasDown newZoneMap <- combineDyn Map.union prevZoneMap zoneMap let newEdits = leftmost [prevEdits,edits] let newHints = leftmost [prevHints,hints] return (newZoneMap,newEdits,newHints) -viewWidget (ViewDiv c v) i deltasDown = divClass c $ viewWidget v i deltasDown +viewWidget ctx renderInfo (ViewDiv c v) i deltasDown = divClass c $ viewWidget ctx renderInfo v i deltasDown -viewWidget (StructureView n) i deltasDown = do +viewWidget ctx renderInfo (StructureView n) i deltasDown = do let i' = f $ Map.findWithDefault (Structure EmptyTransformedPattern) n i let deltasDown' = fmap (justStructures . justEditsInZone n) deltasDown (value,edits,hints) <- topLevelTransformedPatternWidget i' deltasDown' @@ -121,17 +122,18 @@ viewWidget (StructureView n) i deltasDown = do where f (Structure x) = x f _ = EmptyTransformedPattern -viewWidget (TidalTextView n rows) i deltasDown = do +viewWidget ctx renderInfo (TidalTextView n rows) i deltasDown = do let i' = f $ Map.findWithDefault (TextProgram (Live (TidalTextNotation MiniTidal,"") L3)) n i let deltasDown' = fmapMaybe (lastOrNothing . justTextPrograms . justEditsInZone n) deltasDown - (value,edits,hints) <- tidalTextWidget rows i' deltasDown' + e <- mapDyn (Map.lookup n . errors) renderInfo + (value,edits,hints) <- tidalTextWidget ctx e rows i' deltasDown' value' <- mapDyn (Map.singleton n . TextProgram) value let edits' = fmap (ZoneRequest . Sited n . Edit . TextProgram) edits return (value',edits',hints) where f (TextProgram x) = x f _ = Live (TidalTextNotation MiniTidal,"") L3 -viewWidget (LabelView n) i deltasDown = do +viewWidget _ _ (LabelView n) i deltasDown = do let i' = f $ Map.findWithDefault (LabelText "") n i let deltasDown' = fmap (justLabelTexts . justEditsInZone n) deltasDown edits <- labelWidget i' deltasDown' @@ -140,7 +142,7 @@ viewWidget (LabelView n) i deltasDown = do where f (LabelText x) = x f _ = "" -viewWidget (EvaluableTextView n) i deltasDown = do +viewWidget _ _ (EvaluableTextView n) i deltasDown = do let i' = f $ Map.findWithDefault (EvaluableText "") n i let deltasDown' = fmap (justEvaluableTexts . justEditsInZone n) deltasDown editsOrEvals <- evaluableTextWidget i' deltasDown' @@ -149,6 +151,6 @@ viewWidget (EvaluableTextView n) i deltasDown = do where f (EvaluableText x) = x f _ = "" -viewWidget SvgDisplayView _ _ = do +viewWidget _ _ SvgDisplayView _ _ = do testOurDynSvg return (constDyn Map.empty, never, never) diff --git a/EstuaryClient.hs b/EstuaryClient.hs index 6fac80fc..50ca4269 100644 --- a/EstuaryClient.hs +++ b/EstuaryClient.hs @@ -12,6 +12,7 @@ import Estuary.Protocol.Foreign import Estuary.Types.Context import Estuary.Widgets.Estuary import Estuary.WebDirt.SampleEngine +import Estuary.RenderInfo import Estuary.RenderState import Estuary.Renderer