diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 lazyLambda + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Templates/DomExtras.hs b/src/Templates/DomExtras.hs new file mode 100644 --- /dev/null +++ b/src/Templates/DomExtras.hs @@ -0,0 +1,15 @@ +{-# Language OverloadedStrings #-} +module Templates.DomExtras where + +import Reflex.Dom.Core +import Data.Text as T + +elStyle :: DomBuilder t m => + T.Text + -> T.Text + -> m a + -> m a +elStyle etag styleString inner = elAttr etag ("style" =: styleString) inner + +elDynStyle :: (PostBuild t m, DomBuilder t m) => T.Text -> Dynamic t T.Text -> m a -> m a +elDynStyle etag styleString inner = elDynAttr etag ((=:) "style" <$> styleString) inner diff --git a/src/Templates/Partials/Buttons.hs b/src/Templates/Partials/Buttons.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Buttons.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Templates.Partials.Buttons where + +import Templates.Types +import Classh as C +import Classh.Reflex as C +import Data.Text as T +import Reflex.Dom.Core +import Control.Lens ((%~)) +import Data.Proxy +import Data.Char (isAlphaNum, isSpace) + +iconButton :: DomBuilder t m => Text -> m (Event t ()) +iconButton icon = do + (e, _) <- elClass' "button" classes $ text icon + pure $ domEvent Click e + where + classes = "focus:outline-none bg-primary rounded p-2.5 w-[50%] font-icon text-icon text-white leading-none shadow-button h-[95%]" + +iconButton' :: (DomBuilder t m, PostBuild t m) => Dynamic t Bool -> Text -> m (Event t ()) +iconButton' enabled icon = do + let attrs = ffor enabled $ \b -> if b then "class" =: classes else "class" =: classes <> "disabled" =: "1" + (e, _) <- elDynAttr' "button" attrs $ text icon + pure $ domEvent Click e + where + classes = "focus:outline-none flex-shrink-0 bg-primary rounded p-2.5 font-icon text-icon text-white leading-none shadow-button" + + + +primaryButton' :: (DomBuilder t m, PostBuild t m) => Dynamic t Bool -> Text -> m (Event t ()) +primaryButton' enabled buttonText = do + let attrs = ffor enabled $ \b -> if b then "class" =: classes else "class" =: classes <> "disabled" =: "1" + (e, _) <- elDynAttr' "button" attrs $ text buttonText + pure $ domEvent Click e + where + classes = + "focus:outline-none w-full p-4 mt-12 shadow-button bg-primary \ + \ font-facit font-bold text-white text-body text-center rounded \ + \ hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50" + +secondaryIconButton :: DomBuilder t m => Text -> Text -> m (Event t ()) +secondaryIconButton cs icon = do + (e, _) <- elClass' "button" classes $ + elClass "div" "font-icon leading-none text-icon text-primary-dark" $ text icon + pure $ domEvent Click e + where + classes = + "focus:outline-none rounded border border-metaline \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ p-2.5 flex-shrink-0 bg-primary-light " <> cs + + +secondaryButton :: DomBuilder t m => Text -> Text -> m (Event t ()) +secondaryButton cs label = do + (e, _) <- elClass' "button" classes $ + text label + pure $ domEvent Click e + where + classes = + "w-full p-2.5 leading-none text-center rounded border border-metaline \ + \ bg-primary-light text-primary-darker font-bold font-facit focus:outline-none \ + \ focus:ring-4 ring-primary ring-opacity-50 " <> cs + +sendButton :: DomBuilder t m => m (Event t ()) +sendButton = iconButton "send" + + +navyBlueButton :: DomBuilder t m => Text -> m (Event t ()) +navyBlueButton buttonText = do + (e, _) <- elClass' "button" other $ C.textS textCfg' buttonText + pure $ domEvent Click e + where + textCfg' = $(C.classh' [ C.text_color C..~~ C.White + , C.text_font C..~~ C.Font_Custom "Sarabun" + , C.text_weight C..~~ C.Bold + ]) + other = + "focus:outline-none w-full p-4 shadow-button bg-[#2E3A59] \ + \ rounded-3xl hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ transition-all duration-300 ease-in-out \ + \ transform hover:scale-105 active:scale-95 \ + \ hover:shadow-md active:shadow-lg" + + + + +-- FROM ACE + +primaryButtonImageDyn + :: ( PostBuild t m + , DomBuilder t m + ) + => Dynamic t Text + -> Height + -> Width + -> m (Event t ()) +primaryButtonImageDyn dynImageHref height width = do + (e, _) <- elClass' "button" classes $ + elDynAttr "img" imgAttrs blank + pure $ domEvent Click e + where + otherImgAttrs = "height" =: height <> "width" =: width <> "class" =: "block mx-auto" + imgAttrs = (\src -> otherImgAttrs <> "src" =: src) <$> dynImageHref + classes = + "focus:outline-none w-full p-4 mt-16 shadow-button bg-[#00B9DA] \ + \ font-[Sarabun] font-bold text-white text-body text-center rounded-xl \ + \ hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ transition-all duration-300 ease-in-out \ + \ transform hover:scale-105 active:scale-95 \ + \ hover:shadow-md active:shadow-lg" + + + +type Height = Text +type Width = Text +primaryButtonImage :: DomBuilder t m => Text -> Height -> Width -> m (Event t ()) +primaryButtonImage imageHref height width = do + (e, _) <- elClass' "button" classes $ + elAttr "img" ("src" =: imageHref <> "height" =: height <> "width" =: width <> "class" =: "block mx-auto") blank + pure $ domEvent Click e + where + classes = + "focus:outline-none w-full p-4 mt-16 shadow-button bg-[#00B9DA] \ + \ font-[Sarabun] font-bold text-white text-body text-center rounded-xl \ + \ hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ transition-all duration-300 ease-in-out \ + \ transform hover:scale-105 active:scale-95 \ + \ hover:shadow-md active:shadow-lg" + +primaryButtonImageText :: DomBuilder t m => Text -> Height -> Width -> Text -> m (Event t ()) +primaryButtonImageText imageHref height width bottomText = do + (e, _) <- elClass' "button" classes $ do + elAttr "img" ("src" =: imageHref <> "height" =: height <> "width" =: width <> "class" =: "block mx-auto") blank + text bottomText -- TODO: replace with styledText + pure $ domEvent Click e + where + classes = + "focus:outline-none w-full p-4 mt-16 shadow-button bg-[#00B9DA] \ + \ font-[Sarabun] font-bold text-white text-body text-center rounded-xl \ + \ hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ transition-all duration-300 ease-in-out \ + \ transform hover:scale-105 active:scale-95 \ + \ hover:shadow-md active:shadow-lg" + + +primaryButtonSized :: DomBuilder t m => TWSize -> TWSize -> Text -> m (Event t ()) +primaryButtonSized height width buttonText = do + (e, _) <- elAttr' "button" ("class" =: classTW <> "name" =: name) $ text buttonText + pure $ domEvent Click e + where + classTW = primaryClass <&> ("py-" <> showTW height) <&> ("px-" <> showTW width) + -- for testing / selenium mainly + name = T.filter (\c -> isAlphaNum c || isSpace c ) buttonText + + +primaryButton :: DomBuilder t m => Text -> m (Event t ()) +primaryButton buttonText = do + (e, _) <- elAttr' "button" ("class" =: (primaryClass <&> "py-4 px-8") <> "name" =: name) $ text buttonText + pure $ domEvent Click e + where + -- for testing / selenium mainly + name = T.filter (\c -> isAlphaNum c || isSpace c ) buttonText + +primaryClass = + "focus:outline-none shadow-button bg-[#00B9DA] \ + \ font-[Sarabun] font-bold text-white text-body text-center rounded-xl \ + \ hover:bg-primary-rich active:bg-primary-desaturated \ + \ focus:ring-4 ring-primary ring-opacity-50 \ + \ transition-all duration-300 ease-in-out \ + \ transform hover:scale-105 active:scale-95 \ + \ whitespace-nowrap inline-block \ + \ hover:shadow-md active:shadow-lg min-[0px]:text-xs md:text-lg" + +example :: Template t m => m (Event t ()) +example = buttonToggleBody "" True $ \case + True -> text "hey" + False -> text "Hello" + +-- | Toggles between 2 inner bodies based on its clicks +buttonToggleBody :: Template t m => Dynamic t T.Text -> Bool -> (Bool -> m a) -> m (Event t ()) +buttonToggleBody buttonClasses start dynDom = mdo + (e, _) <- elDynClass' "button" buttonClasses $ dyn $ ffor booly $ dynDom + let clk = domEvent Click e + booly <- toggle start clk + pure clk + + +-- | Stop event propogation on click +greedyButton :: forall t m a. DomBuilder t m => m a -> m (Event t (), a) +greedyButton c = do + let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m)) + & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (const stopPropagation) + (e, a) <- element "button" cfg c + return (domEvent Click e, a) + +greedyButton_ :: forall t m a. DomBuilder t m => m a -> m (Event t ()) +greedyButton_ c = fmap fst $ greedyButton c diff --git a/src/Templates/Partials/Checkbox.hs b/src/Templates/Partials/Checkbox.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Checkbox.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Templates.Partials.Checkbox where + +import Reflex.Dom.Core hiding (checkbox, Checkbox(..), CheckboxConfig(..)) +import Data.Default +import qualified Data.Map as Map +import qualified Data.Text as T + + + +data CheckboxConfig t = CheckboxConfig + { _checkboxConfig_setValue :: Event t Bool + , _checkboxConfig_attributes :: Dynamic t (Map.Map T.Text T.Text) + } + +instance Reflex t => Default (CheckboxConfig t) where + {-# INLINABLE def #-} + def = CheckboxConfig { _checkboxConfig_setValue = never + , _checkboxConfig_attributes = constDyn mempty + } + +data Checkbox t + = Checkbox { _checkbox_value :: Dynamic t Bool + , _checkbox_change :: Event t Bool + } + +instance HasValue (Checkbox t) where + type Value (Checkbox t) = Dynamic t Bool + value = _checkbox_value + +checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t) +checkbox checked config = do + let permanentAttrs = "type" =: "checkbox" + dAttrs = Map.delete "checked" . Map.union permanentAttrs <$> _checkboxConfig_attributes config + modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs + i <- inputElement $ def + & inputElementConfig_initialChecked .~ checked + & inputElementConfig_setChecked .~ _checkboxConfig_setValue config + & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys (AttributeName Nothing) permanentAttrs + & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs + return $ Checkbox + { _checkbox_value = _inputElement_checked i + , _checkbox_change = _inputElement_checkedChange i + } diff --git a/src/Templates/Partials/Containers.hs b/src/Templates/Partials/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Containers.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +module Templates.Partials.Containers where + +import Classh +import Classh.Reflex +import Templates.Partials.Image +import Templates.Partials.Buttons +import Templates.Types + +import Data.Text as T (Text) +import Data.Bool +import Control.Monad.Fix +import Control.Monad +import Reflex.Dom.Core + +screenContainer :: (DomBuilder t m) => m a -> m a +screenContainer = elClass "div" $(classh' [w .~~ TWSize_Screen, h .~~ TWSize_Screen, custom .~ "flex flex-col overflow-hidden"]) + +toggleButton :: (MonadFix m, DomBuilder t m, PostBuild t m, MonadHold t m) => Text -> m (Dynamic t Bool) +toggleButton label = do + let + classes :: Bool -> Text + classes shown = + "text-icon font-icon transform select-none " -- Icon display classes + <> "transition-transform duration-300 ease-in-out " -- Animation settings classes + <> bool "rotate-180" mempty shown -- Do a little twirl! + + -- The icon for a rendered container is a triangle pointing up, and + -- the icon for an unrendered container is that same triangle, rotated + -- 180deg. Using a single icon + a rotation means the transition can + -- be animated; Having the "neutral" position be "no transform" means + -- the icon won't do a twirl on page load. + rec + (labelEl, _) <- elClass' "div" $(classh' [ mt .~~ TWSize 8 + , custom .~ "cursor-pointer flex flex-row justify-between" + ]) $ do + textS $(classh' [ text_color .~~ White ]) label + elDynClass' "span" (classes <$> toggled) $ text "expand_less" + let toggleEv = domEvent Click labelEl + toggled <- holdUniqDyn =<< toggle True toggleEv + + pure toggled + + + + +-- | Wrap the body contents in a container that can be collapsed by +-- clicking on its header. As an optimisation, when the container is +-- collapsed, the inner tree is not rendered. +collapsibleContainer_ :: (MonadFix m, DomBuilder t m, PostBuild t m, MonadHold t m) => Text -> m a -> m () +collapsibleContainer_ label body = do + toggled <- toggleButton label + + dyn_ (bool blank (void body) <$> toggled) + +-- | Wrap the body contents in a container that can be collapsed by +-- clicking on its header. +collapsibleContainer :: (MonadFix m, DomBuilder t m, PostBuild t m, MonadHold t m) => Text -> m a -> m a +collapsibleContainer label body = do + let + bodyClasses :: Bool -> Text + bodyClasses shown = bool "hidden" mempty shown + + toggled <- toggleButton label + + elDynClass "div" (bodyClasses <$> toggled) body + + +-- | Wrap the body contents in a container that can be collapsed by +-- clicking on its header. +collapsibleContainerWithImage + :: (MonadFix m, DomBuilder t m, PostBuild t m, MonadHold t m) + => Text + -> Text + -> m a + -> m a +collapsibleContainerWithImage imgSrc label body = do + let + bodyClasses :: Bool -> Text + bodyClasses shown = bool "hidden" mempty shown + + toggled <- toggleButton' imgSrc label + elDynClass "div" (bodyClasses <$> toggled) body + + +toggleButton' :: (MonadFix m, DomBuilder t m, PostBuild t m, MonadHold t m) => Text -> Text -> m (Dynamic t Bool) +toggleButton' imgSrc label = do + let + classes :: Bool -> Text + classes shown = + "text-icon font-icon transform select-none " -- Icon display classes + <> "transition-transform duration-300 ease-in-out " -- Animation settings classes + <> bool "rotate-180" mempty shown -- Do a little twirl! + + -- The icon for a rendered container is a triangle pointing up, and + -- the icon for an unrendered container is that same triangle, rotated + -- 180deg. Using a single icon + a rotation means the transition can + -- be animated; Having the "neutral" position be "no transform" means + -- the icon won't do a twirl on page load. + rec + (labelEl, _) <- elClass' "div" "grid grid-cols-12 p-4" $ do + elClass "div" $(classh' [colSpan .~~ 2]) $ imgClass imgSrc "" + elClass "div" $(classh' [colSpan .~~ 9]) $ textS $(classh' [text_size .|~ [Base,LG,XL,XL2, XL3]]) label + elDynClass' "span" (classes <$> toggled) $ + dynText "expand_less" + + let toggleEv = domEvent Click labelEl + toggled <- holdUniqDyn =<< toggle True toggleEv + + pure toggled + + + +openCloseButton :: Template t m => ImgSrc -> Color -> T.Text -> m (Event t ()) +openCloseButton imgSrc tColor name = do + buttonToggleBody (constDyn "pl-10") True $ \case + True -> do + --gridCol Col12 $ do + col [6] $ imgClass imgSrc $(classh' [custom .~ "rotate-180 inline-block", position .~~ centered ]) + divClass $(classh' [colSpan .|~ [6], position .~~ centered, custom .~ "inline-block"]) $ do + textS (classhUnsafe [text_color .~~ tColor]) $ "close" <&> name + False -> do + col [6] $ imgClass imgSrc $(classh' [custom .~ "rotate-180 inline-block", position .~~ centered ]) + divClass $(classh' [colSpan .|~ [6], position .~~ centered, custom .~ "inline-block"]) $ do + textS (classhUnsafe [text_color .~~ tColor]) $ "open" <&> name diff --git a/src/Templates/Partials/Containers/Dropdown.hs b/src/Templates/Partials/Containers/Dropdown.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Containers/Dropdown.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Templates.Partials.Containers.Dropdown where + +import Classh +import Classh.Reflex +import Reflex.Dom.Core +import Control.Monad.Fix +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Text as T + + +-- | TODO: take an element config for the options elements as well +-- | TODO: clean up and upstream to reflex-dom-contrib +dropdown' + :: ( MonadFix m + , DomBuilder t m + ) + => Map.Map a T.Text + -> SelectElementConfig er t (DomBuilderSpace m) + -> m (Dynamic t a) +dropdown' options cfg' = mdo + let class' = "w-full px-4 py-3 border border-gray-300 rounded-lg focus:outline-none focus:border-[#00B9DA] font-[Sarabun] text-lg mb-5 bg-white" + let safeInitial = (snd . head $ Map.toList options) + let cfg = cfg' + & selectElementConfig_initialValue .~ safeInitial + & selectElementConfig_setValue .~ optionsEvent + & selectElementConfig_elementConfig . elementConfig_initialAttributes .~ ("class" =: class') + (selectEl, optionsEvent) <- selectElement cfg $ do + optionsEv <- mapM makeOpt $ fmap snd $ Map.toList options + pure $ leftmost optionsEv + let options' = Map.fromList $ fmap flipTup $ Map.toList options + pure $ fmap (\v -> fromJust $ Map.lookup v options') $ _selectElement_value selectEl + where + flipTup (a_,b_) = (b_,a_) + makeOpt optText = do + (e, _) <- elAttr' "option" ("value" =: optText) $ text optText + pure $ optText <$ domEvent Click e + +dropdownWithDefault + :: ( MonadFix m + , DomBuilder t m + ) + => Map.Map a T.Text + -> T.Text + -> SelectElementConfig er t (DomBuilderSpace m) + -> m (Dynamic t a) +dropdownWithDefault options start cfg' = mdo + let class' = $(classh' [ w .~~ TWSize_Full, px .~~ TWSize 4, py .~~ TWSize 3 + , bw .~~ B1 + , bc .~ [("def",Gray C300), ("focus", hex "00B9DA")] + , br .~~ R_Lg + , border . bStyle .~ [("focus",BNone)] + , custom .~ "focus:outline-none focus:border-" + , mb .~~ TWSize 5 + , bgColor .~~ White + ]) + let safeInitial = start + let cfg = cfg' + & selectElementConfig_initialValue .~ safeInitial + & selectElementConfig_setValue .~ optionsEvent + & selectElementConfig_elementConfig . elementConfig_initialAttributes .~ ("class" =: class') + (selectEl, optionsEvent) <- selectElement cfg $ do + optionsEv <- mapM makeOpt $ fmap snd $ Map.toList options + pure $ leftmost optionsEv + let options' = Map.fromList $ fmap flipTup $ Map.toList options + pure $ fmap (\v -> fromJust $ Map.lookup v options') $ _selectElement_value selectEl + where + flipTup (a_,b_) = (b_,a_) + makeOpt optText = do + (e, _) <- elAttr' "option" ("value" =: optText) $ textS $(classh' [text_font .~~ Font_Custom "Sarabun", text_size .~~ LG]) optText + pure $ optText <$ domEvent Click e diff --git a/src/Templates/Partials/Errors.hs b/src/Templates/Partials/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Errors.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Partial templates for displaying error messages. +module Templates.Partials.Errors where + +import Classh +import Classh.Reflex (textS) + +import Templates.Types +import Reflex.Dom.Core +import Data.Text (Text) + +eitherDisplay + :: Template t m + => Dynamic t (Either e a) -- ^ What to watch for + -> (a -> m ()) -- ^ How to render contents + -> (e -> m ()) + -> m () +eitherDisplay dynEith template failtemplate = dyn_ $ ffor dynEith $ \case + Left e -> failtemplate e + Right x_ -> template x_ + +-- | Render the given template only when the 'Dynamic' is 'Just'. +maybeDisplay + :: Template t m + => (a -> m ()) -- ^ How to render contents + -> Dynamic t (Maybe a) -- ^ What to watch for + -> m () +maybeDisplay template val = dyn_ $ ffor val $ \case + Nothing -> blank + Just x -> template x + +-- | Render the given template when the 'Event' fires. +displayOn :: Template t m => (a -> m ()) -> Event t a -> m () +displayOn template ev = maybeDisplay template =<< holdDyn Nothing (Just <$> ev) + +-- | Render an error message. +errorMessage :: Template t m => Text -> m () +errorMessage t = + elClass "div" $(classh' [mt .~~ TWSize 1, h .~~ twSize' 4]) $ textS "text-opacity-70" t diff --git a/src/Templates/Partials/Image.hs b/src/Templates/Partials/Image.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Image.hs @@ -0,0 +1,23 @@ +module Templates.Partials.Image where + +import Templates.Types +import Reflex.Dom.Core +import System.FilePath (takeBaseName) +import qualified Data.Map as Map +import qualified Data.Text as T + +mkBasicName :: T.Text -> T.Text +mkBasicName = T.replace (T.pack "-") (T.pack " ") . T.pack . takeBaseName . T.unpack + +img :: DomBuilder t m => ImgSrc -> m () +img src = elAttr (T.pack "img") ((T.pack "src") =: src <> (T.pack "alt") =: mkBasicName src) blank + +imgAttr :: DomBuilder t m => ImgSrc -> Map.Map T.Text T.Text -> m () +imgAttr src atrs = elAttr (T.pack "img") ((T.pack "src") =: src <> atrs <> maybeAlt) blank + where + maybeAlt = case Map.lookup (T.pack "alt") atrs of + Just _ -> mempty + Nothing -> (T.pack "alt") =: mkBasicName src + +imgClass :: DomBuilder t m => ImgSrc -> T.Text -> m () +imgClass src class' = elAttr (T.pack "img") ((T.pack "src") =: src <> (T.pack "class") =: class' <> (T.pack "alt") =: mkBasicName src) blank diff --git a/src/Templates/Partials/Inputs.hs b/src/Templates/Partials/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Inputs.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +module Templates.Partials.Inputs where + +import Reflex.Dom.Core hiding (El) +import Templates.Types +import Data.Text as T +import Data.Map as Map + +import Classh as C + +commonClassesBox :: T.Text +commonClassesBox = $(classh' [mx .~~ TWSize 1, custom .~ "focus:outline-none bg-inset flex-grow" ]) + +commonClassesText :: T.Text +commonClassesText = $(classh' [text_size .|~ [XL2, XL4], custom .~ "font-label" ]) + +messageInput' + :: Template t m + => Event t (Map AttributeName Text) + -> Event t () + -> m (InputEl t m) +messageInput' newAttributes clearEvent = inputElement $ def + & initialAttributes .~ messageInputAttrs + & inputElementConfig_setValue .~ ("" <$ clearEvent) + & (inputElementConfig_elementConfig . elementConfig_modifyAttributes) .~ ((fmap.fmap) Just newAttributes) + +messageInput + :: Template t m + => Event t (Map AttributeName Text) + -> Event t () + -> m (TextAreaElement EventResult (DomBuilderSpace m) t) +messageInput newAttributes clearEvent = textAreaElement $ def + & initialAttributes .~ messageInputAttrs + & textAreaElementConfig_setValue .~ ("" <$ clearEvent) + & (textAreaElementConfig_elementConfig . elementConfig_modifyAttributes) .~ ((fmap.fmap) Just newAttributes) + + +messageInputAttrs :: Map.Map AttributeName T.Text +messageInputAttrs = + "class" =: $(classh' [w .~~ TWSize_Full, p .~~ TWSize 4, custom .~ "text-2xl"] ) + <> "placeholder" =: "Type your message" + <> "type" =: "text" + <> "rows" =: "2" + +attachmentInput + :: Template t m + => Event t () + -> m (InputEl t m) +attachmentInput clearEvent = + divClass classhd $ + inputElement $ def + & initialAttributes .~ ("type" =: "file" <> "class" =: "") + & inputElementConfig_setValue .~ ("" <$ clearEvent) + where + classhd = "focus:outline-none mx-1 font-facit font-label text-2xl bg-inset" + <&> boxCSS (def & position .~ centeredOnly ) diff --git a/src/Templates/Partials/Invitebar.hs b/src/Templates/Partials/Invitebar.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Invitebar.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +module Templates.Partials.Invitebar where + +import Classh +import Classh.Reflex (textS) + +import Data.Default +import Data.Text (Text) +import Data.Text as T +import Control.Monad.Fix (MonadFix) + +import Reflex.Dom.Core +import Templates.Types +import Templates.Partials.Buttons + +emailParse :: a -> Either T.Text Bool +emailParse _ = Right True + +-- | Builds an input bar for emails, it returns both the input and +-- the button that sends it. +invitebar :: (PostBuild t m, DomBuilder t m, MonadHold t m, MonadFix m) => Text -> m (InputEl t m, Event t ()) +invitebar placeholder = do + rec + let emailClass e = ffor (emailParse <$> e) $ \case + Right True -> "border-rose-600 text-rose-600" + _ -> "border-rose-600 text-rose-600" + emailText e = case emailParse e of + Right True -> "Invitation sent to " <> e + -- TODO: remove + Right False -> "Email must be @aceinterviewprep.io" + Left _ -> "Invalid email format" + invbar@(invInput, invButton) <- elClass "div" $(classh' [my .~~ TWSize 2 + , w .~~ TWSize_Full + , custom .~ "shadow-button flex flex-row" + , bgColor .~~ White + , br .~~ R_Normal + ]) $ do + elClass "button" $(classh' [ pl .~~ TWSize 2 ]) $ textS "font-icon text-icon" "email" + invInput' <- inputElement $ def + & initialAttributes .~ + ("class" =: + $(classh' [ w .~~ TWSize_Full + , h .~~ TWSize_Full + , bgColor .~~ Transparent + , px .~~ TWSize 1 + , pt .~~ TWSize 3 + , pb .~~ TWSize 3 + , pr .~~ TWSize 2 + , custom .~ "focus:outline-none flex-grow placeholder-light font-label" + ] + ) + <> "placeholder" =: placeholder + <> "type" =: "email" + ) + invButton' <- iconButton' toEnable "send" + + return (invInput', invButton') + + toEnable <- holdDyn False $ + const True <$> gate + (current $ T.null <$> _inputElement_value invInput) + (_inputElement_input invInput) + + toHide <- holdDyn "hidden " $ + const mempty <$> gate + (current $ not . T.null <$> _inputElement_value invInput) + invButton + + feedback <- holdDyn mempty $ + emailText <$> tag + (current $ _inputElement_value invInput) + invButton + + let + dynClass = + fmap ( (<>) $(classh' [pl .~~ TWSize 1, pt .~~ TWSize 0, pb .~~ TWSize 1, pr .~~ TWSize 3, custom .~ "text-center"])) + $ toHide + <> (emailClass $ _inputElement_value invInput) + + elDynClass "div" dynClass + $ dynText feedback + + return invbar diff --git a/src/Templates/Partials/Lists.hs b/src/Templates/Partials/Lists.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Lists.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Partial for rendering list items. +module Templates.Partials.Lists where + +import Classh +import Classh.Reflex (textS) + +import Data.Default +import Data.List (intersperse) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom.Core + +-- | Configuration for a list item. +data ListItemConfig t = ListItemConfig + { _listItemConfig_clickable :: Dynamic t Bool + , _listItemConfig_subtext :: Dynamic t (Maybe Text) + , _listItemConfig_icon :: Dynamic t (Maybe Text) + , _listItemConfig_highlight :: Dynamic t (Maybe Text) + , _listItemConfig_unread :: Dynamic t (Maybe Int) + } + +-- | The default configuration for list items is to have no subtext, no +-- icon, no highlighting information, and to not be clickable. +defListItemConfig :: Applicative (Dynamic t) => ListItemConfig t +defListItemConfig = ListItemConfig + { _listItemConfig_clickable = pure False + , _listItemConfig_subtext = pure Nothing + , _listItemConfig_icon = pure Nothing + , _listItemConfig_highlight = pure Nothing + , _listItemConfig_unread = pure Nothing + } + +instance Reflex t => Default (ListItemConfig t) where + def = defListItemConfig + +-- | Render the given 'Text' with highlighting given by the +-- 'ListItemConfig'. +renderHighlight :: (DomBuilder t m, PostBuild t m) => ListItemConfig t -> Text -> m () +renderHighlight cfg txt = dyn_ $ ffor (_listItemConfig_highlight cfg) $ \case + Just tok | not (T.null tok) -> + sequence_ $ intersperse + (elClass "span" "font-bold" (text tok)) -- Bold occurences of the highlighted text, + (text <$> T.splitOn tok txt) -- inbetween the rest of the label text + _ -> text txt -- If there is no highlighting information, just render it as text. + + +-- | Render a list item with the given label. +listItem + :: ( DomBuilder t m + , PostBuild t m + ) + => ListItemConfig t -- ^ Visual configuration for the list item + -> Dynamic t Text -- ^ The label + -> m (Event t ()) + -- ^ If the configuration has '_listItemConfig_clickable' set, then + -- this is the 'Click' event for the list item. Otherwise, it's + -- 'never'. +listItem cfg label = do + let + topClass :: (Bool, Maybe Int) -> Text + topClass (click, unread) = T.intercalate " " $ + [ "flex flex-col py-2 border-b border-metaline" ] + <> case click of + True -> ["cursor-pointer hover:bg-[#2E3A59]"] + False -> [] + <> case unread of + Just _ -> [ "bg-[#FF6D31]" ] + Nothing -> [] + let topClassDyn = topClass <$> ((,) <$> _listItemConfig_clickable cfg <*> _listItemConfig_unread cfg) + + + (e, _) <- elDynClass' "div" topClassDyn $ do + + elClass "div" "leading-none font-facit text-body text-xl text-white flex flex-row items-center gap-2 overflow-hidden" $ do + dyn_ $ ffor (_listItemConfig_icon cfg) $ \case + Nothing -> blank + Just icon -> elClass "span" "font-icon text-icon select-none" $ text icon + + el "span" $ dyn_ $ renderHighlight cfg <$> label + + dyn_ $ ffor (_listItemConfig_subtext cfg) $ \case + Just subtext -> elClass "div" "mt-1 leading-none font-facit text-label text-light" $ text subtext + Nothing -> blank + + + pure $ domEvent Click e + + + diff --git a/src/Templates/Partials/Modal.hs b/src/Templates/Partials/Modal.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Modal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Templates.Partials.Modal where + +import Templates.Partials.Image +import Templates.Types +import Reflex.Dom.Core +import Control.Monad.Fix +import Data.Text as T + + +modal :: ( DomBuilder t m + , MonadFix m + , MonadHold t m + , PostBuild t m + ) + => ImgSrc + -> Event t () + -> m a + -> m (Event t a) +modal xButtonImgSrc open modalDom = mdo + let styleBase = "position:fixed;z-index:20;padding-top:100px;left:0;top:0;width:100%;height:100%;overflow:auto;background-color:rgb(0,0,0);background-color:rgba(0,0,0,0.4);" + hideModal = ("style" =: ("display:none;" <> styleBase)) + showModal = ("style" =: ("display:block;" <> styleBase)) + modalAttrs <- holdDyn hideModal $ mergeWith const [showModal <$ open, hideModal <$ close] + close <- elDynAttr "div" modalAttrs $ do + elAttr "div" ("style" =: "background-color:#00004D;margin:auto;padding:20px;width:80%;color:white;" + <> "class" =: "border-double rounded-md border-8 border-black text-base") $ do + e <- fmap fst $ elClass' "span" "pl-5 ml-5 pb-4 text-rose-500 grid justify-items-end" $ do + imgAttr xButtonImgSrc ("height" =: "30px" <> "width" =: "30px") + x' <- modalDom + pure $ x' <$ (domEvent Click e) + pure close diff --git a/src/Templates/Partials/Searchbar.hs b/src/Templates/Partials/Searchbar.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Partials/Searchbar.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Templates.Partials.Searchbar where + +import Classh + +import Data.Default +import Data.Text (Text) + +import Reflex.Dom.Core +import Templates.Types + +searchbar + :: DomBuilder t m + => Text + -> Event t a + -> m (InputEl t m) +searchbar placeholder clearEvent = do + elClass "div" $(classh' [mt .~~ TWSize 0, w .~~ TWSize_Full, bgColor .~~ White, br .~~ R_Normal, custom .~ "flex flex-row"]) $ do + elClass "button" $(classh' [ px .~~ TWSize 3 + , br .~~ R_Normal + , custom .~ "leading-none shadow-button focus:outline-none font-icon"]) $ text "search" + inputElement $ def + & initialAttributes .~ + ("class" =: ($(classh' [ w .~~ (pix 96) + , h .~~ TWSize_Full + , bgColor .~~ Transparent + , pl .~~ TWSize 2 + , py .~~ TWSize 1 + , pr .~~ TWSize 3 + , custom .~ "focus:outline-none flex-grow placeholder-light" + ] + ) <> $(classh' [ text_color .~~ Black + , text_weight .~~ Light + , text_size .~~ XL + , custom .~ "text-icon" + ] + ) + ) + <> "placeholder" =: placeholder + <> "type" =: "text" + ) + & inputElementConfig_setValue .~ (mempty <$ clearEvent) + diff --git a/src/Templates/Types.hs b/src/Templates/Types.hs new file mode 100644 --- /dev/null +++ b/src/Templates/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module Templates.Types + ( module Templates.Types + ) where + +import Reflex.Dom.Core hiding (El) +import Control.Monad.Fix (MonadFix) +import Data.Text (Text) + +type Template t m = (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) + +type InputEl t m = InputElement EventResult (DomBuilderSpace m) t + +type TextAreaEl t m = TextAreaElement EventResult (DomBuilderSpace m) t + +type El t m = Element EventResult (DomBuilderSpace m) t + +type ImgSrc = Text diff --git a/templates.cabal b/templates.cabal new file mode 100644 --- /dev/null +++ b/templates.cabal @@ -0,0 +1,53 @@ +name: templates +version: 0.1.0.0 +cabal-version: >= 1.10 +build-type: Simple +maintainer: galen.sprout@gmail.com +category: Web +license-file: LICENSE +license: MIT +synopsis: Out of the box reflex-dom elements +description: + Out of the box reflex-dom elements built with ClasshSS and reflex-classhss +source-repository head + type: git + location: https://github.com/Ace-Interview-Prep/templates + +library + hs-source-dirs: src + exposed-modules: Templates.Partials.Buttons + Templates.Partials.Checkbox + Templates.Partials.Image + Templates.Partials.Containers + Templates.Partials.Containers.Dropdown + Templates.Partials.Inputs + Templates.Partials.Lists + Templates.Partials.Modal + Templates.Partials.Searchbar + Templates.Partials.Errors + Templates.Partials.Invitebar + Templates.Types + Templates.DomExtras + default-language: Haskell2010 + default-extensions: + ConstraintKinds + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + LambdaCase + MultiParamTypeClasses + RankNTypes + RecursiveDo + ScopedTypeVariables + TemplateHaskell + + build-depends: ClasshSS >= 0.2.0 && < 0.3 + , base >= 4.19.0 && < 4.21 + , containers >= 0.7 && < 0.8 + , data-default >= 0.8.0 && < 0.9 + , filepath >= 1.5.4 && < 1.6 + , lens >= 5.3.6 && < 5.4 + , reflex-classhss >= 0.1.0 && < 0.2 + , reflex-dom >= 0.6.3 && < 0.7 + , text >= 2.1.3 && < 2.2