happstack-helpers-0.50: Happstack/Helpers/HtmlOutput/Common.hs
{- |
Simple stupid output of common types of html
-}
module Happstack.Helpers.HtmlOutput.Common where
import Happstack.Server.SimpleHTTP
import Control.Monad (mplus)
import Text.StringTemplate
import Text.StringTemplate.Helpers
import Data.List
import Safe (atMay)
import Data.String.Utils
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as UTF
-- | fullUrlLink \"http://www.google.com\"
-- | for when you want a link that the anchor text is the full url. eg, for displaying a url for darcs get.
fullUrlLink :: FilePath -> String
fullUrlLink url = simpleLink (url,url)
-- | simpleLink (\"http://www.google.com\",\"google is a nice way to look for information\")
simpleLink :: (FilePath,String) -> String
simpleLink (url,anchortext) = render1 [("url",url),("anchortext",anchortext)] "<a href=\"$url$\">$anchortext$</a>"
{- |
like simpleLink, but a link tag is class=attention
if class attention is defined via css you can get some useful behavior. I typically do something like the following, in a global css file:
a.attention:link {color: orange}
a.attention:active {color: orange}
a.attention:visited {color: orange}
a.attention:hover {color: orange}
-}
simpleAttentionLink :: (String, String) -> String
simpleAttentionLink (url,anchortext) =
render1 [("url",url),("anchortext",anchortext)] "<a class=attention href=\"$url$\">$anchortext$</a>"
{- |
width and height args blank blank if you don't want to specify this
simpleImage (url, alttext) (width, height) = ...
-}
simpleImage :: (FilePath,String) -> (String,String) -> String
simpleImage (url, alttext) (width, height) =
render1 [("url",url),("alttext",alttext),("width",width),("height",height)] "<img src=\"$url$\" alt=\"$alttext$\" width=$width$ height=$height$>"
-- | format a list of text vertically by putting list items in paragraphs
paintVHtml :: [String] -> String
paintVHtml = concatMap p
where p s = render1 [("s",s)] "<p>$s$</p>"
{- |
paintTable mbHeaderCells datacells mbPagination = ...
mbHeaderCells: text for header cells, if you want them. Can use html formatting if desired.
pagination also optional
-}
paintTable :: Maybe [String] -- ^ optional header rows
-> [[String]] -- ^ table cells
-> Maybe Pagination -- ^ optional pagination
-> String
paintTable mbHeaderRows =
case mbHeaderRows of
Just rs -> paintTable' defTableF defTrF defSpacerRow (Just (rs,defTrF))
Nothing -> paintTable' defTableF defTrF defSpacerRow Nothing
where
defTableF rows = render1 [("rows",rows)] "<table> $ rows $ </table>"
defTrFMeh row = render1 [("row",row)] "<tr> $ row $ </tr>"
defTdF cell = render1 [("cell",cell)] "<td> $cell$ </td>"
defSpacerRow = ("",False)
defTrF cells = defTrFMeh . concat . map defTdF $ cells
{- |
paintTable' tableF trF spacerRow mbHeaderStuff datacells mbPagination =
helper function for a table with pagination
see paintTable for an example of how this can be used
-}
paintTable' :: (String -> String) -- ^ table tag function
-> ([String] -> String) -- ^ row tag function, input is table cell contents
-> (String,Bool) -- ^ (spacer row, more padding)
-- (use ("",False) for no spacer rows)
-- if more padding is true, prepend and append spacers
-> Maybe ([String], [String] -> String) -- ^ optional (header rows, header row tag function)
-> [[String]] -- ^ table cells
-> Maybe Pagination -- ^ optional pagination
-> String
paintTable' _ _ _ _ [] _ = ""
paintTable' tableF trF (spacerRow,morePadding) mbHeaderStuff datacells mbPagination =
let trows = case mbHeaderStuff of
Just (headerCells, htrF) -> htrF headerCells ++ rows
Nothing -> rows
where rows = let rows' = join spacerRow . map trF $ tableCells
in if morePadding
then spacerRow ++ rows' ++ spacerRow
else rows'
tableCells :: [[String]]
tableCells = maybe datacells (getPaginatedCells datacells) mbPagination
paginationBar :: String
paginationBar = maybe "" (paintPaginationBar datacells) mbPagination
in ( tableF trows ) ++ paginationBar
biggerfont x = "<font size=+1>" ++ x ++ "</font>"
-- import Text.StringTemplate hiding (directoryGroup)
data Pagination = Pagination { currentbar :: Int
, resultsPerBar :: Int
, currentpage :: Int
, resultsPerPage :: Int
, baselink :: String
, paginationtitle :: String
}
--tpr = paginationRanges (Pagination 1 10000 1 3 "" "") tbl -- [["blee","blah","bloo"],["mee","mah","moo"]]
-- where tbl = map (const ["blee","blah","bloo"]) [1..10]
--paginationRanges :: Pagination -> [[String]] -> [ ([(Int,[String])], (Int, Int) ) ]
--paginationRanges pg datacells = barRanges = splitList (resultsPerPage pg) datacells
--barRanges pg datacells = splitList (resultsPerBar pg) $ zip datacells [1..]
-- tp = paintPaginationBar [[]] (Pagination 1 10000 1 20 "" "")
-- variable nomenclature is kind of poor here
-- think of "bar" as the outer loop and "page" as the inner loop
paintPaginationBar :: [[String]] -> Pagination -> String
paintPaginationBar datacells pg | resultsPerPage pg > length datacells = ""
| otherwise =
let paintresultsbar (barindex, ( xs,(fr,to)) ) =
let attrs = [("currentbar",show barindex)
, ("resultsPerBar",show $ resultsPerBar pg)
, ("currentpage", show 1)
, ("resultsPerPage",show $ resultsPerPage pg)
, ("from",show fr)
, ("to",show to)]
in if (currentbar pg) == barindex
then let paintresultspage (pageindex, (xs,(fr,to))) =
let adjust = (barindex-1)*(resultsPerBar pg)
attrs = [("currentbar",show barindex)
, ("resultsPerBar",show $ resultsPerBar pg)
, ("currentpage", show pageindex)
, ("resultsPerPage",show $ resultsPerPage pg)
, ("from",show $ adjust + fr)
, ("to",show $ adjust + to)]
in if currentpage pg == pageindex
then render1 attrs pagselected
else render1 attrs pagunselected
pglinks = map paintresultspage $ zip [1..] ( splitList (resultsPerPage pg) xs )
in concat . intersperse " | " $ pglinks
else render1 attrs pagunselected
-- barlinks = map paintbarlinks $ zip [1..]
barlinks = map paintresultsbar $ zip [1..] ( splitList (resultsPerBar pg) datacells )
pagselected = "<a class=menuitemSelected href=$baselink$?currentbar=$currentbar$&resultsPerBar=$resultsPerBar$¤tpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>"
pagunselected = "<a class=menuitem href=$baselink$?currentbar=$currentbar$&resultsPerBar=$resultsPerBar$¤tpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>"
in (paginationtitle pg) ++ ( concat . intersperse " | " $ barlinks )
getPaginatedCells :: [[String]] -> Pagination -> [[String]]
getPaginatedCells [] _ = [[]]
getPaginatedCells datacells pg =
let currb = (currentbar pg)-1
in case splitList (resultsPerBar pg) datacells `atMay` currb of
Nothing -> [["getPaginatedCells, index not in range, currb: " ++ (show currb) ]]
Just (datacells2, (_,_) ) ->
let currp = (currentpage pg)-1
in case splitList (resultsPerPage pg) datacells2 `atMay` currp of
Nothing -> [["getPaginatedCells, index not in range, currp: " ++ (show currp) ]]
Just (res,(_,_)) -> res
-- splitList 3 [1..11]
-- [([(1,1),(2,2),(3,3)],(1,3)),([(4,4),(5,5),(6,6)],(4,6)),([(7,7),(8,8),(9,9)],(7,9)),([(10,10),(11,11)],(10,11))]
-- the result is a list of (indexed sublist,(fist index, last index))
--splitList :: Int -> [b] -> [([b], (Int, Int))]
splitList n x = let
part = splitList' n ( zip [1..] x)
bounded = map (\l -> (map snd l,bounds l)) part
bounds [] = (0,0)
bounds l@((_,_):_) = (fst . head $ l,fst . last $ l)
in bounded
where
splitList' :: Int -> [a] -> [[a]]
splitList' _ [] = []
splitList' n l@(x:xs) =
let (a,b') = genericSplitAt n l
b = splitList' n b'
in a : b
-- | substitute newlines with <br>
newlinesToHtmlLines :: String -> String
newlinesToHtmlLines = concatMap formatnewlines
where formatnewlines c = if c == '\n' then "<br>" else [c]
{- |
The checkbox form element has optional attribute "checked".
If this attribute is present, readcheckbox returns true, otherwise false.
use in conjunction with checkStringIfTrue, when, eg, writing StringTemplate code that renders a from with a box that might or not be checked. Something like:
attrs = [ ... , ("somethingIsChecked", checkedStringIfTrue $ someBoolVal ) ... ]
-}
readcheckbox :: String -> RqData Bool
readcheckbox checkboxname = (return . (=="on") =<< look checkboxname `mplus` return "")
{- |
useful hack for dealing with checkboxes in HAppS. Maybe there's a better way?
checkedStringIfTrue p = if p then \"checked\" else \"\"
-}
checkedStringIfTrue :: Bool -> String
checkedStringIfTrue p = if p then "checked" else ""
-- | Render a list of strings as an unordered list (<ul>...</ul>)
paintVUL :: [String] -> String
paintVUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"
-- | Render a list of strings as an ordered list (<ol>...</ol>)
paintVOL :: [String] -> String
paintVOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"
-- | render a list of strings horizontally, separated by \" | \"
paintHBars :: [String] -> String
paintHBars = intercalate " | "
newtype HtmlString = HtmlString String
instance ToMessage HtmlString where
toContentType _ = B.pack "text/html;charset=utf-8"
toMessage (HtmlString s) = UTF.fromString s