diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Data/Alias.hs | 30 | ||||
| -rw-r--r-- | src/Data/Journal.hs | 41 | ||||
| -rw-r--r-- | src/Data/License.hs | 40 | ||||
| -rw-r--r-- | src/Data/Linked.hs | 44 | ||||
| -rw-r--r-- | src/Data/Name.hs | 5 | ||||
| -rw-r--r-- | src/Data/Paper.hs | 69 | ||||
| -rw-r--r-- | src/Data/Person.hs | 14 | ||||
| -rw-r--r-- | src/Hakyll/Aeson.hs | 42 | ||||
| -rw-r--r-- | src/Hakyll/Alias.hs | 23 | ||||
| -rw-r--r-- | src/Hakyll/Parsec.hs | 1 | ||||
| -rw-r--r-- | src/Hakyll/TeX/BibTeX.hs | 2 | ||||
| -rw-r--r-- | src/Prolog.hs | 57 | ||||
| -rw-r--r-- | src/WWW/Base.hs | 11 | ||||
| -rw-r--r-- | src/WWW/HW.hs | 19 | ||||
| -rw-r--r-- | src/WWW/Templates.hs | 2 |
15 files changed, 378 insertions, 22 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 diff --git a/src/Hakyll/Aeson.hs b/src/Hakyll/Aeson.hs new file mode 100644 index 0000000..f4090d5 --- /dev/null +++ b/src/Hakyll/Aeson.hs @@ -0,0 +1,42 @@ +module Hakyll.Aeson + ( compileJSON + , jsonCompiler + , compileYAML + , yamlCompiler + , JSONWriter (..) + , YAMLWriter (..) + ) where + +import Prolog +import Hakyll +import Hakyll.Error +import Data.Aeson as A +import Data.Yaml qualified as Y + + +compileJSON :: (FromJSON a, StringConv s LazyByteString, Traversable t, MonadError [String] m) => t s -> m (t a) +compileJSON = traverse $ liftErr . A.eitherDecode . toSL + +jsonCompiler :: FromJSON a => Compiler (Item a) +jsonCompiler = getResourceLBS >>= compileJSON + +compileYAML :: (FromJSON a, StringConv s StrictByteString, Traversable t, MonadThrow m) => t s -> m (t a) +compileYAML = traverse $ Y.decodeThrow . toSL + +yamlCompiler :: FromJSON a => Compiler (Item a) +yamlCompiler = getResourceLBS >>= compileYAML + + +newtype JSONWriter a = JSONWriter { runJSONWriter :: a } + deriving stock (Generic, Show) + deriving newtype (FromJSON, ToJSON, Binary) + +instance ToJSON a => Writable (JSONWriter a) where + write p = A.encodeFile p . runJSONWriter . itemBody + +newtype YAMLWriter a = YAMLWriter { runYAMLWriter :: a } + deriving stock (Generic, Show) + deriving newtype (FromJSON, ToJSON, Binary) + +instance ToJSON a => Writable (YAMLWriter a) where + write p = Y.encodeFile p . runYAMLWriter . itemBody diff --git a/src/Hakyll/Alias.hs b/src/Hakyll/Alias.hs new file mode 100644 index 0000000..598f5e2 --- /dev/null +++ b/src/Hakyll/Alias.hs @@ -0,0 +1,23 @@ +module Hakyll.Alias + ( aliasCtxt + , personCtxt + ) where + +import Prolog +import Hakyll +import Data.Alias +import Data.Name +import Data.Person + + +functionField1 :: String -> (String -> Compiler String) -> Context a +functionField1 n f = functionField n $ \case + [x] -> \_ -> f x + _ -> \_ -> fail $ "Expecting exactly one argument to " <> n + +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 + + +personCtxt :: AliasMap Name_ Person_ -> Context a +personCtxt = aliasCtxt "person" (parseName . toSL) (pure . toSL . personHtml) diff --git a/src/Hakyll/Parsec.hs b/src/Hakyll/Parsec.hs index edd7b18..a1cc706 100644 --- a/src/Hakyll/Parsec.hs +++ b/src/Hakyll/Parsec.hs @@ -8,7 +8,6 @@ module Hakyll.Parsec import Prolog import Hakyll import Text.Parsec -import Text.Parsec.Error import Hakyll.Error -- evalParsec :: (MonadError [String] m) => Either ParseError a -> m a diff --git a/src/Hakyll/TeX/BibTeX.hs b/src/Hakyll/TeX/BibTeX.hs index a3adce7..eb87c4e 100644 --- a/src/Hakyll/TeX/BibTeX.hs +++ b/src/Hakyll/TeX/BibTeX.hs @@ -31,7 +31,7 @@ instance Writable [B.T] where compileBibtex :: (StringConv s String) => Item s -> Compiler (Item BibTeX) -compileBibtex = compileParsec_ p . fmap toSL +compileBibtex = fmap (B.lowerCaseFieldNames <<$>>) . compileParsec_ p . fmap toSL where p = B.skippingLeadingSpace $ B.file <* P.space <* P.eof diff --git a/src/Prolog.hs b/src/Prolog.hs index df4a772..145f2d3 100644 --- a/src/Prolog.hs +++ b/src/Prolog.hs @@ -52,6 +52,8 @@ module Prolog , foreach , liftMaybe , squashMaybe + , throwEither + , squashEither ) where import Control.Applicative @@ -62,6 +64,7 @@ import Control.Monad.Except import Control.Monad.Identity import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Aeson qualified as A import Data.Bifunctor import Data.Bifoldable import Data.Binary @@ -92,6 +95,7 @@ import Text.Blaze.Html.Renderer.Text as BT import Text.Blaze.Html.Renderer.Utf8 as BB import Text.LaTeX.Base qualified as L import Text.LaTeX.Base.Syntax qualified as L +import Text.LaTeX.Packages.Hyperref qualified as LH type StrictText = T.Text type LazyText = TL.Text @@ -140,6 +144,14 @@ squashMaybe :: (Alternative m, Monad m) => m (Maybe a) -> m a squashMaybe = (>>= liftMaybe) {-# INLINE squashMaybe #-} +throwEither :: (Exception e, MonadThrow m) => Either e a -> m a +throwEither = either throwM pure +{-# INLINE throwEither #-} + +squashEither :: (Exception e, MonadThrow m) => m (Either e a) -> m a +squashEither = (>>= throwEither) +{-# INLINE squashEither #-} + renderTo :: (StringConv T.Text s, L.Render r) => r -> s renderTo = toSL . L.render {-# INLINE renderTo #-} @@ -214,6 +226,47 @@ instance StringConv URI B.ByteString where instance StringConv URI BL.ByteString where strConv l = strConv l . show +instance StringConv URI LH.URL where + strConv _ = fromString . show + +instance StringConv String LH.URL where + strConv _ = fromString + +instance StringConv T.Text LH.URL where + strConv l = fromString . strConv l + +instance StringConv TL.Text LH.URL where + strConv l = fromString . strConv l + +instance StringConv B.ByteString LH.URL where + strConv l = fromString . strConv l + +instance StringConv BL.ByteString LH.URL where + strConv l = fromString . strConv l + +instance StringConv LH.URL T.Text where + strConv _ = L.render + +instance StringConv LH.URL TL.Text where + strConv l = strConv l . L.render + +instance StringConv LH.URL String where + strConv l = strConv l . L.render + +instance StringConv LH.URL B.ByteString where + strConv l = strConv l . L.render + +instance StringConv LH.URL BL.ByteString where + strConv l = strConv l . L.render + +instance ToMarkup LH.URL where + toMarkup = toMarkup . L.render + preEscapedToMarkup = preEscapedToMarkup . L.render + +instance ToValue LH.URL where + toValue = toValue . L.render + preEscapedToValue = preEscapedToValue . L.render + instance ToMarkup URI where toMarkup = toMarkup . show preEscapedToMarkup = preEscapedToMarkup . show @@ -224,3 +277,7 @@ instance ToValue URI where instance MonadThrow H.Compiler where throwM = throwError . pure . displayException + +-- | 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 diff --git a/src/WWW/Base.hs b/src/WWW/Base.hs index 7c752da..ab4f214 100644 --- a/src/WWW/Base.hs +++ b/src/WWW/Base.hs @@ -3,11 +3,14 @@ module WWW.Base , baseHakyll , domain , wwwRoot + , myHakyllReaderOptions + , myHakyllWriterOptions ) where import Prolog import Hakyll import System.Process +import Text.Pandoc.Options -- | mathematicaster.org @@ -34,3 +37,11 @@ baseConfig p = defaultConfiguration baseHakyll :: MonadIO m => FilePath -> Rules a -> m () baseHakyll p = liftIO . hakyllWith (baseConfig p) + +myHakyllReaderOptions :: ReaderOptions +myHakyllReaderOptions = defaultHakyllReaderOptions + +myHakyllWriterOptions :: WriterOptions +myHakyllWriterOptions = defaultHakyllWriterOptions + { writerHTMLMathMethod = MathJax mempty + } diff --git a/src/WWW/HW.hs b/src/WWW/HW.hs index 1ce601f..9387961 100644 --- a/src/WWW/HW.hs +++ b/src/WWW/HW.hs @@ -1,6 +1,8 @@ module WWW.HW ( removeEnv , removeSolutions + , setDocLocation + , setDocLocation_ -- * LaTeX utils , LaTeX (..) , texmap @@ -9,13 +11,28 @@ module WWW.HW , module Hakyll.TeX.LaTeX ) where --- import Prolog +import Prolog +import Hakyll import Hakyll.TeX.HaTeX import Hakyll.TeX.LaTeX +import Network.URI import Text.LaTeX.Base.Syntax +import Text.LaTeX.Packages.Hyperref removeEnv :: (String -> Bool) -> LaTeX -> LaTeX removeEnv p = texmap (\case { TeXEnv s _ _ -> p s; _ -> False }) $ pure mempty removeSolutions :: LaTeX -> LaTeX removeSolutions = removeEnv (== "solution") + +setDocLocation :: URI -> (String -> [TeXArg] -> Bool) -> Item LaTeX -> Compiler (Item LaTeX) +setDocLocation u p (Item i l) = Item i <$> texmapM (\case { TeXComm _ _ -> True; _ -> False }) mapper l + where + mapper = \case + TeXComm s args | p s args -> do + relpath <- getRoute i >>= maybe (fail $ show i <> " has no route") pure >>= maybe (fail $ "Cannot parse " <> show i <> " as a relative URI") pure . parseRelativeReference + pure $ TeXComm s [ FixArg $ url $ toSL $ relpath `relativeTo` u ] + x -> pure x + +setDocLocation_ :: URI -> Item LaTeX -> Compiler (Item LaTeX) +setDocLocation_ u = setDocLocation u $ \s _ -> s == "doclink" diff --git a/src/WWW/Templates.hs b/src/WWW/Templates.hs index 0068a07..f73236e 100644 --- a/src/WWW/Templates.hs +++ b/src/WWW/Templates.hs @@ -13,6 +13,7 @@ import Prolog import Hakyll import Hakyll.TeX.TikZ (tikzTemplate) +import Hakyll.Web.Template.Util (slug) defaultTemplate :: Template @@ -29,5 +30,6 @@ myContext :: Context String myContext = fold [ constField "personalEmail" "chris@mathematicaster.org" , constField "workEmail" "coc0014@auburn.edu" + , slug , defaultContext ] |
