diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for common + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Jappie Klooster + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jappie Klooster nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# awesome-project-name diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bulmex.cabal b/bulmex.cabal new file mode 100644 --- /dev/null +++ b/bulmex.cabal @@ -0,0 +1,59 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 2b99255d36d075b833dc8c72472ac37a01a82e94c211ebc8955bb3075e4f5d12 + +name: bulmex +version: 1.0.0 +synopsis: Reflex infused with bulma (css) +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/jappeace/bulmex#readme +bug-reports: https://github.com/jappeace/bulmex/issues +author: Jappie Klooster +maintainer: jappieklooster@hotmail.com +copyright: 2018 Jappie Klooster +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/jappeace/bulmex + +library + exposed-modules: + Reflex.Bulmex.Attr + Reflex.Bulmex.Event + Reflex.Bulmex.Html + Reflex.Bulmex.Input.Polymorphic + Reflex.Bulmex.Load + Reflex.Bulmex.PreventDefault + Reflex.Bulmex.Space + Reflex.Bulmex.Tag + other-modules: + Paths_bulmex + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Widentities + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , jsaddle + , jsaddle-dom + , lens + , network-uri + , reflex >=0.6.1 && <0.7 + , reflex-dom-core >=0.5 && <0.6 + , reflex-dom-helpers >=0.2.0.1 && <0.3.0.0 + , text + , time + , witherable + default-language: Haskell2010 diff --git a/src/Reflex/Bulmex/Attr.hs b/src/Reflex/Bulmex/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Attr.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Deal with attribute maps, which revolves mostly around assigning +-- a class so we get appropriate styling + +module Reflex.Bulmex.Attr + ( AttrMap + , attrUnion + , isSelectedAttr + , whenAttr + , inputAttr + , classAttr + , disabled + , isHidden + , switchAttr + , colspan + ) where + +import Data.Bool +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Reflex +import Reflex.Bulmex.Space + +-- | This type occures to often to not alias +type AttrMap = Map.Map Text.Text Text.Text + +isHidden :: AttrMap +isHidden = classAttr "is-hidden" + +-- | Unifies all keys by concatinating the values with a whitespace +attrUnion :: AttrMap -> AttrMap -> AttrMap +attrUnion = Map.unionWith spaceJoin + +-- | If bool true adds isSelected +isSelectedAttr :: Bool -> AttrMap +isSelectedAttr = whenAttr "is-selected" + +whenAttr :: Text.Text -> Bool -> AttrMap +whenAttr = switchAttr mempty + +switchAttr :: Text.Text -> Text.Text -> Bool -> AttrMap +switchAttr lies truth = bool (classAttr lies) (classAttr truth) + +inputAttr :: Reflex t => Dynamic t AttrMap +inputAttr = constDyn $ classAttr "input" + +-- | class attr is what is needed most of the time +classAttr :: Text.Text -> AttrMap +classAttr = Map.singleton "class" + +disabled :: AttrMap +disabled = Map.singleton "disabled" "disabled" + +colspan :: Int -> AttrMap +colspan = Map.singleton "colspan" . Text.pack . show diff --git a/src/Reflex/Bulmex/Event.hs b/src/Reflex/Bulmex/Event.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Event.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | Helper functions for dealing with events +module Reflex.Bulmex.Event where + +import Control.Applicative (empty) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import Data.Time.Clock (NominalDiffTime) +import Data.Witherable +import Reflex +import qualified Reflex.Dom.Builder.Class as Dom +import qualified Reflex.Dom.Widget.Basic as Dom + +eventJoin :: (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) +eventJoin = switchHold never + +-- | Block those nothing events and only let trough 'Just' values +noNothing :: (Filterable f, Filterable f) => f (Maybe a) -> f a +noNothing = fmapMaybe id + +-- | Do something monadic with an event val +-- Because of haskell lazyness the things inside a holdevent +-- don't get evaluated untill the event fires, which makes the first +-- time slow. However it is good for initialization as we don't +-- need to load things unused. +holdEvent :: + (Dom.DomBuilder t m, MonadHold t m) + => b + -> Event t a + -> (a -> m b) + -> m (Dynamic t b) +holdEvent val evt fun = Dom.widgetHold (pure val) $ fun <$> evt + +-- | Convenience holdEvent for the case where we don't care about the +-- value. +holdEvent_ :: + (Dom.DomBuilder t m, MonadHold t m) => Event t a -> (a -> m b) -> m () +holdEvent_ = fmap void . holdEvent undefined -- we throw away the value + + +-- | Get rid of a dynimc around a tupple of events, +-- common sense says we should be able to do this for any traversable, +-- but keeping the values of events hetrogenous is hard (I don't know how to) +switchTup :: + (Reflex t) => Dynamic t (Event t b, Event t c) -> (Event t b, Event t c) +switchTup tup = (switchDyn $ fst <$> tup, switchDyn $ snd <$> tup) + +-- | Do something monadic with an event val, and get the event which is +-- delayed for a moment. +-- Using this may indicate you're doing something weird. +-- Although I've found it handy in getting just something to work +holdAfter :: + ( PostBuild t m + , Dom.DomBuilder t m + , MonadHold t m + , PerformEvent t m + , TriggerEvent t m + , MonadIO (Performable m) + ) + => b + -> Event t a + -> (a -> Event t a -> m b) + -> m (Dynamic t b) +holdAfter val evt fun = delay 0 evt >>= holdEvent val evt . flip fun + +-- | show something for 5 seconds after an event +flash :: + (Monoid c, Dom.DomBuilder t m, PerformEvent t m, MonadHold t m, TriggerEvent t m, (MonadIO (Performable m))) + => Event t b + -> (b -> m c) + -> m (Dynamic t c) +flash = flash' 5 mempty + +flash' :: (Dom.DomBuilder t m, PerformEvent t m, MonadHold t m, TriggerEvent t m, (MonadIO (Performable m))) + => NominalDiffTime + -> c + -> Event t b + -> (b -> m c) + -> m (Dynamic t c) +flash' time defVal event monadFunc = do + delayed <- delay time event + holdEvent defVal (leftmost [pure <$> event, empty <$ delayed]) $ + maybe (pure defVal) monadFunc diff --git a/src/Reflex/Bulmex/Html.hs b/src/Reflex/Bulmex/Html.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Html.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | A root for an app, +-- usefull for server side html rendering. +-- has a neat api for the head tag, use this if that api your needs. +module Reflex.Bulmex.Html + ( htmlWidget + -- * Head tag stuff + , HeadSettings(..) + , head_js + , head_css + , head_title + , HeadScript(..) + , script_uri + , script_is_async + -- * Defaults + , defScript + , defSettings + ) where + +import Control.Lens +import Control.Monad (void) +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Network.URI +import qualified Reflex.Dom.Builder.Class as Dom +import qualified Reflex.Dom.Widget as Dom + +-- | Adds the core html tags. +-- we already know most of the head. +htmlWidget :: (Dom.DomBuilder t m) => HeadSettings -> m a -> m a +htmlWidget settings content = + Dom.el "html" $ do + void $ Dom.el "head" $ do + headWidget settings + Dom.el "body" $ content + +defSettings :: HeadSettings +defSettings = HeadSettings{ + _head_js = mempty + , _head_css = mempty + , _head_title = mempty + } + +data HeadSettings = HeadSettings + { _head_js :: [HeadScript] + , _head_css :: [URI] + , _head_title :: Text.Text + } deriving (Generic, Show) + +head_js :: Lens' HeadSettings [HeadScript] +head_js = lens _head_js $ \x b -> x{_head_js=b} + +head_css :: Lens' HeadSettings [URI] +head_css = lens _head_css $ \x b -> x{_head_css=b} + +head_title :: Lens' HeadSettings Text.Text +head_title = lens _head_title $ \x b -> x{_head_title=b} + +data HeadScript = HeadScript + { _script_is_async :: Bool + , _script_uri :: URI + } deriving (Generic, Show) + +defScript :: HeadScript +defScript = HeadScript { + _script_is_async = True + , _script_uri = nullURI + } + +script_uri :: Lens' HeadScript URI +script_uri = lens _script_uri $ \x b -> x{_script_uri=b} + +script_is_async :: Lens' HeadScript Bool +script_is_async = lens _script_is_async $ \x b -> x{_script_is_async=b} + +isasync :: (Text.Text, Text.Text) +isasync = ("async","true") + +scriptToMap :: HeadScript -> Map.Map Text.Text Text.Text +scriptToMap script = Map.fromList $ + if (script ^. script_is_async) then [isasync, src] else [src] + where + src = ("src", script ^. script_uri . to (Text.pack . show)) + +-- | Try to keep the head as small as possible. +-- Only things that are required initially should be placed in the head. +-- so the pattern is that we require a bunch of different components +-- initially but we put them in different files. +-- for example we needed the bulma css file for most styling +-- and balloon css for just tooltips. +headWidget :: Dom.DomBuilder t m => HeadSettings -> m () +headWidget settings = do + traverse_ (\attrlist -> Dom.elAttr "script" attrlist Dom.blank) $ settings ^.. head_js . traversed . to scriptToMap + -- google complaints about viewport, but it breaks the table + -- metaAttr (Map.fromList [("name", "viewport"), ("content", "device-width, initial-scale=1")]) Dom.blank + void $ Dom.el "title" $ Dom.text $ settings ^. head_title + traverse_ + (\href -> + Dom.elAttr "link" + (Map.fromList -- bulmo + [("rel", "stylesheet"), ("href", href)]) + Dom.blank) $ settings ^.. head_css . traversed . to (Text.pack . show) diff --git a/src/Reflex/Bulmex/Input/Polymorphic.hs b/src/Reflex/Bulmex/Input/Polymorphic.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Input/Polymorphic.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} + + +-- | This is just a copy of the upstream code except polymorphic: +-- Get rid of m ~ Ghcjsdomspace to allow these widgets to be prerendered +module Reflex.Bulmex.Input.Polymorphic + (textInput, TextInput(..), textArea, TextArea(..), textArea_value, textArea_keypress + , textInput_value + , textInput_keyup + , textInput_keypress + , textInput_keydown + , textInput_input + , textInput_hasFocus + ) where + +import Control.Lens +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Reflex +import Reflex.Dom.Builder.Class +import Reflex.Dom.Widget.Basic +import qualified Reflex.Dom.Widget.Input as Inp + +textInput :: (DomBuilder t m, PostBuild t m) => Inp.TextInputConfig t -> m (TextInput t) +textInput (Inp.TextInputConfig inputType initial eSetValue dAttrs) = do + modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.insert "type" inputType) dAttrs + i <- inputElement $ Inp.def + & inputElementConfig_initialValue .~ initial + & inputElementConfig_setValue .~ eSetValue + & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs + return $ TextInput + { _textInput_value = _inputElement_value i + , _textInput_input = _inputElement_input i + , _textInput_keypress = domEvent Keypress i + , _textInput_keydown = domEvent Keydown i + , _textInput_keyup = domEvent Keyup i + , _textInput_hasFocus = _inputElement_hasFocus i + } + +data TextInput t + = TextInput { _textInput_value :: Dynamic t Text.Text + , _textInput_input :: Event t Text.Text + , _textInput_keypress :: Event t Word + , _textInput_keydown :: Event t Word + , _textInput_keyup :: Event t Word + , _textInput_hasFocus :: Dynamic t Bool + } + +instance Inp.HasValue (TextInput t) where + type Value (TextInput t) = Dynamic t Text.Text + value = _textInput_value + +textArea :: (DomBuilder t m, PostBuild t m) => Inp.TextAreaConfig t -> m (TextArea t) +textArea (Inp.TextAreaConfig initial eSet attrs) = do + modifyAttrs <- dynamicAttributesToModifyAttributes attrs + i <- textAreaElement $ Inp.def + & textAreaElementConfig_initialValue .~ initial + & textAreaElementConfig_setValue .~ eSet + & textAreaElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs + return $ TextArea + { _textArea_value = _textAreaElement_value i + , _textArea_input = _textAreaElement_input i + , _textArea_keypress = domEvent Keypress i + , _textArea_hasFocus = _textAreaElement_hasFocus i + } + +data TextArea t = TextArea { _textArea_value :: Dynamic t Text.Text + , _textArea_input :: Event t Text.Text + , _textArea_hasFocus :: Dynamic t Bool + , _textArea_keypress :: Event t Word + } + +instance Inp.HasValue (TextArea t) where + type Value (TextArea t) = Dynamic t Text.Text + value = _textArea_value + +textArea_keypress :: Lens' (TextArea t) (Event t Word) +textArea_keypress f (TextArea x1 x2 x3 x4) = (\y -> TextArea x1 x2 x3 y) <$> f x4 + +textArea_value :: Lens' (TextArea t) (Dynamic t Text.Text) +textArea_value f (TextArea x1 x2 x3 x4) = (\y -> TextArea y x2 x3 x4) <$> f x1 + +textInput_hasFocus :: Lens' (TextInput t) (Dynamic t Bool) +textInput_hasFocus f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput x1 x2 x3 x4 x5 y ) <$> f x6 + +textInput_input :: Lens' (TextInput t) (Event t Text.Text) +textInput_input f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput x1 y x3 x4 x5 x6 ) <$> f x2 + +textInput_keydown :: Lens' (TextInput t) (Event t Word) +textInput_keydown f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput x1 x2 x3 y x5 x6 ) <$> f x4 + +textInput_keypress :: Lens' (TextInput t) (Event t Word) +textInput_keypress f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput x1 x2 y x4 x5 x6 ) <$> f x3 + +textInput_keyup :: Lens' (TextInput t) (Event t Word) +textInput_keyup f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput x1 x2 x3 x4 y x6 ) <$> f x5 + +textInput_value :: Lens' (TextInput t) (Dynamic t Text.Text) +textInput_value f (TextInput x1 x2 x3 x4 x5 x6 ) = (\y -> TextInput y x2 x3 x4 x5 x6) <$> f x1 diff --git a/src/Reflex/Bulmex/Load.hs b/src/Reflex/Bulmex/Load.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Load.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Load functions +module Reflex.Bulmex.Load where + +import Control.Monad (join) +import Data.Aeson +import Data.Aeson.Text +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as Text +import Data.Text.Encoding +import qualified Data.Text.Lazy as LText +import JSDOM +import JSDOM.Generated.Element +import JSDOM.Generated.NonElementParentNode +import Reflex +import qualified Reflex.Dom.Builder.Class as Dom +import qualified Reflex.Dom.Prerender as Dom +import qualified Reflex.Dom.Widget.Basic as Dom + +-- | Insert an encodable in the document body, +-- in case of the server side rendering we encode it as script tag with jsonval, +-- in case of ghcjsdom we read the value from that script tag +-- first arg is the idname to connect the two up (has to be uniq for a doc) +writeReadDom :: (FromJSON a, ToJSON a, Dom.DomBuilder t m, Dom.Prerender js t m) => + Text.Text -> a -> m (Dynamic t a) +writeReadDom comelid serverState = + Dom.prerender (do + Dom.elAttr "script" (Map.fromList [ + ("type", "application/json"), + ("id", comelid) + ]) $ + Dom.text $ LText.toStrict $ encodeToLazyText serverState + pure serverState + ) $ do + mayDoc <- currentDocument + mayEl' <- sequence $ (getElementById <$> mayDoc) <*> pure comelid + mayInner <- sequence $ getInnerHTML <$> join mayEl' + let result = (join $ decode . LBS.fromStrict . encodeUtf8 <$> mayInner) + pure $ fromMaybe serverState -- TODO don't fail silently + result diff --git a/src/Reflex/Bulmex/PreventDefault.hs b/src/Reflex/Bulmex/PreventDefault.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/PreventDefault.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | ripped from https://gist.github.com/3noch/134b1ee7fa48c347be9d164c3fac4ef7 +module Reflex.Bulmex.PreventDefault where + +import Control.Lens ((%~), (.~)) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Reflex.Dom.Core + +-- | Like 'elDynAttr'' but configures "prevent default" on the given event. +elDynAttrPrevDef :: + forall a en m t. (DomBuilder t m, PostBuild t m) + => EventName en -- ^ Event on the element to configure with 'preventDefault' + -> Text -- ^ Element tag + -> Dynamic t (Map Text Text) -- ^ Element attributes + -> m a -- ^ Child of element + -> m (Element EventResult (DomBuilderSpace m) t, a) -- An element and the result of the child +elDynAttrPrevDef ev = + elDynAttrModConf + (\elCfg -> + elCfg & + elementConfig_eventSpec %~ + addEventSpecFlags + (Proxy :: Proxy (DomBuilderSpace m)) + ev + (const preventDefault)) + +-- | Like 'elDynAttr'' but allows you to modify the element configuration. +-- +-- Special thanks to @luigy: https://gist.github.com/luigy/b49ce04de8462e594c9c2b5b455ae5a5#file-foo-hs +elDynAttrModConf :: + (DomBuilder t m, PostBuild t m) + => (ElementConfig EventResult t (DomBuilderSpace m) -> ElementConfig EventResult t (DomBuilderSpace m)) + -> Text + -> Dynamic t (Map Text Text) + -> m a + -> m (Element EventResult (DomBuilderSpace m) t, a) +elDynAttrModConf f elementTag attrs child = do + modifyAttrs <- dynamicAttributesToModifyAttributes attrs + let cfg = + def & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs + result <- element elementTag (f cfg) child + postBuild <- getPostBuild + notReadyUntil postBuild + pure result diff --git a/src/Reflex/Bulmex/Space.hs b/src/Reflex/Bulmex/Space.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Space.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Sometimes you just need some space in your life +module Reflex.Bulmex.Space + ( space, spaceJoin + ) where + +import qualified Data.Text as Text + +space :: Text.Text +space = " " + +spaceJoin :: Text.Text -> Text.Text -> Text.Text +spaceJoin a b = a <> space <> b diff --git a/src/Reflex/Bulmex/Tag.hs b/src/Reflex/Bulmex/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Bulmex/Tag.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | bulma divs +module Reflex.Bulmex.Tag where + +import Control.Applicative +import Data.Bool +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Reflex +import Reflex.Bulmex.Attr +import Reflex.Bulmex.Space +import qualified Reflex.Dom.Builder.Class as Dom +import qualified Reflex.Dom.Widget as Dom +import qualified Reflex.Tags as T + +container :: Dom.DomBuilder t m => m a -> m a +container = containerClass mempty + +containerClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +containerClass = partialDiv "container" + +partialDiv :: Dom.DomBuilder t m => Text.Text -> Text.Text -> m a -> m a +partialDiv = txtEl T.divClass + +txtEl :: (Text.Text -> m a -> m a) -> Text.Text -> Text.Text -> m a -> m a +txtEl = defaultEl spaceJoin + +-- | allows us to set a default value for tags by defining a join function +-- not a monoid because often it does it wrong, text needs a space +-- for example in case of classes, and the default map monoid is broken +defaultEl :: (arg -> arg -> arg) -> (arg -> m a -> m a) -> arg -> arg -> m a -> m a +defaultEl monoidF elF a b = elF $ monoidF a b + +buttons :: Dom.DomBuilder t m => m a -> m a +buttons = T.divClass "buttons" + +-- | kindoff hard to set an image tag in reflex +image :: Dom.DomBuilder t m => Text.Text -> m() +image url = T.imgAttr (Map.singleton "src" url) Dom.blank + +-- | first class second src +imageClass :: Dom.DomBuilder t m => Text.Text -> Text.Text -> m() +imageClass clazz url = T.imgAttr (Map.fromList [("src",url), ("class", clazz)]) Dom.blank + +-- | bulma hero sturcture +-- |
+-- |
+-- |
+hero :: Dom.DomBuilder t m => Text.Text -> m a -> m a +hero styles = + txtEl T.sectionClass "hero" styles . T.divClass "hero-body" . container + +content :: Dom.DomBuilder t m => m a -> m a +content = T.divClass "content" + +sect :: (Dom.DomBuilder t m) => m a -> m a +sect = T.divClass "section" + +section :: (PostBuild t m, Dom.DomBuilder t m) => m a -> m a +section = sectionDyn $ constDyn mempty + +sectionDyn :: + (PostBuild t m, Dom.DomBuilder t m) => Dynamic t AttrMap -> m a -> m a +sectionDyn = + dynAttrEl (\a b -> T.divDynAttr a $ container b) $ classAttr "section" + +columns :: Dom.DomBuilder t m => m a -> m a +columns = columnsClass mempty + +column :: Dom.DomBuilder t m => m a -> m a +column = columnClass mempty + +columnsClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +columnsClass = partialDiv "columns" + +columnClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +columnClass = partialDiv "column" + +control :: Dom.DomBuilder t m => m a -> m a +control = controlClass mempty + +controlClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +controlClass = partialDiv "control" + +controlDyn :: + (PostBuild t m, Dom.DomBuilder t m) => Dynamic t AttrMap -> m a -> m a +controlDyn = dynAttrEl T.divDynAttr $ classAttr "control" + +tile :: Dom.DomBuilder t m => Text.Text -> m a -> m a +tile = partialDiv "tile" + +tileChild :: Dom.DomBuilder t m => m a -> m a +tileChild = tileChildClass mempty + +tileChildClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +tileChildClass = txtEl tile "is-child" + +tileParentClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +tileParentClass = txtEl tile "is-parent" + +tileParent :: Dom.DomBuilder t m => m a -> m a +tileParent = tileParentClass mempty + +tileAncestor :: Dom.DomBuilder t m => m a -> m a +tileAncestor = tile "is-ancestor" + +dynAttrEl :: + Reflex t + => (Dynamic t AttrMap -> m a -> m a) + -> AttrMap + -> Dynamic t AttrMap + -> m a + -> m a +dynAttrEl f = defaultEl ((<*>) . (<$>) attrUnion) f . constDyn + +field :: Dom.DomBuilder t m => m a -> m a +field = fieldClass mempty + +fieldClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +fieldClass = partialDiv "field" + +fieldGrouped :: Dom.DomBuilder t m => m a -> m a +fieldGrouped = fieldClass "is-grouped" + +title :: Dom.DomBuilder t m => m a -> m a +title = titleClazz "is-1" + +titleClazz :: Dom.DomBuilder t m => Text.Text -> m a -> m a +titleClazz = txtEl T.h1Class "title" + +subtitle :: Dom.DomBuilder t m => m a -> m a +subtitle = subtitleClass "is-3" + +subtitleClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +subtitleClass = txtEl T.h2Class "subtitle" + +box :: Dom.DomBuilder t m => m a -> m a +box = T.divClass "box" + +evtText :: (Dom.DomBuilder t m, PostBuild t m, MonadHold t m) => Event t Text.Text -> m () +evtText evt = Dom.dynText =<< holdDyn "" evt + + +labeled' :: Dom.DomBuilder t m => m () -> m a -> m a +labeled' labelM inputM = do + labelEl labelM + control inputM + +-- | named labelEl cause didn't want to fix name clashes +labelEl :: Dom.DomBuilder t m => m a -> m a +labelEl = labelClass mempty + +labelClass :: Dom.DomBuilder t m => Text.Text -> m a -> m a +labelClass = txtEl T.labelClass "label" + +data ToolDirection + = Top -- top is graphic bugged + | Lft + | Rght + | Down + +-- | balloon css, for example: https://cdnjs.cloudflare.com/ajax/libs/balloon-css/0.5.0/balloon.min.css +tooltipText :: + (PostBuild t m, Dom.DomBuilder t m) => Dynamic t Text.Text -> m a -> m a +tooltipText = tooltipText' Rght + +tooltipText' :: + (PostBuild t m, Dom.DomBuilder t m) + => ToolDirection + -> Dynamic t Text.Text + -> m a + -> m a +tooltipText' dir tipDyn monad = T.spanDynAttr (tipToAttr dir <$> tipDyn) $ monad + +tipToAttr :: ToolDirection -> Text.Text -> AttrMap +tipToAttr dir "" = tipToAttr dir "-" +tipToAttr dir tip = + Map.fromList [("data-balloon", tip), ("data-balloon-pos", direction dir)] + +direction :: ToolDirection -> Text.Text +direction Top = "top" +direction Lft = "left" +direction Rght = "right" +direction Down = "down" + +icon :: (PostBuild t m, Dom.DomBuilder t m) => Text.Text -> m () +icon = iconClass "" + +-- | second is name +iconClass :: + (PostBuild t m, Dom.DomBuilder t m) => Text.Text -> Text.Text -> m () +iconClass wrapClass = + iconDyn (constDyn (classAttr wrapClass)) . constDyn . classAttr + +iconDyn :: + (PostBuild t m, Dom.DomBuilder t m) + => Dynamic t AttrMap + -> Dynamic t AttrMap + -> m () +iconDyn wrapClass mdiClass = do + textSpace + T.spanDynAttr (attrUnion (classAttr "icon") <$> wrapClass) $ + T.iDynAttr (Map.unionWith (<>) (classAttr "mdi mdi-") <$> mdiClass) $ + Dom.blank + textSpace + +-- | sometimes you just need 2 pieces of text to seperate with a space +textSpace :: Dom.DomBuilder t m => m () +textSpace = Dom.text space + +flask :: (PostBuild t m, Dom.DomBuilder t m) => m () +flask = icon "flask" + +-- | a html tag that accepts any text into it's href value +ahref :: (Dom.DomBuilder t m, PostBuild t m) => Text.Text -> m a -> m a +ahref = ahref' mempty + +ahref' :: (Dom.DomBuilder t m, PostBuild t m) => AttrMap -> Text.Text -> m a -> m a +ahref' uno = ahrefDyn (constDyn uno) . constDyn + +ahrefDyn :: (Dom.DomBuilder t m, PostBuild t m) => Dynamic t AttrMap -> Dynamic t Text.Text -> m a -> m a +ahrefDyn uno txt = T.aDynAttr $ (attrUnion <$> uno) <*> (Map.singleton "href" <$> txt) + +switchDiv :: + (PostBuild t m, Dom.DomBuilder t m) + => Dynamic t Bool + -> m () + -> m a + -> m a +switchDiv attrDyn true false = do + hideDiv_ (not <$> attrDyn) true + hideDiv_ attrDyn false + +-- | when dynamic is true ishidden will be added, else the attrmap is used +hideDiv :: + (PostBuild t m, Dom.DomBuilder t m) + => Dynamic t AttrMap + -> Dynamic t Bool + -> m a + -> m a +hideDiv attrDyn hide = + T.divDynAttr $ bool <$> attrDyn <*> constDyn isHidden <*> hide + +hideDiv_ :: (PostBuild t m, Dom.DomBuilder t m) => Dynamic t Bool -> m a -> m a +hideDiv_ = hideDiv $ constDyn Map.empty + +loadSpinner :: (Dom.DomBuilder t m) => m () +loadSpinner = imageClass "loadSpinner" "spinner.svg" + +hideEmptyDiv :: + (Eq (f b), Alternative f, PostBuild t m, Dom.DomBuilder t m) + => Dynamic t (f b) + -> m a + -> m a +hideEmptyDiv = hideEmptyDyn $ constDyn Map.empty + +hideEmptyDyn :: + (Eq (f b), Alternative f, PostBuild t m, Dom.DomBuilder t m) + => Dynamic t AttrMap + -> Dynamic t (f b) + -> m a + -> m a +hideEmptyDyn dyn = hideDiv dyn . fmap ((==) empty)