diff options
Diffstat (limited to 'site.hs')
| -rw-r--r-- | site.hs | 76 |
1 files changed, 58 insertions, 18 deletions
@@ -119,20 +119,24 @@ checkTarget fp = do then error $ "colliding renders for page: " ++ fp else targets %= S.insert fp +-- | Prepend the root path to the given link +rootUrl :: FilePath -> Site FilePath +rootUrl = pure . ('/' :) + -- | Process a single link pointing out from a page. processLink :: FilePath -> String -> Site String processLink base l = do if isAbsolute l - then pure l + then pure l -- TODO prepend the root url else (do io . putStrLn $ "rel:" ++ l pure $ '/' : (base </> l) -- TODO ) -- | Get a mount point of the page into the correct location. pageFilename :: FilePath -> Site FilePath -pageFilename p = indexFilename $ "page" </> p +pageFilename = indexFilename --- | Like `Mu.substitute` but writes and throws stuff on errors +-- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors checkedSubstitute :: Mu.Template -> Y.Value -> IO T.Text checkedSubstitute t v = do let (es, txt) = Mu.checkedSubstitute t v @@ -183,7 +187,7 @@ dataFilename :: String -> FilePath -> Site (FilePath, FilePath) dataFilename hash basename = do od <- use outputDir let (h1, h2) = splitAt 3 hash - loc = "data" </> h1 </> h2 </> basename + loc = "files" </> h1 </> h2 </> basename pure (od </> loc, loc) -- | Copy a source file to the destination, making the necessary directories in the process. @@ -247,31 +251,67 @@ invTags x = tagFilename :: FilePath -> Site FilePath tagFilename tag = indexFilename $ "tag" </> tag +-- | Fold the hierarchical tag bits to a slashed path. +tagPath :: [String] -> FilePath +tagPath = foldr (</>) "" + +-- | Make a link to the tag page +tagLink :: [String] -> Site FilePath +tagLink = rootUrl . ("tag" </>) . tagPath + +-- | Make metadata for printing out a single hierarchical tag (all levels clickable) +makeHTagMeta :: [String] -> Site Y.Value +makeHTagMeta tag = do + links <- zip (Y.Null:map fromString tag) . map fromString <$> traverse tagLink (inits tag) + pure . Y.array $ + map + (\(t, p) -> Y.object [("tag", t), ("href", p)]) + links + +-- | Make metadata for printing out a single tag as-is, without levels +makeHTagLinkMeta :: [String] -> Site Y.Value +makeHTagLinkMeta tag = do + link <- tagLink tag + pure $ + Y.object [("href", fromString link), ("tags", Y.array $ map fromString tag)] + +makePageLinkMeta :: FilePath -> Site Y.Value +makePageLinkMeta mount = do + link <- rootUrl mount + meta <- use $ pages . to (M.! mount) . pageMeta + pure $ Y.object [("href", fromString link), ("meta", meta)] + +-- | Create the complete metadata structure for the template that renders a given tag page +makeTagMeta :: [String] -> Site Y.Value +makeTagMeta tag = do + taggedPages <- use $ htags . to (M.! tag) + subtags <- + gets + (^.. htags . to M.keys . each . filtered (not . null) . + filtered ((== tag) . init)) + htagMeta <- makeHTagMeta tag + subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags + pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages + pure $ + Y.object + [("htag", htagMeta), ("subtags", subtagsMeta), ("pages", pagesMeta)] + -- | Render a site for a given tag string. -renderTag :: [String] -> [FilePath] -> Site () -renderTag tag pages = do +renderTag :: [String] -> Site () +renderTag tag = do tname <- use tagTemplate templ <- use $ templates . to (M.! fromString tname) - let tagpath = foldr (</>) mempty tag - file <- tagFilename tagpath + file <- tagFilename (tagPath tag) checkTarget file + meta <- makeTagMeta tag io $ do putStrLn $ "# -> " ++ file makeDirectories file - let str = fromString - arr = Y.array - meta = - Y.Object $ - KM.fromList - [ ("tagpath", str tagpath) - , ("tag", arr $ map str tag) - , ("pages", arr $ map str pages) - ] checkedSubstitute templ meta >>= TIO.writeFile file -- | Render all tag sites. renderTags :: Site () -renderTags = use (htags . to M.assocs) >>= traverse_ (uncurry renderTag) +renderTags = use (htags . to M.keys) >>= traverse_ renderTag -- | Build the whole site. main = |