1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
{-
- 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 System.Directory
( createDirectoryIfMissing
, doesDirectoryExist
, getDirectoryContents
)
import System.FilePath ((</>), 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)
-- | 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
-- | 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
|
