blog/blog-meta/lib/Misc.hs

100 lines
3.3 KiB
Haskell
Raw Normal View History

2021-07-23 21:35:02 -04:00
module Misc where
import qualified System.Console.GetOpt as GetOpt
import System.Environment
import System.Exit
import Data.Text (Text)
2024-09-16 13:45:50 -04:00
import Data.Time
import qualified Data.Text as Text
import Data.Char (isAlphaNum, isAscii, toLower)
import Text.Pandoc.Definition
2021-07-23 21:35:02 -04:00
-- | exception on 'Left'
unwrap :: Show a => FilePath -> Either a b -> IO b
unwrap file = either (\x -> fail $ file <> ":" <> show x) return
2024-09-16 13:45:50 -04:00
-- | @getOptionsWith hdr start opts@:
--
-- * calls 'getOpt' on the command line arguments
-- * if there are no unrecognised flags, calls 'start' on the non-option
-- arguments, and then applies the functions from the options to the result of
-- that
-- * otherwise it shows a usage message where the header is 'hdr' applied to the
-- executable name
2021-07-23 21:35:02 -04:00
getOptionsWith :: (String -> String) -> ([String] -> Maybe a)
-> [GetOpt.OptDescr (a -> a)] -> IO a
getOptionsWith hdr mkDef descrs = do
res <- GetOpt.getOpt GetOpt.Permute descrs <$> getArgs
case res of
(fs, rest, []) | Just def <- mkDef rest ->
return $ foldl (flip ($)) def fs
_ -> do
prog <- getProgName
putStrLn $ GetOpt.usageInfo (hdr prog) descrs
exitFailure
2024-09-16 13:45:50 -04:00
-- | makes a url slug by:
--
-- * replacing all sequences of non-ascii or non-alphanumeric characters with
-- @"-"@
-- * lowercasing all (ascii) letters
makeSlug :: Text -> Text
2024-09-15 11:39:37 -04:00
makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where
chunks txt =
if Text.null txt then [] else
let (this', that') = Text.span isOK txt
this = Text.map toLower this'
that = Text.dropWhile (not . isOK) that' in
this : chunks that
isOK c = (isAlphaNum c && isAscii c) || c == '-'
2024-09-16 13:45:50 -04:00
-- | tries to convert a meta value to a list of strings
toTextList :: MetaValue -> Maybe [Text]
toTextList (MetaList vs) = traverse toText vs
toTextList _ = Nothing
2024-09-16 13:45:50 -04:00
-- | tries to convert a meta value to a single string
toText :: MetaValue -> Maybe Text
toText (MetaString str) = Just str
toText (MetaInlines is) = foldMap inlineText is
toText (MetaBlocks bs) = foldMap blockText bs
toText _ = Nothing
2024-09-16 13:45:50 -04:00
-- | converts a pandoc inline into a string, if it contains only text.
inlineText :: Inline -> Maybe Text
inlineText (Str txt) = Just txt
inlineText Space = Just " "
inlineText SoftBreak = Just " "
inlineText LineBreak = Just " "
inlineText (RawInline _ txt) = Just txt
inlineText _ = Nothing
2024-09-16 13:45:50 -04:00
-- | converts a pandoc inline into a string, if it contains only paragraphs of
-- text.
blockText :: Block -> Maybe Text
blockText (Plain is) = foldMap inlineText is
2024-09-16 13:45:50 -04:00
blockText (Para is) = foldMap (fmap (<> "\n\n") . inlineText) is
blockText (RawBlock _ txt) = Just txt
blockText _ = Nothing
2024-09-16 13:45:50 -04:00
-- | date in YYYY-MM-DD format
newtype IsoDate = ID Day deriving (Eq, Ord)
-- | actually allows one-digit months and days
parseIsoDate :: MonadFail f => Text -> f IsoDate
parseIsoDate =
fmap ID . parseTimeM True defaultTimeLocale "%Y-%-m-%-d" . Text.unpack
-- | formats a date in the RSS format, e.g. @Mon, 09 Sep 2024 00:00:01 UT@
rssDate :: IsoDate -> Text
rssDate (ID d) =
Text.pack $ formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d
-- | formats a date in a format i like, e.g. @mon 9 sep 2024@
showDate :: IsoDate -> Text
showDate (ID d) =
Text.pack $ toLower <$> formatTime defaultTimeLocale "%a %-d %B %Y" d