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 +++++-- src/Hakyll/Alias.hs | 1 + src/Hakyll/Paper.hs | 8 ++++---- src/Prolog.hs | 12 ++++++++++-- 6 files changed, 44 insertions(+), 22 deletions(-) (limited to 'src') 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 diff --git a/src/Hakyll/Alias.hs b/src/Hakyll/Alias.hs index 73beb86..129ec42 100644 --- a/src/Hakyll/Alias.hs +++ b/src/Hakyll/Alias.hs @@ -29,6 +29,7 @@ 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 @Name_ @Person_ "personA" (parseName . toSL) (pure . toSL . personHtml) +-- personCtxt = aliasCtxtFrom @Name_ @Person_ "personA" (parseName . toSL) (pure . toSL . (\(Person n _) -> toMarkup $ renderNameFML n)) -- personCtxtFrom :: Identifier -> Context a -- personCtxtFrom = functionField1 diff --git a/src/Hakyll/Paper.hs b/src/Hakyll/Paper.hs index 609f74d..06c45d0 100644 --- a/src/Hakyll/Paper.hs +++ b/src/Hakyll/Paper.hs @@ -27,14 +27,14 @@ authorCtxt = fold $ [ field "name" $ pure . renderNameFML . fmap toSL . itemBody ] -paperCtxt :: StringConv a String => FieldContext a -> Context (Paper a) +paperCtxt :: StringConv a String => (forall b. Context b) -> Context (Paper a) paperCtxt fctxt = fold $ - [ listFieldWith "authors" (_authorCtxt fctxt <> authorCtxt) $ pure . traverse authors + [ listFieldWith "authors" (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 <> _journalCtxt fctxt) + , status >$< (statusCtxt <> fctxt) , listFieldWith "eprints" eprintCtxt $ pure . traverse eprints -- , eprint >$< maybeContext eprintCtxt , field "extra" $ \i -> case extraLink $ itemBody i of @@ -47,7 +47,7 @@ paperCtxt fctxt = fold $ _ -> fail $ "No extra for " <> k ] -mkPaperContext :: (StringConv a String, StringConv String a) => FieldContext a -> [Paper a] -> Context b +mkPaperContext :: (StringConv a String, StringConv String a) => (forall c. Context c) -> [Paper a] -> Context b mkPaperContext fctxt papers = listField "papers" (paperCtxt fctxt) $ do fp <- getResourceFilePath forM papers $ \p -> do diff --git a/src/Prolog.hs b/src/Prolog.hs index f7e72eb..1910a78 100644 --- a/src/Prolog.hs +++ b/src/Prolog.hs @@ -78,11 +78,13 @@ import Data.Bitraversable import Data.Bool import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as BL +import Data.Char qualified as C import Data.Either import Data.Foldable import Data.Function import Data.Functor import Data.Functor.Contravariant +import Data.List qualified as L import Data.Map.Strict (Map) import Data.Maybe import Data.Set (Set) @@ -233,10 +235,16 @@ instance StringConv Html T.Text where strConv l = strConv l . BT.renderHtml instance StringConv Html TL.Text where - strConv _ = BT.renderHtml + strConv _ = TL.strip . BT.renderHtml instance StringConv Html String where - strConv _ = BS.renderHtml + strConv _ = strip . BS.renderHtml + where + strip :: String -> String + strip = + let d = L.dropWhile C.isSpace + in L.reverse . d . L.reverse . d + instance StringConv Html B.ByteString where strConv l = strConv l . BB.renderHtml -- cgit v1.2.3