scotty-view (empty) → 1.0.0
raw patch · 7 files changed
+1046/−0 lines, 7 filesdep +basedep +scottydep +scotty-viewsetup-changed
Dependencies added: base, scotty, scotty-view, text, transformers
Files
- HtmlPage.hs +458/−0
- HtmlPageBuilder.hs +299/−0
- ScottyView.hs +25/−0
- Setup.hs +2/−0
- executable/Web.hs +44/−0
- executable/index.html +185/−0
- scotty-view.cabal +33/−0
+ HtmlPage.hs view
@@ -0,0 +1,458 @@+{-#LANGUAGE TypeSynonymInstances #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE OverlappingInstances #-}++module HtmlPage+ ( -- * Types+ HtmlPage, Tag(..), TagId, Attributes,+ -- * Content functions+ emptyContent, emptyPage, (?), (?=), (<<+), (<+), (<<),++ -- * Attributes functions+ emptyAttributes, attributeList, (@+), (@?),++ -- * Cursor functions+ tagId, select, nextTagId, parentTagId,++ -- * IO functions+ fromFile,+ ) where++import Data.List (find)+import Data.Text (unpack, strip, pack, toLower)+++------------------------------------------------------------------------------+-- Types --+------------------------------------------------------------------------------++-- | An HTML page.+type HtmlPage = Content++-- | An HTML tag.+data Tag =+ PairedTag {+ tagName :: String,+ attributes :: Attributes,+ content :: Content+ } |+ UnpairedTag {+ tagName :: String,+ attributes :: Attributes+ } |+ Doctype {+ dtdInformation :: String+ } |+ Comment {+ commentContent :: String+ }++-- | An attribute of a tag.+data Attribute = Attribute {+ attributeName :: String,+ attributeValue :: String+}++-- | A content (a list containing strings and tags).+type Content = [Either String Tag]++-- | A list of attributes.+type Attributes = [Attribute]++-- | The id of a tag in the page (i.e. a cursor).+type TagId = [Int]+++------------------------------------------------------------------------------+-- Library functions --+------------------------------------------------------------------------------++instance Read Content where+ readsPrec _ string+ | null string = [(emptyContent, "")]+ | otherwise = [getContent string emptyContent]+ where+ -- | Returns the content of a tag from a given string.+ getContent :: String -> Content -> (Content, String)+ getContent "" content = (content, "")+ getContent ('<' : '/' : after) content =+ (content, snd (splitFirst after '>'))+ getContent ('<' : after) content+ | isScript && scriptEmpty = getContent afterScript (content <<+ tag)+ | isScript && not scriptEmpty =+ getContent afterScript (content <<+ (tag << (emptyContent <+ script)))+ | otherwise = case tag of+ PairedTag {} -> getContent afterTag $ content <<+ (tag << tagContent)+ _ -> getContent rest (content <<+ tag)+ where+ isScript = after `startsWith` "script"+ scriptEmpty = null (trim script)+ tag = read tagString :: Tag+ (tagString, rest) = getTagString 0 "" ('<' : after)+ (tagContent, afterTag) = getContent rest emptyContent+ (script, afterScript) = getScript 0 rest+ getContent string content+ | contentEmpty && null after = getContent "" content+ | contentEmpty && (not . null) after = getContent ('<' : after) content+ | otherwise = getContent ('<' : after) (content <+ contentString)+ where+ (contentString, after) = splitFirst string '<'+ contentEmpty = null (trim contentString)++instance Read Tag where+ readsPrec _ "" = noParse+ readsPrec _ string = [getTag (trim string)]+ where+ -- | Returns a tag from a given string.+ getTag :: String -> (Tag, String)+ getTag ('<' : string)+ | last tagContent == '/' =+ (UnpairedTag tagName attributesUnpairedTag, "")+ | string `startsWith` "!--" = (Comment contentComment, "")+ | string `startsWith` "!doctype" = (Doctype dtdInformation, "")+ | otherwise = (PairedTag tagName attributesPairedTag emptyContent, "")+ where+ tagContent = take (length string - 1) string+ (tagName, attributes) = if ' ' `elem` tagContent+ then splitFirst tagContent ' '+ else splitFirst tagContent '/'+ attributesPairedTag = read attributes :: Attributes+ attributesUnpairedTag =+ read (take (length attributes - 1) attributes) :: Attributes+ contentComment = drop 3 (take (length string - 3) string)+ (_, dtdInformation) = splitFirst_ (dropSpaces attributes) " PUBLIC "+ getTag _ = noParse++instance Read Attribute where+ readsPrec _ string+ | '=' `elem` string = [(Attribute name value, "")]+ | otherwise = noParse+ where+ (name, valueInQuotes) = splitFirst (trim string) '='+ value = case split valueInQuotes '\"' of+ [] -> []+ value' -> head value'++instance Read Attributes where+ readsPrec _ string = [(getAttributes emptyAttributes "" string, "")]+ where+ -- | Returns a list of attributes from a given string.+ getAttributes :: Attributes -> String -> String -> Attributes+ getAttributes attributes attribute "" = attributes+ getAttributes attributes attribute ('\"' : string) =+ getAttributes (attributes @+ attribute') "" (dropSpaces rest)+ where+ (value, rest) = splitFirst string '\"'+ attribute' = read (attribute ++ "\"" ++ value ++ "\"") :: Attribute+ getAttributes attributes attribute ('\'' : string) =+ getAttributes (attributes @+ attribute') "" (dropSpaces rest)+ where+ (value, rest) = splitFirst string '\''+ attribute' = read (attribute ++ "\'" ++ value ++ "\'") :: Attribute+ getAttributes attributes attribute (char : string) =+ getAttributes attributes (attribute ++ [char]) string++instance Show Attribute where+ show (Attribute name value) = name ++ "=\"" ++ value ++ "\""++instance Show Attributes where+ show attributes = unwords [show attribute | attribute <- attributes]++instance Show Tag where+ show (PairedTag name [] content) =+ "<" ++ name ++ ">" ++ show content ++ "</" ++ name ++ ">"+ show (PairedTag name attributes content) =+ "<" ++ name ++ " " ++ show attributes ++ ">"+ ++ show content ++ "</" ++ name ++ ">"+ show (UnpairedTag name []) = "<" ++ name ++ " />"+ show (UnpairedTag name attributes) =+ "<" ++ name ++ " " ++ show attributes ++ " />"+ show (Doctype []) = "<!DOCTYPE html>"+ show (Doctype dtdInformation) =+ "<!DOCTYPE html PUBLIC " ++ dtdInformation ++ ">"+ show (Comment content) = "<!--" ++ content ++ "-->"++instance Show Content where+ show [] = ""+ show (Left string : content) = string ++ show (content :: Content)+ show (Right tag : content) = show tag ++ show (content :: Content)++instance Show TagId where+ show [] = ""+ show [index] = show index+ show (index : indices) = show index ++ "." ++ show (indices :: TagId)++-- | Returns an empty content.+emptyContent :: Content+emptyContent = []++-- | Returns an empty HTML page.+emptyPage :: HtmlPage+emptyPage = emptyContent++-- | Returns the tag/string at the given position (TagId) in a content.+(?) :: Content -> TagId -> Either String Tag+(?) _ [] = tagNotInPage+(?) content [index]+ | index < length content = content !! index+ | otherwise = tagNotInPage+(?) content (index : indices) = case content !! index of+ Right tag @ (PairedTag _ _ content') -> content' ? indices+ _ -> tagNotInPage++-- | Replaces the tag/string at the given position (TagId) in a content.+(?=) :: Content -> (TagId, Either String Tag) -> Content+(?=) _ ([], _) = impossibleToAddTag+(?=) content ([index], stringOrTag)+ | index < length content = content !!= (index, stringOrTag)+ | index == length content = case stringOrTag of+ Left string -> content <+ string+ Right tag -> content <<+ tag+ | otherwise = impossibleToAddTag+(?=) content (index : indices, stringOrTag)+ | index < length content = case content !! index of+ Right tag @ (PairedTag _ _ content') ->+ content !!= (index, Right $ tag << (content' ?= (indices, stringOrTag)))+ _ -> impossibleToAddTag+ | otherwise = impossibleToAddTag++-- | Adds a tag to a content.+(<<+) :: Content -> Tag -> Content+(<<+) content tag = content ++ [Right tag]++-- | Adds a string to a content.+(<+) :: Content -> String -> Content+(<+) _ "" = stringMustNotBeEmpty+(<+) content string = content ++ [Left string]++-- | Replaces the content of the given tag by the given content.+(<<) :: Tag -> Content -> Tag+(<<) (PairedTag name attributes _) = PairedTag name attributes+(<<) (UnpairedTag _ _) = unpairedTagsDoNotHaveAContent+(<<) (Doctype _) = doctypesDoNotHaveAContent+(<<) (Comment _) = commentsDoNotHaveAContent++-- | Returns a TagId from a given string.+tagId :: String -> TagId+tagId string = [read index :: Int | index <- split string '.']++-- | Returns a tag matching the given selector string from the given page.+-- A selector is composed of a tag name and is optionally followed by a hash+-- and an HTML id name.+select :: HtmlPage -> String -> (TagId, Tag)+select page selector = case find (tagMatches (null after)) (tagList page) of+ Just tagIdAndTag -> tagIdAndTag+ _ -> noSuchTag+ where+ (tagString, after) = splitFirst selector '#'+ tagMatches _ (_, Comment _) = False+ tagMatches _ (_, Doctype _) = False+ tagMatches True (_, tag) = tagString == tagName tag+ tagMatches False (_, tag) =+ tagString == tagName tag && (attributes tag @? "id" == after)++-- | Returns the next TagId from a given TagId.+nextTagId :: TagId -> Bool -> TagId+nextTagId tagId True = tagId ++ [0]+nextTagId tagId False = take (length tagId - 1) tagId ++ [last tagId + 1]++-- | Returns the parent TagId of the given TagId.+parentTagId :: TagId -> TagId+parentTagId tagId = take (length tagId - 1) tagId++-- | Returns an empty attribute list.+emptyAttributes :: Attributes+emptyAttributes = []++-- | Returns a list of attributes from a given list of attribute names and+-- values.+attributeList :: [(String, String)] -> Attributes+attributeList namesAndValues = attributes' namesAndValues emptyAttributes+ where+ attributes' [] attributes = attributes+ attributes' ((name, value) : namesAndValues') attributes =+ attributes' namesAndValues' (attributes @+ Attribute name value)++-- | Adds an attribute to an attribute list.+(@+) :: Attributes -> Attribute -> Attributes+(@+) attributes attribute = attributes ++ [attribute]++-- | Returns the value of the attribute matching the given name.+(@?) :: Attributes -> String -> String+(@?) attributes name =+ case find (\attribute -> attributeName attribute == name) attributes of+ Just (Attribute _ value) -> value+ _ -> ""++-- | Reads a file and produces an HtmlPage.+fromFile :: FilePath -> IO HtmlPage+fromFile filePath = do+ string <- readFile filePath+ return (read string :: Content)+++------------------------------------------------------------------------------+-- Helper functions --+------------------------------------------------------------------------------++-- | Replaces, in a given list, the value at the given index with a new given+-- value.+(!!=) :: [a] -> (Int, a) -> [a]+(!!=) [] _ = emptyList+(!!=) list (index, value)+ | index > (length list - 1) = indexTooLarge+ | index < 0 = negativeIndex+ | otherwise = take index list ++ [value] ++ drop (index + 1) list++-- | Returns the content of a script tag.+getScript :: Int -> String -> (String, String)+getScript _ "" = ("", "")+getScript numberOfQuotesBefore string =+ if isPair (numberOfQuotesInScript + numberOfQuotesBefore)+ then (script, dropSpaces afterScript)+ else (script ++ script', rest')+ where+ (script, rest) = splitFirst_ string "</script"+ (_, afterScript) = splitFirst rest '>'+ numberOfQuotesInScript = numberOfQuotes script+ (script', rest') =+ getScript (numberOfQuotesBefore + numberOfQuotesInScript) rest++-- | Returns the tag at the beginning of the string.+getTagString :: Int -> String -> String -> (String, String)+getTagString _ _ "" = ("", "")+getTagString numberOfQuotesBefore suffix string+ | null suffix && string `startsWith` "<!--" =+ getTagString numberOfQuotesBefore "-->" string+ | null suffix && string `startsWith` "<" =+ getTagString numberOfQuotesBefore ">" string+ | isPair (numberOfQuotesInTag + numberOfQuotesBefore) = (tag ++ suffix, rest)+ | otherwise = (tag ++ tag', rest')+ where+ (tag, rest) = splitFirst_ string suffix+ numberOfQuotesInTag = numberOfQuotes tag+ (tag', rest') =+ getTagString (numberOfQuotesBefore + numberOfQuotesInTag) suffix rest++-- | Drops the spaces at the beginning of a string.+dropSpaces :: String -> String+dropSpaces (' ' : string) = dropSpaces string+dropSpaces ('\n' : string) = dropSpaces string+dropSpaces ('\r' : string) = dropSpaces string+dropSpaces ('\t' : string) = dropSpaces string+dropSpaces string = string++-- | Splits a string in two with a given delimiting character.+splitFirst :: String -> Char -> (String, String)+splitFirst string delimiter = (before, drop 1 after)+ where+ (before, after) = break (== delimiter) string++-- | Splits a string in two with a given delimiting string.+splitFirst_ :: String -> String -> (String, String)+splitFirst_ string delimiter = splitFirst' "" string+ where+ delimiterLength = length delimiter+ splitFirst' before after+ | take delimiterLength after == delimiter =+ (before, drop delimiterLength after)+ | null after = (before, "")+ | otherwise = splitFirst' (before ++ take 1 after) (drop 1 after)++-- | Splits a string with a given delimiting character.+split :: String -> Char -> [String]+split string delimiter = split' [] string+ where+ split' before "" = before+ split' before after = if null before'+ then split' before after'+ else split' (before ++ [before']) after'+ where+ (before', after') = splitFirst after delimiter++-- | Removes the spaces at the beginning and at the end of a string.+trim :: String -> String+trim string = unpack . strip $ pack string++-- | Returns the number of quotes in a string.+numberOfQuotes :: String -> Int+numberOfQuotes string = quotes string False False+ where+ quotes "" _ _ = 0+ quotes ('\"' : after) False False = 1 + quotes after True False+ quotes ('\'' : after) False False = 1 + quotes after False True+ quotes ('\"' : after) True _ = 1 + quotes after False False+ quotes ('\'' : after) True _ = quotes after True False+ quotes ('\"' : after) _ True = quotes after False True+ quotes ('\'' : after) _ True = 1 + quotes after False False+ quotes (char : after) inDoubleQuotes inSingleQuotes =+ quotes after inDoubleQuotes inSingleQuotes++-- | Indicates whether the given integer is pair.+isPair :: Int -> Bool+isPair int = int `mod` 2 == 0++-- | Indicates whether the first given string starts with the second given+-- string (not case sensitive).+startsWith :: String -> String -> Bool+startsWith _ [] = True+startsWith [] _ = False+startsWith firstString secondString = firstText == secondText+ where+ firstString' = take (length secondString) firstString+ firstText = toLower $ pack firstString'+ secondText = toLower $ pack secondString++-- | Returns a list containing all the tags (and all their associated TagId) of+-- a given Content.+tagList :: Content -> [(TagId, Tag)]+tagList content' = tagList' content' [0]+ where+ tagList' [] _ = []+ tagList' (Left _ : rest) currentTagId = restOfList rest currentTagId+ tagList' (Right tag : rest) currentTagId = case tag of+ PairedTag {} ->+ (currentTagId, tag) : contentList ++ restOfList rest currentTagId+ _ -> (currentTagId, tag) : restOfList rest currentTagId+ where+ contentList = tagList' (content tag) (nextTagId currentTagId True)+ restOfList content tagId = tagList' content (nextTagId tagId False)+++------------------------------------------------------------------------------+-- Errors --+------------------------------------------------------------------------------++noParse :: a+noParse = error "HtmlPage.read: no parse"++tagNotInPage :: a+tagNotInPage = error "HtmlPage.?: this tag does not exist in the page"++impossibleToAddTag :: a+impossibleToAddTag = error "HtmlPage.?=: impossible to add the tag"++noSuchTag :: a+noSuchTag = error "HtmlPage.tagId: there is no such tag in the given page"++emptyList :: a+emptyList = error "HtmlPage.!!=: empty list"++indexTooLarge :: a+indexTooLarge = error "HtmlPage.!!=: index too large"++negativeIndex :: a+negativeIndex = error "HtmlPage.!!=: negative index"++unpairedTagsDoNotHaveAContent :: a+unpairedTagsDoNotHaveAContent =+ error "HtmlPage.<<: unpaired tags do not have a content"++doctypesDoNotHaveAContent :: a+doctypesDoNotHaveAContent = error "HtmlPage.<<: doctypes do not have a content"++commentsDoNotHaveAContent :: a+commentsDoNotHaveAContent = error "HtmlPage.<<: comments do not have a content"++stringMustNotBeEmpty :: a+stringMustNotBeEmpty = error "HtmlPage.<+: the string must not be empty"
+ HtmlPageBuilder.hs view
@@ -0,0 +1,299 @@+module HtmlPageBuilder+ ( -- * Types+ HtmlPageBuilder(..),++ -- * Initialize+ doctype,++ -- * Add HTML elements+ meta, link, base, title, h1, h2, h3, h4, h5, h6, div, header, footer,+ section, article, aside, main, nav, p, ul, ol, li, br, hr, comment, text,++ -- * Derived functions+ unorderedList,++ -- * Cursor functions+ parent, goTo, goIn,++ -- * Run function+ run,++ -- * Functions from HtmlPage+ attributeList+ ) where++import Prelude (Functor, Monad, String, Bool(..), Either(..), ($), (.), (++),+ error, return, (>>=), fst, snd, flip)+import Control.Applicative++import HtmlPage+++------------------------------------------------------------------------------+-- Types --+------------------------------------------------------------------------------++-- | The state of an HtmlPageBuilder. The TagId is the position at which the+-- next element may be added (i.e. a cursor).+type HtmlPageBuilderState = (TagId, HtmlPage)++-- | An HtmlPage builder.+data HtmlPageBuilder m a =+ HtmlPageBuilder (HtmlPageBuilderState -> m (a, HtmlPageBuilderState))+++------------------------------------------------------------------------------+-- Library functions --+------------------------------------------------------------------------------++instance Applicative (HtmlPageBuilder m)++instance Functor (HtmlPageBuilder m)++instance Monad m => Monad (HtmlPageBuilder m) where+ -- | Returns a new HtmlPageBuilder from a given result.+ return result = HtmlPageBuilder $ \state -> return (result, state)++ -- | Returns a new HtmlPageBuilder from a given HtmlPageBuilder and+ -- function.+ HtmlPageBuilder builder >>= function = HtmlPageBuilder $ \state1 -> do+ (result, state2) <- builder state1+ let HtmlPageBuilder builder2 = function result in builder2 state2++-- | Creates the skeleton of the page (the doctype as well as the html, head+-- and body tags).+doctype :: (Monad m) => String -> HtmlPageBuilder m ()+doctype version = HtmlPageBuilder $ \state -> case snd state of+ [] -> case version of+ "html5" -> return ((), (tagId "1.1.0", html5))+ "xhtml1-strict" -> return ((), (tagId "1.1.0", xhtml1Strict))+ "xhtml1-transitional" -> return ((), (tagId "1.1.0", xhtml1Transitional))+ "xhtml11" -> return ((), (tagId "1.1.0", xhtml11))+ _ -> pageMustBeEmpty+ where+ headTag = PairedTag "head" emptyAttributes emptyContent+ bodyTag = PairedTag "body" emptyAttributes emptyContent+ htmlTag attributes =+ PairedTag "html" attributes $ emptyContent <<+ headTag <<+ bodyTag+ html5 = emptyPage <<+ doctypeHtml5 <<+ htmlTag emptyAttributes+ xhtmlNameSpace = attributeList [("xmlns", "http://www.w3.org/1999/xhtml")]+ xhtml1Strict = emptyContent <<+ doctypeXhtml1Strict+ <<+ htmlTag xhtmlNameSpace+ xhtml1Transitional = emptyContent <<+ doctypeXhtml1Transitional+ <<+ htmlTag xhtmlNameSpace+ xhtml11 = emptyContent <<+ doctypeXhtml11 <<+ htmlTag xhtmlNameSpace++-- | Adds a meta tag to the head.+meta :: Monad m => Attributes -> HtmlPageBuilder m ()+meta = unpairedTagInHead "meta"++-- | Adds a link tag to the head.+link :: Monad m => Attributes -> HtmlPageBuilder m ()+link = unpairedTagInHead "link"++-- | Adds a base tag to the head.+base :: Monad m => Attributes -> HtmlPageBuilder m ()+base = unpairedTagInHead "base"++-- | Defines the title of the page.+title :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+title = flip $ pairedTagInHead "title"++-- | Adds a level 1 title to the page body.+h1 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h1 = simplePairedTagInBody "h1"++-- | Adds a level 2 title to the page body.+h2 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h2 = simplePairedTagInBody "h2"++-- | Adds a level 3 title to the page body.+h3 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h3 = simplePairedTagInBody "h3"++-- | Adds a level 4 title to the page body.+h4 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h4 = simplePairedTagInBody "h4"++-- | Adds a level 5 title to the page body.+h5 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h5 = simplePairedTagInBody "h5"++-- | Adds a level 6 title to the page body.+h6 :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+h6 = simplePairedTagInBody "h6"++-- | Adds an empty div tag to the page body and puts the cursor in it.+div :: Monad m => Attributes -> HtmlPageBuilder m ()+div = pairedTagInBody "div"++-- | Adds an empty header tag to the page body and puts the cursor in it.+header :: Monad m => Attributes -> HtmlPageBuilder m ()+header = pairedTagInBody "header"++-- | Adds an empty footer tag to the page body and puts the cursor in it.+footer :: Monad m => Attributes -> HtmlPageBuilder m ()+footer = pairedTagInBody "footer"++-- | Adds an empty section tag to the page body and puts the cursor in it.+section :: Monad m => Attributes -> HtmlPageBuilder m ()+section = pairedTagInBody "section"++-- | Adds an empty article tag to the page body and puts the cursor in it.+article :: Monad m => Attributes -> HtmlPageBuilder m ()+article = pairedTagInBody "article"++-- | Adds an empty aside tag to the page body and puts the cursor in it.+aside :: Monad m => Attributes -> HtmlPageBuilder m ()+aside = pairedTagInBody "aside"++-- | Adds an empty main tag to the page body and puts the cursor in it.+main :: Monad m => Attributes -> HtmlPageBuilder m ()+main = pairedTagInBody "main"++-- | Adds an empty nav tag to the page body and puts the cursor in it.+nav :: Monad m => Attributes -> HtmlPageBuilder m ()+nav = pairedTagInBody "nav"++-- | Adds an empty p tag to the page body and puts the cursor in it.+p :: Monad m => Attributes -> HtmlPageBuilder m ()+p = pairedTagInBody "p"++-- | Adds an empty ul tag to the page body and puts the cursor in it.+ul :: Monad m => Attributes -> HtmlPageBuilder m ()+ul = pairedTagInBody "ul"++-- | Adds an empty ol tag to the page body and puts the cursor in it.+ol :: Monad m => Attributes -> HtmlPageBuilder m ()+ol = pairedTagInBody "ol"++-- | Adds a list element to the page body.+li :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+li = simplePairedTagInBody "li"++-- | Adds a line break to the page body.+br :: Monad m => HtmlPageBuilder m ()+br = unpairedTagInBody "br" $ attributeList []++-- | Adds a thematic break to the page body.+hr :: Monad m => Attributes -> HtmlPageBuilder m ()+hr = unpairedTagInBody "hr"++-- | Adds a comment to the body.+comment :: Monad m => String -> HtmlPageBuilder m ()+comment string = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId tagId False, page ?= (tagId, Right (Comment string))))++-- | Inserts some text in a tag.+text :: Monad m => String -> HtmlPageBuilder m ()+text string = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId tagId False, page ?= (tagId, Left string)))++-- | Generates an unordered list from a given list of string and adds it to+-- the page body.+unorderedList :: Monad m+ => [String] -> Attributes -> Attributes -> HtmlPageBuilder m ()+unorderedList list ulAttributes liAttributes = do+ ul ulAttributes+ listToLi list+ where+ listToLi [] = parent+ listToLi (string : rest) = do+ li string liAttributes+ listToLi rest++-- | Puts the cursor back to the parent element (after the element in which+-- the cursor was).+parent :: Monad m => HtmlPageBuilder m ()+parent = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId (parentTagId tagId) False, page))++-- | Puts the cursor on the tag matching the given selector string.+goTo :: Monad m => String -> HtmlPageBuilder m ()+goTo selector = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (fst (page `select` selector), page))++-- | Puts the cursor in the tag matching the given selector string.+goIn :: Monad m => String -> HtmlPageBuilder m ()+goIn selector = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId (fst (page `select` selector)) True, page))++-- | Runs a builder program and returns the generated HtmlPage.+run :: Monad m => HtmlPageBuilder m a -> HtmlPage -> m HtmlPage+run (HtmlPageBuilder program) page = do+ builderState <- program ([0], page)+ return ((snd . snd) builderState)+++------------------------------------------------------------------------------+-- Helper functions --+------------------------------------------------------------------------------++-- | Adds a given tag to the head.+tagInHead :: Monad m => Tag -> HtmlPageBuilder m ()+tagInHead tag = HtmlPageBuilder $ \(tagId, page) -> do+ let (headTagId, headTag @ (PairedTag _ _ headContent)) = page `select` "head"+ newHeadTag = headTag << (headContent <<+ tag)+ return ((), (tagId, page ?= (headTagId, Right newHeadTag)))++-- | Adds an unpaired tag to the head.+unpairedTagInHead :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+unpairedTagInHead tagName attributes =+ tagInHead $ UnpairedTag tagName attributes++-- | Adds a paired tag to the head.+pairedTagInHead :: Monad m+ => String -> Attributes -> String -> HtmlPageBuilder m ()+pairedTagInHead tagName attributes content =+ tagInHead $ PairedTag tagName attributes (emptyContent <+ content)++-- | Adds an empty paired tag to the body and puts the cursor in it.+pairedTagInBody :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+pairedTagInBody tagName attributes = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId tagId True, page ?= (tagId, Right tag)))+ where+ tag = PairedTag tagName attributes emptyContent++-- | Adds a paired tag with the given content string to the body.+simplePairedTagInBody :: Monad m+ => String -> String -> Attributes -> HtmlPageBuilder m ()+simplePairedTagInBody tagName content attributes = do+ pairedTagInBody tagName attributes+ HtmlPageBuilder $ \(tagId, page) -> do+ let newTagId = nextTagId (parentTagId tagId) False+ return ((), (newTagId, page ?= (tagId, Left content)))++unpairedTagInBody :: Monad m => String -> Attributes -> HtmlPageBuilder m ()+unpairedTagInBody tagName attributes = HtmlPageBuilder $ \(tagId, page) ->+ return ((), (nextTagId tagId False, page ?= (tagId, Right tag)))+ where+ tag = UnpairedTag tagName attributes+++------------------------------------------------------------------------------+-- Doctypes --+------------------------------------------------------------------------------++doctypeHtml5 :: Tag+doctypeHtml5 = Doctype ""++doctypeXhtml1Strict :: Tag+doctypeXhtml1Strict = Doctype $ "\"-//W3C//DTD XHTML 1.0 Strict//EN\" "+ ++ "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\""++doctypeXhtml1Transitional :: Tag+doctypeXhtml1Transitional = Doctype $+ "\"-//W3C//DTD XHTML 1.0 Transitional//EN\" "+ ++ "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\""++doctypeXhtml11 :: Tag+doctypeXhtml11 = Doctype $ "\"-//W3C//DTD XHTML 1.1//EN\" "+ ++ "\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\""+++------------------------------------------------------------------------------+-- Errors --+------------------------------------------------------------------------------++pageMustBeEmpty :: a+pageMustBeEmpty = error "HtmlPageBuilder.doctype: the page must be empty"
+ ScottyView.hs view
@@ -0,0 +1,25 @@+module ScottyView (getView, getViewFromFile) where++import Web.Scotty (ActionM, liftAndCatchIO, html)+import Data.Text.Lazy (pack)++import HtmlPage (emptyPage, fromFile)+import HtmlPageBuilder (HtmlPageBuilder, run)+++------------------------------------------------------------------------------+-- Library functions --+------------------------------------------------------------------------------++-- | Returns a view (ActionM) from a given HtmlPageBuilder.+getView :: HtmlPageBuilder IO () -> ActionM ()+getView builder = do+ page <- liftAndCatchIO $ run builder emptyPage+ html $ pack (show page)++-- | Returns a view (ActionM) from a given file path and HtmlPageBuilder.+getViewFromFile :: String -> HtmlPageBuilder IO () -> ActionM ()+getViewFromFile filePath builder = do+ page <- liftAndCatchIO $ fromFile filePath+ newPage <- liftAndCatchIO $ run builder page+ html $ pack (show newPage)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ executable/Web.hs view
@@ -0,0 +1,44 @@+module Main where++import Web.Scotty (ActionM, scotty, get, capture)++import qualified HtmlPageBuilder as HTML+import ScottyView++-- | The main.+-- The HTML file is a slightly different version of the "Real Estate or Travel"+-- template from foundation.zurb.com.+main :: IO ()+main = scotty 3000 $+ get (capture "/") (readHtmlFileView "executable/index.html" info)++-- | A simple to-do list.+toDoListView :: [String] -> String -> ActionM ()+toDoListView list info = getView $ do+ HTML.doctype "html5"+ HTML.title "To-do list" $ HTML.attributeList []+ HTML.meta $ HTML.attributeList [("charset", "UTF-8")]+ HTML.div $ HTML.attributeList [("id", "to-do")]+ HTML.h1 "To-do list" $ HTML.attributeList []+ HTML.unorderedList list (HTML.attributeList [("class", "to-do-list")])+ (HTML.attributeList [("class", "to-do-list-element")])+ HTML.parent+ HTML.div $ HTML.attributeList [("id", "info")]+ HTML.p $ HTML.attributeList []+ HTML.text info++-- | Reads a file, changes a paragraph in it and returns the view (ActionM).+readHtmlFileView :: FilePath -> String -> ActionM ()+readHtmlFileView filePath info = getViewFromFile filePath $ do+ HTML.goIn "p#info"+ HTML.text (take 60 info ++ "…")++list :: [String]+list = ["Repair the roof", "Repaint the bathroom", "Call Dominique"]++info :: String+info = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Quisque ex "+ ++ "lacus, consequat non mi sed, tempor malesuada risus. Donec nec consequat "+ ++ "massa. In eros neque, efficitur a arcu quis, imperdiet tristique leo. In "+ ++ "quis augue ultrices, condimentum est fringilla, auctor leo. Morbi non "+ ++ "felis nulla. Proin tempus interdum leo, ac feugiat purus tempor nec."
+ executable/index.html view
@@ -0,0 +1,185 @@+<!doctype html>+<html class="no-js" lang="en">+<head>+<meta charset="utf-8"/>+<meta name="viewport" content="width=device-width, initial-scale=1.0"/>+<title>Foundation | Welcome</title>+<link rel="stylesheet" href="http://dhbhdrzi4tiry.cloudfront.net/cdn/sites/foundation.min.css" />+<link href='http://cdnjs.cloudflare.com/ajax/libs/foundicons/3.0.0/foundation-icons.css' rel='stylesheet' type='text/css' />++</head>+<body>++<div class="title-bar" data-responsive-toggle="realEstateMenu" data-hide-for="small">+<button class="menu-icon" type="button" data-toggle></button>+<div class="title-bar-title">Menu</div>+</div>+<div class="top-bar" id="realEstateMenu">+<div class="top-bar-left">+<ul class="menu" data-responsive-menu="accordion">+<li class="menu-text">Interplanetary</li>+<li><a href="#">One</a></li>+<li><a href="#">Two</a></li>+<li><a href="#">Three</a></li>+</ul>+</div>+<div class="top-bar-right">+<ul class="menu">+<li><a href="#">My Account</a></li>+<li><a class="button">Login</a></li>+</ul>+</div>+</div>++<br />+<div class="row">+<div class="medium-7 large-6 columns">+<h1>Close Your Eyes and Open Your Mind</h1>+<p class="subheader">There is beauty in space, and it is orderly. There is no weather, and there is regularity. It is predictable. Everything in space obeys the laws of physics. If you know these laws, and obey them, space will treat you kindly.</p>+<button class="button">Take a Tour</button>+<button class="button">Start a free trial</button>+</div>+<div class="show-for-large large-3 columns">+<img src="http://placehold.it/400x370&text=PSR1257 + 12 C" alt="picture of space" />+</div>+<div class="medium-5 large-3 columns">+<div class="callout secondary">+<form>+<div class="row">+<div class="small-12 columns">+<label>Find Your Dream Planet+<input type="text" placeholder="Search destinations" />+</label>+</div>+<div class="small-12 columns">+<label>Number of Moons+<input type="number" placeholder="Moons required" />+</label>+<button type="submit" class="button">Search Now!</button>+</div>+</div>+</form>+</div>+</div>+</div>+<div class="row column">+<hr />+</div>+<div class="row column">+<p class="lead">Trending Planetary Destinations</p>+</div>+<div class="row small-up-1 medium-up-2 large-up-3">+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader" id="info">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+<div class="column">+<div class="callout">+<p>Pegasi B</p>+<p><img src="http://placehold.it/400x370&text=Pegasi B" alt="image of a planet called Pegasi B" /></p>+<p class="lead">Copernican Revolution caused an uproar</p>+<p class="subheader">Find Earth-like planets life outside the Solar System</p>+</div>+</div>+</div>+<div class="row column">+<a class="button hollow expanded">Load More</a>+</div>+<footer>+<div class="row expanded callout secondary">+<div class="small-6 large-3 columns">+<p class="lead">Offices</p>+<ul class="menu vertical">+<li><a href="#">One</a></li>+<li><a href="#">Two</a></li>+<li><a href="#">Three</a></li>+<li><a href="#">Four</a></li>+</ul>+</div>+<div class="small-6 large-3 columns">+<p class="lead">Solar Systems</p>+<ul class="menu vertical">+<li><a href="#">One</a></li>+<li><a href="#">Two</a></li>+<li><a href="#">Three</a></li>+<li><a href="#">Four</a></li>+</ul>+</div>+<div class="small-6 large-3 columns">+<p class="lead">Contact</p>+<ul class="menu vertical">+<li><a href="#"><i class="fi-social-twitter"></i> Twitter</a></li>+<li><a href="#"><i class="fi-social-facebook"></i> Facebook</a></li>+<li><a href="#"><i class="fi-social-instagram"></i> Instagram</a></li>+<li><a href="#"><i class="fi-social-pinterest"></i> Pinterest</a></li>+</ul>+</div>+<div class="small-6 large-3 columns">+<p class="lead">Offices</p>+<ul class="menu vertical">+<li><a href="#">One</a></li>+<li><a href="#">Two</a></li>+<li><a href="#">Three</a></li>+<li><a href="#">Four</a></li>+</ul>+</div>+</div>+<div class="row">+<div class="medium-6 columns">+<ul class="menu">+<li><a href="#">Legal</a></li>+<li><a href="#">Partner</a></li>+<li><a href="#">Explore</a></li>+</ul>+</div>+<div class="medium-6 columns">+<ul class="menu float-right">+<li class="menu-text">Copyright</li>+</ul>+</div>+</div>+</footer>+<script src="https://code.jquery.com/jquery-2.1.4.min.js"></script>+<script src="http://dhbhdrzi4tiry.cloudfront.net/cdn/sites/foundation.js"></script>+<script>+ $(document).foundation();+ </script>+<script type="text/javascript" src="https://intercom.zurb.com/scripts/zcom.js"></script>+</body>+</html>
+ scotty-view.cabal view
@@ -0,0 +1,33 @@+-- Initial scotty-view.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: scotty-view+description: An extension for Scotty allowing its user to build an HTML+ page easily. This library can also read an HTML page from a+ file and modify it.+version: 1.0.0+author: Philémon Bouzy+maintainer: philemon.bouzy@gmail.com+license: MIT+category: Web+build-type: Simple+cabal-version: >=1.10+data-files: executable/index.html++library+ exposed-modules: ScottyView, HtmlPageBuilder, HtmlPage+ build-depends: base >=4.7 && <4.8,+ scotty,+ text,+ transformers >= 0.4.3+ default-language: Haskell2010++executable web+ hs-source-dirs: executable+ build-depends: base >=4.7 && <4.8,+ scotty,+ text,+ transformers >= 0.4.3,+ scotty-view+ main-is: Web.hs+ default-language: Haskell2010