From fb41d17b4dcc55c13106de015fcc1ee03ed49688 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 27 May 2015 10:06:26 +0200 Subject: Add list of features to output --- Main.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) (limited to 'Main.hs') diff --git a/Main.hs b/Main.hs index 4ee68ac..010dba7 100644 --- a/Main.hs +++ b/Main.hs @@ -4,7 +4,7 @@ import Control.Applicative import Control.Monad import Data.Monoid import Data.Yaml -import Data.List (nub, sort, sortBy) +import Data.List (nub, sort, sortBy, isPrefixOf) import Data.Function (on) import Data.Maybe (catMaybes) import qualified Data.Text as T @@ -98,6 +98,16 @@ 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 @@ -246,6 +256,20 @@ introduction db = 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_ $ toHtml $ fname feature + maybe mempty (dd_ . toHtml) $ fdescription feature + -- | The list of protocols protocols :: Database -> Html () protocols db = section_ [id_ "protocols"] $ do @@ -278,6 +302,7 @@ page db attrib = doctypehtml_ $ do div_ [class_ "page-header"] $ do h1_ "comatose" introduction db + features db protocols db references (sortBy (compare `on` lookup "year" . E.fields) attrib) extjs "script.js" -- cgit v1.2.3