diff options
author | Adam Gundry <adam@well-typed.com> | 2015-10-16 13:58:52 +0100 |
---|---|---|
committer | Adam Gundry <adam@well-typed.com> | 2015-10-16 13:58:52 +0100 |
commit | 5a1b4f814f74ec1c48152d97523744518e212777 (patch) | |
tree | 7c2207ecacbd37f12c78dbcf9d4334827164e0fb /utils/mkUserGuidePart/Table.hs | |
parent | 6757950cdd8bb0af0355539987ee78401a6a8f6b (diff) | |
parent | 808bbdf08058785ae5bc59b5b4f2b04951d4cbbf (diff) | |
download | haskell-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.hs | 75 |
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,'+'] |