summaryrefslogtreecommitdiff
path: root/utils/mkUserGuidePart/Table.hs
diff options
context:
space:
mode:
authorAdam Gundry <adam@well-typed.com>2015-10-16 13:58:52 +0100
committerAdam Gundry <adam@well-typed.com>2015-10-16 13:58:52 +0100
commit5a1b4f814f74ec1c48152d97523744518e212777 (patch)
tree7c2207ecacbd37f12c78dbcf9d4334827164e0fb /utils/mkUserGuidePart/Table.hs
parent6757950cdd8bb0af0355539987ee78401a6a8f6b (diff)
parent808bbdf08058785ae5bc59b5b4f2b04951d4cbbf (diff)
downloadhaskell-wip/orf-reboot.tar.gz
Merge remote-tracking branch 'origin/master' into wip/orf-rebootwip/orf-reboot
Conflicts: compiler/rename/RnNames.hs compiler/typecheck/TcRnMonad.hs utils/haddock
Diffstat (limited to 'utils/mkUserGuidePart/Table.hs')
-rw-r--r--utils/mkUserGuidePart/Table.hs75
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,'+']