diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | Main.hs | 330 | ||||
| -rw-r--r-- | comatose.cabal | 2 | ||||
| -rw-r--r-- | src/Db.hs | 129 | ||||
| -rw-r--r-- | src/Main.hs | 23 | ||||
| -rw-r--r-- | src/Render.hs | 197 | ||||
| -rw-r--r-- | src/Util.hs | 7 |
7 files changed, 358 insertions, 332 deletions
@@ -2,4 +2,4 @@ .cabal-sandbox/ cabal.sandbox.config dist/ -comatose.html +_build/ diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 06de6ef..0000000 --- a/Main.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative -import Control.Monad -import Data.Monoid -import Data.Yaml -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 qualified Data.Aeson as A -import Text.BibTeX.Parse -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 System.FilePath ((<.>), splitExtension) -import System.Directory (copyFile) -import Network.URI (isReserved, escapeURIString) -import Lucid - -import Paths_comatose - --- |A MAC protocol/algorithm -data Protocol = Protocol { - -- |Short protocol name, usually its abbreviation - pname :: String - -- |Long protocol name - , plongname :: Maybe String - -- |Free-text protocol description - , pdescription :: Maybe String - -- |List of publication references describing this protocol - , pref :: [String] - -- |Feature references of this protocol - , pfeatures :: M.Map String (Maybe String) - -- |List of references to other protocols, usually from the paper’s - -- “related work” section - , prelated :: [String] - -- |Relevance of this protocol, calculated (pun intended) - , prank :: Float - } deriving Show - --- |A MAC protocol feature -data Feature = Feature { - -- |Referenceable name - fname :: String - -- |Its description - , fdescription :: Maybe String - } deriving Show - --- |The whole database -data Database = Database { - -- |Key-value pair for each protocol - dalgos :: M.Map String Protocol - -- |Global list of available features - , dfeatures :: M.Map String Feature - -- |Global list of available publications - , dpublications :: [T] - } deriving Show - -instance FromJSON Protocol where - parseJSON (Object v) = Protocol - <$> v .: "name" - <*> v .:? "longname" - <*> v .:? "description" - <*> v .:? "ref" .!= [] - <*> v .:? "features" .!= M.empty - <*> v .:? "related" .!= [] - <*> return 0 - parseJSON _ = mzero - -instance FromJSON Feature where - parseJSON (Object v) = Feature - <$> v .: "name" - <*> v .:? "description" - parseJSON _ = mzero - -instance FromJSON Database where - parseJSON (Object v) = Database - <$> v .: "algos" - <*> v .: "features" - <*> pure [] - parseJSON _ = mzero - --- |Safe head function -safeHead [] = Nothing -safeHead (x:_) = Just x - --- |Find publication with identifier `ident` -findPublication db ident = safeHead $ filter (\x -> ident == E.identifier x) $ dpublications db - --- |Get a list of all publications referenced by proto @p@ -protoPublications db p = map (findPublication db) (pref p) - --- |Find all referenced features’ names -referencedFeatures db = nub $ sort $ concat $ map (M.keys . pfeatures) $ M.elems $ dalgos db - -filterMap filterF mapF xs = map mapF $ filter filterF xs - --- |Get all features at `level`, starting with 0 -getFeaturesByLevel db level = M.filterWithKey (\k v -> countDots k == level) $ dfeatures db - where - countDots = length . filter ((==) '.') - --- |Get features by `base` feature -getFeaturesByBase db base = M.filterWithKey (\k v -> (base ++ ".") `isPrefixOf` k) $ dfeatures db - --- |Read protocol and bib database from file -readDb :: String -> IO Database -readDb f = do - yamlres <- decodeFileEither f - --print yamlres - let - (Right yamldb) = yamlres - (basename, _) = splitExtension f - bibres <- parseFromFile file (basename <.> "bib") - --print bibres - let (Right bibdb) = bibres - return $ calcRank $ yamldb { dpublications = bibdb } - --- |Protocol rank/popularity, uses the pagerank algorithm -calcRank db = - let - initalgos = M.mapWithKey initial $ dalgos db - n = fromIntegral $ M.size $ dalgos db - d = 0.85 - initial ident p = p { prank = 1.0/n } - -- Get all incoming references - pincoming algos ident = filter (\(_, x) -> ident `elem` prelated x) $ M.toList algos - -- Calculate new rank for p - modify algos ident p = p { prank = (1-d)/n + d*sum (map inrank (pincoming algos ident)) } - -- Incoming rank for p - inrank (_, p) = prank p / fromIntegral (length (prelated p)) - absdiff :: M.Map String Protocol -> (String, Protocol) -> Float - absdiff b (ident, p) = abs (prank (b M.! ident) - prank p) - rankdiff :: M.Map String Protocol -> M.Map String Protocol -> Float - rankdiff a b = 1/n * M.foldlWithKey (\x ident p -> x + absdiff b (ident, p)) 0 a - iterateUntil fiter fcmp a = let b = fiter a in if fcmp a b then iterateUntil fiter fcmp b else b - run algos = M.mapWithKey (modify algos) algos - stop prevalgos algos = rankdiff prevalgos algos > 0.00001 - in db { dalgos = (iterateUntil run stop initalgos) } - -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) - --- |Read attributions from bibtex file -readAttributions = getDataFileName "data/attribution.bib" >>= parseFromFile file - -copyDataFile source dest = getDataFileName source >>= (\x -> copyFile x dest) - -main = do - db <- getDataFileName "data/db.yaml" >>= readDb - (Right attribution) <- readAttributions - render "_build/index.html" db attribution - copyDataFile "data/style.css" "_build/style.css" - copyDataFile "data/script.js" "_build/script.js" - diff --git a/comatose.cabal b/comatose.cabal index 6112b16..e618489 100644 --- a/comatose.cabal +++ b/comatose.cabal @@ -20,6 +20,6 @@ executable comatose -- other-modules: -- other-extensions: build-depends: base >=4.6 && <4.10, bibtex, yaml, containers, parsec, lucid, bytestring, text, filepath, network-uri, aeson, directory - -- hs-source-dirs: + hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Db.hs b/src/Db.hs new file mode 100644 index 0000000..8f6fdba --- /dev/null +++ b/src/Db.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} +module Db where + +import System.FilePath ((<.>), splitExtension) +import Data.List (nub, sort, sortBy, isPrefixOf) +import Control.Monad +import Data.Yaml +import Text.Parsec.Error +import Text.ParserCombinators.Parsec.Prim +import Text.BibTeX.Parse +import Text.BibTeX.Entry as E +import qualified Data.Aeson as A +import qualified Data.Map as M + +import Util + +-- |A MAC protocol/algorithm +data Protocol = Protocol { + -- |Short protocol name, usually its abbreviation + pname :: String + -- |Long protocol name + , plongname :: Maybe String + -- |Free-text protocol description + , pdescription :: Maybe String + -- |List of publication references describing this protocol + , pref :: [String] + -- |Feature references of this protocol + , pfeatures :: M.Map String (Maybe String) + -- |List of references to other protocols, usually from the paper’s + -- “related work” section + , prelated :: [String] + -- |Relevance of this protocol, calculated (pun intended) + , prank :: Float + } deriving Show + +-- |A MAC protocol feature +data Feature = Feature { + -- |Referenceable name + fname :: String + -- |Its description + , fdescription :: Maybe String + } deriving Show + +-- |The whole database +data Database = Database { + -- |Key-value pair for each protocol + dalgos :: M.Map String Protocol + -- |Global list of available features + , dfeatures :: M.Map String Feature + -- |Global list of available publications + , dpublications :: [T] + } deriving Show + +instance FromJSON Protocol where + parseJSON (Object v) = Protocol + <$> v .: "name" + <*> v .:? "longname" + <*> v .:? "description" + <*> v .:? "ref" .!= [] + <*> v .:? "features" .!= M.empty + <*> v .:? "related" .!= [] + <*> return 0 + parseJSON _ = mzero + +instance FromJSON Feature where + parseJSON (Object v) = Feature + <$> v .: "name" + <*> v .:? "description" + parseJSON _ = mzero + +instance FromJSON Database where + parseJSON (Object v) = Database + <$> v .: "algos" + <*> v .: "features" + <*> pure [] + parseJSON _ = mzero + +-- |Find publication with identifier `ident` +findPublication db ident = safeHead $ filter (\x -> ident == E.identifier x) $ dpublications db + +-- |Get a list of all publications referenced by proto @p@ +protoPublications db p = map (findPublication db) (pref p) + +-- |Find all referenced features’ names +referencedFeatures db = nub $ sort $ concat $ map (M.keys . pfeatures) $ M.elems $ dalgos db + +-- |Get all features at `level`, starting with 0 +getFeaturesByLevel db level = M.filterWithKey (\k v -> countDots k == level) $ dfeatures db + where + countDots = length . filter ((==) '.') + +-- |Get features by `base` feature +getFeaturesByBase db base = M.filterWithKey (\k v -> (base ++ ".") `isPrefixOf` k) $ dfeatures db + +-- |Read protocol and bib database from file +readDb :: String -> IO Database +readDb f = do + yamlres <- decodeFileEither f + --print yamlres + let + (Right yamldb) = yamlres + (basename, _) = splitExtension f + bibres <- parseFromFile file (basename <.> "bib") + --print bibres + let (Right bibdb) = bibres + return $ calcRank $ yamldb { dpublications = bibdb } + +-- |Protocol rank/popularity, uses the pagerank algorithm +calcRank db = + let + initalgos = M.mapWithKey initial $ dalgos db + n = fromIntegral $ M.size $ dalgos db + d = 0.85 + initial ident p = p { prank = 1.0/n } + -- Get all incoming references + pincoming algos ident = filter (\(_, x) -> ident `elem` prelated x) $ M.toList algos + -- Calculate new rank for p + modify algos ident p = p { prank = (1-d)/n + d*sum (map inrank (pincoming algos ident)) } + -- Incoming rank for p + inrank (_, p) = prank p / fromIntegral (length (prelated p)) + absdiff :: M.Map String Protocol -> (String, Protocol) -> Float + absdiff b (ident, p) = abs (prank (b M.! ident) - prank p) + rankdiff :: M.Map String Protocol -> M.Map String Protocol -> Float + rankdiff a b = 1/n * M.foldlWithKey (\x ident p -> x + absdiff b (ident, p)) 0 a + iterateUntil fiter fcmp a = let b = fiter a in if fcmp a b then iterateUntil fiter fcmp b else b + run algos = M.mapWithKey (modify algos) algos + stop prevalgos algos = rankdiff prevalgos algos > 0.00001 + in db { dalgos = (iterateUntil run stop initalgos) } + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..1521382 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,23 @@ +module Main (main) where + +import Text.ParserCombinators.Parsec.Prim +import Text.BibTeX.Parse +import System.Directory (copyFile) + +import Render (render) +import Db (readDb) + +import Paths_comatose + +-- |Read attributions from bibtex file +readAttributions = getDataFileName "data/attribution.bib" >>= parseFromFile file + +copyDataFile source dest = getDataFileName source >>= (\x -> copyFile x dest) + +main = do + db <- getDataFileName "data/db.yaml" >>= readDb + (Right attribution) <- readAttributions + render "_build/index.html" db attribution + copyDataFile "data/style.css" "_build/style.css" + copyDataFile "data/script.js" "_build/script.js" + 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) + diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 0000000..15ca593 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,7 @@ +module Util (safeHead) where + +-- |Safe head function +safeHead [] = Nothing +safeHead (x:_) = Just x + + |