Writing utils for parsing and formatting my papers

5 files changed, 136 insertions, 12 deletions

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