reploy/Utils.hs

{-
 - Copyright (C) 2023 University of Luxembourg
 -
 - Licensed under the Apache License, Version 2.0 (the "License"); you may not
 - use this file except in compliance with the License. You may obtain a copy
 - of the License from the LICENSE file in this repository, or at:
 -
 - http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
 - WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
 - License for the specific language governing permissions and limitations
 - under the License.
 -}
{-# LANGUAGE OverloadedStrings #-}

module Utils where

import Control.Monad (filterM, forM)
import Control.Monad.IO.Class
import Data.List.Extra (stripSuffix)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Lens.Micro.Mtl
import System.Directory
  ( createDirectoryIfMissing
  , doesDirectoryExist
  , getDirectoryContents
  )
import qualified System.FilePath
import System.FilePath (splitDirectories, takeDirectory)
import Text.Pandoc.Definition
import qualified Text.Pandoc.Walk
import Types

-- | A shortcut for `liftIO`.
io :: MonadIO m => IO a -> m a
io = liftIO

-- | A helper for throwing an error if something is `Nothing`
just :: String -> Maybe a -> a
just _ (Just val) = val
just err Nothing = error ("Missing: " ++ err)

-- | Test for whether something listy has a suffix
hasSuffix :: Eq a => [a] -> [a] -> Bool
hasSuffix s = isJust . stripSuffix s

-- | The same second as from arrows et al.
second :: (a -> b) -> (c, a) -> (c, b)
second f (a, b) = (a, f b)

-- | A pandoc walker for modifying the URLs.
walkURLs ::
     (FilePath -> Site FilePath)
  -> Text.Pandoc.Definition.Pandoc
  -> Site Text.Pandoc.Definition.Pandoc
walkURLs f = Text.Pandoc.Walk.walkM go
  where
    go (Link a i (u, t)) = do
      u' <- T.pack <$> f (T.unpack u)
      pure $ Link a i (u', t)
    go (Image a i (u, t)) = do
      u' <- T.pack <$> f (T.unpack u)
      pure $ Image a i (u', t)
    go x = pure x

-- | A pandoc walker for adding the local links to the headings (links are
-- appended and get a given class)
addHeadingLinks ::
     T.Text -> Text.Pandoc.Definition.Pandoc -> Text.Pandoc.Definition.Pandoc
addHeadingLinks cls = Text.Pandoc.Walk.walk go
  where
    go h@(Header lvl attr@(id, _, _) inlines) =
      Header
        lvl
        attr
        (inlines
           ++ [ Link
                  ("", [cls], [])
                  [Str "#"]
                  ("#" <> id, "Link to this section")
              ])
    go x = x

-- | @"https://example.com" `hasUriScheme` "https"@
hasUriScheme :: String -> String -> Bool
hasUriScheme x = all id . zipWith (==) x . (++ ":")

-- | @unAbsolute "/root/path" == "root/path"@
unAbsolute :: String -> String
unAbsolute = dropWhile (== '/')

-- | Lift a function that processes `Block`s to a function that -- processes a
-- `Pandoc`.
withPandocBlocks :: ([Block] -> [Block]) -> Pandoc -> Pandoc
withPandocBlocks f (Pandoc meta blocks) = Pandoc meta (f blocks)

infixr 5 </>

a </> b@('/':_) =
  error
    $ "internal error: unchecked concatenation of absolute path: "
        ++ a
        ++ " </> "
        ++ b
a </> b = (System.FilePath.</>) a b

-- | Get all contents of a directory. (Interned from Hakyll.)
getRecursiveContents ::
     (FilePath -> IO Bool) -- ^ Ignore this file/directory
  -> FilePath -- ^ Directory to search
  -> IO [FilePath] -- ^ List of files found
getRecursiveContents ignore top = go ""
  where
    isProper x
      | x `elem` [".", ".."] = return False
      | otherwise = not <$> ignore x
    go dir = do
      dirExists <- doesDirectoryExist (top </> dir)
      if not dirExists
        then return []
        else do
          names <- filterM isProper =<< getDirectoryContents (top </> dir)
          paths <-
            forM names $ \name -> do
              let rel = dir </> name
              isDirectory <- doesDirectoryExist (top </> rel)
              if isDirectory
                then go rel
                else return [rel]
          return $ concat paths

-- | A nice tool interned from Relude.
foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
foldMapM f xs = foldr step return xs mempty
  where
    step x r z = f x >>= \y -> r $! z `mappend` y

-- | Source paths from a source-y directory. The paths that have to be ignored
-- by config `notSourceDirs` are omitted.
sourcePaths :: Monoid a => FilePath -> (FilePath -> Site a) -> Site a
sourcePaths fp process = do
  notSource <- use notSourceDirs
  let ignoreDir ds
        | null ds = False
        | last ds `elem` notSource = True
        | otherwise = False
  io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp)
    >>= foldMapM process

-- | Given a path to a file, try to make the path writable by making all
-- directories on the path. (Interned from Hakyll.)
makeDirectories :: FilePath -> IO ()
makeDirectories = createDirectoryIfMissing True . takeDirectory