Merge branch 'mk-howtocards-fixes' into 'master'

updates required for howto-cards

See merge request lcsb/sps/reploy!5

1 files changed, 20 insertions, 1 deletions

diff --git a/Utils.hs b/Utils.hs
index 4426b68..9c901cc 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -22,12 +22,13 @@ 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 System.FilePath ((</>), takeDirectory)
+import System.FilePath ((</>), splitDirectories, takeDirectory)
 import Text.Pandoc.Definition
 import qualified Text.Pandoc.Walk
 import Types
@@ -116,6 +117,24 @@ getRecursiveContents ignore top = go ""
                 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 ()