blog/blog-meta/lib/Misc.hs

module Misc where

import qualified System.Console.GetOpt as GetOpt
import System.Environment
import System.Exit
import Data.Text (Text)
import Data.Time
import qualified Data.Text as Text
import Data.Char (isAlphaNum, isAscii, toLower)
import Text.Pandoc.Definition

-- | exception on 'Left'
unwrap :: Show a => FilePath -> Either a b -> IO b
unwrap file = either (\x -> fail $ file <> ":" <> show x) return

-- | @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
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

-- | makes a url slug by:
--
-- * replacing all sequences of non-ascii or non-alphanumeric characters with
--   @"-"@
-- * lowercasing all (ascii) letters
makeSlug :: Text -> Text
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 == '-'


-- | tries to convert a meta value to a list of strings
toTextList :: MetaValue -> Maybe [Text]
toTextList (MetaList vs) =  traverse toText vs
toTextList _ = Nothing

-- | 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

-- | 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

-- | converts a pandoc inline into a string, if it contains only paragraphs of
-- text.
blockText :: Block -> Maybe Text
blockText (Plain is)       = foldMap inlineText is
blockText (Para  is)       = foldMap (fmap (<> "\n\n") . inlineText) is
blockText (RawBlock _ txt) = Just txt
blockText _                = Nothing


-- | 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