diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Data/Name.hs | 76 | ||||
| -rw-r--r-- | src/Data/Person.hs | 31 | ||||
| -rw-r--r-- | src/Hakyll/TeX/BibTeX.hs | 2 | ||||
| -rw-r--r-- | src/Prolog.hs | 28 | ||||
| -rw-r--r-- | src/WWW/HW.hs | 2 |
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 |