From 74a68488be7ec0565f173d19e3e05bffd51c8cb4 Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Tue, 14 Apr 2015 11:17:24 +0200
Subject: Initial import

---
 Main.hs | 142 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 142 insertions(+)
 create mode 100644 Main.hs

(limited to 'Main.hs')

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"
+
-- 
cgit v1.2.3