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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
{-
- 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
|
