summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/Abbr.hs2
-rw-r--r--src/Data/Alias.hs4
-rw-r--r--src/Data/Linked.hs2
-rw-r--r--src/Data/Name.hs2
-rw-r--r--src/Data/Paper.hs24
-rw-r--r--src/Data/Person.hs2
-rw-r--r--src/Hakyll/Alias.hs8
-rw-r--r--src/Hakyll/Paper.hs47
-rw-r--r--src/Hakyll/TeX/BibTeX.hs3
-rw-r--r--src/Prolog.hs8
10 files changed, 68 insertions, 34 deletions
diff --git a/src/Data/Abbr.hs b/src/Data/Abbr.hs
index f42134f..8ee4bc0 100644
--- a/src/Data/Abbr.hs
+++ b/src/Data/Abbr.hs
@@ -27,7 +27,7 @@ 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
+instance Ord a => ToAliases (Abbr a) a where
toAliases (Abbr t st _) = S.fromList $ t : toList st
instance FromAlias a (Abbr a) where
diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs
index 357f901..9082c14 100644
--- a/src/Data/Alias.hs
+++ b/src/Data/Alias.hs
@@ -23,6 +23,7 @@ import Data.Aeson.KeyMap qualified as KM
import Data.Map.Strict qualified as M
import Data.Set qualified as S
import Data.Typeable
+import Hakyll qualified as H
data WithAliases a x = WithAliases (Set a) x
@@ -103,6 +104,9 @@ newtype AliasMap a x = AliasMap (Map a x)
deriving newtype (Binary, Foldable, Functor, Semigroup, Monoid)
deriving stock (Show, Traversable)
+instance H.Writable (AliasMap a x) where
+ write _ _ = pure ()
+
buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
buildAliasMap = fmap AliasMap $ foldMap $ (<$) <*> toMap . toAliases
{-# INLINE buildAliasMap #-}
diff --git a/src/Data/Linked.hs b/src/Data/Linked.hs
index 8e78f86..de1dc77 100644
--- a/src/Data/Linked.hs
+++ b/src/Data/Linked.hs
@@ -38,7 +38,7 @@ instance ToMaybe Maybe where
toMaybe = liftMaybe
instance ToMaybe Identity where
- toMaybe (Identity a) = pure a
+ toMaybe (Identity x) = pure x
instance ToMaybe Proxy where
toMaybe _ = empty
diff --git a/src/Data/Name.hs b/src/Data/Name.hs
index 647c285..faf8d8c 100644
--- a/src/Data/Name.hs
+++ b/src/Data/Name.hs
@@ -84,7 +84,7 @@ readNameFML t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
[] -> empty
(f:xs) -> case unsnoc xs of
Nothing -> empty
- Just (m, l) -> pure $ Name f l $ case m of
+ Just (m, l) -> pure $ Name l f $ case m of
[] -> Nothing
_ -> Just $ T.unwords m
diff --git a/src/Data/Paper.hs b/src/Data/Paper.hs
index 25b6d98..0dedc46 100644
--- a/src/Data/Paper.hs
+++ b/src/Data/Paper.hs
@@ -1,11 +1,16 @@
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
module Data.Paper
( Paper (..)
, Status (..)
, ArXiv (..)
+ , ArXivType (..)
, DOI (..)
, Eprint (..)
, mkPaper
+ -- * helpers
+ , doiLink
+ , arXivLink
) where
import Prolog
@@ -15,9 +20,10 @@ import Data.Name
import Data.Time
import Network.URI
import Network.URI.Static
+import Hakyll qualified as H
import Text.BibTeX.Entry qualified as B
-import Text.BibTeX.Parse qualified as B
+import Text.BibTeX.Parse qualified as BP
data Paper a = Paper
@@ -32,6 +38,12 @@ data Paper a = Paper
instance Binary a => Binary (Paper a)
+instance H.Writable (Paper a) where
+ write _ _ = pure ()
+
+instance H.Writable (t (Paper a)) where
+ write _ _ = pure ()
+
-- instance (Binary a, Binary (Status f a), Binary (f (Person a))) => Binary (Paper f a)
data Status a
@@ -101,13 +113,13 @@ mkPaper bib = do
abstract = M.lookup "abstract" fields
-- extraLink = M.lookup "extralink" fields
title <- find' "title"
- authors <- find' "authors" >>= traverse (ffmap toSL . parseName . toSL) . B.splitAuthorList
+ authors <- find' "author" >>= traverse (ffmap toSL . parseName . toSL) . BP.splitAuthorList
status <- do
date <- getDate
traverse puri (M.lookup "doi" fields) >>= \case
Just u -> do
let doi = DOI u
- journal <- findit "journal"
+ journal <- findit "journal" fields
pure $ Published {..}
Nothing -> pure $ case M.lookup "journal" fields of
Just journal -> Accepted {..}
@@ -124,7 +136,7 @@ mkPaper bib = do
-- date <- getDate
-- pure $ Published {..}
extraLink <- traverse puri $ M.lookup "extralink" fields
- eprint <- case toLower <<$>> M.lookup "eprinttype" fields of
+ eprints <- case toLower <<$>> M.lookup "eprinttype" fields of
Just "arxiv" -> do
_identifier <- find' "eprint" >>= puri
_class <- find' "eprintclass"
@@ -138,10 +150,10 @@ mkPaper bib = do
where
fields = M.fromList $ B.fields bib
find' k = findit k fields
- getDate = mapM findit [ "month", "year" ] >>= parseTimeM True defaultTimeLocale "%b %Y" . unwords
+ getDate = mapM (`findit` fields) [ "month", "year" ] >>= parseTimeM True defaultTimeLocale "%b %Y" . unwords
puri :: MonadFail m => String -> m URI
-puri u = maybe (fail $ show u <> " cannot be understood as a uri") pure $ parseURI u
+puri u = maybe (fail $ show u <> " cannot be understood as a uri") pure $ parseRelativeReference u
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/Data/Person.hs b/src/Data/Person.hs
index 853408e..389d1ed 100644
--- a/src/Data/Person.hs
+++ b/src/Data/Person.hs
@@ -28,7 +28,7 @@ instance Binary a => Binary (Person a)
type Person_ = Person StrictText
personHtml :: (ToMarkup a) => Person a -> Html
-personHtml (Person n w) = linkedHtml $ Linked (renderNameFML $ toMarkup <$> n) w Nothing
+personHtml (Person n w) = linkedHtml $ Linked (contents $ renderNameFML $ contents . toMarkup <$> n) w Nothing
personFromName :: Name a -> Person a
personFromName n = Person n Nothing
diff --git a/src/Hakyll/Alias.hs b/src/Hakyll/Alias.hs
index 33ed5c1..73beb86 100644
--- a/src/Hakyll/Alias.hs
+++ b/src/Hakyll/Alias.hs
@@ -20,7 +20,7 @@ import Hakyll.Web.Template.Util (functionField1)
aliasCtxt :: (Ord a, FromAlias a x) => String -> (String -> Compiler a) -> (x -> Compiler String) -> AliasMap a x -> Context c
aliasCtxt name toa fromx amap = functionField1 name $ toa >=> flip resolveAlias amap >=> fromx
-aliasCtxtFrom :: (Ord a, FromAlias a x) => String -> (String -> Compiler a) -> (x -> Compiler String) -> Identifier -> Context c
+aliasCtxtFrom :: forall a x c . (Binary a, Binary x, Typeable a, Typeable x, Ord a, FromAlias a x) => String -> (String -> Compiler a) -> (x -> Compiler String) -> Identifier -> Context c
aliasCtxtFrom name toa fromx ident = functionField1 name $ \s -> do
amap <- loadBody ident
toa s >>= flip resolveAlias amap >>= fromx
@@ -28,15 +28,15 @@ aliasCtxtFrom name toa fromx ident = functionField1 name $ \s -> do
-- personCtxt :: (StringConv StrictText s, Ord (Name s), ToMarkup s) => AliasMap (Name s) (Person s) -> Context a
personCtxt :: Identifier -> Context a
-personCtxt = aliasCtxtFrom @StrictText "personA" (ffmap toSL . parseName . toSL) (pure . toSL . personHtml)
+personCtxt = aliasCtxtFrom @Name_ @Person_ "personA" (parseName . toSL) (pure . toSL . personHtml)
-- personCtxtFrom :: Identifier -> Context a
-- personCtxtFrom = functionField1
-- licenseCtxt :: (StringConv String s, Ord s, ToMarkup s) => AliasMap s (License s) -> Context a
licenseCtxt :: Identifier -> Context a
-licenseCtxt = aliasCtxtFrom @StrictText "licenseA" (pure . toSL) (pure . toSL . licenseHtml)
+licenseCtxt = aliasCtxtFrom @StrictText @License_ "licenseA" (pure . toSL) (pure . toSL . licenseHtml)
-- journalCtxt :: (StringConv String s, Ord s, ToMarkup s) => AliasMap s (Journal s) -> Context a
journalCtxt :: Identifier -> Context a
-journalCtxt = aliasCtxtFrom @StrictText "journalA" (pure . toSL) (pure . toSL . journalHtml)
+journalCtxt = aliasCtxtFrom @StrictText @Journal_ "journalA" (pure . toSL) (pure . toSL . journalHtml)
diff --git a/src/Hakyll/Paper.hs b/src/Hakyll/Paper.hs
index 0c997eb..609f74d 100644
--- a/src/Hakyll/Paper.hs
+++ b/src/Hakyll/Paper.hs
@@ -8,25 +8,36 @@ import Data.Time.Format
import Hakyll.Util (transformContext_)
import Hakyll.Core.Identifier.Pattorn
import System.FilePath
+import Witherable
+import Network.URI (parseRelativeReference)
+import Data.String.Slugger (toSlug)
+import Hakyll.TeX.BibTeX (compileBibtex)
+data FieldContext a = FieldContext
+ { _authorCtxt :: Context (Name a)
+ , _journalCtxt :: Context (Status a)
+ }
+
+
authorCtxt :: StringConv a String => Context (Name a)
authorCtxt = fold $
- [ field "name" $ pure . renderNameFML . fmap toSL . getItemBody
+ [ field "name" $ pure . renderNameFML . fmap toSL . itemBody
]
-paperCtxt :: StringConv a String => Context (Paper a)
-paperCtxt = fold $
- [ listFieldWith "authors" authorCtxt $ pure . authors . itemBody
+paperCtxt :: StringConv a String => FieldContext a -> Context (Paper a)
+paperCtxt fctxt = fold $
+ [ listFieldWith "authors" (_authorCtxt fctxt <> authorCtxt) $ pure . traverse authors
+ -- fmap pure . authors . itemBody
, field "abstract" $ liftMaybe . fmap toSL . abstract . itemBody
, field "title" $ pure . toSL . title . itemBody
, field "key" $ pure . sluggedKey . itemBody
- , status >$< statusCtxt
- , listFieldWith "eprints" eprintCtxt $ pure . eprints . itemBody
+ , status >$< (statusCtxt <> _journalCtxt fctxt)
+ , listFieldWith "eprints" eprintCtxt $ pure . traverse eprints
-- , eprint >$< maybeContext eprintCtxt
- , field "extra" $ \i -> case extraLink $ getItemBody i of
+ , field "extra" $ \i -> case extraLink $ itemBody i of
Just l -> pure $ show l
Nothing -> do
let k = sluggedKey $ itemBody i
@@ -36,19 +47,19 @@ paperCtxt = fold $
_ -> fail $ "No extra for " <> k
]
-mkPaperContext :: StringConv a String => [Paper a] -> Context b
-mkPaperContext papers = listField "papers" paperCtxt $ do
+mkPaperContext :: (StringConv a String, StringConv String a) => FieldContext a -> [Paper a] -> Context b
+mkPaperContext fctxt papers = listField "papers" (paperCtxt fctxt) $ do
fp <- getResourceFilePath
forM papers $ \p -> do
let itm = Item (fromFilePath $ replaceFileName fp (sluggedKey p)) p
e <- findLocal itm
- pure $ (\x -> x { eprint = eprint x <> e }) <$> itm
+ pure $ (\x -> x { eprints = eprints x <> e }) <$> itm
statusCtxt :: StringConv a String => Context (Status a)
statusCtxt = fold $
- [ field "date" $ formatTime defaultTimeLocale "%b %Y" . date . itemBody
+ [ field "date" $ pure . formatTime defaultTimeLocale "%b %Y" . date . itemBody
, field "journal" $ \i -> case itemBody i of
Published _ j _ -> pure $ toSL j
Accepted _ j -> pure $ toSL j
@@ -57,7 +68,7 @@ statusCtxt = fold $
Published _ _ d -> pure $ show (doiLink d)
_ -> fail "No DOI"
, boolField "published" $ \case
- Item _ (Published {..}) -> True
+ Item _ (Published {}) -> True
_ -> False
-- \i -> case itemBody i of
-- Published _ _ _ -> True
@@ -76,13 +87,13 @@ statusCtxt = fold $
eprintCtxt :: StringConv a String => Context (Eprint a)
eprintCtxt = fold $
[ field "eprint" $ \i -> pure $ case itemBody i of
- ArXivEprint a _ -> show $ arXivLink ArXivAbs a
- OtherEprint _ l -> show $ l
+ ArXivEprint a -> show $ arXivLink ArXivAbs a
+ OtherEprint _ l -> show l
, field "eprintName" $ \i -> pure $ case itemBody i of
- ArXivEprint _ c -> "arXiv[" <> toSL c <> "]"
- OtherEprint n _ -> show n
+ ArXivEprint (ArXiv _ c) -> "arXiv[" <> toSL c <> "]"
+ OtherEprint n _ -> toSL n
, field "arXivClass" $ \i -> case itemBody i of
- ArXivEprint _ c -> pure $ toSL c
+ ArXivEprint (ArXiv _ c) -> pure $ toSL c
_ -> fail "No arXiv"
, functionField "arXivLink" $ \args i -> case itemBody i of
ArXivEprint a ->
@@ -91,7 +102,7 @@ eprintCtxt = fold $
["pdf"] -> pure $ show $ arXivLink ArXivPdf a
["src"] -> pure $ show $ arXivLink ArXivSrc a
xs -> fail $ "Invalid argument to arXivLink: " <> show xs
- _ -> fail "No ArXiv"
+ _ -> fail "No ArXiv"
]
findLocal :: (StringConv a String, StringConv String a) => Item (Paper a) -> Compiler [Eprint a]
diff --git a/src/Hakyll/TeX/BibTeX.hs b/src/Hakyll/TeX/BibTeX.hs
index eb87c4e..a78f254 100644
--- a/src/Hakyll/TeX/BibTeX.hs
+++ b/src/Hakyll/TeX/BibTeX.hs
@@ -33,7 +33,8 @@ instance Writable [B.T] where
compileBibtex :: (StringConv s String) => Item s -> Compiler (Item BibTeX)
compileBibtex = fmap (B.lowerCaseFieldNames <<$>>) . compileParsec_ p . fmap toSL
where
- p = B.skippingLeadingSpace $ B.file <* P.space <* P.eof
+ p = B.skippingSpace B.file
+ -- p = B.skippingLeadingSpace $ B.file <* P.space <* P.eof
bibtexCompiler :: Compiler (Item BibTeX)
bibtexCompiler = getResourceBody >>= compileBibtex
diff --git a/src/Prolog.hs b/src/Prolog.hs
index 94a6eb6..f7e72eb 100644
--- a/src/Prolog.hs
+++ b/src/Prolog.hs
@@ -23,6 +23,7 @@ module Prolog
, Binary
, Generic
, Generic1
+ , Typeable
, Generically (..)
, MonadThrow (..)
, Exception (..)
@@ -89,6 +90,8 @@ import Data.String
import Data.String.Conv
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
+import Data.Time qualified as Time
+import Data.Typeable (Typeable)
import GHC.Generics
import Network.URI
@@ -186,7 +189,7 @@ rebaseWith :: (Applicative m, Comonad w) => (a -> b) -> w a -> m b
rebaseWith f = rebaseWithM $ pure . f
{-# INLINE rebaseWith #-}
-rebaseWithM :: (Applicative m, Comonad w) => (a -> m b) -> w a -> m b
+rebaseWithM :: (Comonad w) => (a -> m b) -> w a -> m b
rebaseWithM f = f . extract
{-# INLINE rebaseWithM #-}
@@ -311,3 +314,6 @@ instance MonadThrow H.Compiler where
-- | Huh, I guess I need a version bump for this guy?
instance A.FromJSON URI where
parseJSON = A.withText "URI" $ maybe (fail "Invalid URI") pure . parseURI . toSL
+
+deriving instance Generic Time.Day
+deriving newtype instance Binary Time.Day
generated by cgit v1.2.3 (git 2.25.1) at 2026-07-09 19:06:14 +0000