{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Potato.Flow.Vty.Params ( ParamsWidgetConfig(..) , ParamsWidget(..) , holdParamsWidget -- exposed for testing , selectParamsFromSelection , networkParamsWidgetOutputDynForTesting , holdSuperStyleWidget ) where import Relude import Potato.Flow import Potato.Flow.Vty.Common import Potato.Reflex.Vty.Helpers import Potato.Flow.Vty.PotatoReader import Potato.Reflex.Vty.Widget.TextInputHelpers import Data.Align import Data.Dependent.Sum (DSum ((:=>))) import qualified Data.IntMap as IM import qualified Data.List.Extra as L import qualified Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Text.Zipper as TZ import Data.These import Data.Tuple.Extra import qualified Graphics.Vty as V import Reflex import Reflex.Network import Reflex.Potato.Helpers import Reflex.Vty deriving instance Show FocusId listForMi :: (Monad m) => [a] -> ((a, Int) -> m b) -> m [b] listForMi x f = forM (zip x [0..]) f controllersWithId_to_llama :: ControllersWithId -> Llama controllersWithId_to_llama = makePFCLlama . OwlPFCManipulate paramsNavigation :: (MonadWidget t m) => Behavior t Bool -> m (Event t Int) paramsNavigation allowReturnBeh = do tabEv <- key (V.KChar '\t') -- TODO this will cause the return key to never get sent to Layers when in renaming mode so you can't confirm a rename with enter -- I guess you need to disablee return navigation if you're in the layers menu... returnEv <- key V.KEnter let fwd = fmap (const 1) $ leftmost [tabEv, gate allowReturnBeh returnEv] back <- fmap (const (-1)) <$> key V.KBackTab return $ leftmost [fwd, back] repeatNavigation :: (MonadWidget t m, HasFocus t m) => m () repeatNavigation = do -- only allow navigation if we have focus mfiddyn <- focusedId let allowReturnBeh = fmap isJust (current mfiddyn) navEv <- paramsNavigation allowReturnBeh requestFocus $ Refocus_Shift <$> navEv -- Maybe Params stuff -- | method type for picking out params from SuperSEltLabel type ParamsSelector a = (Eq a) => SuperOwl -> Maybe a -- | method type for picking out params when there is no selection type DefaultParamsSelector a = PotatoDefaultParameters -> a type ToolOverrideSelector = Tool -> Bool toolOverrideTextAlign :: ToolOverrideSelector toolOverrideTextAlign = (== Tool_Text) toolOverrideSuperStyle :: ToolOverrideSelector toolOverrideSuperStyle = (\t -> t == Tool_Box || t == Tool_Text || t == Tool_Line) toolOverrideLineStyle :: ToolOverrideSelector toolOverrideLineStyle = (\t -> t == Tool_Line) toolOverrideSBoxType :: ToolOverrideSelector toolOverrideSBoxType = (const False) -- NOTE default variant here does nothing as this is always overriden based on tool -- | method to extract common parameters from a selection -- returns Nothing if nothing in the selection has the selected param -- returns Just (selection, Nothing) if selection that has the selected param do not share the same value selectParamsFromSelection :: (Eq a) => ParamsSelector a -> Selection -> Maybe (Selection, Maybe a) selectParamsFromSelection ps (SuperOwlParliament selection) = r where -- TODO don't do list conversion in between whataver ugh params = catMaybes . toList . fmap (\sowl -> ps sowl >>= \a -> Just (sowl, a)) $ selection values = fmap snd params subSelection = SuperOwlParliament $ Seq.fromList $ fmap fst params r = case values of [] -> Nothing x:_ -> if L.allSame values then Just (subSelection, Just x) else Just (subSelection, Nothing) makeParamsInputDyn :: (Eq a) => ToolOverrideSelector -> ParamsSelector a -> DefaultParamsSelector a -> Tool -> Selection -> PotatoDefaultParameters -> Maybe (Selection, Maybe a, Tool) makeParamsInputDyn tooloverridef psf dpsf tool selection pdp = r where r = if tooloverridef tool then Just (selection, Just (dpsf pdp), tool) else fmap (\(a,b) -> (a,b,tool)) $ selectParamsFromSelection psf selection -- similar to makeParamsInputDyn except specialized for LineStyle -- LineStyle is special because it is split between start/end and we L.allSame on each end individually makeLineStyleInputDyn :: Tool -> Selection -> PotatoDefaultParameters -> Maybe (Selection, Maybe (Maybe LineStyle, Maybe LineStyle), Tool) makeLineStyleInputDyn tool selection pdp = r where selectLineStyleFromSelection :: Selection -> Maybe (Selection, Maybe (Maybe LineStyle, Maybe LineStyle)) selectLineStyleFromSelection (SuperOwlParliament sel) = r_d1 where ps = (\x -> (getSEltLineStyle x, getSEltLineStyleEnd x)) . superOwl_toSElt_hack rawparams = ffilter (\(_,(x,y)) -> isJust x || isJust y) . fmap (\sowl -> (sowl, ps sowl)) $ sel startvalues = catMaybes . toList . fmap fst . fmap snd $ rawparams endvalues = catMaybes . toList . fmap snd . fmap snd $ rawparams subSelection = SuperOwlParliament $ fmap fst rawparams r_d1 = case (startvalues, endvalues) of ([],[]) -> Nothing (x:_, y:_) -> Just (subSelection, Just (if L.allSame startvalues then Just x else Nothing, if L.allSame endvalues then Just y else Nothing)) -- NOTE the outer maybe in `Maybe (Maybe LineStyle, Maybe LineStyle)` is redundant -- should be joined into the inner `Maybe`s when used r = if toolOverrideLineStyle tool then Just (selection, Just (Just $ _potatoDefaultParameters_lineStyle pdp, Just $ _potatoDefaultParameters_lineStyleEnd pdp), tool) else fmap (\(a,b) -> (a,b,tool)) $ selectLineStyleFromSelection selection type MaybeParamsWidgetOutputDyn t m b = Dynamic t (Maybe (m (Dynamic t Int, Event t (), Event t b))) type ParamsWidgetOutputDyn t m b = Dynamic t (m (Dynamic t Int, Event t (), Event t b)) -- if the `Maybe a` part is `Nothing` then the selection has different such properties type ParamsWidgetFn t m a b = Dynamic t PotatoDefaultParameters -> Dynamic t (Selection, Maybe a, Tool) -> ParamsWidgetOutputDyn t m b networkParamsWidgetOutputDynForTesting :: (MonadWidget t m, HasPotato t m) => ParamsWidgetOutputDyn t m b -> m (Dynamic t Int, Event t (), Event t b) networkParamsWidgetOutputDynForTesting p = do out' <- networkView p outHeightDyn <- holdDyn (constDyn 0) $ fmap fst3 out' outCaptureEv <- switchHold never $ fmap snd3 out' outEv <- switchHold never $ fmap thd3 out' return (join outHeightDyn, outCaptureEv, outEv) -- | -- returned Dynamic contains Nothing if selection was Nothing, otherwise contains Just the widget to modify parameters -- remember that input dynamic must not be disconnected from output event or there will be an infinite loop! -- maybe use delayEvent :: forall t m a. (Adjustable t m) => Event t a -> m) (Event t a) 😱 holdMaybeParamsWidget :: forall t m a b. (MonadWidget t m) => Dynamic t PotatoDefaultParameters -> Dynamic t (Maybe (Selection, Maybe a, Tool)) -- ^ selection/params input -> ParamsWidgetFn t m a b -- ^ function creating widget, note that it should always return non-nothing but using Maybe type makes life easier -> m (MaybeParamsWidgetOutputDyn t m b) holdMaybeParamsWidget pdpDyn mInputDyn widgetFn = do -- only remake the widget if it goes from Just to Nothing uniqDyn <- holdUniqDynBy (\a b -> isJust a == isJust b) mInputDyn return . join . ffor uniqDyn $ \case Nothing -> constDyn Nothing -- eh this is weird, fromMaybe should always succeed, maybe using fromJust is ok due to laziness but I don't care to find out Just _ -> Just <$> widgetFn pdpDyn (fmap (fromMaybe (isParliament_empty, Nothing, Tool_Select)) mInputDyn) emptyWidget :: (Monad m) => m () emptyWidget = return () -- SuperStyle stuff data SuperStyleCell = SSC_TL | SSC_TR | SSC_BL | SSC_BR | SSC_V | SSC_H | SSC_Fill deriving (Show) updateFromSuperStyle :: SuperStyleCell -> (SuperStyle -> TZ.TextZipper) updateFromSuperStyle ssc = r where r ss = case gettfn ssc ss of Nothing -> TZ.empty Just c -> TZ.top . TZ.fromText . T.singleton $ c gettfn = \case SSC_TL -> _superStyle_tl SSC_TR -> _superStyle_tr SSC_BL -> _superStyle_bl SSC_BR -> _superStyle_br SSC_V -> _superStyle_vertical SSC_H -> _superStyle_horizontal SSC_Fill -> (\case FillStyle_Simple c -> Just c _ -> Nothing) . _superStyle_fill makeSuperStyleTextEntry :: (MonadWidget t m, HasPotato t m) => SuperStyleCell -> Dynamic t (Maybe SuperStyle) -> m (Behavior t (Maybe PChar)) makeSuperStyleTextEntry ssc mssDyn = do mss0 <- sample . current $ mssDyn let modifyEv = (fmap (maybe id (\ss -> const (updateFromSuperStyle ssc ss))) (updated mssDyn)) ti <- singleCellTextInput modifyEv $ case mss0 of Nothing -> "" Just ss0 -> updateFromSuperStyle ssc ss0 return . current . fmap (\t -> fmap (\(c,_) -> c) (T.uncons t)) $ ti makeSuperStyleEvent :: (Reflex t) => Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Behavior t (Maybe PChar) -> Event t () -> Event t SuperStyle makeSuperStyleEvent tl v bl h f tr br trig = pushAlways pushfn trig where pushfn _ = do tl' <- sample tl v' <- sample v bl' <- sample bl h' <- sample h f' <- sample f tr' <- sample tr br' <- sample br return $ def { -- TODO Nothing is text cell was blank... _superStyle_tl = tl' , _superStyle_tr = tr' , _superStyle_bl = bl' , _superStyle_br = br' , _superStyle_vertical = v' , _superStyle_horizontal = h' --, _superStyle_point :: PChar , _superStyle_fill = maybe FillStyle_Blank FillStyle_Simple f' } -- TODO move to SELts.hs presetSuperStyles :: [[Char]] presetSuperStyles = ["╔╗╚╝║═ ","****|- ", "██████ ", "┌┐└┘│─ "] holdSuperStyleWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m SuperStyle (Either Llama SetPotatoDefaultParameters) holdSuperStyleWidget pdpDyn inputDyn = constDyn $ mdo do (grout . fixed) 1 $ text "style:" typeChoiceDyn <- (grout . stretch) 1 $ radioListSimple 0 ["custom", "presets"] setStyleEvEv <- networkView $ ffor typeChoiceDyn $ \case 1 -> do setStyleEv' <- do presetClicks <- listForMi presetSuperStyles $ \(s,i) -> (grout . fixed) 1 $ row $ (grout . stretch) 1 $ do -- TODO highlight if style matches selection text (show i <> ". " <> constant (T.pack s)) fmap (fmap (\_ -> s)) (mouseDown V.BLeft) return $ fmap superStyle_fromListFormat (leftmost presetClicks) return (length presetSuperStyles + 2, never, setStyleEv') 0 -> do -- TODO the awesome version of this has a toggle box so that you can choose to do horiz/vertical together (once you support separate horiz/vert left/right/top/down styles) -- TODO also a toggle for setting corners to common sets let mssDyn = fmap snd3 inputDyn (focusDyn,tl,v,bl,h,f,tr,br) <- do --(tile . fixed) 1 $ text (fmap (T.pack . superStyle_toListFormat . Data.Maybe.fromJust) $ current mssDyn) (tl'',h'',tr'') <- (grout . fixed) 1 $ row $ do tl' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_TL mssDyn h' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_H mssDyn tr' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_TR mssDyn return (tl',h',tr') (v'',f'') <- (grout . fixed) 1 $ row $ do v' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_V mssDyn f' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_Fill mssDyn _ <- (grout . fixed) 1 $ emptyWidget -- TODO you can modify this too, why not, 2 boxes for the same thing return (v',f') (bl'',br'') <- (grout . fixed) 1 $ row $ do bl' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_BL mssDyn _ <- (grout . fixed) 1 $ emptyWidget -- TODO you can modify this too, why not, 2 boxes for the same thing br' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_BR mssDyn return (bl',br') focusDyn' <- focusedId return (focusDyn',tl'',v'',bl'',h'',f'',tr'',br'') captureEv1 <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForSingleCharacter focusDynUnique <- holdUniqDyn focusDyn let -- TODO maybe just do it when any of the cell dynamics are updated rather than when focus changes... -- TODO if we do it on focus change, you don't want to set when escape is pressed... so maybe it's better just to do 🖕 setStyleEv' = makeSuperStyleEvent tl v bl h f tr br (void $ updated focusDynUnique) captureEv' = leftmost [void setStyleEv', captureEv1] return (5, captureEv', setStyleEv') _ -> error "radioList returned invalid index" setStyleEv <- switchHold never (fmap thd3 setStyleEvEv) captureEv <- switchHold never (fmap snd3 setStyleEvEv) heightDyn <- holdDyn 0 (fmap fst3 setStyleEvEv) let pushSuperStyleFn :: SuperStyle -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) pushSuperStyleFn ss = do (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn pdp <- sample . current $ pdpDyn let fmapfn sowl = case getSEltLabelSuperStyle (superOwl_toSEltLabel_hack sowl) of Nothing -> Nothing Just oldss -> if oldss == ss then Nothing else Just (_superOwl_id sowl, CTagSuperStyle :=> Identity (CSuperStyle (DeltaSuperStyle (oldss, ss)))) return $ if toolOverrideSuperStyle tool then if _potatoDefaultParameters_superStyle pdp == ss then Nothing else Just . Right $ def { _setPotatoDefaultParameters_superStyle = Just ss } else case Data.Maybe.mapMaybe fmapfn . toList $ selection of [] -> Nothing x -> Just . Left . controllersWithId_to_llama $ IM.fromList x ssparamsEv = push pushSuperStyleFn setStyleEv return (heightDyn, captureEv, ssparamsEv) data LineStyleCell = LSC_L | LSC_R | LSC_U | LSC_D updateFromLineStyle :: LineStyleCell -> (LineStyle -> TZ.TextZipper) updateFromLineStyle lsc = TZ.top . TZ.fromText . gettfn lsc where gettfn = \case LSC_L -> _lineStyle_leftArrows LSC_R -> _lineStyle_rightArrows LSC_U -> _lineStyle_upArrows LSC_D -> _lineStyle_downArrows makeLineStyleEvent :: (Reflex t) => Behavior t Text -> Behavior t Text -> Behavior t Text -> Behavior t Text -> Event t () -> Event t LineStyle makeLineStyleEvent l r u d trig = pushAlways pushfn trig where pushfn _ = do l' <- sample l r' <- sample r u' <- sample u d' <- sample d return $ def { _lineStyle_leftArrows = l' , _lineStyle_rightArrows = r' , _lineStyle_upArrows = u' , _lineStyle_downArrows = d' } -- TODO someday do backwards expanding text entry boxes for LSC_R and LSC_D makeLineStyleTextEntry :: (MonadWidget t m, HasPotato t m) => LineStyleCell -> Dynamic t (Maybe LineStyle) -> m (Dynamic t Text) makeLineStyleTextEntry lsc mlsDyn = do mls0 <- sample . current $ mlsDyn let modifyEv = (fmap (maybe id (\ss -> const (updateFromLineStyle lsc ss))) (updated mlsDyn)) -- TODO need to use different text input type ti <- singleCellTextInput modifyEv $ case mls0 of Nothing -> "" Just ls0 -> updateFromLineStyle lsc ls0 return ti -- TODO move to SELts.hs presetLineStyles :: [([Char], [Char], [Char], [Char])] presetLineStyles = [("","","",""), ("<",">","^","v"), ("⇦","⇨","⇧","⇩")] presetLineStyle_toText :: ([Char], [Char], [Char], [Char]) -> Text presetLineStyle_toText (l,r,u,d) = T.pack $ l <> " " <> r <> " " <> u <> " " <> d leftmostEither :: (Reflex t) => Event t a -> Event t b -> Event t (Either a b) leftmostEither eva evb = leftmost [(fmap Left eva), (fmap Right evb)] -- TODO lineystel widget should be like this -- [x] start | [x] end (the one being modified is highlighted) -- custom | preset -- .... holdLineStyleWidgetNew :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m (Maybe LineStyle, Maybe LineStyle) (Either Llama SetPotatoDefaultParameters) holdLineStyleWidgetNew pdpDyn inputDyn = constDyn $ do potatostylebeh <- fmap _potatoConfig_style askPotato let buttonAttrBeh = ffor potatostylebeh (\ps -> (_potatoStyle_normal ps, _potatoStyle_selected ps)) (grout . fixed) 1 $ text "line end style:" -- TODO in the future, we'd like to be able to disable line ends more easily (without going into presets) -- i.e. [x] start | [x] end -- alternatively, consider combining with super sytyle (endChoiceDyn, flipButtonEv) <- (grout . fixed) 1 $ row $ do endChoiceDyn' <- col $ (grout . fixed) 17 $ radioListSimple 0 ["both", "start", "end"] flipButtonEv' <- col $ (grout . stretch) 1 $ oneLineButton buttonAttrBeh "flip" return (endChoiceDyn', flipButtonEv') typeChoiceDyn <- (grout . stretch) 1 $ radioListSimple 0 ["custom", "presets"] setStyleEvEv <- do networkView $ ffor2 typeChoiceDyn endChoiceDyn $ \tc' ec' -> case (tc', ec') of (1, _) -> do setStyleEv' <- do presetClicks <- listForMi presetLineStyles $ \(s, i) -> (grout . fixed) 1 $ row $ (grout . stretch) 1 $ do -- TODO highlight if style matches selection text (constant (show i <> ". " <> presetLineStyle_toText s)) fmap (fmap (\_ -> s)) (mouseDown V.BLeft) return $ fmap lineStyle_fromListFormat (leftmost presetClicks) return (5, never, setStyleEv') (0, ec) -> do let joinmaybetuple mx = case mx of Nothing -> (Nothing, Nothing) Just x -> x lssDyn = ffor(fmap joinmaybetuple $ fmap snd3 inputDyn) $ \(start, end) -> case ec of 0 -> if start == end then start else Nothing 1 -> start 2 -> end _ -> error "radioList returned invalid index" (focusDyn,wasChangeDyn,l,r,u,d) <- do --(tile . fixed) 1 $ text (fmap (T.pack . superStyle_toListFormat . Data.Maybe.fromJust) $ current mssDyn) l_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text " left:" (tile . stretch) 1 $ makeLineStyleTextEntry LSC_L lssDyn r_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text "right:" (tile . stretch) 1 $ makeLineStyleTextEntry LSC_R lssDyn u_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text "up:" (tile . stretch) 1 $ makeLineStyleTextEntry LSC_U lssDyn d_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text "down:" (tile . stretch) 1 $ makeLineStyleTextEntry LSC_D lssDyn focusDyn' <- focusedId -- track if there were changes made in the cell and reset each time we change cells let trueInputChangeEv = difference (leftmost [updated l_d1 $> True, updated r_d1 $> True, updated u_d1 $> True, updated d_d1 $> True]) (updated lssDyn) wasChangeDyn' <- holdDyn False $ leftmost [updated focusDyn' $> False, trueInputChangeEv] return (focusDyn',wasChangeDyn',l_d1,r_d1,u_d1,d_d1) captureEv'' <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForSingleCharacter focusDynUnique <- holdUniqDyn focusDyn let setStyleEv' = makeLineStyleEvent (current l) (current r) (current u) (current d) (void $ gate (current wasChangeDyn) (updated focusDynUnique)) captureEv' = leftmost [void setStyleEv', captureEv''] return (7, captureEv', setStyleEv') _ -> error "radioList returned invalid index" setStyleEv <- switchHold never (fmap thd3 setStyleEvEv) captureEv <- switchHold never (fmap snd3 setStyleEvEv) heightDyn <- holdDyn 0 (fmap fst3 setStyleEvEv) let pushLineStyleFn :: Either () LineStyle -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) pushLineStyleFn eflipss = do pdp <- sample . current $ pdpDyn whichEnd' <- sample . current $ endChoiceDyn (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn let whichEnd = case whichEnd' of 0 -> SetLineStyleEnd_Both 1 -> SetLineStyleEnd_Start 2 -> SetLineStyleEnd_End _ -> error "radioList returned invalid index" (setstart, setend) = case whichEnd of SetLineStyleEnd_Start -> (True, False) SetLineStyleEnd_End -> (False, True) SetLineStyleEnd_Both -> (True, True) whichEndFn sowl = case whichEnd of SetLineStyleEnd_Start -> startStyle SetLineStyleEnd_End -> endStyle SetLineStyleEnd_Both -> if startStyle == endStyle then startStyle else Nothing where seltl = superOwl_toSEltLabel_hack sowl startStyle = getSEltLabelLineStyle seltl endStyle = getSEltLabelLineStyleEnd seltl return $ case eflipss of Left () -> case Data.Maybe.mapMaybe fmapleftfn . toList $ selection of [] -> Nothing x -> Just . Left . makeCompositionLlama $ x where fmapleftfn sowl = makeLlamaForFlipLineStyle sowl Right ss -> if toolOverrideLineStyle tool then if _potatoDefaultParameters_lineStyle pdp == ss then Nothing else Just . Right $ -- is there a better syntax to do this LOL? def { _setPotatoDefaultParameters_lineStyle = if setstart then Just ss else _setPotatoDefaultParameters_lineStyle def , _setPotatoDefaultParameters_lineStyleEnd = if setend then Just ss else _setPotatoDefaultParameters_lineStyleEnd def } else case Data.Maybe.mapMaybe fmaprightfn . toList $ selection of [] -> Nothing x -> Just . Left . makeCompositionLlama $ x where fmaprightfn sowl = case whichEndFn sowl of Nothing -> llama Just oldss -> if oldss == ss then Nothing else llama where llama = Just $ makeLlamaForLineStyle sowl whichEnd ss ssparamsEv = push pushLineStyleFn (leftmostEither flipButtonEv setStyleEv) return (heightDyn, captureEv, ssparamsEv) -- Text Alignment stuff holdTextAlignmentWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m TextAlign (Either Llama SetPotatoDefaultParameters) holdTextAlignmentWidget _ inputDyn = constDyn $ do let mtaDyn = fmap snd3 inputDyn let alignDyn = ffor mtaDyn $ \case Nothing -> [] Just TextAlign_Left -> [0] Just TextAlign_Center -> [1] Just TextAlign_Right -> [2] (grout . fixed) 1 $ text "text align:" -- I'm actually not sure why using alignDyn here isn't causing an infinite loop -- I guess the whole widget is getting recreated when alignment changes... but when I sampled alignDyn instead, it didn't update correctly 🤷🏼‍♀️ (setAlignmentEv', _) <- (grout . stretch) 1 $ radioList (constDyn ["left","center","right"]) alignDyn Nothing let setAlignmentEv = fmap (\case 0 -> TextAlign_Left 1 -> TextAlign_Center 2 -> TextAlign_Right _ -> error "radioList returned invalid index" ) $ setAlignmentEv' pushAlignmentFn :: TextAlign -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) pushAlignmentFn ta = do (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn let fmapfn sowl = case getSEltLabelBoxTextStyle (superOwl_toSEltLabel_hack sowl) of Nothing -> Nothing Just oldts -> if oldts == TextStyle ta then Nothing else Just (_superOwl_id sowl, CTagBoxTextStyle :=> Identity (CTextStyle (DeltaTextStyle (oldts, TextStyle ta)))) return $ if toolOverrideTextAlign tool then Just . Right $ def { _setPotatoDefaultParameters_box_text_textAlign = Just ta } else case Data.Maybe.mapMaybe fmapfn . toList $ selection of [] -> Nothing x -> Just . Left . controllersWithId_to_llama $ IM.fromList x alignmentParamsEv = push pushAlignmentFn setAlignmentEv return (2, never, alignmentParamsEv) holdSBoxTypeWidget :: forall t m. (MonadLayoutWidget t m) => ParamsWidgetFn t m SBoxType (Either Llama SetPotatoDefaultParameters) holdSBoxTypeWidget _ inputDyn = constDyn $ do let mBoxType = fmap snd3 inputDyn let stateDyn = ffor mBoxType $ \case -- Not great, this will override everything in selection without having a "grayed out state" and do the override in a not so great way, but whatever Nothing -> (False,False) Just SBoxType_Box -> (True,False) Just SBoxType_BoxText -> (True,True) Just SBoxType_NoBox -> (False,False) Just SBoxType_NoBoxText -> (False,True) borderDyn = fmap fst stateDyn textDyn = fmap snd stateDyn (b,t) <- do b_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text "border:" (grout . stretch) 1 $ checkBox borderDyn t_d1 <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text " text:" (grout . stretch) 1 $ checkBox textDyn return (b_d1,t_d1) let captureEv = void $ leftmost [b,t] pushSBoxTypeFn :: These Bool Bool -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) pushSBoxTypeFn bt = do (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn curState <- sample . current $ stateDyn let fmapfn sowl = case getSEltLabelBoxType (superOwl_toSEltLabel_hack sowl) of Nothing -> Nothing Just oldbt -> if oldbt == newbt then Nothing else Just (_superOwl_id sowl, CTagBoxType :=> Identity (CBoxType (oldbt, newbt))) where newbt = case bt of This border -> make_sBoxType border (sBoxType_isText oldbt) That txt -> make_sBoxType (sBoxType_hasBorder oldbt) txt These border txt -> make_sBoxType border txt return $ if toolOverrideSBoxType tool -- UNTESTED, it's probably currect but the tool overrides this default so I never actually tested it then Just . Right $ def { _setPotatoDefaultParameters_sBoxType = Just $ case bt of This border -> make_sBoxType border (snd curState) That txt -> make_sBoxType (fst curState) txt These border txt -> make_sBoxType border txt } else case Data.Maybe.mapMaybe fmapfn . toList $ selection of [] -> Nothing x -> Just . Left . controllersWithId_to_llama $ IM.fromList x sBoxTypeParamsEv = push pushSBoxTypeFn (align b t) -- TODO return (2, captureEv, sBoxTypeParamsEv) -- manually pass in 'Dynamic t SCanvas' because it's not a property of th selection holdCanvasSizeWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => Dynamic t SCanvas -> ParamsWidgetFn t m () XY holdCanvasSizeWidget canvasDyn _ _ = constDyn $ do let cSizeDyn = fmap (_lBox_size . _sCanvas_box) canvasDyn cWidthDyn = fmap (\(V2 x _) -> x) cSizeDyn cHeightDyn = fmap (\(V2 _ y) -> y) cSizeDyn (focusDyn,wDyn,hDyn) <- do (grout . fixed) 1 $ text "canvas:" wDyn' <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text " width:" (tile . stretch) 1 $ dimensionInput cWidthDyn hDyn' <- (grout . fixed) 1 $ row $ do (grout . fixed) 8 $ text "height:" (tile . stretch) 1 $ dimensionInput cHeightDyn focusDyn' <- focusedId return (focusDyn',wDyn',hDyn') focusDynUnique <- holdUniqDyn focusDyn let outputEv = flip push (void $ updated focusDynUnique) $ \_ -> do cw <- sample . current $ cWidthDyn ch <- sample . current $ cHeightDyn w <- sample . current $ wDyn h <- sample . current $ hDyn return $ if cw /= w || ch /= h then Just $ V2 (w-cw) (h-ch) -- it's a delta D: else Nothing captureEv1 <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForNumberInput let -- causes causality loop idk why :( --captureEv = leftmost [void outputEv, void (updated wDyn), void (updated hDyn)] captureEv = leftmost [void outputEv, captureEv1] return (3, captureEv, outputEv) data ParamsWidgetConfig t = ParamsWidgetConfig { _paramsWidgetConfig_selectionDyn :: Dynamic t Selection , _paramsWidgetConfig_canvasDyn :: Dynamic t SCanvas , _paramsWidgetConfig_defaultParamsDyn :: Dynamic t PotatoDefaultParameters , _paramsWidgetConfig_toolDyn :: Dynamic t Tool -- many params don't set anything until they lose focus. However if we lose focus because we clicked onto another pane, that focus event doesn't propogate down far enough so we have to pass it down manually , _paramsWidgetConfig_loseFocusEv :: Event t () } data ParamsWidget t = ParamsWidget { _paramsWidget_paramsEvent :: Event t Llama , _paramsWidget_canvasSizeEvent :: Event t XY , _paramsWidget_setDefaultParamsEvent :: Event t SetPotatoDefaultParameters , _paramsWidget_captureInputEv :: Event t () , _paramsWidget_widgetHeight :: Dynamic t Int } joinHold :: (Reflex t, MonadHold t m) => Event t (Dynamic t a) -> Dynamic t a -> m (Dynamic t a) joinHold ev d0 = do dyndyn <- holdDyn d0 ev return $ join dyndyn fth4 :: (a,b,c,d) -> d fth4 (_,_,_,d) = d fstsndthd4 :: (a,b,c,d) -> (a,b,c) fstsndthd4 (a,b,c,_) = (a,b,c) holdParamsWidget :: forall t m. (MonadWidget t m, HasPotato t m) => ParamsWidgetConfig t -> m (ParamsWidget t) holdParamsWidget ParamsWidgetConfig {..} = mdo let selectionDyn = _paramsWidgetConfig_selectionDyn canvasDyn = ffor2 _paramsWidgetConfig_canvasDyn canvasSizeChangeEventDummyDyn const defaultParamsDyn = _paramsWidgetConfig_defaultParamsDyn toolDyn = _paramsWidgetConfig_toolDyn mTextAlignInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn toolOverrideTextAlign ((fmap (\(TextStyle ta) -> ta)) . getSEltLabelBoxTextStyle . superOwl_toSEltLabel_hack) _potatoDefaultParameters_box_text_textAlign mSuperStyleInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn toolOverrideSuperStyle (getSEltLabelSuperStyle . superOwl_toSEltLabel_hack) _potatoDefaultParameters_superStyle mLineStyleInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeLineStyleInputDyn mSBoxTypeInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn toolOverrideSBoxType (getSEltLabelBoxType . superOwl_toSEltLabel_hack) _potatoDefaultParameters_sBoxType -- show canvas params when nothing is selected mCanvasSizeInputDyn = ffor2 toolDyn selectionDyn (\t s -> if isParliament_null s then Just (isParliament_empty, Nothing, t) else Nothing) -- TODO consider doing initManager_ within the widgets if you don't want to tab from one widget to the next (paramsOutputEv, captureEv, canvasSizeOutputEv, heightDyn) <- initManager_ $ col $ do repeatNavigation requestFocus $ (Refocus_Clear <$ _paramsWidgetConfig_loseFocusEv) textAlignmentWidget <- holdMaybeParamsWidget defaultParamsDyn mTextAlignInputDyn holdTextAlignmentWidget superStyleWidget2 <- holdMaybeParamsWidget defaultParamsDyn mSuperStyleInputDyn holdSuperStyleWidget lineStyleWidget <- holdMaybeParamsWidget defaultParamsDyn mLineStyleInputDyn holdLineStyleWidgetNew sBoxTypeWidget <- holdMaybeParamsWidget defaultParamsDyn mSBoxTypeInputDyn holdSBoxTypeWidget canvasSizeWidget <- holdMaybeParamsWidget defaultParamsDyn mCanvasSizeInputDyn (holdCanvasSizeWidget canvasDyn) -- apparently textAlignmentWidget gets updated after any change which causes the whole network to rerender and we lose our focus state... let controllersWithIdParamsWidgets = fmap catMaybes . mconcat . (fmap (fmap (:[]))) $ [textAlignmentWidget, superStyleWidget2, lineStyleWidget, sBoxTypeWidget] paramsNetwork <- networkView . ffor2 controllersWithIdParamsWidgets canvasSizeWidget $ \widgets mcsw -> col $ do outputs <- forM widgets $ \w -> mdo (sz, captureEv', ev) <- (tile . fixed) sz w return (sz, ev, captureEv') -- canvas size widget is special becaues it's output type is different (cssz, cssev, captureEv2) <- case mcsw of Nothing -> return (0, never, never) Just csw -> mdo (cssz', csCaptureEv', cssev') <- (tile . fixed) cssz' csw return (cssz', cssev', csCaptureEv') let heightDyn'' = liftA2 (+) cssz $ foldr (liftA2 (+)) 0 $ fmap fst3 outputs -- NOTE multiple capture events will fire at once due to the way makeCaptureFromUpdateTextZipperMethod is scoped return $ (leftmostWarn "paramsLayout" (fmap snd3 outputs), leftmost (captureEv2 : fmap thd3 outputs), cssev, heightDyn'') heightDyn' <- joinHold (fmap fth4 paramsNetwork) 0 (paramsOutputEv', captureEv', canvasSizeOutputEv') <- switchHoldTriple never never never $ fmap fstsndthd4 paramsNetwork return (paramsOutputEv', captureEv', canvasSizeOutputEv', heightDyn') let -- TODO move to Data.Either.Extra maybeLeft (Left a) = Just a maybeLeft _ = Nothing maybeRight (Right a) = Just a maybeRight _ = Nothing canvasSizeChangeEventDummyDyn <- holdDyn () (void canvasSizeOutputEv) return ParamsWidget { _paramsWidget_paramsEvent = (fmapMaybe maybeLeft paramsOutputEv) , _paramsWidget_canvasSizeEvent = canvasSizeOutputEv , _paramsWidget_setDefaultParamsEvent = fmapMaybe maybeRight paramsOutputEv , _paramsWidget_captureInputEv = captureEv , _paramsWidget_widgetHeight = heightDyn }