diff --git a/obelisk/frontend/frontend.cabal b/obelisk/frontend/frontend.cabal index 6ad1337cded7a6c365f9da301388da89ae5af878..54a642b321ca8ec48a8c2cd9833885a66370525b 100644 --- a/obelisk/frontend/frontend.cabal +++ b/obelisk/frontend/frontend.cabal @@ -92,6 +92,7 @@ library Pages.MagicFolders Pages.FirstRun Pages.TechDemo + Pages.Widgets WormholeInvite ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits diff --git a/obelisk/frontend/src/Pages/FileBrowser.hs b/obelisk/frontend/src/Pages/FileBrowser.hs index 48a74f39225881239738f537f991c942f9a627f0..4af2fe3b4d3c50a6be31e69578ac1b82dfd701f6 100644 --- a/obelisk/frontend/src/Pages/FileBrowser.hs +++ b/obelisk/frontend/src/Pages/FileBrowser.hs @@ -19,7 +19,7 @@ import Control.Exception (Exception, SomeException, throwIO) import Tahoe.Announcement (Announcements(..)) import App (App(App, appGrid)) import PerformEvent (performEventInThread) -import Pages.MagicFolders (errorBox) +import Pages.Widgets (errorBox) import System.Posix.Files (rename) import FrontendPaths (getCacheDir, viewFile) import qualified Data.ByteString as B diff --git a/obelisk/frontend/src/Pages/MagicFolders.hs b/obelisk/frontend/src/Pages/MagicFolders.hs index 2de74b006425cc70f3a49c317bd39301c065f920..dc3f0ecd3d397bacb8490ae798c8139580375cb0 100644 --- a/obelisk/frontend/src/Pages/MagicFolders.hs +++ b/obelisk/frontend/src/Pages/MagicFolders.hs @@ -5,9 +5,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} -module Pages.MagicFolders (magicFolders, receiveFolderInviteText, errorBox) where +module Pages.MagicFolders (magicFolders) where -import Data.Maybe (isJust) import Control.Exception (Exception, SomeException) import Control.Monad (void) import qualified Data.Map.Strict as Map @@ -16,6 +15,7 @@ import Reflex.Dom.Core import Obelisk.Route.Frontend import Common.Route import Pages.TechDemo (doWormholeInvite) +import Pages.Widgets (errorBox, mdcButton, mdcDialog, mdcText) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Fix (MonadFix) @@ -186,80 +186,6 @@ folderWidget (MagicFolder name _state) = do setRoute $ FrontendRoute_FileBrowser :/ (name, []) <$ domEvent Click theEl' --- | Show Just an error message on the page or nothing when the error message --- is Nothing. Also return an Event that triggers when the error should be --- dismissed. -errorBox - :: ( PostBuild t m - , DomBuilder t m - ) - => Dynamic t (Maybe T.Text) - -> m (Event t ()) -errorBox msg = do - (_, _, closeButton) <- mdcDialog visible (text "Error") (dynText msg') $ do - (closeButton, _) <- mdcButton "close" $ do - divClass "mdc-button__ripple" blank - divClass "mdc-button__label" $ text "Dismiss" - pure closeButton - pure $ domEvent Click closeButton - where - visible = isJust <$> msg - msg' = ffor msg $ \case - Nothing -> "" - Just txt -> txt - --- | An MDC-themed dialog widget. -mdcDialog - :: (DomBuilder t m, PostBuild t m) - => Dynamic t Bool - -- ^ A dynamic of whether the dialog is visible or not. - -> m title - -- ^ A widget for the dialog title. - -> m content - -- ^ A widget for the dialog content. - -> m actions - -- ^ A widget for any actions (eg, "ok" / "cancel" buttons) the dialog - -- has. - -> m (title, content, actions) - -- ^ A widget with the results of the components. -mdcDialog visible title content actions = - elDynAttr "div" topLevelDynAttrs $ do - divClass "mdc-dialog__container" $ do - divClass "mdc-dialog__surface" $ do - titleValue <- elClass "h2" "mdc-dialog__title" title - (contentValue, actionsValue) <- divClass "mdc-dialog__content" $ do - contentValue <- content - actionsValue <- divClass "mdc-dialog__actions" actions - pure (contentValue, actionsValue) - pure (titleValue, contentValue, actionsValue) - <* divClass "mdc-dialog__scrim" blank - - where - topLevelDynAttrs = attributes' <$> visible - - attributes' :: Bool -> Map.Map T.Text T.Text - -- Auto-initialize in "closed" state, then change class to - -- "mdc-dialog--open" to show the dialog in a modal fashion (with an - -- overlay temporarily disabling all other elements). - attributes' True = commonAttrs <> "class" =: "mdc-dialog mdc-dialog--open" - attributes' False = commonAttrs <> "class" =: "mdc-dialog mdc-dialog--closed" - - commonAttrs = "data-mdc-auto-init" =: "MDCDialog" - - --- | An MDC-themed text field widget. -mdcText - :: DomBuilder t m - => m a - -- ^ A widget of the unstyled text. - -> m a - -- ^ The text field widget with the result of the wrapped widget. -mdcText = elAttr "label" attrs - where - attrs - = "class" =: "mdc-text-field mdc-text-field--filled" - <> "data-mdc-auto-init" =: "MDCTextField" - -- | An MDC-themed text input field. inviteCode :: DomBuilder t m => m (InputElement EventResult (DomBuilderSpace m) t) inviteCode = do @@ -269,17 +195,6 @@ inviteCode = do elClass "span" "mdc-line-ripple" blank pure inputEl --- | An MDC-themed button. -mdcButton - :: DomBuilder t m - => T.Text - -- ^ The text on the button. - -> m a - -- ^ A widget that will be made a child of the button. - -> m (Element EventResult (DomBuilderSpace m) t, a) - -- ^ The button element and the result of the child widget. -mdcButton label = - elAttr' "button" ("type" =: "button" <> "class" =: "mdc-button mdc-dialog__button" <> "data-mdc-dialog-action" =: label) -- | A widget where a wormhole code can be submitted and when it is, the -- currently active route is changed to the invite-handling route. diff --git a/obelisk/frontend/src/Pages/Widgets.hs b/obelisk/frontend/src/Pages/Widgets.hs new file mode 100644 index 0000000000000000000000000000000000000000..b2a3d81dea8f6e71e21dc3e3b3cb4df57095d001 --- /dev/null +++ b/obelisk/frontend/src/Pages/Widgets.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + +module Pages.Widgets (errorBox, mdcButton, mdcDialog, mdcText) where + +import Data.Maybe (isJust) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Reflex.Dom.Core + + +-- | Show Just an error message on the page or nothing when the error message +-- is Nothing. Also return an Event that triggers when the error should be +-- dismissed. +errorBox + :: ( PostBuild t m + , DomBuilder t m + ) + => Dynamic t (Maybe T.Text) + -> m (Event t ()) +errorBox msg = do + (_, _, closeButton) <- mdcDialog visible (text "Error") (dynText msg') $ do + (closeButton, _) <- mdcButton "close" $ do + divClass "mdc-button__ripple" blank + divClass "mdc-button__label" $ text "Dismiss" + pure closeButton + pure $ domEvent Click closeButton + where + visible = isJust <$> msg + msg' = ffor msg $ \case + Nothing -> "" + Just txt -> txt + + +-- | An MDC-themed dialog widget. +mdcDialog + :: (DomBuilder t m, PostBuild t m) + => Dynamic t Bool + -- ^ A dynamic of whether the dialog is visible or not. + -> m title + -- ^ A widget for the dialog title. + -> m content + -- ^ A widget for the dialog content. + -> m actions + -- ^ A widget for any actions (eg, "ok" / "cancel" buttons) the dialog + -- has. + -> m (title, content, actions) + -- ^ A widget with the results of the components. +mdcDialog visible title content actions = + elDynAttr "div" topLevelDynAttrs $ do + divClass "mdc-dialog__container" $ do + divClass "mdc-dialog__surface" $ do + titleValue <- elClass "h2" "mdc-dialog__title" title + (contentValue, actionsValue) <- divClass "mdc-dialog__content" $ do + contentValue <- content + actionsValue <- divClass "mdc-dialog__actions" actions + pure (contentValue, actionsValue) + pure (titleValue, contentValue, actionsValue) + <* divClass "mdc-dialog__scrim" blank + + where + topLevelDynAttrs = attributes' <$> visible + + attributes' :: Bool -> Map.Map T.Text T.Text + -- Auto-initialize in "closed" state, then change class to + -- "mdc-dialog--open" to show the dialog in a modal fashion (with an + -- overlay temporarily disabling all other elements). + attributes' True = commonAttrs <> "class" =: "mdc-dialog mdc-dialog--open" + attributes' False = commonAttrs <> "class" =: "mdc-dialog mdc-dialog--closed" + + commonAttrs = "data-mdc-auto-init" =: "MDCDialog" + + +-- | An MDC-themed text field widget. +mdcText + :: DomBuilder t m + => m a + -- ^ A widget of the unstyled text. + -> m a + -- ^ The text field widget with the result of the wrapped widget. +mdcText = elAttr "label" attrs + where + attrs + = "class" =: "mdc-text-field mdc-text-field--filled" + <> "data-mdc-auto-init" =: "MDCTextField" + + +-- | An MDC-themed button. +mdcButton + :: DomBuilder t m + => T.Text + -- ^ The text on the button. + -> m a + -- ^ A widget that will be made a child of the button. + -> m (Element EventResult (DomBuilderSpace m) t, a) + -- ^ The button element and the result of the child widget. +mdcButton label = + elAttr' "button" ("type" =: "button" <> "class" =: "mdc-button mdc-dialog__button" <> "data-mdc-dialog-action" =: label)