stack.yaml Modified

@@ -10,4 +10,7 @@
 
 # These options are from the Kowainik style guide.
 ghc-options:
-  "$locals": -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -Wmissing-deriving-strategies -Wunused-packages
+  "$locals": -Wall -Wcompat -Widentities -Wincomplete-uni-patterns
+    -Wincomplete-record-updates -Wredundant-constraints -Wmissing-export-lists
+    -Wpartial-fields -Wmissing-deriving-strategies -Wunused-packages
+    -fno-warn-unused-do-bind

src/Templates.hs Modified

@@ -9,17 +9,16 @@
 
 import Control.Monad (filterM, (<=<))
 import Data.Char (toLower)
-import Data.Either (rights, Either)
+import Data.Either (rights)
 import Data.List (isSuffixOf)
-import Data.Maybe (catMaybes)
 import Data.Text (unpack, Text)
 import qualified Data.HashMap.Strict as HashMap
 import System.Directory (doesFileExist, getDirectoryContents)
-import System.FilePath ((</>), FilePath)
+import System.FilePath ((</>))
 import System.IO.Error (tryIOError)
 import qualified Text.Ginger.AST as G
 import qualified Text.Ginger.Parse as G
-import Text.Ginger.GVal (toGVal, GVal, ToGVal)
+import Text.Ginger.GVal (GVal)
 import Text.Ginger.Html (htmlSource, Html)
 import Text.Ginger.Run (easyRenderM, Run, RuntimeError)
 
@@ -58,11 +57,10 @@
 HTML/CSS/JS files.
 -}
 isTemplate :: FilePath -> IO Bool
-isTemplate path = (&&) (isTemplate' path) <$> doesFileExist path
+isTemplate path = (&&) (isTemplate' (map toLower path)) <$> doesFileExist path
   where
-    p = map toLower path
     isTemplate' :: FilePath -> Bool
-    isTemplate' path = isSuffixOf "html" p || isSuffixOf "css" p || isSuffixOf "js" p
+    isTemplate' p = isSuffixOf "html" p || isSuffixOf "css" p || isSuffixOf "js" p
 
 {-
 This wraps getDirectoryContents so that we get a list of fully qualified paths of the

src/Repositories.hs Modified

@@ -6,20 +6,18 @@
 ) where
 
 import Conduit (runConduit, (.|), sinkList)
-import Control.Monad ((<=<))
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Reader (ReaderT)
 import Data.Either (fromRight)
-import Data.Foldable (foldMap)
 import Data.Tagged
-import Data.Text (Text)
+import Data.Text (pack, Text)
+import Data.Maybe (catMaybes)
 import Git
-import Git.Types (RefTarget)
 import Git.Libgit2 (lgFactory, LgRepo)
-import qualified Data.HashMap.Strict as HashMap
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath ((</>), takeFileName)
 import System.IO.Error (tryIOError)
+import qualified Data.HashMap.Strict as HashMap
 
 import Config (Config, repoPaths, outputDirectory)
 import Templates (Template, generate)
@@ -40,28 +38,28 @@
 (after informing the user of course).
 -}
 processRepo :: [Template] -> FilePath -> FilePath -> IO ()
-processRepo templates outputDirectory path = withRepository lgFactory path $
-    processRepo' templates outputDirectory path
+processRepo templates directory path = withRepository lgFactory path $
+    processRepo' templates directory path
 
 -- This is split out to make type reasoning a bit easier.
 processRepo' :: [Template] -> FilePath -> FilePath -> ReaderT LgRepo IO ()
-processRepo' templates outputDirectory path = do
+processRepo' templates directory path = do
     liftIO $ createDirectoryIfMissing True outPath
     resolveReference "HEAD" >>= \case
         Nothing -> liftIO . print $ "gitserve: " <> name <> ": Failed to resolve HEAD."
         Just commitID -> do
-            let head = Tagged commitID
-            -- Variables available in the ginger templates --
+            let gitHead = Tagged commitID
+            -- Variables available in the ginger templates: --
 
             -- description: The description of the repository from repo/description, if
-            -- it exists
+            -- it exists.
             description <- liftIO $ getDescription $ outPath </> "description"
 
             -- commits: A list of `Git.Commit` objects to HEAD.
-            commits <- getCommits head
+            commits <- getCommits gitHead
 
             -- tree: A list of `(TreeFilePath, TreeEntry r)` objects at HEAD.
-            tree <- getTree head
+            tree <- getTree gitHead
 
             -- Run the generator --
             let repo = package description commits tree
@@ -69,25 +67,32 @@
             return ()
   where
     name = takeFileName path
-    outPath = outputDirectory </> name
+    outPath = directory </> name
 
 getCommits :: CommitOid LgRepo -> ReaderT LgRepo IO [Commit LgRepo]
-getCommits commitID = mapM loadCommit <=<
-    runConduit $ sourceObjects Nothing commitID False .| sinkList
+getCommits commitID = do
+    oids <- runConduit $ sourceObjects Nothing commitID False .| sinkList
+    sequence . catMaybes $ loadCommit <$> oids
 
-loadCommit :: ObjectOid LgRepo -> ReaderT LgRepo IO (Commit LgRepo)
-loadCommit (CommitObjOid oid) = lookupCommit oid
+loadCommit :: ObjectOid LgRepo -> Maybe (ReaderT LgRepo IO (Commit LgRepo))
+loadCommit (CommitObjOid oid) = Just $ lookupCommit oid
+loadCommit _ = Nothing
 
 getTree :: CommitOid LgRepo -> ReaderT LgRepo IO [(TreeFilePath, TreeEntry LgRepo)]
 getTree commitID = do
-    head <- lookupCommit commitID
-    lookupTree (commitTree head) >>= listTreeEntries
+    gitHead <- lookupCommit commitID
+    lookupTree (commitTree gitHead) >>= listTreeEntries
 
-getDescription :: FilePath -> IO String
-getDescription path = fromRight "" <$> tryIOError (readFile path)
+getDescription :: FilePath -> IO Text
+getDescription path = fromRight "" <$> tryIOError (pack <$> readFile path)
 
+package
+    :: Text
+    -> [Commit LgRepo]
+    -> [(TreeFilePath, TreeEntry r)]
+    -> HashMap.HashMap Text Text
 package description commits tree = HashMap.fromList
     [ ("commits", "commits")
-    , ("description", "description")
+    , ("description", description)
     , ("tree", "tree")
     ]

src/Main.hs Modified

@@ -1,5 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Main where
+
+module Main (
+    main
+) where
 
 import Config (getConfig)
 import Repositories (run)

src/Config.hs Modified

@@ -5,8 +5,8 @@
     Config,
     repoPaths,
     templateDirectory,
-    outputDirectory,
-    getConfig
+    getConfig,
+    outputDirectory
 ) where
 
 import Dhall