module Happstack.Helpers.HtmlOutput.Common where
import Happstack.Server.SimpleHTTP
import Control.Monad (mplus)
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.UTF8 as UTF
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Encoding as TE
fullUrlLink :: FilePath -> String
fullUrlLink url = simpleLink (url,url)
simpleLink :: (FilePath,String) -> String
simpleLink (url,anchortext) = render1 [("url",url),("anchortext",anchortext)] "<a href=\"$url$\">$anchortext$</a>"
simpleAttentionLink :: (String, String) -> String
simpleAttentionLink (url,anchortext) =
render1 [("url",url),("anchortext",anchortext)] "<a class=attention href=\"$url$\">$anchortext$</a>"
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$>"
paintVHtml :: [String] -> String
paintVHtml = concatMap p
where p s = render1 [("s",s)] "<p>$s$</p>"
paintTable :: Maybe [String]
-> [[String]]
-> Maybe 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' :: (String -> String)
-> ([String] -> String)
-> (String,Bool)
-> Maybe ([String], [String] -> String)
-> [[String]]
-> Maybe 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>"
data Pagination = Pagination { currentbar :: Int
, resultsPerBar :: Int
, currentpage :: Int
, resultsPerPage :: Int
, baselink :: String
, paginationtitle :: String
}
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, (_,(fr',to'))) =
let adjust = (barindex1)*(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 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 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@(_:_) =
let (a,b') = genericSplitAt n' l
b = splitList' n' b'
in a : b
newlinesToHtmlLines :: String -> String
newlinesToHtmlLines = concatMap formatnewlines
where formatnewlines c = if c == '\n' then "<br>" else [c]
readcheckbox :: String -> RqData Bool
readcheckbox checkboxname = (return . (=="on") =<< look checkboxname `mplus` return "")
checkedStringIfTrue :: Bool -> String
checkedStringIfTrue p = if p then "checked" else ""
paintVUL :: [String] -> String
paintVUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"
paintVOL :: [String] -> String
paintVOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"
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
newtype HtmlText = HtmlText Text
instance ToMessage HtmlText where
toContentType _ = B.pack "text/html; charset=utf-8"
toMessage (HtmlText s) = TE.encodeUtf8 s