summaryrefslogtreecommitdiff
path: root/Main.hs
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2017-10-16 15:16:56 +0200
committerLars-Dominik Braun <lars@6xq.net>2017-10-16 15:17:18 +0200
commit25379bbdcc51e0ccd243d3391fa6bc266cd314e2 (patch)
treebdf4fcfbf0a5485ecde15ed2dd410974f2c630a7 /Main.hs
parent5703498008563418c4407c1608cd8cac933f96c0 (diff)
downloadcomatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.tar.gz
comatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.tar.bz2
comatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.zip
Split Main.hs
Replace tabs with spaces. No functional changes.
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs330
1 files changed, 0 insertions, 330 deletions
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"
-