Technically working, but I need a cleaner way to pass personA and

journalA into a list context...

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