diff --git a/hikaru.cabal b/hikaru.cabal
index 081c2ed9b443e738e9c36076c75bb8c41d4cfd62..47a62fe2b0f8a7e48066a4026165e72a009c6816 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -37,6 +37,7 @@ common common
DataKinds
DefaultSignatures
DeriveGeneric
+ DuplicateRecordFields
EmptyDataDecls
FlexibleContexts
FlexibleInstances
@@ -53,6 +54,8 @@ common common
RecordWildCards
ScopedTypeVariables
StandaloneDeriving
+ TupleSections
+ TypeApplications
UndecidableInstances
ghc-options:
@@ -98,6 +101,7 @@ library
Hikaru.Config
Hikaru.CSRF
Hikaru.Dispatch
+ Hikaru.Widget
Hikaru.Form
Hikaru.Link
Hikaru.Localize
diff --git a/lib/Hikaru/Widget.hs b/lib/Hikaru/Widget.hs
new file mode 100644
index 0000000000000000000000000000000000000000..bd1a456ddd3c4dd968ee7b5dbcfa5b73ed94be6e
--- /dev/null
+++ b/lib/Hikaru/Widget.hs
@@ -0,0 +1,226 @@
+-- |
+-- Module : Hikaru.Widget
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module tries to simplify building custom HTML widgets that react
+-- to query string parameters and/or form fields and render with different
+-- CSS frameworks such as Bootstrap or Bulma.
+--
+-- The primary user is the "Hikaru.Form" module, but you are welcome to
+-- used it for any interactive content such as the filtered, sorted and
+-- paged tables all applications seem to eventually grow.
+--
+-- Example:
+--
+-- @
+-- -- Alias for Bootstrap 5 in our case.
+-- data B5 = B5
+--
+-- -- Base type for our widget.
+-- data RedText = RedText (Maybe Text)
+--
+-- -- Nothing fancy, just render a piece of text in red.
+-- instance (Monad m) => 'Render' B5 m RedText where
+-- 'render' (RedText Nothing) = \"\"
+-- 'render' (RedText (Just text)) = do
+-- span_ [style_ \"color: red\"] do
+-- 'toHtml' text
+--
+-- -- Smart constructor that can take a default.
+-- redText :: (Monad m) => Maybe Text -> 'WidgetT' m RedText
+-- redText dfl = do
+-- text <- 'getArgumentMaybe' "text"
+-- return $ RedText $ text \<|\> dfl
+--
+-- -- And this is how you use it.
+-- demo :: ('Hikaru.Action.MonadAction' m) => 'HtmlT' m ()
+-- demo = do
+-- 'getWidget' @B5 \"demo.\" do
+-- redText (Just \"Hello, World!\")
+-- @
+--
+
+module Hikaru.Widget
+ (
+ -- * Using Widgets
+ newWidget
+ , getWidget
+ , postWidget
+
+ -- * Building Widgets
+ , WidgetT
+ , getArguments
+ , getArgumentMaybe
+ , getArgumentDefault
+ , getArgumentList
+
+ -- * Rendering Widgets
+ , Render(..)
+ )
+where
+ import Relude
+ import Data.Text (stripPrefix)
+ import Data.List (lookup)
+ import Lucid
+ import Hikaru.Types
+ import Hikaru.Action
+
+
+ -- |
+ -- Create new widget without GET or POST data.
+ --
+ newWidget :: forall t m a. (Render t m a, MonadAction m)
+ => Text -> WidgetT m a -> HtmlT m ()
+ newWidget prefix WidgetT{..} = do
+ widget <- lift $ runReaderT runWidgetT =<< newEnv prefix
+ render @t widget
+
+
+ -- |
+ -- Create the widget using GET query string parameters.
+ --
+ getWidget :: forall t m a. (Render t m a, MonadAction m)
+ => Text -> WidgetT m a -> HtmlT m ()
+ getWidget prefix WidgetT{..} = do
+ widget <- lift $ runReaderT runWidgetT =<< getEnv prefix
+ render @t widget
+
+
+ -- |
+ -- Create the widget using POST form fields.
+ --
+ postWidget :: forall t m a. (Render t m a, MonadAction m)
+ => Text -> WidgetT m a -> HtmlT m ()
+ postWidget prefix WidgetT{..} = do
+ widget <- lift $ runReaderT runWidgetT =<< postEnv prefix
+ render @t widget
+
+
+ -- |
+ -- Create widget environment without GET or POST data.
+ --
+ newEnv :: (MonadAction m) => Text -> m Env
+ newEnv prefix = do
+ args <- pure []
+ return Env{..}
+
+
+ -- |
+ -- Create widget environment from GET query string parameters.
+ --
+ getEnv :: (MonadAction m) => Text -> m Env
+ getEnv prefix = do
+ args <- mapMaybe (unprefix prefix) <$> getParams
+ return Env{..}
+
+
+ -- |
+ -- Create widget environment from POST form fields.
+ --
+ postEnv :: (MonadAction m) => Text -> m Env
+ postEnv prefix = do
+ args <- mapMaybe (unprefix prefix) <$> getFields
+ return Env{..}
+
+
+ -- |
+ -- Return only keys matching given prefix while stripping it.
+ --
+ unprefix :: Text -> (Text, v) -> Maybe (Text, v)
+ unprefix prefix (key, val) = (, val) <$> stripPrefix prefix key
+
+
+ -- |
+ -- Context for widget construction.
+ --
+ -- Makes it possible to access widget arguments in a way that is
+ -- portable across request methods and scoped, so that the same widget
+ -- type can be used multiple times on a single page.
+ --
+ newtype WidgetT m a
+ = WidgetT
+ { runWidgetT :: ReaderT Env m a
+ }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
+
+ instance (MonadAction m) => MonadAction (WidgetT m) where
+ getActionEnv = lift getActionEnv
+
+
+ -- |
+ -- WidgetT environment.
+ --
+ data Env
+ = Env
+ { args :: [(Text, Text)]
+ , prefix :: Text
+ }
+
+
+ -- |
+ -- Obtain all widget arguments as pieces of text.
+ --
+ getArguments :: (Monad m) => WidgetT m [(Text, Text)]
+ getArguments = WidgetT do
+ Env{args} <- ask
+ return args
+
+
+ -- |
+ -- Obtain a specific widget argument and parse it on the fly.
+ -- Parsing failure maps to 'Nothing'.
+ --
+ getArgumentMaybe :: (Monad m, Param a) => Text -> WidgetT m (Maybe a)
+ getArgumentMaybe n = do
+ value <- lookup n <$> getArguments
+ return $ fromParam =<< value
+
+
+ -- |
+ -- Similar to 'getArgumentMaybe', but return either the parsed parameter
+ -- or the specified default value.
+ --
+ getArgumentDefault :: (Monad m, Param a) => Text -> a -> WidgetT m a
+ getArgumentDefault n v = fromMaybe v <$> getArgumentMaybe n
+
+
+ -- |
+ -- Obtain a group of request query string parameters with the same name
+ -- and parse them on the fly to the target type.
+ --
+ getArgumentList :: (Monad m, Param a) => Text -> WidgetT m [a]
+ getArgumentList n = mapMaybe (fromParam . snd)
+ <$> filter ((n ==) . fst)
+ <$> getArguments
+
+
+ -- |
+ -- Class to render widgets using various HTML/CSS frameworks.
+ --
+ -- Example:
+ --
+ -- @
+ -- -- For Bootstrap 5
+ -- data B5 = B5
+ --
+ -- data Green a = Green a
+ --
+ -- instance (Monad m) => 'Render' B5 m (Green Text) where
+ -- 'render' (Green text) = do
+ -- span_ [style_ \"color: green\"] do
+ -- toHtml text
+ -- @
+ --
+ class (Monad m) => Render t m a where
+ -- |
+ -- Render widget as HTML.
+ --
+ render :: a -> HtmlT m ()
+
+
+-- vim:set ft=haskell sw=2 ts=2 et: