A lot of work on aliases and the like

7 files changed, 224 insertions, 19 deletions

diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs
index 8eec279..270ce1f 100644
--- a/src/Data/Alias.hs
+++ b/src/Data/Alias.hs
@@ -5,9 +5,13 @@ module Data.Alias
     , WithAliases (..)
     , withAliases
     , NoAliases (..)
+    , TrivialAlias (..)
     -- * Containers
     , AliasMap (..)
     , buildAliasMap
+    , findAlias
+    , lookupAlias
+    , resolveAlias
     -- * Errors
     , NoAlias (..)
     , missingAlias
@@ -24,7 +28,7 @@ import Data.Typeable
 data WithAliases a x = WithAliases (Set a) x
     deriving stock (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
 
-withAliases :: (Ord a, ToAliases x a) => Set a -> x -> WithAliases a x
+withAliases :: ToAliases x a => Set a -> x -> WithAliases a x
 withAliases as x = WithAliases (as <> toAliases x) x
 
 instance Ord a => Applicative (WithAliases a) where
@@ -80,14 +84,21 @@ instance ToAliases x a => ToAliases [x] a where
 class FromAlias a x where
     fromAlias :: MonadThrow m => a -> m x
 
-instance FromAlias a a where
-    fromAlias = pure
+newtype TrivialAlias a = TrivialAlias { getTrivialAlias :: a }
+    deriving stock (Generic, Show)
+    deriving newtype (Eq, Binary, Ord)
+
+instance FromAlias (TrivialAlias a) a where
+    fromAlias = pure . getTrivialAlias
+
+-- instance FromAlias a a where
+--     fromAlias = pure
 
 instance (FromAlias a x, FromAlias b x) => FromAlias (Either a b) x where
     fromAlias = either fromAlias fromAlias
 
 instance FromAlias a x => FromAlias (Aliased a x) x where
-    fromAlias = fromAlias . unAliased
+    fromAlias = either fromAlias pure . unAliased
 
 
 
@@ -96,7 +107,8 @@ newtype AliasMap a x = AliasMap (Map a x)
     deriving stock (Show, Traversable)
 
 buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
-buildAliasMap = fmap AliasMap $ foldMap $ \x -> x <$ toMap (toAliases x)
+buildAliasMap = fmap AliasMap $ foldMap $ (<$) <*> toMap . toAliases
+{-# INLINE buildAliasMap #-}
 
 toMap :: Ord a => Set a -> Map a ()
 toMap = M.fromAscList . fmap (, ()) . S.toAscList
@@ -106,12 +118,12 @@ findAlias :: Ord a => a -> AliasMap a x -> Either (NoAlias a) x
 findAlias a (AliasMap h) = maybe (Left $ NoAlias a) Right $ M.lookup a h
 
 -- | Throws an error when not found
-lookupAlias :: (MonadThrow m, Typeable a, Ord a, Show a, FromAlias b x) => a -> AliasMap a b -> m x
-lookupAlias a = either throwM fromAlias . findAlias a
+lookupAlias :: (MonadThrow m, Typeable a, Ord a, Show a) => a -> AliasMap a x -> m x
+lookupAlias a = either throwM pure . findAlias a
 
 -- | Uses 'fromAlias' when not found
-resolveAlias :: (MonadThrow m, Ord a, FromAlias a x, FromAlias b x) => a -> AliasMap a b -> m x
-resolveAlias a = either (\(NoAlias x) -> fromAlias x) fromAlias . findAlias a
+resolveAlias :: (MonadThrow m, Ord a, FromAlias a x) => a -> AliasMap a x -> m x
+resolveAlias a = either (\(NoAlias x) -> fromAlias x) pure . findAlias a
 
 instance (FromJSON a, FromJSON x, ToAliases x a, Ord a) => FromJSON (AliasMap a x) where
     parseJSON = fmap b . parseJSON
diff --git a/src/Data/Journal.hs b/src/Data/Journal.hs
new file mode 100644
index 0000000..ea15644
--- /dev/null
+++ b/src/Data/Journal.hs
@@ -0,0 +1,41 @@
+module Data.Journal
+    ( Journal (..)
+    , Journal_
+    , journalHtml
+    ) 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 Journal a = Journal
+    { title :: !a
+    , shortTitle :: !(Maybe a)
+    , link :: !(Maybe URI)
+    } deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (Journal a)
+
+type Journal_ = Journal StrictText
+
+journalHtml :: (ToMarkup a) => Journal a -> Html
+journalHtml (Journal t st l) = linkedHtml $ Linked (maybe t id st) l (t <$ st)
+
+
+instance Ord a => ToAliases (Journal a) a where
+    toAliases (Journal t st _) = S.fromList $ t : toList st
+
+instance FromAlias a (Journal a) where
+    fromAlias t = pure $ Journal t Nothing Nothing
+
+instance FromJSON a => FromJSON (Journal a) where
+    parseJSON = withObject "Journal" $ \v -> Journal
+        <$> v .: "title"
+        <*> v .:? "short" .!= Nothing
+        <*> v .:? "link" .!= Nothing
diff --git a/src/Data/License.hs b/src/Data/License.hs
new file mode 100644
index 0000000..2039806
--- /dev/null
+++ b/src/Data/License.hs
@@ -0,0 +1,40 @@
+module Data.License
+    ( License (..)
+    , License_
+    , licenseHtml
+    ) 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 License a = License
+    { name :: !a
+    , shortName :: !(Maybe a)
+    , link :: !(Maybe URI)
+    } deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (License a)
+
+type License_ = License StrictText
+
+licenseHtml :: ToMarkup a => License a -> Html
+licenseHtml (License n sn l) = linkedHtml $ Linked (maybe n id sn) l (n <$ sn)
+
+instance Ord a => ToAliases (License a) a where
+    toAliases (License n sn _) = S.fromList $ n : toList sn
+
+instance FromAlias a (License a) where
+    fromAlias n = pure $ License n Nothing Nothing
+
+instance FromJSON a => FromJSON (License a) where
+    parseJSON = withObject "License" $ \v -> License
+        <$> v .: "name"
+        <*> v .:? "short" .!= Nothing
+        <*> v .:? "link" .!= Nothing
diff --git a/src/Data/Linked.hs b/src/Data/Linked.hs
new file mode 100644
index 0000000..8e78f86
--- /dev/null
+++ b/src/Data/Linked.hs
@@ -0,0 +1,44 @@
+module Data.Linked
+    ( Linked (..)
+    , linkedHtml
+    , ToMaybe (..)
+    ) where
+
+import Prelude hiding (span)
+import Prolog
+import Data.Proxy
+import Network.URI
+import Text.Blaze.Html
+import Text.Blaze.Html5 (a, span)
+import Text.Blaze.Html5.Attributes (href, class_)
+
+
+data Linked l t a = Linked
+    { baseText :: !a
+    , link :: !(l URI)
+    , tooltip :: !(t a)
+    }
+
+
+linkedHtml :: (ToMarkup a, ToMaybe l, ToMaybe t) => Linked l t a -> Html
+-- linkedHtml (Linked t (toMaybe -> Nothing) (toMaybe -> Nothing)) = toMarkup t
+linkedHtml (Linked t (toMaybe -> l) (toMaybe -> tt)) =
+    maybe id (\x -> a ! href (toValue x)) l $ maybe id withToolTip tt $ toMarkup t
+    -- a ! (maybe mempty (\x -> href $ toValue x) l) $ maybe id withToolTip tt $ toMarkup t
+-- ! (maybe mempty (\_ -> class_ "has-tooltip") tt) $ toMarkup t <> (maybe mempty (\x -> span ! class_ "tooltip" $ toMarkup x) tt)
+
+
+withToolTip :: (ToMarkup t) => t -> Html -> Html
+withToolTip tt h = a ! class_ "has-tooltip" $ h <> (span ! class_ "tooltip" $ toMarkup tt)
+
+class ToMaybe f where
+    toMaybe :: Alternative m => f a -> m a
+
+instance ToMaybe Maybe where
+    toMaybe = liftMaybe
+
+instance ToMaybe Identity where
+    toMaybe (Identity a) = pure a
+
+instance ToMaybe Proxy where
+    toMaybe _ = empty
diff --git a/src/Data/Name.hs b/src/Data/Name.hs
index ab49273..88e5bda 100644
--- a/src/Data/Name.hs
+++ b/src/Data/Name.hs
@@ -2,6 +2,7 @@ module Data.Name
     ( Name (..)
     , Name_
     -- * Parsers
+    , parseName
     , readNameLFM
     , readNameFML
     -- * Writers
@@ -15,7 +16,6 @@ import Prolog
 import Data.Aeson
 import Data.Alias
 import Data.Char (isSpace)
-import Data.List qualified as L
 import Data.Set qualified as S
 import Data.Text qualified as T
 
@@ -88,6 +88,9 @@ readNameFML t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
                                                      [] -> Nothing
                                                      _ -> Just $ T.unwords m
 
+parseName :: Alternative m => StrictText -> m Name_
+parseName = (<|>) <$> readNameLFM <*> readNameFML
+
 showNameLFM :: Name_ -> StrictText
 showNameLFM (Name l f m) = stt l <> ", " <> stt f <> maybe "" (\x -> " " <> stt x) m
 
diff --git a/src/Data/Paper.hs b/src/Data/Paper.hs
new file mode 100644
index 0000000..c2d4b3e
--- /dev/null
+++ b/src/Data/Paper.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Data.Paper
+    ( Paper (..)
+    , Status (..)
+    ) where
+
+import Prolog
+import Data.Journal
+import Data.Person
+import Data.Time
+import Network.URI
+import Network.URI.Static
+
+
+data Paper a = Paper
+    { title :: !a
+    , authors :: ![Name a]
+    , status :: !(Status a)
+    } deriving (Eq, Generic, Ord, Show)
+
+-- instance (Binary a, Binary (Status f a), Binary (f (Person a))) => Binary (Paper f a)
+
+data Status a
+    = Submitted
+    | Accepted
+        { journal :: !a
+        }
+    | Published
+        { date :: !Day
+        , journal :: !a
+        , doi :: !DOI
+        }
+    | Unpublished
+    deriving (Eq, Generic, Ord, Show)
+
+-- instance (Binary a, Binary (f (Journal a))) => Binary (Status f a)
+
+newtype DOI = DOI URI
+    deriving (Eq, Generic, Ord, Show)
+    deriving newtype Binary
+
+data ArXiv a = ArXiv
+    { _identifier :: !URI
+    , _class :: !a
+    } deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+
+instance Binary a => Binary (ArXiv a)
+
+arXivURI :: URI
+arXivURI = [uri|https://arxiv.org/|]
+
+data ArXivType = ArXivAbs | ArXivPdf | ArXivSrc
+    deriving (Bounded, Enum, Eq, Generic, Ord, Show)
+
+arXivTypeRelative :: ArXivType -> URI
+arXivTypeRelative = \case
+    ArXivAbs -> [relativeReference|/abs|]
+    ArXivPdf -> [relativeReference|/pdf|]
+    ArXivSrc -> [relativeReference|/src|]
+
+arXivLink :: ArXivType -> ArXiv a -> URI
+arXivLink at a = _identifier a `relativeTo` arXivTypeRelative at `relativeTo` arXivURI
+
+
+doiURI :: URI
+doiURI = [uri|https://doi.org/|]
+
+doiLink :: DOI -> URI
+doiLink (DOI u) = u `relativeTo` doiURI
diff --git a/src/Data/Person.hs b/src/Data/Person.hs
index c829fc4..853408e 100644
--- a/src/Data/Person.hs
+++ b/src/Data/Person.hs
@@ -1,5 +1,6 @@
 module Data.Person
     ( Person (..)
+    , Person_
     , personHtml
     , personFromName
     , Name (..)
@@ -9,18 +10,13 @@ module Data.Person
 import Prolog
 import Data.Aeson
 import Data.Alias
+import Data.Linked
 import Data.Name
 import Data.Set qualified as S
 import Network.URI (URI)
-import Network.URI qualified as URI
 import Text.Blaze
 import Text.Blaze.Html
-import Text.Blaze.Html5 (a)
-import Text.Blaze.Html5.Attributes (href)
 
--- | Huh, I guess I need a version bump for this guy?
-instance FromJSON URI where
-    parseJSON = withText "URI" $ maybe (fail "Invalid URI") pure . URI.parseURI . toSL
 
 data Person a = Person
     { name :: !(Name a)
@@ -29,10 +25,10 @@ data Person a = Person
 
 instance Binary a => Binary (Person a)
 
+type Person_ = Person StrictText
+
 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
+personHtml (Person n w) = linkedHtml $ Linked (renderNameFML $ toMarkup <$> n) w Nothing
 
 personFromName :: Name a -> Person a
 personFromName n = Person n Nothing