1 files changed, 75 insertions, 0 deletions
diff --git a/utils/mkUserGuidePart/Table.hs b/utils/mkUserGuidePart/Table.hs
new file mode 100644
index 0000000000..eeff8205cb
--- /dev/null
+++ b/utils/mkUserGuidePart/Table.hs
@@ -0,0 +1,75 @@
+module Table where
+
+import Data.Char
+import Data.List
+import Data.Maybe (isJust, fromMaybe)
+import qualified DList
+
+type Row = [String]
+
+type ColWidth = Int
+
+type WrappedString = [String]
+
+-- | Wrap a string to lines of at most the given length on whitespace
+-- if possible.
+wrapAt :: Int -> String -> WrappedString
+wrapAt width = wrapLine
+  where
+    wrapLine :: String -> WrappedString
+    wrapLine s =
+      go width mempty (take width s : wrapLine (drop width s)) s
+
+    go :: Int               -- ^ remaining width
+       -> DList.DList Char  -- ^ accumulator
+       -> WrappedString     -- ^ last good wrapping
+       -> String            -- ^ remaining string
+       -> WrappedString
+    go 0 _     back _        = back
+    go n accum _    (c:rest)
+      | breakable c          = go (n-1) accum'
+                                  (DList.toList accum' : wrapLine rest) rest
+      where accum' = accum `DList.snoc` c
+    go n accum back (c:rest) = go (n-1) (accum `DList.snoc` c) back rest
+    go _ accum _    []       = [DList.toList accum]
+
+    breakable = isSpace
+
+transpose' :: [[a]] -> [[Maybe a]]
+transpose' = goRow
+  where
+    peel :: [a] -> (Maybe a, [a])
+    peel (x:xs) = (Just x, xs)
+    peel []     = (Nothing, [])
+
+    goRow xs =
+      case unzip $ map peel xs of
+        (xs', ys)
+          | any isJust xs' -> xs' : goRow ys
+          | otherwise      -> []
+
+table :: [ColWidth] -> Row -> [Row] -> String
+table widths hdr rows = unlines $
+    [rule '-'] ++
+    [formatRow hdr] ++
+    [rule '='] ++
+    intersperse (rule '-') (map formatRow rows) ++
+    [rule '-']
+  where
+    formatRow :: Row -> String
+    formatRow cols =
+        intercalate "\n"
+        $ map (rawRow . map (fromMaybe ""))
+        $ transpose'
+        $ zipWith wrapAt (map (subtract 4) widths) cols
+
+    rawRow :: Row -> String
+    rawRow cols = "| " ++ intercalate " | " (zipWith padTo widths cols) ++ " |"
+    padTo width content = take width $ content ++ repeat ' '
+
+    rule :: Char -> String
+    rule lineChar =
+      ['+',lineChar]
+      ++intercalate [lineChar,'+',lineChar]
+                    (map (\n -> replicate n lineChar) widths)
+      ++[lineChar,'+']