summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--package.yaml1
-rw-r--r--src/Data/Abbr.hs40
-rw-r--r--src/Data/Name.hs2
-rw-r--r--src/Data/Paper.hs88
-rw-r--r--src/Hakyll/Paper.hs0
-rw-r--r--src/Hakyll/Web/Template/Util.hs18
-rw-r--r--www/templates/paper.html19
7 files changed, 152 insertions, 16 deletions
diff --git a/package.yaml b/package.yaml
index 31406be..595b307 100644
--- a/package.yaml
+++ b/package.yaml
@@ -63,6 +63,7 @@ library:
- text
- time
- uri-encode
+ - witherable
- yaml
executables:
diff --git a/src/Data/Abbr.hs b/src/Data/Abbr.hs
new file mode 100644
index 0000000..f42134f
--- /dev/null
+++ b/src/Data/Abbr.hs
@@ -0,0 +1,40 @@
+module Data.Abbr
+ ( Abbr (..)
+ , Abbr_
+ , abbrHtml
+ ) where
+
+import Prolog
+import Network.URI
+import Data.Aeson
+import Data.Alias
+import Data.Set qualified as S
+import Text.Blaze
+import Text.Blaze.Html
+
+import Data.Linked
+
+data Abbr a = Abbr
+ { name :: !a
+ , shortName :: !(Maybe a)
+ , link :: !(Maybe URI)
+ } deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (Abbr a)
+
+type Abbr_ = Abbr StrictText
+
+abbrHtml :: ToMarkup a => Abbr a -> Html
+abbrHtml (Abbr n sn l) = linkedHtml $ Linked (fromMaybe n sn) l (n <$ sn)
+
+instance Ord a => ToAliases (Abbr a) where
+ toAliases (Abbr t st _) = S.fromList $ t : toList st
+
+instance FromAlias a (Abbr a) where
+ fromAlias t = pure $ Abbr t Nothing Nothing
+
+instance FromJSON a => FromJSON (Abbr a) where
+ parseJSON = withObject "Abbr" $ \v -> Abbr
+ <$> v .: "name"
+ <*> v .:? "short" .!= Nothing
+ <*> v .:? "link" .!= Nothing
diff --git a/src/Data/Name.hs b/src/Data/Name.hs
index 88e5bda..647c285 100644
--- a/src/Data/Name.hs
+++ b/src/Data/Name.hs
@@ -51,7 +51,7 @@ instance (StringConv s StrictText, ToJSON s) => ToJSONKey (Name s) where
toJSONKey = showNameLFM . fmap toSL >$< toJSONKey
instance StringConv StrictText s => FromJSONKey (Name s) where
- fromJSONKey = FromJSONKeyTextParser $ \t -> toSL <<$>> (readNameLFM t <|> readNameFML t)
+ fromJSONKey = FromJSONKeyTextParser $ \t -> toSL <<$>> parseName t
diff --git a/src/Data/Paper.hs b/src/Data/Paper.hs
index c2d4b3e..f8b691d 100644
--- a/src/Data/Paper.hs
+++ b/src/Data/Paper.hs
@@ -2,36 +2,53 @@
module Data.Paper
( Paper (..)
, Status (..)
+ , ArXiv (..)
+ , DOI (..)
+ , Eprint (..)
+ , mkPaper
) where
import Prolog
-import Data.Journal
-import Data.Person
+import Data.Char (toLower)
+import Data.Map.Strict qualified as M
+import Data.Name
import Data.Time
import Network.URI
import Network.URI.Static
+import Text.BibTeX.Entry qualified as B
+import Text.BibTeX.Parse qualified as B
+
data Paper a = Paper
- { title :: !a
+ { status :: !(Status a)
+ , key :: !a
+ , title :: !a
, authors :: ![Name a]
- , status :: !(Status a)
- } deriving (Eq, Generic, Ord, Show)
+ , abstract :: !(Maybe a)
+ , extraLink :: !(Maybe URI)
+ , eprint :: !(Maybe (Eprint a))
+ } deriving (Eq, Foldable, Functor, Ord, Generic, Show, Traversable)
+
+instance Binary a => Binary (Paper a)
-- instance (Binary a, Binary (Status f a), Binary (f (Person a))) => Binary (Paper f a)
data Status a
- = Submitted
- | Accepted
- { journal :: !a
- }
+ = Unpublished { date :: !Day }
| Published
{ date :: !Day
, journal :: !a
, doi :: !DOI
}
- | Unpublished
- deriving (Eq, Generic, Ord, Show)
+ | Accepted
+ { date :: !Day
+ , journal :: !a
+ }
+ | Submitted { date :: !Day }
+ deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (Status a)
-- instance (Binary a, Binary (f (Journal a))) => Binary (Status f a)
@@ -39,6 +56,15 @@ newtype DOI = DOI URI
deriving (Eq, Generic, Ord, Show)
deriving newtype Binary
+data Eprint a
+ = ArXivEprint (ArXiv a)
+ | OtherEprint { eprintName :: !a
+ , eprintLink :: !URI
+ }
+ deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (Eprint a)
+
data ArXiv a = ArXiv
{ _identifier :: !URI
, _class :: !a
@@ -67,3 +93,43 @@ doiURI = [uri|https://doi.org/|]
doiLink :: DOI -> URI
doiLink (DOI u) = u `relativeTo` doiURI
+
+
+mkPaper :: (MonadFail m, Alternative m) => B.T -> m (Paper String)
+mkPaper bib = do
+ let key = B.identifier bib
+ abstract = M.lookup "abstract" fields
+ -- extraLink = M.lookup "extralink" fields
+ title <- find' "title"
+ authors <- find' "authors" >>= traverse (ffmap toSL . parseName . toSL) . B.splitAuthorList
+ status <- toLower <<$>> find' "pubstate" >>= \case
+ "submitted" -> Submitted <$> getDate
+ "unpublished" -> Unpublished <$> getDate
+ "accepted" -> Accepted <$> getDate <*> find' "journal"
+ _ -> do
+ journal <- find' "journal"
+ doi <- find' "doi" >>= fmap DOI . puri
+ date <- getDate
+ pure $ Published {..}
+ extraLink <- traverse puri $ M.lookup "extralink" fields
+ eprint <- case toLower <$> M.lookup "eprinttype" fields of
+ Just "arxiv" -> do
+ _identifier <- find' "eprint" >>= puri
+ _class <- find' "eprintclass"
+ pure $ Just $ ArXivEprint $ ArXiv {..}
+ Just s -> do
+ let eprintName = s
+ eprintLink <- find' "eprint" >>= puri
+ pure $ Just $ OtherEprint {..}
+ Nothing -> pure Nothing
+ pure $ Paper {..}
+ where
+ fields = M.fromList $ B.fields bib
+ find' k = findit k fields
+ getDate = mapM findit [ "month", "year" ] >>= parseTimeM True defaultTimeLocale "%b %Y" . unwords
+
+puri :: MonadFail m => String -> m URI
+puri u = undefined
+
+findit :: (Show a, Ord a, MonadFail m) => a -> M.Map a x -> m x
+findit k = maybe (fail $ "Field " <> show k <> " does not exist") pure . M.lookup k
diff --git a/src/Hakyll/Paper.hs b/src/Hakyll/Paper.hs
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/src/Hakyll/Paper.hs
diff --git a/src/Hakyll/Web/Template/Util.hs b/src/Hakyll/Web/Template/Util.hs
index f08c041..02a46b0 100644
--- a/src/Hakyll/Web/Template/Util.hs
+++ b/src/Hakyll/Web/Template/Util.hs
@@ -1,6 +1,8 @@
module Hakyll.Web.Template.Util
( functionField1
, slug
+ , cat
+ , identifierLink
) where
import Prolog
@@ -8,6 +10,7 @@ import Hakyll
import Hakyll.Web.Template.Context
import Data.String.Slugger
import System.FilePath
+import Witherable
functionField1 :: String -> (String -> Compiler String) -> Context a
functionField1 n f = functionField n $ \case
@@ -16,3 +19,18 @@ functionField1 n f = functionField n $ \case
slug :: Context a
slug = functionField "slug" $ \strs _ -> pure $ toSlug $ unwords strs
+
+cat :: Context a
+cat = functionField "cat" $ \strs _ -> pure $ concat strs
+
+
+identifierLink :: Context a
+identifierLink = functionField1 "identifier" $ \str -> do
+ getPaths (fromString str) >>= \case
+ [] -> noResult $ "No filepaths match the pattern " <> str
+ x@(_:_:_) -> noResult $ "Multiple filepaths match the pattern " <> str <> ": " <> show x
+ [x] -> pure x
+
+
+getPaths :: Pattern -> Compiler [FilePath]
+getPaths = getMatches >=> witherM getRoute
diff --git a/www/templates/paper.html b/www/templates/paper.html
index 0a19137..33b8aa5 100644
--- a/www/templates/paper.html
+++ b/www/templates/paper.html
@@ -5,7 +5,7 @@
<div class="paper-author">
<ul>
$for(authors)$
- <li>$alias(author)$</li>
+ <li>$personA(author)$</li>
$endfor$
</ul>
</div>
@@ -18,17 +18,28 @@
$endif$
<div class="paper-foot">
<ul>
+ $if(identifier(cat("research/",slug(key),".pdf")))$
+ <li><a href="$identifier(cat("research/",slug(key),".pdf"))$">.pdf</a></li>
+ $endif$
+ $if(identifier(cat("research/",slug(key),"/index.*")))$
+ <li><a href="$identifier(cat("research/",slug(key),"/"))$">Extra</a></li>
+ $endif$
+ $if(extra)$
+ <li><a href="$extra$">Extra</a></li>
+ $endif$
$if(submitted)$
<li>Submitted</li>
$endif$
$if(accepted)$
- <li>$journal$ (Accepted)</li>
+ <li>$journalA(journal)$ (Accepted)</li>
$endif$
$if(published)$
- <li>$journal$</li>
+ <li>$journalA(journal)$</li>
<li>$pubdate$</li>
$endif$
- $if(abstract)$<button class="abstract-button" style="float:right" onclick="toggle('$slug(title)$-abstract');">Abstract</button>$endif$
+ $if(abstract)$
+ <button class="abstract-button" style="float:right" onclick="toggle('$slug(title)$-abstract');">Abstract</button>
+ $endif$
</ul>
</div>
</div>
generated by cgit v1.2.3 (git 2.25.1) at 2026-07-09 18:10:24 +0000