TidalTextWidget gives visual indication of the existence of a parse e…

…rror for that zone

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
+  }

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,

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 ()

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

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,57 +40,55 @@ 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
   hints <- liftM switchPromptlyDyn $ mapDyn (\(_,_,x,_)->x) w
   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"
   back <- liftM (Splash <$) $ button  "<----"
   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)
 

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

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

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)

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