summaryrefslogtreecommitdiff
path: root/Main.hs
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2015-04-14 11:17:24 +0200
committerLars-Dominik Braun <lars@6xq.net>2015-04-14 11:17:24 +0200
commit74a68488be7ec0565f173d19e3e05bffd51c8cb4 (patch)
tree3f12f02aabda0b4e87cbc9cd43e0e13c7f6bf69b /Main.hs
downloadcomatose-74a68488be7ec0565f173d19e3e05bffd51c8cb4.tar.gz
comatose-74a68488be7ec0565f173d19e3e05bffd51c8cb4.tar.bz2
comatose-74a68488be7ec0565f173d19e3e05bffd51c8cb4.zip
Initial import
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs142
1 files changed, 142 insertions, 0 deletions
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..1a5bba4
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+import Data.Yaml
+import Data.List (nub, sort)
+import Data.Maybe (catMaybes)
+import qualified Data.Text as T
+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 qualified Data.ByteString.Lazy as BS
+import System.FilePath ((<.>), splitExtension)
+import Lucid
+
+import Paths_comatose
+
+data Protocol = Protocol {
+ pname :: Maybe String
+ , pabbrv :: Maybe String
+ , pref :: [String]
+ , pfeatures :: M.Map String (Maybe String)
+ } deriving Show
+
+data Database = Database {
+ dalgos :: M.Map String Protocol
+ , dfeatures :: M.Map String Feature
+ , dpublications :: [T]
+ } deriving Show
+
+data Feature = Feature {
+ fname :: String
+ , fdescription :: Maybe String
+ } deriving Show
+
+type FeatureList = M.Map String Feature
+
+instance FromJSON Protocol where
+ parseJSON (Object v) = Protocol
+ <$> v .:? "name"
+ <*> v .:? "abbrv"
+ <*> v .:? "ref" .!= []
+ <*> v .:? "features" .!= M.empty
+ parseJSON _ = mzero
+
+instance FromJSON Database where
+ parseJSON (Object v) = Database
+ <$> v .: "algos"
+ <*> v .: "features"
+ <*> pure []
+ parseJSON _ = mzero
+
+instance FromJSON Feature where
+ parseJSON (Object v) = Feature
+ <$> v .: "name"
+ <*> v .:? "description"
+ parseJSON _ = mzero
+
+safeHead [] = Nothing
+safeHead (x:_) = Just x
+
+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
+
+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 yamldb { dpublications = bibdb }
+
+maybeToHtml = maybe (toHtml ("" :: String)) toHtml
+
+head' [] = Nothing
+head' (x:_) = Just x
+
+protoentry :: Database -> [String] -> (String, Protocol) -> Html ()
+protoentry db featurekeys (ident, p) = tr_ $ do
+ let
+ pubs = protoPublications db p
+ firstpub = join (head' pubs)
+ field key = firstpub >>= (return . E.fields) >>= lookup key
+ td_ $ maybeToHtml $ pname p
+ td_ $ maybeToHtml $ pabbrv p
+ td_ $ maybeToHtml $ field "year"
+ forM_ featurekeys (\x -> td_ $ toHtml $ maybe ("" :: String) (const "✓") $ M.lookup x (pfeatures 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)
+
+page db = doctypehtml_ $ do
+ head_ $ do
+ title_ "comatose"
+ meta_ [charset_ "utf-8"]
+ extjs "https://code.jquery.com/jquery-1.10.2.min.js"
+ extcss "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.2/css/bootstrap.min.css"
+ extcss "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.2/css/bootstrap-theme.min.css"
+ extjs "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.2/js/bootstrap.min.js"
+ extcss "https://cdn.datatables.net/1.10.5/css/jquery.dataTables.css"
+ extjs "https://cdn.datatables.net/1.10.5/js/jquery.dataTables.js"
+ extcss "https://cdn.datatables.net/plug-ins/f2c75b7247b/integration/bootstrap/3/dataTables.bootstrap.css"
+ extjs "https://cdn.datatables.net/plug-ins/f2c75b7247b/integration/bootstrap/3/dataTables.bootstrap.js"
+ body_ $ do
+ div_ [class_ "container"] $ do
+ div_ [class_ "page-header"] $ do
+ h1_ "comatose"
+ h2_ "COmprehensive MAc TaxonOmy databaSE"
+ table_ [id_ "algo", class_ "table-striped"] $ do
+ let featurekeys = referencedFeatures db
+ thead_ $ do
+ tr_ $ do
+ th_ "Name"
+ th_ "Abbrv"
+ th_ "Year"
+ th_ [colspan_ (T.pack $ show $ length featurekeys)] "Features"
+ tr_ $ do
+ th_ ""
+ th_ ""
+ th_ ""
+ forM_ featurekeys (\x -> maybe (th_ "") (th_ . toHtml . fname) $ M.lookup x (dfeatures db))
+ tbody_ $ forM_ (M.toList $ dalgos db) (protoentry db featurekeys)
+ script_ "$(document).ready( function () { $('#algo').DataTable( { paging: false, \"columnDefs\": [ ] } ); } );"
+
+render f db = renderToFile f (page db)
+
+main = getDataFileName "data/db.yaml" >>= readDb >>= render "comatose.html"
+