From 3a949d34da649b199235b06ab33927ad02cfdc26 Mon Sep 17 00:00:00 2001 From: Chris Wells Date: Thu, 29 Jan 2026 15:33:24 -0600 Subject: Things are compiling nicely finally --- src/Data/Linked.hs | 32 +++++++++++++++++++++----------- src/Data/Paper.hs | 6 +++--- src/Data/Person.hs | 7 +++++-- 3 files changed, 29 insertions(+), 16 deletions(-) (limited to 'src/Data') diff --git a/src/Data/Linked.hs b/src/Data/Linked.hs index de1dc77..e4ba05f 100644 --- a/src/Data/Linked.hs +++ b/src/Data/Linked.hs @@ -4,12 +4,12 @@ module Data.Linked , ToMaybe (..) ) where -import Prelude hiding (span) +import Prelude hiding (span, div) import Prolog import Data.Proxy import Network.URI import Text.Blaze.Html -import Text.Blaze.Html5 (a, span) +import Text.Blaze.Html5 (a, span, div) import Text.Blaze.Html5.Attributes (href, class_) @@ -21,15 +21,25 @@ data Linked l t a = Linked 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) +linkedHtml (Linked t (toMaybe -> Nothing) (toMaybe -> Nothing)) = toMarkup t +linkedHtml (Linked t (toMaybe -> Just l) (toMaybe -> Nothing)) = a ! href (toValue l) $ toMarkup t +linkedHtml (Linked t (toMaybe -> l) (toMaybe -> Just tt)) = anchor $ toMarkup t <> (span ! class_ "tooltip" $ toMarkup tt) + where + anchor = case l of + Nothing -> div ! class_ "has-tooltip" + Just l' -> a ! class_ "has-tooltip" ! href (toValue l') + -- where + -- anchor + -- mklink x = maybe x ((!) x . href . toValue) l + -- mktooltip tt txt = maybe (toMarkup txt) (\tt' -> x <> (span ! class_ "tooltip" $ toMarkup tt')) tt + -- linkctxt = a ! +-- maybe id withToolTip tt $ maybe id (\x -> a ! href (toValue x)) l $ 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 = div ! class_ "has-tooltip" $ h <> (span ! class_ "tooltip" $ toMarkup tt) class ToMaybe f where toMaybe :: Alternative m => f a -> m a diff --git a/src/Data/Paper.hs b/src/Data/Paper.hs index 0dedc46..b86b2f0 100644 --- a/src/Data/Paper.hs +++ b/src/Data/Paper.hs @@ -92,9 +92,9 @@ data ArXivType = ArXivAbs | ArXivPdf | ArXivSrc arXivTypeRelative :: ArXivType -> URI arXivTypeRelative = \case - ArXivAbs -> [relativeReference|/abs|] - ArXivPdf -> [relativeReference|/pdf|] - ArXivSrc -> [relativeReference|/src|] + ArXivAbs -> [relativeReference|/abs/|] + ArXivPdf -> [relativeReference|/pdf/|] + ArXivSrc -> [relativeReference|/src/|] arXivLink :: ArXivType -> ArXiv a -> URI arXivLink at a = _identifier a `relativeTo` arXivTypeRelative at `relativeTo` arXivURI diff --git a/src/Data/Person.hs b/src/Data/Person.hs index 389d1ed..3dbdd80 100644 --- a/src/Data/Person.hs +++ b/src/Data/Person.hs @@ -27,8 +27,11 @@ instance Binary a => Binary (Person a) type Person_ = Person StrictText -personHtml :: (ToMarkup a) => Person a -> Html -personHtml (Person n w) = linkedHtml $ Linked (contents $ renderNameFML $ contents . toMarkup <$> n) w Nothing +personHtml :: (StringConv a StrictText) => Person a -> Html +personHtml (Person n w) = linkedHtml $ Linked (renderNameFML $ ts <$> n) w Nothing + where + ts :: (StringConv a StrictText) => a -> StrictText + ts = toSL personFromName :: Name a -> Person a personFromName n = Person n Nothing -- cgit v1.2.3