99 lines
3.3 KiB
Haskell
99 lines
3.3 KiB
Haskell
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
|