src/Templates.hs Modified

@@ -1,12 +1,21 @@
 {-# Language LambdaCase #-}
 
 module Templates (
+    -- The Template data type and its constructors.
     Template,
+    templatePath,
     templateGinger,
+    -- The Env data type and its constructors.
+    Env,
+    envConfig,
+    envTemplates,
+    envIndexTemplate,
+    envCommitTemplate,
+    envFileTemplate,
+    -- The entrypoint used by main.
     loadTemplates,
-    loadTemplate,
+    -- The core functionality for which templates are used.
     generate,
-    templatePath,
 ) where
 
 import Control.Monad (filterM, (<=<))
@@ -24,7 +33,19 @@
 import Text.Ginger.Html (htmlSource, Html)
 import Text.Ginger.Run (easyRenderM, Run, RuntimeError)
 
-import Config (Config, templateDirectory, indexTemplate, commitTemplate, fileTemplate)
+import Config
+
+{-
+The Env data type represents all of the program's state, including user configuration
+and loaded template data. This can be accessed as immutable global state at any point.
+-}
+data Env = Env
+    { envConfig :: Config
+    , envTemplates :: [Template]
+    , envIndexTemplate :: Maybe Template
+    , envCommitTemplate :: Maybe Template
+    , envFileTemplate :: Maybe Template
+    }
 
 data Template = Template
     { templatePath :: FilePath
@@ -32,16 +53,43 @@
     }
 
 {-
-This takes the session's `Config` and returns the set of available templates loaded from
-files found in the template directory, excluding the index template if it is in the same
-directory.
+This creates the runtime environment, collecting the config and loading template data
+from file.
 -}
-loadTemplates :: Config -> IO [Template]
+loadTemplates :: Config -> IO Env
 loadTemplates config = do
+    -- Custom templates
     files <- getFiles config
-    let files' = filter ((/=) $ indexTemplate config) files
-    parsed <- sequence $ parseGingerFile includeResolver <$> files'
-    return $ zipWith ($) (Template <$> files') (rights parsed)
+    parsed <- sequence $ parseGingerFile includeResolver <$> files
+    let templates = zipWith ($) (Template <$> files) (rights parsed)  -- TODO: lefts not filtered from files
+    -- Scoped templates
+    indexT <- loadTemplate $ indexTemplate config
+    commitT <- loadTemplate $ commitTemplate config
+    fileT <- loadTemplate $ fileTemplate config
+    -- Global environment
+    return Env { envConfig = config
+    , envTemplates = templates
+    , envIndexTemplate = indexT
+    , envCommitTemplate = commitT
+    , envFileTemplate = fileT
+    }
+
+{-
+This is the generator function that receives repository-specific variables and uses
+Ginger to render templates using them.
+-}
+generate
+    :: FilePath
+    -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
+    -> Template
+    -> IO (Either (RuntimeError SourcePos) (GVal (Run SourcePos IO Html)))
+generate output context template = do
+    let target = (</>) output . takeFileName . templatePath $ template
+    writeFile target ""  -- Clear contents of file if it exists
+    easyRenderM (writeTo target) context . templateGinger $ template
+
+----------------------------------------------------------------------------------------
+-- Private -----------------------------------------------------------------------------
 
 {-
 This takes the session's `Config` and maybe returns a loaded template for the
@@ -54,8 +102,6 @@
         print . peErrorMessage $ err
         return Nothing
 
-----------------------------------------------------------------------------------------
-
 {-
 This is a Ginger `IncludeResolver` that will eventually be extended to enable caching of
 includes.
@@ -103,17 +149,3 @@
 -}
 writeTo :: FilePath -> Html -> IO ()
 writeTo path = appendFile path . unpack . htmlSource
-
-{-
-This is the generator function that receives repository-specific variables and uses
-Ginger to render templates using them.
--}
-generate
-    :: FilePath
-    -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
-    -> Template
-    -> IO (Either (RuntimeError SourcePos) (GVal (Run SourcePos IO Html)))
-generate output context template = do
-    let target = (</>) output . takeFileName . templatePath $ template
-    writeFile target ""  -- Clear contents of file if it exists
-    easyRenderM (writeTo target) context . templateGinger $ template

src/Repositories.hs Modified

@@ -29,53 +29,34 @@
 import Text.Ginger.Parse (SourcePos)
 import qualified Data.HashMap.Strict as HashMap
 
-import Config (Config, repoPaths, outputDirectory, host)
-import Templates (Template, generate, templatePath)
+import Config
+import Templates
 
 {-
 This is the entrypoint that receives the ``Config`` and uses it to map over our
 repositories, reading from them and writing out their web pages using the given
 templates.
 -}
-run
-    :: Config
-    -> [Template]
-    -> Maybe Template
-    -> Maybe Template
-    -> Maybe Template
-    -> IO ()
-run config templates indexT commitT fileT = do
-    foldMap (processRepo config templates commitT fileT) . repoPaths $ config
-    runIndex config indexT
+run :: Env -> IO ()
+run env = do
+    foldMap (processRepo env) . repoPaths . envConfig $ env  -- TODO: make concurrent
+    runIndex (envConfig env) (envIndexTemplate env)
 
 ----------------------------------------------------------------------------------------
+-- Private -----------------------------------------------------------------------------
 
 {-
 This receives a file path to a single repository and tries to process it. If the
 repository doesn't exist or is unreadable in any way we can forget about it and move on
 (after informing the user of course).
 -}
-processRepo
-    :: Config
-    -> [Template]
-    -> Maybe Template
-    -> Maybe Template
-    -> FilePath
-    -> IO ()
-processRepo config templates commitT fileT path = withRepository lgFactory path $
-    processRepo' config templates commitT fileT path
+processRepo :: Env -> FilePath -> IO ()
+processRepo env path = withRepository lgFactory path $ processRepo' env path
 
--- This is split out to make type reasoning a bit easier.
-processRepo'
-    :: Config
-    -> [Template]
-    -> Maybe Template
-    -> Maybe Template
-    -> FilePath
-    -> ReaderT LgRepo IO ()
-processRepo' config templates commitT fileT path = do
+processRepo' :: Env -> FilePath -> ReaderT LgRepo IO ()
+processRepo' env path = do
     let name = takeFileName path
-    let output = outputDirectory config </> name
+    let output = outputDirectory (envConfig env) </> name
     liftIO $ createDirectoryIfMissing True output
     resolveReference "HEAD" >>= \case
         Nothing -> liftIO . print $ "gitserve: " <> name <> ": Failed to resolve HEAD."
@@ -94,12 +75,12 @@
             tree <- getTree gitHead
 
             -- Run the generator --
-            let repo = package config name description commits tree
-            liftIO . mapM (generate output repo) $ templates
-            let commitScope = packageCommit config name description
-            liftIO . mapM (generateCommit config name commitScope commitT) $ commits
-            let fileScope = packageFile config name description
-            liftIO . mapM (generateFile config name fileScope fileT) $ tree
+            let repo = package env name description commits tree
+            liftIO . mapM (generate output repo) $ envTemplates env
+            let commitScope = packageCommit env name description
+            liftIO . mapM (generateCommit output commitScope $ envCommitTemplate env) $ commits
+            let fileScope = packageFile env name description
+            liftIO . mapM (generateFile output fileScope $ envFileTemplate env) $ tree
             return ()
 
 {-
@@ -109,15 +90,15 @@
 hashmap which Ginger can use to look up variables.
 -}
 package
-    :: Config
+    :: Env
     -> FilePath
     -> Text
     -> [Commit LgRepo]
     -> [TreeFile]
     -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
-package config name description commits tree = HashMap.fromList
-    [ ("host", toGVal $ host config)
-    , ("name", toGVal $ pack name)
+package env name description commits tree = HashMap.fromList
+    [ ("host", toGVal . host . envConfig $ env)
+    , ("name", toGVal . pack $ name)
     , ("description", toGVal description)
     , ("commits", toGVal . reverse $ commits)  -- Could be optimised
     , ("tree", toGVal tree)
@@ -242,30 +223,28 @@
 ----------------------------------------------------------------------------------------
 
 generateCommit
-    :: Config
-    -> FilePath
+    :: FilePath
     -> (Commit LgRepo -> HashMap.HashMap Text (GVal (Run SourcePos IO Html)))
     -> Maybe Template
     -> Commit LgRepo
     -> IO ()
-generateCommit _ _ _ Nothing _ = return ()
-generateCommit config name scope (Just template) commit = do
+generateCommit _ _ Nothing _ = return ()
+generateCommit output scope (Just template) commit = do
     let hash = unpack . renderObjOid . commitOid $ commit
     let template' = template { templatePath = hash ++ ".html" }
-    let output = outputDirectory config </> name </> "commits"
-    liftIO $ createDirectoryIfMissing True output
-    generate output (scope commit) template'
+    liftIO $ createDirectoryIfMissing True (output </> "commits")
+    generate (output </> "commits") (scope commit) template'
     return ()
 
 packageCommit
-    :: Config
+    :: Env
     -> FilePath
     -> Text
     -> Commit LgRepo
     -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
-packageCommit config name description commit = HashMap.fromList
-    [ ("host", toGVal $ host config)
-    , ("name", toGVal $ pack name)
+packageCommit env name description commit = HashMap.fromList
+    [ ("host", toGVal . host . envConfig $ env)
+    , ("name", toGVal . pack $ name)
     , ("description", toGVal description)
     , ("commit", toGVal commit)
     ]
@@ -273,30 +252,28 @@
 -- TODO: DRY
 
 generateFile
-    :: Config
-    -> FilePath
+    :: FilePath
     -> (TreeFile -> HashMap.HashMap Text (GVal (Run SourcePos IO Html)))
     -> Maybe Template
     -> TreeFile
     -> IO ()
-generateFile _ _ _ Nothing _ = return ()
-generateFile config name scope (Just template) file = do
+generateFile _ _ Nothing _ = return ()
+generateFile output scope (Just template) file = do
     let path = unpack . replace "/" "." . decodeUtf8 . treeFilePath $ file
     let template' = template { templatePath = path ++ ".html" }
-    let output = outputDirectory config </> name </> "files"
-    liftIO $ createDirectoryIfMissing True output
-    generate output (scope file) template'
+    liftIO $ createDirectoryIfMissing True (output </> "files")
+    generate (output </> "files") (scope file) template'
     return ()
 
 packageFile
-    :: Config
+    :: Env
     -> FilePath
     -> Text
     -> TreeFile
     -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
-packageFile config name description file = HashMap.fromList
-    [ ("host", toGVal $ host config)
-    , ("name", toGVal $ pack name)
+packageFile env name description file = HashMap.fromList
+    [ ("host", toGVal . host . envConfig $ env)
+    , ("name", toGVal . pack $ name)
     , ("description", toGVal description)
     , ("file", toGVal file)
     ]

src/Main.hs Modified

@@ -4,15 +4,9 @@
     main
 ) where
 
-import Config (getConfig, indexTemplate, commitTemplate, fileTemplate)
+import Config (getConfig)
+import Templates (loadTemplates)
 import Repositories (run)
-import Templates (loadTemplates, loadTemplate)
 
 main :: IO ()
-main = do
-    config <- getConfig "./config.dhall"
-    templates <- loadTemplates config
-    indexT <- loadTemplate $ indexTemplate config
-    commitT <- loadTemplate $ commitTemplate config
-    fileT <- loadTemplate $ fileTemplate config
-    run config templates indexT commitT fileT
+main = getConfig "./config.dhall" >>= loadTemplates >>= run