From b4c02352143c05fdbe35629bed63f6ad32cbd313 Mon Sep 17 00:00:00 2001 From: Thomas Ulmer Date: Wed, 3 Jun 2026 16:36:21 -0700 Subject: header and footer cli args --- src/Main.hs | 74 ++++++++++++++++++++++--------------------------------------- 1 file changed, 26 insertions(+), 48 deletions(-) (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 2e80a6a..3499403 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,40 +25,6 @@ prettyName :: FilePath -> String {- XXX more -} prettyName f = takeBaseName $ dropExtension f -header :: T.Text -> T.Text -> T.Text -header title nav = T.unlines - [ T.pack "" - , T.pack "" - , T.pack " " - , T.pack " " - , T.concat [T.pack " " , title , T.pack "" ] - , T.pack " " - , T.pack " " - , T.pack " " - , T.pack " " - , T.pack "
" - , T.pack "
" - , T.pack "

" - , T.pack " Professional Webring >>" - , T.pack " Prev - Roscoe" - , T.pack " |" - , T.pack " Next - Elle" - , T.pack "

" - , T.pack "
" - , T.concat [ T.pack "" ] - , T.pack "
" - , T.pack "
" - ] - -footer :: T.Text -footer = T.pack $ unlines - [ "
" - , "" - , "" - , "" - ] - parse :: FilePath -> IO (T.Text, T.Text) {- XXX use T.hGetLine to try to delay the memory cost. @@ -149,13 +115,13 @@ fallbackIndexNav p ns = NavFile (fallbackIndexFrag p ns) (T.pack . takeFileName fallbackIndexFrag :: FilePath -> [Nav] -> T.Text fallbackIndexFrag _ _ = (T.pack "

Fallback index.

") -generate :: T.Text -> Nav -> T.Text +generate :: (T.Text -> T.Text -> T.Text, T.Text) -> T.Text -> Nav -> T.Text {- Generate the full text of a page. -} -generate nav (NavFile f t _) = +generate (header, footer) nav (NavFile f t _) = T.concat [ header t nav , f , footer ] -generate nav (NavDir _ (NavFile f t _) _) = +generate (header, footer) nav (NavDir _ (NavFile f t _) _) = T.concat [ header t nav , f , footer ] -generate _ _ = error "malformed NavDir" +generate _ _ _ = error "malformed NavDir" mkNavItem :: Nav -> T.Text {- Generate a listing for a file or a listing for a dir and optionally @@ -169,11 +135,11 @@ mkNavItem (NavFile _ t p) = ] mkNavItem (NavDir _ idxf _) = mkNavItem idxf -emit :: FilePath -> T.Text -> Nav -> T.Text -> IO () -emit outdir nav1 f@(NavFile _ _ p) nav2 = do - let contents = generate (T.append nav1 nav2) f +emit :: (T.Text -> T.Text -> T.Text, T.Text) -> FilePath -> T.Text -> Nav -> T.Text -> IO () +emit hf outdir nav1 f@(NavFile _ _ p) nav2 = do + let contents = generate hf (T.append nav1 nav2) f T.writeFile (outdir p -<.> "html") contents -emit outdir nav1 (NavDir cs i dp) nav2 = do +emit hf outdir nav1 (NavDir cs i dp) nav2 = do let newdir = outdir dp exists <- doesDirectoryExist newdir unless exists $ createDirectory newdir @@ -185,13 +151,13 @@ emit outdir nav1 (NavDir cs i dp) nav2 = do let posts = tails ncs let nbefore = map (\x -> T.append sharedBefore (T.concat x)) priors let nafter = map (\x -> T.append (T.concat x) sharedAfter ) posts - let actions = zipWith3 (emit outdir) (tail nbefore) cs (tail nafter) + let actions = zipWith3 (emit hf outdir) (tail nbefore) cs (tail nafter) _ <- sequence actions - emit outdir (head nbefore) i (head nafter) + emit hf outdir (head nbefore) i (head nafter) main :: IO () main = do - flags@(Flags r o s) <- canonicalizeFlags <$> handleArgs + flags@(Flags r o h f s) <- canonicalizeFlags <$> handleArgs unless (valid r r) $ die $ "R isn't valid. Maybe not absolute? " ++ r unless (isAbsolute o) $ @@ -200,17 +166,22 @@ main = do tree <- convert r r hPutStr stderr $ "\nFound tree:\n" ++ show tree let rNav = T.append (T.pack "") + headerTemplate <- withFile h ReadMode T.hGetContents + let headerFunc title nav = T.replace (T.pack "%t") title $ T.replace (T.pack "%n") nav headerTemplate + footer <- withFile f ReadMode T.hGetContents + emit (headerFunc,footer) o rNav tree (T.pack "") when (isJust s) $ case isAbsolute $ fromJust s of True -> copyInto (fromJust s) o False -> die $ "S input not absolute " ++ (fromJust s) - where canonicalizeFlags (Flags r o s) = - Flags (normalise r) (normalise o) (normalise <$> s) + where canonicalizeFlags (Flags r o h f s) = + Flags (normalise r) (normalise o) (normalise h) (normalise f) (normalise <$> s) data Flags = Flags { root :: FilePath , output :: FilePath + , header :: FilePath + , footer :: FilePath , static :: Maybe FilePath } deriving (Show) @@ -222,12 +193,16 @@ handleArgs = do let missing = Flags { root = error "-r root is required" , output = error "-o output is required" + , header = error "-e header.html is required" + , footer = error "-f footer.html is required" , static = Nothing } helper missing args where helper f [] = pure f helper f ("-r":a:rest) = helper (f { root = a }) rest helper f ("-o":a:rest) = helper (f { output = a }) rest + helper f ("-e":a:rest) = helper (f { header = a }) rest + helper f ("-f":a:rest) = helper (f { footer = a }) rest helper f ("-s":a:rest) = helper (f { static = Just a }) rest helper _ ("-h":_) = die usage helper _ (x:_) = die $ "Unknown or orphan flag: " ++ x ++ "\n" ++ usage @@ -238,6 +213,9 @@ usage = unlines , "\tloom -r {root path} -o {output path} [-s {static path}]" , "\t-r supplies a root to pull fragments from" , "\t-o supplies the output directory to place html in" + , "\t-e supplies a html template for the header of each page" + , "\t\t%t is replaced with the title, and %n with the nav contents." + , "\t-f supplies a html template for the footer. " , "\t-s (optional) supplies a directory to be copied into the output after generation" , "all paths must be absolute." , "any fragment may be given a name by having the first line be in the following format:" -- cgit v1.2.3