94 lines
3.1 KiB
Haskell
94 lines
3.1 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Handler.Utils.Table where
|
|
-- General Utilities for Tables
|
|
|
|
import Import hiding ((<>))
|
|
-- import Data.Monoid ((<>))
|
|
import Data.Profunctor
|
|
|
|
import Control.Monad.Except
|
|
|
|
import Text.Blaze as B
|
|
|
|
import Colonnade
|
|
import Yesod.Colonnade
|
|
|
|
import Data.List ((!!))
|
|
import Data.Either
|
|
|
|
|
|
-- Table design
|
|
tableDefault :: Attribute
|
|
tableDefault = customAttribute "class" "table table-striped table-hover"
|
|
|
|
tableSortable :: Attribute
|
|
tableSortable = customAttribute "class" "js-sortable"
|
|
|
|
-- Colonnade Tools
|
|
numberColonnade :: (IsString c) => Colonnade Headed Int c
|
|
numberColonnade = headed "Nr" (fromString.show)
|
|
|
|
pairColonnade :: (Functor h) => Colonnade h a c -> Colonnade h b c -> Colonnade h (a,b) c
|
|
pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
|
|
|
|
|
|
-- Table Modification
|
|
encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
|
|
encodeHeadedWidgetTableNumbered attrs colo tdata =
|
|
encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
|
|
where
|
|
numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
|
|
numberCol = headed "Nr" (fromString.show.fst)
|
|
|
|
headedRowSelector :: ( PathPiece b
|
|
, Eq b
|
|
)
|
|
=> (a -> Handler b)
|
|
-> (b -> Handler c)
|
|
-> Attribute
|
|
-> Colonnade Headed a (Cell UniWorX)
|
|
-> [a]
|
|
-> MForm Handler (FormResult [c], Widget)
|
|
headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
|
externalIds <- mapM (lift . toExternal) tdata
|
|
|
|
let
|
|
checkbox extId = Field parse view UrlEncoded
|
|
where
|
|
parse [] _ = return $ Right Nothing
|
|
parse optlist _ = runExceptT $ do
|
|
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
|
|
case () of
|
|
_ | extId `elem` extIds
|
|
-> Just <$> (lift $ fromExternal extId)
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
view _ name attributes val _ = do
|
|
[whamlet|
|
|
<label style="display: block">
|
|
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
|
|]
|
|
|
|
selectionIdent <- newFormIdent
|
|
|
|
(selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \ident -> mopt (checkbox ident) ("" { fsName = Just selectionIdent }) Nothing
|
|
|
|
let
|
|
selColonnade :: Colonnade Headed Int (Cell UniWorX)
|
|
selColonnade = headed "Markiert" $ cell . fvInput . (selectionBoxes !!)
|
|
|
|
collectResult :: [FormResult a] -> FormResult [a]
|
|
collectResult [] = FormSuccess []
|
|
collectResult (FormFailure errs : _) = FormFailure errs
|
|
collectResult (FormMissing:rs) = collectResult rs
|
|
collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
|
|
|
|
return ( catMaybes <$> collectResult selectionResults
|
|
, encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
|
|
)
|