From 25379bbdcc51e0ccd243d3391fa6bc266cd314e2 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 16 Oct 2017 15:16:56 +0200 Subject: Split Main.hs Replace tabs with spaces. No functional changes. --- src/Render.hs | 197 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 197 insertions(+) create mode 100644 src/Render.hs (limited to 'src/Render.hs') diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 index 0000000..d48a567 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedStrings #-} +module Render (render) where + +import Control.Applicative +import Control.Monad +import Data.Monoid +import Data.List (nub, sort, sortBy, isPrefixOf) +import Data.Function (on) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Text.BibTeX.Entry as E +import qualified Data.Map as M +import Text.Parsec.Error +import Text.ParserCombinators.Parsec.Prim +import Text.Printf (printf) +import qualified Data.ByteString.Lazy as BS +import Network.URI (isReserved, escapeURIString) +import Lucid + +import Util +import Db + +maybeToHtml = maybe mempty toHtml + +scholarSearch q = "http://scholar.google.com/scholar?q=" ++ escapeURIString isReserved q + +resolveDoi :: String -> String +resolveDoi q = "http://doi.org/" ++ q + +-- |List of protocol features +protofeatures :: Database -> Protocol -> Html () +protofeatures _ p | (M.size $ pfeatures p) == 0 = mempty +protofeatures db p = do + dt_ "Features" + dd_ $ ul_ [class_ "features list-inline"] $ forM_ (sort $ M.keys $ pfeatures p) (\x -> li_ [data_ "id" (T.pack x), class_ "list-inline-item"] $ toHtml $ maybe ("" :: String) fname $ M.lookup x (dfeatures db)) + +-- |List of protocol publications +protopapers :: [T] -> Html () +protopapers pubs | length pubs == 0 = mempty +protopapers pubs = do + dt_ "Published in" + dd_ [class_ "ref"] $ if length pubs == 1 + then p_ $ bibentry $ head pubs + else ol_ $ forM_ pubs (li_ . bibentry) + +-- |Protocol description +protodesc :: Protocol -> Html () +protodesc Protocol { pdescription = Nothing } = mempty +protodesc Protocol { pdescription = Just desc } = p_ $ toHtml desc + +protorelated :: Database -> Protocol -> Html () +protorelated _ p | null $ prelated p = mempty +protorelated db p = + let + algos = dalgos db + lookup k = M.lookup k algos >>= \y -> return (k, y) + rel = catMaybes $ map lookup $ prelated p + in do + dt_ "Related" + dd_ [class_ "related"] $ ul_ [class_ "list-inline"] $ forM_ rel $ + \(ident, x) -> li_ [class_ "list-inline-item"] $ a_ [href_ (T.pack $ '#':ident)] $ toHtml $ pname x + +-- |One protocol +protoentry :: Database -> (String, Protocol) -> Html () +protoentry db (ident, p) = + let + pubs = catMaybes $ protoPublications db p + firstpub = safeHead pubs + field key = firstpub >>= (return . E.fields) >>= lookup key + in + section_ [ + id_ $ T.pack ident + , class_ "protocol" + , data_ "rank" (T.pack $ show $ prank p) + ] $ do + h3_ [class_ "name"] $ do + a_ [href_ (T.pack $ '#':ident), title_ "permalink"] $ toHtml $ pname p + " " + maybe "" (small_ [class_ "longname"] . toHtml) $ plongname p + protodesc p + dl_ $ do + protopapers pubs + protofeatures db p + protorelated db p + +extcss url = link_ [rel_ "stylesheet", type_ "text/css", href_ url] + +extjs :: T.Text -> Html () +extjs url = script_ [type_ "text/javascript", charset_ "utf8", src_ url] ("" :: T.Text) + +-- | Try very hard to find an appropriate URL for the bibentry, DOIs are prefered +bibentryurl bib = safeHead $ catMaybes [doi, url] + where + fields = E.fields bib + doi = lookup "doi" fields >>= return . resolveDoi + url = lookup "url" fields + +-- | Format bibliography/references item +bibentry :: E.T -> Html () +bibentry bib = do + let + fields = E.fields bib + htmlLookup k = maybeToHtml $ lookup k fields + maybe + (span_ [class_ "title"] $ htmlLookup "title") + (\x -> a_ [href_ $ T.pack $ x, class_ "title"] $ htmlLookup "title") + (bibentryurl bib) + ", " + span_ [class_ "author"] $ htmlLookup "author" + ", " + span_ [class_ "year"] $ htmlLookup "year" + +-- | References section +references :: [E.T] -> Html () +references attrib = section_ $ do + h2_ "References" + ol_ $ forM_ attrib (li_ . bibentry) + +-- | What is this?! +introduction :: Database -> Html () +introduction db = + let + algocount = M.size $ dalgos db + pubyears = catMaybes $ map (lookup "year" . E.fields) $ dpublications db + firstyear = foldr min (head pubyears) (tail pubyears) + lastyear = foldr max (head pubyears) (tail pubyears) + in section_ [class_ "container"] $ do + h1_ [class_ "display-3"] "comatose" + p_ $ do + "The comprehensive MAC taxonomy database (comatose) is a collection of " + toHtml $ show algocount + " wireless media/medium access protocols published between " + toHtml firstyear + " and " + toHtml lastyear + "." + +-- |List of protocol features +features :: Database -> Html () +features db = + section_ [id_ "features"] $ do + h2_ "Features" + p_ "This section presents so-called “features” that are assigned to each protocol." + forM_ (M.toList $ getFeaturesByLevel db 0) $ \(baseident, basefeature) -> do + let featureanchor = "feature-" ++ baseident in do + h3_ [id_ $ T.pack featureanchor] $ a_ [href_ $ T.pack $ '#':featureanchor] $ toHtml $ fname basefeature + maybe mempty (p_ . toHtml) $ fdescription basefeature + dl_ $ forM_ (M.toList $ getFeaturesByBase db baseident) $ \(ident, feature) -> do + dt_ [class_ "form-inline"] $ let i = T.pack ("filter-feature-" ++ ident) in do + input_ [type_ "checkbox", id_ i, class_ "filter-feature", value_ (T.pack ident)] + " " + label_ [for_ i] $ toHtml $ fname feature + maybe mempty (dd_ . toHtml) $ fdescription feature + +-- | The list of protocols +protocols :: Database -> Html () +protocols db = section_ [id_ "protocols"] $ do + h2_ "Protocols" + forM_ (M.toList $ dalgos db) (protoentry db) + +-- |Page template +page db attrib = doctypehtml_ $ do + head_ $ do + title_ "comatose" + meta_ [charset_ "utf-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1, shrink-to-fit=no"] + extjs "https://code.jquery.com/jquery-3.2.1.min.js" + extcss "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/css/bootstrap.min.css" + extjs "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/js/bootstrap.min.js" + extcss "style.css" + body_ $ do + nav_ [class_ "navbar navbar-expand-md navbar-dark bg-dark fixed-top"] $ do + div_ [class_ "collapse navbar-collapse"] $ do + span_ [class_ "navbar-brand"] "comatose" + ul_ [class_ "navbar-nav mr-auto"] $ do + li_ [class_ "nav-item" ] $ a_ [class_ "nav-link", href_ "#features"] "Features" + li_ [class_ "nav-item" ] $ a_ [class_ "nav-link", href_ "#protocols"] "Protocols" + form_ [id_ "protosort", class_ "form-inline my-2 my-lg-0"] $ do + input_ [id_ "filter", type_ "search", class_ "form-control mr-sm-2", placeholder_ "Filter by name"] + " " + label_ [for_ "sort"] "Sort by" + " " + select_ [id_ "sort", class_ "form-control"] $ do + option_ [value_ "name"] "Name" + option_ [value_ "year"] "Year" + option_ [value_ "rank"] "Rank" + div_ [class_ "jumbotron" ] $ introduction db + div_ [class_ "container"] $ do + features db + protocols db + references (sortBy (compare `on` lookup "year" . E.fields) attrib) + extjs "script.js" + +-- |Render page +render f db attribution = renderToFile f (page db attribution) + -- cgit v1.2.3