initial (functional?) version

author: Thomas Ulmer <thomasmulmer02@gmail.com> 2026-06-02 17:19:14 -0700
committer: Thomas Ulmer <thomasmulmer02@gmail.com> 2026-06-02 17:19:14 -0700
commit: 924746b8ab4904d24a3cb242b95e8b91f0970129 (patch)
tree: c0f991e2d74665c9f3e184bd31543faf1785db45 /src/Main.hs
1 files changed, 257 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..6d116a0
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,257 @@
+module Main where
+
+import System.Directory
+import System.FilePath
+import System.Environment (getArgs)
+import System.IO
+import Data.Maybe (fromMaybe, isJust, fromJust)
+import Data.List (isPrefixOf, isSuffixOf, scanl, scanr, zipWith3, intersperse, sort, inits, tails)
+import Control.Monad (when, unless)
+import System.Exit (die)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+isFragment :: FilePath -> Bool
+isFragment f =
+  (isSuffixOf ".html" f || isSuffixOf ".frag" f)
+
+valid :: FilePath -> FilePath -> Bool
+valid r f =
+  and $ (isAbsolute r):(isAbsolute f):zipWith (==) r f
+
+prettyName :: FilePath -> String
+{- XXX more -}
+prettyName f = takeBaseName $ dropExtension f
+
+header :: T.Text -> T.Text -> T.Text
+header title nav = T.unlines
+  [ T.pack "<!DOCTYPE html>"
+  , T.pack "<html>"
+  , T.pack "  <head>"
+  , T.pack "    <meta charset='UTF-8' />"
+  , T.concat [T.pack "    <title>" , title , T.pack "</title>" ]
+  , T.pack "    <link rel=\"stylesheet\" href=\"/css/style.css\" />"
+  , T.pack "    <link rel=\"icon\" href=\"/favicon.ico\" type=\"image/x-icon\"/>"
+  , T.pack "  </head>"
+  , T.pack "  <body>"
+  , T.pack "  <div class=\"stuck\">"
+  , T.pack "    <header>"
+  , T.pack "      <p>"
+  , T.pack "        Professional Webring >>"
+  , T.pack "        <a href=\"https://roscoeeh.github.io\">Prev - Roscoe</a>"
+  , T.pack "        |"
+  , T.pack "        <a href=\"https://elle-wen.github.io\">Next - Elle</a>"
+  , T.pack "      </p>"
+  , T.pack "    </header>"
+  , T.concat [ T.pack "<nav>" , nav , T.pack "</nav>" ]
+  , T.pack "  </div>"
+  , T.pack "    <main>"
+  ]
+
+footer :: T.Text
+footer = T.pack $ unlines
+  [ "</main>"
+  , "<footer>"
+  , "</footer>"
+  , "</body>"
+  , "</html>"
+  ]
+
+parse :: FilePath -> IO (T.Text, T.Text)
+{- XXX use T.hGetLine to try to delay the memory cost.
+
+Maybe doesn't matter if I'm going to have it all in memory later
+anyway?
+-}
+parse f = withFile f ReadMode $ \h -> do
+  c <- T.hGetContents h
+  case T.lines c of
+    [] -> pure (fallback, c)
+    l:_ -> case T.stripPrefix (T.pack "<!-- == ") l
+                >>= T.stripSuffix (T.pack " -->") of
+      Nothing -> pure (fallback, c)
+      Just comment ->
+        let pairs = T.splitOn (T.pack "|") comment
+            kvs = map (dropEq . T.span (/= '=')) pairs
+            name = fromMaybe fallback $ lookup (T.pack "title") kvs
+        in pure (name, c)
+  where fallback = T.pack $ prettyName f
+        dropEq (key, ev) = case T.uncons ev of
+          Just ('=', rest) -> (key,rest)
+          _ -> (key, ev)
+
+data Nav
+  = NavDir { navChildren :: [Nav]
+           , navIndexFrag :: Nav {- will be NavFile, contains title -}
+           , navDirPath :: FilePath
+           }
+  | NavFile { navFrag :: T.Text
+            , navTitle :: T.Text
+            , navFilePath :: FilePath
+            }
+
+instance Show Nav where
+  show (NavDir cs _ p) =
+    concat $ intersperse "\n"
+      [ "NavDir " ++ p ++ ":"
+      , concat $ intersperse "\n" $ map (indent . show) cs
+      ]
+    where indent s = concat $ intersperse "\n" $ map ("\t"++) $ lines s
+  show (NavFile _ t p) =
+    "NavFile " ++ T.unpack t ++ " " ++ p
+
+convert :: FilePath -> FilePath -> IO Nav
+convert r f = do
+  unless (valid r f) $
+    error $ "Don't know what to do with: " ++ f
+  de <- doesDirectoryExist f
+  fe <- (isFragment f &&) <$> doesFileExist f
+  case de of
+    True -> do
+      allChildren <- (map (f </>)) <$> listDirectory f
+      let downlinks = sort $ filter (\x -> valid r x && not (isSuffixOf "index.html" x)) $ allChildren
+      navChildren <- mapM (convert r) downlinks
+      navIndexFrag <- do
+        let ifp = f </> "index.html"
+        fe <- doesFileExist ifp
+        case fe of
+          True -> do
+            (name, contents) <- parse ifp
+            pure $ NavFile contents name (makeRelative r ifp)
+          False -> pure $ fallbackIndexNav (makeRelative r ifp) navChildren
+      let navDirPath = makeRelative r f
+      pure $ NavDir { navChildren = navChildren
+                    , navIndexFrag = navIndexFrag
+                    , navDirPath = navDirPath
+                    }
+    False -> case fe of
+      True -> do
+        (navTitle, navFrag) <- parse f
+        let navFilePath = makeRelative r f
+        pure $ NavFile { navFrag = navFrag
+                       , navTitle = navTitle
+                       , navFilePath = navFilePath
+                       }
+      False ->
+        error $ "Path doesn't exist or is not a directory or file: " ++ f
+
+fallbackIndexNav :: FilePath -> [Nav] -> Nav
+fallbackIndexNav p ns = NavFile (fallbackIndexFrag p ns) (T.pack . takeFileName $ takeDirectory p) p
+
+fallbackIndexFrag :: FilePath -> [Nav] -> T.Text
+fallbackIndexFrag _ _ = (T.pack "<p>Fallback index.</p>")
+
+generate :: T.Text -> Nav -> T.Text
+{- Generate the full text of a page. -}
+generate nav (NavFile f t _) =
+  T.concat [ header t nav , f , footer ]
+generate nav (NavDir _ (NavFile f t _) _) =
+  T.concat [ header t nav , f , footer ]
+generate _ _ = error "malformed NavDir"
+
+mkNavItem :: Nav -> T.Text
+{- Generate a listing for a file or a listing for a dir and optionally
+ one level of children -}
+mkNavItem (NavFile _ t p) =
+  T.concat [ T.pack "<li><a class='active' href=\""
+           , T.pack $ (pathSeparator:p -<.> "html")
+           , T.pack "\">"
+           , t
+           , T.pack "</a></li>"
+           ]
+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
+  T.writeFile (outdir </> p -<.> "html") contents
+emit outdir nav1 (NavDir cs i dp) nav2 = do
+  let newdir = outdir </> dp
+  exists <- doesDirectoryExist newdir
+  unless exists $ createDirectory newdir
+
+  let sharedBefore = T.append nav1 $ T.pack "<li><ul>"
+  let sharedAfter = T.append (T.pack "</li></ul>") nav2
+  let ncs = map mkNavItem cs
+  let priors = inits ncs
+  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)
+  _ <- sequence actions
+  emit outdir (head nbefore) i (head nafter)
+
+main :: IO ()
+main = do
+  flags@(Flags r o s) <- canonicalizeFlags <$> handleArgs
+  unless (valid r r) $
+    die $ "R isn't valid. Maybe not absolute? " ++ r
+  unless (isAbsolute o) $
+    die $ "O not absolute " ++ o
+  hPutStr stderr $ "Using config: " ++ show flags
+  tree <- convert r r
+  hPutStr stderr $ "\nFound tree:\n" ++ show tree
+  let rNav = T.append (mkNavItem tree) (T.pack "<ul>")
+  emit o rNav tree (T.pack "</ul>")
+  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)
+
+data Flags = Flags
+  { root :: FilePath
+  , output :: FilePath
+  , static :: Maybe FilePath
+  }
+  deriving (Show)
+
+handleArgs :: IO Flags
+handleArgs = do
+  args <- getArgs
+  when (null args) $ die usage
+  let missing = Flags
+        { root   = error "-r root is required"
+        , output = error "-o output 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 ("-s":a:rest) = helper (f { static = Just a }) rest
+        helper _ ("-h":_) = die usage
+        helper _ (x:_) = die $ "Unknown or orphan flag: " ++ x ++ "\n" ++ usage
+
+usage :: String
+usage = unlines
+  [ "Usage:"
+  , "\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-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:"
+  , "\t<!-- == title={title} -->"
+  , "note that the spaces are important. The title may not contain newlines or the vertical bar character."
+  ]
+
+copyInto ::  FilePath -> FilePath -> IO ()
+copyInto src dst = do
+  se <- doesDirectoryExist src
+  unless se $
+    die $ "source does not exist: " ++ src
+  de <- doesDirectoryExist dst
+  unless de $ createDirectory dst
+  when (isPrefixOf src dst) $
+    die $ "Overlapping directories: " ++ src ++ " to " ++ dst
+  content <- listDirectory src
+  flip mapM_ content $ \name -> do
+    let srcPath = src </> name
+    let dstPath = dst </> name
+    isDirectory <- doesDirectoryExist srcPath
+    if isDirectory
+      then copyInto srcPath dstPath
+      else copyFile srcPath dstPath
author	Thomas Ulmer <thomasmulmer02@gmail.com>	2026-06-02 17:19:14 -0700
committer	Thomas Ulmer <thomasmulmer02@gmail.com>	2026-06-02 17:19:14 -0700
commit	924746b8ab4904d24a3cb242b95e8b91f0970129 (patch)
tree	c0f991e2d74665c9f3e184bd31543faf1785db45 /src/Main.hs