Commit 715508be authored by Michael Hanus 's avatar Michael Hanus

Some libraries for HTML programming from the system libraries packaged

parents
*~
.cpm
.curry
Copyright (c) 2017, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the names of the copyright holders nor the names of its
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
HOLDER 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.
html: Support for HTML programming
==================================
This package contains libraries to support HTML programming.
--------------------------------------------------------------------------
{
"name": "html",
"version": "1.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Libraries for HTML programming.",
"category": [ "Web" ],
"dependencies": { },
"exportedModules": [ "HTML.CategorizedList", "HTML.Parser",
"HTML.Styles.Bootstrap3" ],
"compilerCompatibility": {
"pakcs": ">= 1.14.0, < 2.0.0",
"kics2": ">= 0.5.0, < 2.0.0"
},
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/html.git",
"tag": "$version"
}
}
------------------------------------------------------------------------------
--- This library provides functions to categorize a list of entities
--- into a HTML page with an index access (e.g., "A-Z") to these entities.
---
--- @category web
------------------------------------------------------------------------------
module HTML.CategorizedList
(list2CategorizedHtml, categorizeByItemKey, stringList2ItemList)
where
import List
import HTML
import Char
--- General categorization of a list of entries.
---
--- The item will occur in every category for which the boolean function
--- categoryFun yields True.
--- @param itemL the list of key-item pairs which are supposed to be
--- categorized with respect to key
--- @param categoryL list of key-category pairs to which the items can be
--- sorted in
--- @param categoryFun uses the keys of the items and the keys of the
--- categories to distribute the items among the categories.
--- @return Html containing inner links between the categories
list2CategorizedHtml :: [(a,[HtmlExp])] -> [(b,String)] -> (a -> b -> Bool)
-> [HtmlExp]
list2CategorizedHtml itemL categoryL categoryFun =
categories2LinkList categoryL :
map (\ (categoryKey,categoryString) ->
anchor (string2urlencoded (show categoryKey))
(h2 [htxt categoryString] :
concatMap (\ (_,item)->item++[breakline])
(filter (\ (itemKey,_) ->
categoryFun itemKey categoryKey)
itemL)
++ [categories2LinkList categoryL])
)
categoryL
-- the navigation list
categories2LinkList :: [(_,String)] -> HtmlExp
categories2LinkList categoryL =
par
[center
(concatMap (\ (categoryKey,categoryString) ->
[href ('#':(string2urlencoded (show categoryKey)))
[htxt categoryString], nbsp])
categoryL)]
--- Categorize a list of entries with respect to the inial keys.
---
--- The categories are named as all initial characters of the keys of the items.
--- @param itemL the list of key-item pairs which are supposed to be
--- categorized with respect to key
--- @return Html containing inner links between the categories
categorizeByItemKey :: [(String,[HtmlExp])] -> [HtmlExp]
categorizeByItemKey itemL =
list2CategorizedHtml
itemL
(map (\c -> (toUpper c,[toUpper c])) (listHeads (map fst itemL)))
categorizeStringHead
--- Convert a string list into an key-item list
--- The strings are used as keys and for the simple text layout.
stringList2ItemList :: [String] -> [(String,[HtmlExp])]
stringList2ItemList = map (\str -> (str,[htxt str]))
-- yields every listHead only once
listHeads :: [String] -> [Char]
listHeads =
nubBy isUpperEqual . foldr (\xs ys -> if xs==[] then ys else head xs:ys) []
-- categoryFun for categorizeByItemKey
categorizeStringHead :: String -> Char -> Bool
categorizeStringHead [] _ = False
categorizeStringHead (c:_) c' = isUpperEqual c c'
isUpperEqual c c' = toUpper c == toUpper c'
-- just for testing ----------------------------------------
main = return $ form "CatTest"
(categorizeByItemKey (stringList2ItemList testList))
testList = ["bbcd",
"acde",
"ab",
"cde",
"b",
"xt",
"gbbcd",
"uacde",
"Oab",
"Qcde",
"Tb",
"mxt",
"mxtr"]
-- makecurrycgi -o ~/public_html/cat.cgi CategorizedHtmlList
------------------------------------------------------------------------------
--- This module contains a very simple parser for HTML documents.
---
--- @author Michael Hanus
--- @version March 2015
--- @category web
------------------------------------------------------------------------------
module HTML.Parser(readHtmlFile,parseHtmlString) where
import HTML
import Char
--- Reads a file with HTML text and returns the corresponding HTML expressions.
--- @param file - the name of a file containing HTML text
--- @return a list of HTML expressions (if the file contains exactly one
--- HTML document, this list should contain exactly one element)
readHtmlFile :: String -> IO [HtmlExp]
readHtmlFile file = readFile file >>= return . parseHtmlString
------------------------------------------------------------------------------
--- Transforms an HTML string into a list of HTML expressions.
--- If the HTML string is a well structured document, the list
--- of HTML expressions should contain exactly one element.
parseHtmlString :: String -> [HtmlExp]
parseHtmlString s = reverse (parseHtmlTokens [] (scanHtmlString s))
--- The data type for representing HTML tokens.
data HtmlToken = HText String | HElem String [(String,String)]
-- parse a list of HTML tokens into list of HTML expressions:
-- (first argument "helems" is a stack of already read tokens)
parseHtmlTokens :: [HtmlExp] -> [HtmlToken] -> [HtmlExp]
parseHtmlTokens helems [] = helems
parseHtmlTokens helems (HText s : hs) =
parseHtmlTokens (HtmlText s : helems) hs
parseHtmlTokens helems (HElem (t:ts) args : hs) =
if t == '/'
then let (structargs,elems,rest) = splitHtmlElems ts helems
in parseHtmlTokens ([HtmlStruct ts structargs elems] ++ rest) hs
else parseHtmlTokens (HtmlStruct (t:ts) args [] : helems) hs
-- split the HTML token stack up to a particular token:
splitHtmlElems :: String -> [HtmlExp]
-> ([(String,String)],[HtmlExp],[HtmlExp])
splitHtmlElems _ [] = ([],[],[])
splitHtmlElems tag (HtmlText s : hs) =
let (largs,elems,rest) = splitHtmlElems tag hs
in (largs, elems ++ [HtmlText s], rest)
splitHtmlElems tag (HtmlStruct s args cont@(_:_) : hs) =
let (largs,elems,rest) = splitHtmlElems tag hs
in (largs, elems ++ [HtmlStruct s args cont], rest)
splitHtmlElems tag (HtmlStruct s args []: hs) =
if tag==s
then (args,[],hs)
else let (largs,elems,rest) = splitHtmlElems tag hs
in (largs, elems ++ [HtmlStruct s args []], rest)
-- scan an HTML string into list of HTML tokens:
scanHtmlString :: String -> [HtmlToken]
scanHtmlString s = scanHtml s
where
scanHtml [] = []
scanHtml (c:cs) =
if c=='<'
then if take 3 cs == "!--"
then scanHtmlComment cs
else if take 4 (map toLower cs) == "pre>"
then scanHtmlPre "" (skipFirstNewLine (drop 4 cs))
else scanHtmlElem [] cs
else let (initxt,remtag) = break (=='<') (c:cs)
in HText initxt : scanHtml remtag
-- scan an HTML element
scanHtmlElem :: String -> String -> [HtmlToken]
scanHtmlElem ct [] = [HText ("&lt;"++ct)] -- incomplete element
scanHtmlElem ct (c:cs)
| c=='>' = (if null ct
then HText "&lt;&gt;" -- invalid HTML, but we accept it...
else HElem ct []) : scanHtmlString cs
| isSpace c =
if null ct
then HText "&lt; " : scanHtmlString cs -- invalid HTML, but we accept it...
else let (args,rest) = splitAtElement (=='>') (dropWhile isSpace cs)
revargs = reverse args
in if null args || head revargs /= '/'
then HElem ct (string2args args) : scanHtmlString rest
else HElem ct (string2args (reverse (tail revargs)))
: HElem ('/':ct) [] : scanHtmlString rest
| c=='/' && head cs == '>' = HElem ct [] : HElem ('/':ct) []
: scanHtmlString (tail cs)
| otherwise = scanHtmlElem (ct++[toLower c]) cs
-- scan an HTML comment
scanHtmlComment :: String -> [HtmlToken]
scanHtmlComment [] = []
scanHtmlComment (c:cs) =
if c=='-' && take 2 cs == "->"
then scanHtmlString (drop 2 cs)
else scanHtmlComment cs
-- scan an HTML preformatted element
scanHtmlPre :: String -> String -> [HtmlToken]
scanHtmlPre _ [] = [] -- errorneous incomplete element
scanHtmlPre pre (c:cs) =
if c=='<' && take 5 (map toLower cs) == "/pre>"
then HElem "pre" [] : HText (reverse pre) : HElem "/pre" []
: scanHtmlString (drop 5 cs)
else scanHtmlPre (c:pre) cs
-- split a string into blank separated list of strings:
string2args :: String -> [(String,String)]
string2args [] = []
string2args (c:cs) =
let (arg1,rest) = splitAtElement isSpace (c:cs)
in deleteApo (splitAtElement (=='=') arg1)
: string2args (dropWhile isSpace rest)
deleteApo :: (String,String) -> (String,String)
deleteApo (tag,[]) = (map toLower tag,[])
deleteApo (tag,c:cs) | c=='"' = (map toLower tag, deleteLastApo cs)
| c=='\'' = (map toLower tag, deleteLastApo cs)
| otherwise = (map toLower tag, c:cs)
deleteLastApo :: String -> String
deleteLastApo [] = []
deleteLastApo [c] = if c=='"' || c=='\'' then [] else [c]
deleteLastApo (c1:c2:cs) = c1 : deleteLastApo (c2:cs)
-- split a list at the first element satisfying a predicate:
splitAtElement :: (a -> Bool) -> [a] -> ([a],[a])
splitAtElement _ [] = ([],[])
splitAtElement p (c:cs) =
if p c then ([],cs)
else let (first,rest) = splitAtElement p cs in (c:first,rest)
skipFirstNewLine :: String -> String
skipFirstNewLine [] = []
skipFirstNewLine (c:cs) =
if c=='\n' then cs
else if isSpace c then skipFirstNewLine cs else c:cs
-- end of HTML parser
----------------------------------------------------------------------------
--- This library contains some operations to generate web pages
--- rendered with [Bootstrap](http://twitter.github.com/bootstrap/)
---
--- @author Michael Hanus
--- @version January 2016
--- @category web
----------------------------------------------------------------------------
module HTML.Styles.Bootstrap3
( bootstrapForm, bootstrapPage, titledSideMenu
, defaultButton, smallButton, primButton
, hrefButton, hrefBlock, hrefInfoBlock
, glyphicon, homeIcon, userIcon, loginIcon, logoutIcon
) where
import HTML
----------------------------------------------------------------------------
--- An HTML form rendered with bootstrap.
--- @param rootdir - the root directory to find styles (in subdirectory `css`
--- of the root) and images (in subdirectory `img` of the root)
--- @param styles - the style files to be included (typically,
--- `bootstrap` and `bootstrap-responsive`), stored in
--- `rootdir/css` with suffix `.css`)
--- @param title - the title of the form
--- @param brandurltitle - the URL and contents shown as the brand of the page
--- @lefttopmenu - the menu shown in the left side of the top navigation bar
--- @righttopmenu - the menu shown in the right side of the top navigation bar
--- (could be empty)
--- @param columns - number of columns for the left-side menu
--- (if columns==0, then the left-side menu is omitted)
--- @param sidemenu - the menu shown at the left-side of the main document
--- (maybe created with 'titledSideMenu')
--- @param header - the main header (rendered with jumbotron style)
--- @param contents - the main contents of the document
--- @param footer - the footer of the document
bootstrapForm :: String -> [String] -> String -> (String,[HtmlExp])
-> [[HtmlExp]] -> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp]
-> [HtmlExp] -> [HtmlExp] -> HtmlForm
bootstrapForm rootdir styles title brandurltitle lefttopmenu righttopmenu
leftcols sidemenu header contents footer =
HtmlForm title
([formEnc "utf-8", responsiveView, icon] ++
map (\n -> formCSS (rootdir++"/css/"++n++".css")) styles)
(bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu
leftcols sidemenu header contents footer)
where
-- for a better view on handheld devices:
responsiveView =
HeadInclude (HtmlStruct "meta"
[("name","viewport"),
("content","width=device-width, initial-scale=1.0")] [])
icon = HeadInclude (HtmlStruct "link"
[("rel","shortcut icon"),
("href",rootdir++"/img/favicon.ico")] [])
--- An HTML page rendered with bootstrap.
--- @param rootdir - the root directory to find styles, fonts, scripts
--- (in subdirectories `css`, `fonts`, `js`) and the
--- `favicon.ico`
--- of the root) and images (in subdirectory `img` of the root)
--- @param styles - the style files to be included (typically,
--- `bootstrap` and `bootstrap-responsive`), stored in
--- `rootdir/css` with suffix `.css`)
--- @param title - the title of the form
--- @lefttopmenu - the menu shown in the left side of the top navigation bar
--- @righttopmenu - the menu shown in the right side of the top navigation bar
--- (could be empty)
--- @param columns - number of columns for the left-side menu
--- (if columns==0, then the left-side menu is omitted)
--- @param sidemenu - the menu shown at the left-side of the main document
--- (maybe created with 'titledSideMenu')
--- @param header - the main header (rendered with jumbotron style)
--- @param contents - the main contents of the document
--- @param footer - the footer of the document
bootstrapPage :: String -> [String] -> String -> (String,[HtmlExp])
-> [[HtmlExp]] -> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp]
-> [HtmlExp] -> [HtmlExp] -> HtmlPage
bootstrapPage rootdir styles title brandurltitle lefttopmenu righttopmenu
leftcols sidemenu header contents footer =
HtmlPage title
([pageEnc "utf-8",responsiveView,icon] ++
map (\n -> pageCSS (rootdir++"/css/"++n++".css")) styles)
(bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu
leftcols sidemenu header contents footer)
where
-- for a better view on handheld devices:
responsiveView =
pageMetaInfo [("name","viewport"),
("content","width=device-width, initial-scale=1.0")]
icon = pageLinkInfo [("rel","shortcut icon"),
("href",rootdir++"/favicon.ico")]
--- Create body of HTML page. Used by bootstrapForm and bootstrapPage.
bootstrapBody :: String -> (String,[HtmlExp]) -> [[HtmlExp]]
-> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp]
-> [HtmlExp] -> [HtmlExp] -> [HtmlExp]
bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu
leftcols sidemenu header contents footer =
topNavigationBar brandurltitle lefttopmenu righttopmenu ++
[blockstyle "container-fluid"
([blockstyle "row"
(if leftcols==0
then [blockstyle (bsCols 12)
(headerRow ++ contents)]
else [blockstyle (bsCols leftcols)
[blockstyle "well nav-sidebar" sidemenu],
blockstyle (bsCols (12-leftcols))
(headerRow ++ contents)])] ++
if null footer
then []
else [hrule, HtmlStruct "footer" [] footer]),
-- JavaScript includes placed at the end so page loads faster:
HtmlStruct "script" [("src",rootdir++"/js/jquery.min.js")] [],
HtmlStruct "script" [("src",rootdir++"/js/bootstrap.min.js")] []]
where
bsCols n = "col-sm-" ++ show n ++ " " ++ "col-md-" ++ show n
-- header row:
headerRow = if null header
then []
else [HtmlStruct "header" [("class","jumbotron")] header]
-- Navigation bar at the top. The first argument is a header element
-- put at the left, the second and third arguments are the left
-- and right menus which will be collapsed if the page is two small.
topNavigationBar :: (String,[HtmlExp]) -> [[HtmlExp]] -> [[HtmlExp]]
-> [HtmlExp]
topNavigationBar (brandurl,brandtitle) leftmenu rightmenu =
[blockstyle "navbar navbar-inverse navbar-fixed-top"
[blockstyle "container-fluid"
[blockstyle "navbar-header"
[HtmlStruct "button"
[("type","button"),("class","navbar-toggle collapsed"),
("data-toggle","collapse"),("data-target","#topnavbar"),
("aria-expanded","false"),("aria-controls","topnavbar")]
[textstyle "sr-only" "Toggle navigation",
textstyle "icon-bar" "",
textstyle "icon-bar" "",
textstyle "icon-bar" ""],
href brandurl brandtitle `addClass` "navbar-brand"],
HtmlStruct "div" [("id","topnavbar"),
("class","collapse navbar-collapse")]
([ulist leftmenu `addClass` "nav navbar-nav"] ++
if null rightmenu then []
else [ulist rightmenu `addClass` "nav navbar-nav navbar-right"])]]]
-- Create a side menu containing a title and a list of items:
titledSideMenu :: String -> [[HtmlExp]] -> [HtmlExp]
titledSideMenu title items =
(if null title
then []
else [HtmlStruct "small" [] [htxt title]]) ++
[ulist items `addClass` "nav nav-sidebar"]
----------------------------------------------------------------------------
-- Some buttons:
--- Default input button.
defaultButton :: String -> HtmlHandler -> HtmlExp
defaultButton label handler =
button label handler `addClass` "btn btn-default"
--- Small input button.
smallButton :: String -> HtmlHandler -> HtmlExp
smallButton label handler =
button label handler `addClass` "btn btn-sm btn-default"
--- Primary input button.
primButton :: String -> HtmlHandler -> HtmlExp
primButton label handler =
button label handler `addClass` "btn btn-primary"
--- Hypertext reference rendered as a button.
hrefButton :: String -> [HtmlExp] -> HtmlExp
hrefButton ref hexps =
href ref hexps `addClass` "btn btn-sm btn-default"
--- Hypertext reference rendered as a block level button.
hrefBlock :: String -> [HtmlExp] -> HtmlExp
hrefBlock ref hexps =
href ref hexps `addClass` "btn btn-sm btn-block"
--- Hypertext reference rendered as an info block level button.
hrefInfoBlock :: String -> [HtmlExp] -> HtmlExp
hrefInfoBlock ref hexps =
href ref hexps `addClass` "btn btn-info btn-block"
----------------------------------------------------------------------------
-- Some icons:
glyphicon :: String -> HtmlExp
glyphicon n = textstyle ("glyphicon glyphicon-"++n) ""
homeIcon :: HtmlExp
homeIcon = glyphicon "home"
userIcon :: HtmlExp
userIcon = glyphicon "user"
loginIcon :: HtmlExp
loginIcon = glyphicon "log-in"
logoutIcon :: HtmlExp
logoutIcon = glyphicon "log-out"
----------------------------------------------------------------------------
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment