Adding more functionality

5 files changed, 137 insertions, 2 deletions

diff --git a/src/Data/Name.hs b/src/Data/Name.hs
new file mode 100644
index 0000000..9572709
--- /dev/null
+++ b/src/Data/Name.hs
@@ -0,0 +1,76 @@
+module Data.Name
+    ( Name (..)
+    , Name_
+    -- * Parsers
+    , readNameLFM
+    , readNameFML
+    -- * Writers
+    , renderNameLFM
+    , renderNameFML
+    ) where
+
+import Prolog
+import Data.Char (isSpace)
+import Data.List qualified as L
+import Data.Text qualified as T
+
+
+data Name a = Name
+    { lastName :: !a
+    , firstName :: !a
+    , middleName :: !(Maybe a)
+    } deriving (Eq, Functor, Foldable, Generic, Generic1, Ord, Show, Traversable)
+
+type Name_ = Name StrictText
+
+instance Binary a => Binary (Name a)
+
+instance Applicative Name where
+    pure a = Name a a (pure a)
+    Name l f m <*> Name l' f' m' = Name (l l') (f f') (m <*> m')
+
+
+readNameLFM :: Alternative m => StrictText -> m Name_
+readNameLFM t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
+    case T.break (== ',') t of
+      (l, fm)
+        | T.null l -> empty
+        | otherwise -> case T.dropWhile ((||) <$> isSpace <*> (== ',')) fm of
+                         fm'
+                           | T.null fm' -> empty
+                           | otherwise -> case T.break isSpace fm' of
+                                            (f, m) -> pure $ Name l f $ case T.dropWhile isSpace m of
+                                                                          x | T.null x -> Nothing
+                                                                            | otherwise -> Just x
+
+readNameFML :: Alternative m => StrictText -> m Name_
+readNameFML t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
+    case T.words t of
+      [] -> empty
+      (f:xs) -> case unsnoc xs of
+                  Nothing -> empty
+                  Just (m, l) -> pure $ Name f l $ case m of
+                                                     [] -> Nothing
+                                                     _ -> Just $ T.unwords m
+
+showNameLFM :: Name_ -> StrictText
+showNameLFM (Name l f m) = stt l <> ", " <> stt f <> maybe "" (\x -> " " <> stt x) m
+
+showNameFML :: Name_ -> StrictText
+showNameFML (Name l f m) = stt f <> maybe " " (\x -> " " <> stt x <> " ") m <> stt l
+
+renderNameLFM :: (Semigroup a, IsString a) => Name a -> a
+renderNameLFM (Name l f m) = l <> ", " <> f <> maybe "" (\x -> " " <> x) m
+
+renderNameFML :: (Semigroup a, IsString a) => Name a -> a
+renderNameFML (Name l f m) = f <> maybe " " (\x -> " " <> x <> " ") m <> l
+
+-- Helpers
+
+unsnoc :: [a] -> Maybe ([a],a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+{-# INLINABLE unsnoc #-}
+
+stt :: StrictText -> StrictText
+stt = T.map $ \c -> if isSpace c then '~' else c
+{-# INLINABLE stt #-}
diff --git a/src/Data/Person.hs b/src/Data/Person.hs
new file mode 100644
index 0000000..a649c07
--- /dev/null
+++ b/src/Data/Person.hs
@@ -0,0 +1,31 @@
+module Data.Person
+    ( Person (..)
+    , personHtml
+    , personFromName
+    , Name (..)
+    , URI
+    ) where
+
+import Prolog
+import Data.Name
+import Network.URI (URI)
+import Text.Blaze
+import Text.Blaze.Html
+import Text.Blaze.Html5 (a)
+import Text.Blaze.Html5.Attributes (href)
+
+data Person a = Person
+    { name :: !(Name a)
+    , webpage :: !(Maybe URI)
+    , aliases :: ![Name a]
+    } deriving (Eq, Functor, Foldable, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (Person a)
+
+personHtml :: (ToMarkup a) => Person a -> Html
+personHtml (Person n w _) =
+    let withLink = maybe id (\x -> a ! href (toValue x)) w
+     in withLink $ renderNameFML $ toMarkup <$> n
+
+personFromName :: Name a -> Person a
+personFromName n = Person n Nothing [n]
diff --git a/src/Hakyll/TeX/BibTeX.hs b/src/Hakyll/TeX/BibTeX.hs
index ddf9166..a3adce7 100644
--- a/src/Hakyll/TeX/BibTeX.hs
+++ b/src/Hakyll/TeX/BibTeX.hs
@@ -33,7 +33,7 @@ instance Writable [B.T] where
 compileBibtex :: (StringConv s String) => Item s -> Compiler (Item BibTeX)
 compileBibtex = compileParsec_ p . fmap toSL
     where
-        p = B.skippingLeadingSpace $ B.file <* P.eof
+        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 4b3c666..a6ac1b5 100644
--- a/src/Prolog.hs
+++ b/src/Prolog.hs
@@ -21,6 +21,7 @@ module Prolog
     -- * Types
     , Binary
     , Generic
+    , Generic1
     , Generically (..)
     , MonadThrow (..)
     , Exception (..)
@@ -76,8 +77,10 @@ import Data.String.Conv
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import GHC.Generics
+import Network.URI
 
 import Hakyll qualified as H
+import Text.Blaze
 import Text.Blaze.Html
 import Text.Blaze.Html.Renderer.Pretty as BS
 import Text.Blaze.Html.Renderer.Text as BT
@@ -147,6 +150,8 @@ instance Binary L.MathType
 instance Binary L.Measure
 instance Binary L.TeXArg
 instance Binary L.LaTeX
+instance Binary URIAuth
+instance Binary URI
 
 instance H.Writable L.LaTeX where
     write p = L.renderFile p . H.itemBody
@@ -188,3 +193,26 @@ instance StringConv Html B.ByteString where
 
 instance StringConv Html BL.ByteString where
     strConv _ = BB.renderHtml
+
+instance StringConv URI String where
+    strConv _ = show
+
+instance StringConv URI T.Text where
+    strConv l = strConv l . show
+
+instance StringConv URI TL.Text where
+    strConv l = strConv l . show
+
+instance StringConv URI B.ByteString where
+    strConv l = strConv l . show
+
+instance StringConv URI BL.ByteString where
+    strConv l = strConv l . show
+
+instance ToMarkup URI where
+    toMarkup = toMarkup . show
+    preEscapedToMarkup = preEscapedToMarkup . show
+
+instance ToValue URI where
+    toValue = toValue . show
+    preEscapedToValue = preEscapedToValue . show
diff --git a/src/WWW/HW.hs b/src/WWW/HW.hs
index 0740fe6..aaa8b3f 100644
--- a/src/WWW/HW.hs
+++ b/src/WWW/HW.hs
@@ -3,7 +3,7 @@ module WWW.HW
     , removeSolutions
     ) where
 
-import Prolog
+-- import Prolog
 
 import Text.LaTeX.Base.Syntax