Add src

default.nix

@@ -0,0 +1,28 @@
+{ reflex-platform ? ((import <nixpkgs> {}).fetchFromGitHub {
+    owner = "reflex-frp";
+    repo = "reflex-platform";
+    rev = "efc6d923c633207d18bd4d8cae3e20110a377864";
+    sha256 = "121rmnkx8nwiy96ipfyyv6vrgysv0zpr2br46y70zf4d0y1h1lz5";
+    })
+}:
+(import reflex-platform {}).project ({ pkgs, ... }:{
+  useWarp = true;
+
+  packages = {
+    reflex-dom-extra = ../reflex-dom-extra;
+  };
+
+  shellToolOverrides = ghc: super: {
+    closure-compiler = null;
+    haskell-ide-engine = null;
+    hdevtools = null;
+    hlint = null;
+    stylish-haskell = null;
+    hoogle = null;
+  };
+
+  shells = {
+    ghc = ["reflex-dom-extra"];
+    ghcjs = ["reflex-dom-extra"];
+  };
+})

reflex-dom-extra.cabal

@@ -0,0 +1,35 @@
+cabal-version:       2.4
+-- Initial package description 'reflex-extra.cabal' generated by 'cabal
+-- init'.  For further documentation, see
+-- http://haskell.org/cabal/users-guide/
+
+name:                reflex-dom-extra
+version:             0.1
+synopsis:            Common Reflex-related functions
+license-file:        LICENSE
+author:              Catherine Galkina
+maintainer:          catherine@typeable.io
+copyright:           Antorica LLC
+category:            Web, GUI, FRP
+build-type:          Simple
+
+library
+  exposed-modules:     Reflex.Dom.Extra
+                     , Reflex.Dom.Pagination
+  build-depends:       base >=4.7 && <5
+                     , containers
+                     , jsaddle
+                     , lens
+                     , reflex-dom
+                     , text
+  if impl(ghcjs)
+    build-depends:
+                       ghcjs-base
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+  default-extensions:  FlexibleContexts
+                     , MonoLocalBinds
+                     , OverloadedStrings
+                     , RecordWildCards
+                     , RecursiveDo

shell.nix

@@ -0,0 +1 @@
+(import ./default.nix { }).shells.ghc

src/Reflex/Dom/Extra.hs

@@ -0,0 +1,263 @@
+-- Common helpers to build DOM with Reflex.
+module Reflex.Dom.Extra where
+
+import Control.Lens
+import Control.Monad.Fix
+import Data.Either
+import Data.Map as M
+import Data.Maybe
+import Data.Text as T hiding (zip, map)
+import Language.Javascript.JSaddle
+import Reflex.Dom
+import JavaScript.Object.Internal as JS
+
+-- | @<meta>@ element.
+meta :: DomBuilder t m => Map Text Text -> m ()
+meta attrs = elAttr "meta" attrs blank
+
+-- | Stylesheet link.
+stylesheet :: DomBuilder t m => Text -> m ()
+stylesheet ref = elAttr "link" ("rel" =: "stylesheet" <> "href" =: ref) blank
+
+-- | <script> tag. Do not use in dynamic contexts, or it will be executed twice.
+script :: DomBuilder t m => Text -> m ()
+script url = elAttr "script" ("type" =: "text/javascript" <> "src" =: url) blank
+
+-- | @<main>@ element with given CSS class.
+mainClass :: DomBuilder t m => Text -> m a -> m a
+mainClass = elClass "main"
+
+-- | @<span>@ element with given CSS class.
+spanClass :: DomBuilder t m => Text -> m a -> m a
+spanClass = elClass "span"
+
+-- | @<label>@ element with given CSS class.
+labelClass :: DomBuilder t m => Text -> m a -> m a
+labelClass = elClass "label"
+
+-- | @<section>@ element with given CSS class.
+sectionClass :: DomBuilder t m => Text -> m a -> m a
+sectionClass = elClass "section"
+
+-- | @<b>@ element with given CSS class.
+bClass :: DomBuilder t m => Text -> m a -> m a
+bClass = elClass "b"
+
+-- | @<tr>@ element with given CSS class.
+trClass :: DomBuilder t m => Text -> m a -> m a
+trClass = elClass "tr"
+
+-- | @<th>@ element with given CSS class.
+thClass :: DomBuilder t m => Text -> m a -> m a
+thClass = elClass "th"
+
+-- | @<td>@ element with given CSS class.
+tdClass :: DomBuilder t m => Text -> m a -> m a
+tdClass = elClass "td"
+
+-- | Line break (@<br>@).
+br :: DomBuilder t m => m ()
+br = el "br" blank
+
+-- | Button element, returns click event.
+button
+  :: DomBuilder t m
+  => Text
+  -- ^ Label.
+  -> Map Text Text
+  -- ^ Attributes.
+  -> m (Event t ())
+button label attrs = do
+  (e, _) <- elAttr' "button" (attrs <> "type" =: "button") $ text label
+  return $ domEvent Click e
+
+-- | Button element with only "class" attribute.
+buttonClass
+  :: DomBuilder t m
+  => Text
+  -- ^ Label.
+  -> Text
+  -- ^ CSS class.
+  -> m (Event t ())
+buttonClass label cls = do
+  (e, _) <- elAttr' "button" ("class" =: cls <> "type" =: "button") $ text label
+  return $ domEvent Click e
+
+-- | Button element with dynamic attributes.
+buttonDynAttrs
+  :: (DomBuilder t m, PostBuild t m)
+  => Text
+  -- ^ Label.
+  -> Dynamic t (Map Text Text)
+  -- ^ Attributes.
+  -> m (Event t ())
+buttonDynAttrs label dynAttrs = buttonDyn (constDyn label) dynAttrs
+
+-- | Button element with dynamic label.
+buttonDynLabel
+  :: (DomBuilder t m, PostBuild t m)
+  => Dynamic t Text
+  -- ^ Label.
+  -> Map Text Text
+  -- ^ Attributes.
+  -> m (Event t ())
+buttonDynLabel dynLabel attrs = buttonDyn dynLabel (constDyn attrs)
+
+-- | Button element with dynamic label and attributes.
+buttonDyn
+  :: (DomBuilder t m, PostBuild t m)
+  => Dynamic t Text
+  -- ^ Label.
+  -> Dynamic t (Map Text Text)
+  -- ^ Attributes.
+  -> m (Event t ())
+buttonDyn dynLabel dynAttrs = do
+  (e, _) <- elDynAttr' "button" ((<> "type" =: "button") <$> dynAttrs)
+    $ dynText dynLabel
+  return $ domEvent Click e
+
+-- | Dynamic list widget that creates a list that supports the dynamic
+-- addition and removal of items.  This widget is completely general with zero
+-- markup-specific choices.  It handles all the event plumbing and lets you
+-- completely determine the markup.
+dynamicList
+  :: MonadWidget t m
+  => (Int -> a -> Event t a -> m b)
+  -- ^ Widget used to display each item
+  -> (b -> Event t ())
+  -- ^ Function that gets a remove event from the return value of each item
+  -> Event t a
+  -- ^ Event that adds a new item to the list that is not based on an
+  -- existing item.
+  -> [a]
+  -- ^ Initial list of items
+  -> m (Dynamic t [b])
+dynamicList w removeEvent addEvent initList = do
+  let initMap = M.fromList $ zip [0..] initList
+  rec
+    let
+      vals = mergeWith (<>)
+        [ attachWith addNew (current res) addEvent
+        , remove (current res) ]
+    res <- listWithKeyShallowDiff initMap vals w
+  return $ M.elems <$> res
+  where
+    addNew m a = M.singleton k (Just a)
+      where
+        k = if M.null m then 0 else fst (M.findMax m) + 1
+    remove res = switch (mergeWith (<>) . fmap f . M.toList <$> res)
+      where
+        f (k,b) = M.singleton k Nothing <$ removeEvent b
+
+-- | Build widget using text value, if any. Otherwise stays blank.
+maybeBlank :: DomBuilder t m => Maybe Text -> (Text -> m ()) -> m ()
+maybeBlank mt w = maybe blank w mt
+
+-- | "cursor: pointer" style.
+pointer :: Map Text Text
+pointer = "style" =: "cursor:pointer;"
+
+table :: DomBuilder t m => m a -> m a
+table = el "table"
+
+thead :: DomBuilder t m => m a -> m a
+thead = el "thead"
+
+tbody :: DomBuilder t m => m a -> m a
+tbody = el "tbody"
+
+th :: DomBuilder t m => m a -> m a
+th = el "th"
+
+tr :: DomBuilder t m => m a -> m a
+tr = el "tr"
+
+td :: DomBuilder t m => m a -> m a
+td = el "td"
+
+form :: DomBuilder t m => Map Text Text -> m a -> m a
+form attrs = elAttr "form" attrs
+
+-- | Join event of event into single event.
+joinE
+  :: (Reflex t, MonadHold t m)
+  => Event t (Event t a)
+  -> m (Event t a)
+joinE = switchHold never
+
+-- | Separate an event to two sequences based on given predicate.
+-- The first element of resulting pair keeps events for which the predicate
+-- holds, the second -- those for which it doesn't.
+separateE
+  :: Reflex t
+  => (a -> Bool)
+  -> Event t a
+  -> (Event t a, Event t a)
+separateE p e = (ffilter p e, ffilter (not . p) e)
+
+-- | Separate an event with optional payload.
+-- The first event in the resulting pair keeps @Just@s, the seconds keeps
+-- @Nothing@s.
+separateMaybeE
+  :: Reflex t
+  => Event t (Maybe a)
+  -> (Event t (Maybe a), Event t (Maybe a))
+separateMaybeE = separateE isJust
+
+-- | Filter only events with existing payload.
+fromMaybeE
+  :: Reflex t
+  => Event t (Maybe a)
+  -> Event t a
+fromMaybeE = fmapMaybe id
+
+-- | Separate an event with alternative payload.
+-- The first event in the resulting pair keeps @Left@s, the seconds keeps
+-- @Right@s.
+separateEitherE
+  :: Reflex t
+  => Event t (Either a b)
+  -> (Event t (Either a b), Event t (Either a b))
+separateEitherE = separateE isLeft
+
+-- | Assigns HTML content to an element, allows embedding of arbitrary
+-- HTML tags, so make sure you trust the source of the second argument
+-- @
+--   el <- _element_raw . fst <$> el' "span" blank
+--   unsafeInnerHTML el "this text will be <i>italicised</i>"
+-- @
+unsafeInnerHTML :: (MonadJSM m, ToJSVal rawelem) => rawelem -> Text -> m ()
+unsafeInnerHTML rel html = liftJSM $ do
+  htmlVal <- toJSVal html
+  relVal <- toJSVal rel
+  JS.setProp "innerHTML" htmlVal (JS.Object relVal)
+
+-- | input element which is changes while edited.
+-- It is useful to input dates, phones etc
+inputCorrect
+  :: (MonadFix m, DomBuilder t m, MonadHold t m)
+  => (Text -> Text -> Text) -- ^ old value and new value
+  -> InputElementConfig er t (DomBuilderSpace m)
+  -> m (InputElement er (DomBuilderSpace m) t)
+inputCorrect correct ec = mdo
+  ie <- inputElement $ ec & inputElementConfig_setValue .~ eNewValue
+  dV <- holdUniqDyn $ value ie
+  let
+    eNewValue = attachWith correct (current dV)
+      $ leftmost [ec ^. inputElementConfig_setValue, updated dV]
+  pure ie
+
+-- | input element in form "__/__" (e.g. for credit card)
+inputMonth
+  :: (MonadFix m, DomBuilder t m, MonadHold t m)
+  => InputElementConfig er t (DomBuilderSpace m)
+  -> m (InputElement er (DomBuilderSpace m) t)
+inputMonth ec = inputCorrect correct $ ec
+  & initialAttributes %~ (<> "type" =: "text" <> "maxlength" =: "5")
+  where
+    correct ov nv = case (T.length ov, T.length nv) of
+      (x,2) | x < 2 -> nv <> "/"
+      (x,3) | x > 3 -> T.take 2 nv
+      (_, x) | x > 2 && T.head (T.drop 2 nv) /= '/' ->
+        T.take 5 $ T.take 2 nv <> "/" <> T.drop 2 nv
+      _     -> nv

src/Reflex/Dom/Pagination.hs

@@ -0,0 +1,173 @@
+-- Pagination panel widget.
+module Reflex.Dom.Pagination where
+
+import Control.Monad (join)
+import qualified Data.Text as T
+import Reflex.Dom
+
+type PageNumber = Int
+
+-- | Pagination configuration.
+data PaginationConfig t m = PaginationConfig
+  { pagesNumber :: PageNumber
+  -- ^ Total number of pages.
+  , initPage :: PageNumber
+  -- ^ Initial page number.
+  , pageNumberElem
+    :: Dynamic t PageNumber
+    -> PageNumber
+    -> m (Element EventResult (DomBuilderSpace m) t)
+  -- ^ Element to display every page number given current page.
+  , nextPageElem
+    :: Dynamic t PageNumber
+    -> m (Element EventResult (DomBuilderSpace m) t)
+  -- ^ "Next page" element.
+  , prevPageElem
+    :: Dynamic t PageNumber
+    -> m (Element EventResult (DomBuilderSpace m) t)
+  -- ^ "Previous page" element.
+  , ellipsisWidget :: m ()
+  -- ^ Ellipsis between pages.
+  , pageUpdateEvent :: Event t PageNumber
+  -- ^ Event to update page number.
+  , pageNumberSegmentSize :: Int
+  -- ^ Number of pages after first page, before and after selected page
+  -- and before last page. Skipped pages are replaced with ellipsis.
+  , hideWhenEmpty :: Bool
+  -- ^ Hide pagination panel when there are zero total pages?
+  }
+
+-- | Sanity check for config.
+checkConfig :: PaginationConfig t m -> Bool
+checkConfig PaginationConfig{..} =
+  pagesNumber >= 0 &&
+  initPage > 0 &&
+  pageNumberSegmentSize >= 0
+
+-- | Default element to display page number (current page is darker).
+defaultPageNumberWidget
+  :: MonadWidget t m
+  => Dynamic t PageNumber
+  -> PageNumber
+  -> m (Element EventResult (DomBuilderSpace m) t)
+defaultPageNumberWidget curDyn pageNum = fmap fst . elDynAttr' "button"
+  (mkAttrs <$> curDyn) . text . show' $ pageNum
+  where
+    show' = T.pack . show
+    mkAttrs cur = "type" =: "button" <>
+      if pageNum == cur
+        then "style" =: "background-color: #CCCCCC;"
+        else mempty
+
+-- | Default element for previous page (button with text "Prev").
+defaultPrevPage
+  :: MonadWidget t m
+  => Dynamic t PageNumber
+  -> m (Element EventResult (DomBuilderSpace m) t)
+defaultPrevPage curDyn = fmap fst $
+  elDynAttr' "button" (mkAttrs <$> curDyn) $ text "Prev"
+  where
+    mkAttrs cur = "type" =: "button" <>
+      if cur == 1
+        then "disabled" =: "" <> "style" =: "pointer-events:none;"
+        else mempty
+
+-- | Default element for next page (button with text "Next").
+defaultNextPage
+  :: MonadWidget t m
+  => PageNumber
+  -> Dynamic t PageNumber
+  -> m (Element EventResult (DomBuilderSpace m) t)
+defaultNextPage total curDyn = fmap fst $
+  elDynAttr' "button" (mkAttrs <$> curDyn) $ text "Next"
+  where
+    mkAttrs cur = "type" =: "button" <>
+      if cur == total
+        then "disabled" =: "" <> "style" =: "pointer-events:none;"
+        else mempty
+
+-- | Default ellipsis.
+defaultEllipsis
+  :: MonadWidget t m
+  => m ()
+defaultEllipsis = text "..."
+
+-- | Default config based on total number of items and page size.
+defaultPaginationConfig
+  :: MonadWidget t m
+  => Int
+  -> Int
+  -> PaginationConfig t m
+defaultPaginationConfig totalItems pageSize = PaginationConfig
+  { pagesNumber = totalPages
+  , initPage = 1
+  , pageNumberElem = defaultPageNumberWidget
+  , nextPageElem = defaultNextPage totalPages
+  , prevPageElem = defaultPrevPage
+  , ellipsisWidget = defaultEllipsis
+  , pageUpdateEvent = never
+  , pageNumberSegmentSize = 1
+  , hideWhenEmpty = True }
+  where
+    totalPages = calcPages totalItems pageSize
+
+-- | Calculate total number of pages given input length and page size.
+calcPages :: Int -> Int -> Int
+calcPages totalSize pageSize = (totalSize + pageSize - 1) `div` pageSize
+
+-- | Pagination widget that takes dynamic config (useful when total number
+-- of items may change dynamically).
+paginationDyn
+  :: MonadWidget t m
+  => Dynamic t (PaginationConfig t m)
+  -> m (Dynamic t PageNumber)
+paginationDyn dynCfg = do
+  pageEvDyn <- dyn $ pagination <$> dynCfg
+  pageDynDyn <- holdDyn (initPage <$> dynCfg) pageEvDyn
+  return (join pageDynDyn)
+
+-- | Pagination widget that renders page numbers and returns current page
+-- number.
+pagination
+  :: MonadWidget t m
+  => PaginationConfig t m
+  -> m (Dynamic t PageNumber)
+pagination cfg@PaginationConfig{..}
+  | not (checkConfig cfg) = return (constDyn initPage)
+  | pagesNumber == 0 && hideWhenEmpty = return (constDyn initPage)
+  | otherwise = mdo
+    let shownPagesDyn = mkShownPages <$> currentPage
+    prevEl <- prevPageElem currentPage
+    pageSwitchEe <- (fmap leftmost) <$>
+      (dyn $ mapM (pageSelector currentPage) <$> shownPagesDyn)
+    pageSelectEvent <- switchHold never pageSwitchEe
+    nextEl <- nextPageElem currentPage
+    let
+      prevPageEvent = domEvent Click prevEl
+      nextPageEvent = domEvent Click nextEl
+    currentPage <- foldDyn ($) initPage $ leftmost
+      [ decPage <$ prevPageEvent
+      , setPage <$> pageSelectEvent
+      , incPage <$ nextPageEvent
+      , const <$> pageUpdateEvent ]
+    return currentPage
+    where
+      decPage n = max 1 (n-1)
+      incPage n = min (n+1) pagesNumber
+      setPage newPage currentPage = if newPage `elem` [1 .. pagesNumber]
+        then newPage
+        else currentPage
+      pageSelector _ Nothing = ellipsisWidget >> return never
+      pageSelector cur (Just n) = do
+        selElem <- pageNumberElem cur n
+        return (n <$ domEvent Click selElem)
+      mkShownPages cur = fixPages $
+        [1 .. min (1+pageNumberSegmentSize) pagesNumber] ++
+        [max 1 (cur-pageNumberSegmentSize) ..
+          min (cur+pageNumberSegmentSize) pagesNumber] ++
+        [max 1 (pagesNumber-pageNumberSegmentSize) .. pagesNumber]
+      fixPages (x : y : rest)
+        | y <= x = fixPages (x : rest)
+        | x + 1 < y = Just x : Nothing : fixPages (y : rest)
+        | otherwise = Just x : fixPages (y :rest)
+      fixPages xs = map Just xs