summaryrefslogtreecommitdiff
path: root/lib/Patat/Presentation/Display
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Patat/Presentation/Display')
-rw-r--r--lib/Patat/Presentation/Display/CodeBlock.hs83
-rw-r--r--lib/Patat/Presentation/Display/Table.hs107
2 files changed, 190 insertions, 0 deletions
diff --git a/lib/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs
new file mode 100644
index 0000000..149bc68
--- /dev/null
+++ b/lib/Patat/Presentation/Display/CodeBlock.hs
@@ -0,0 +1,83 @@
+--------------------------------------------------------------------------------
+-- | Displaying code blocks, optionally with syntax highlighting.
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.CodeBlock
+ ( prettyCodeBlock
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Maybe (mapMaybe)
+import Data.Monoid (mconcat, (<>))
+import qualified Data.Text as T
+import Patat.Presentation.Display.Table (themed)
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme
+import Prelude
+import qualified Skylighting as Skylighting
+
+
+--------------------------------------------------------------------------------
+highlight :: [String] -> String -> [Skylighting.SourceLine]
+highlight classes rawCodeBlock = case mapMaybe getSyntax classes of
+ [] -> zeroHighlight rawCodeBlock
+ (syn : _) ->
+ case Skylighting.tokenize config syn (T.pack rawCodeBlock) of
+ Left _ -> zeroHighlight rawCodeBlock
+ Right sl -> sl
+ where
+ getSyntax :: String -> Maybe Skylighting.Syntax
+ getSyntax c = Skylighting.lookupSyntax (T.pack c) syntaxMap
+
+ config :: Skylighting.TokenizerConfig
+ config = Skylighting.TokenizerConfig
+ { Skylighting.syntaxMap = syntaxMap
+ , Skylighting.traceOutput = False
+ }
+
+ syntaxMap :: Skylighting.SyntaxMap
+ syntaxMap = Skylighting.defaultSyntaxMap
+
+
+--------------------------------------------------------------------------------
+-- | This does fake highlighting, everything becomes a normal token. That makes
+-- things a bit easier, since we only need to deal with one cases in the
+-- renderer.
+zeroHighlight :: String -> [Skylighting.SourceLine]
+zeroHighlight str =
+ [[(Skylighting.NormalTok, T.pack line)] | line <- lines str]
+
+
+--------------------------------------------------------------------------------
+prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc
+prettyCodeBlock theme@Theme {..} classes rawCodeBlock =
+ PP.vcat (map blockified sourceLines) <>
+ PP.hardline
+ where
+ sourceLines :: [Skylighting.SourceLine]
+ sourceLines =
+ [[]] ++ highlight classes rawCodeBlock ++ [[]]
+
+ prettySourceLine :: Skylighting.SourceLine -> PP.Doc
+ prettySourceLine = mconcat . map prettyToken
+
+ prettyToken :: Skylighting.Token -> PP.Doc
+ prettyToken (tokenType, str) =
+ themed (syntaxHighlight theme tokenType) (PP.string $ T.unpack str)
+
+ sourceLineLength :: Skylighting.SourceLine -> Int
+ sourceLineLength line = sum [T.length str | (_, str) <- line]
+
+ blockWidth :: Int
+ blockWidth = foldr max 0 (map sourceLineLength sourceLines)
+
+ blockified :: Skylighting.SourceLine -> PP.Doc
+ blockified line =
+ let len = sourceLineLength line
+ indent = PP.NotTrimmable " " in
+ PP.indent indent indent $
+ themed themeCodeBlock $
+ " " <>
+ prettySourceLine line <>
+ PP.string (replicate (blockWidth - len) ' ') <> " "
diff --git a/lib/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs
new file mode 100644
index 0000000..fee68c9
--- /dev/null
+++ b/lib/Patat/Presentation/Display/Table.hs
@@ -0,0 +1,107 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.Table
+ ( Table (..)
+ , prettyTable
+
+ , themed
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (intersperse, transpose)
+import Data.Monoid (mconcat, mempty, (<>))
+import Patat.PrettyPrint ((<$$>))
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
+import Prelude
+
+
+--------------------------------------------------------------------------------
+data Table = Table
+ { tCaption :: PP.Doc
+ , tAligns :: [PP.Alignment]
+ , tHeaders :: [PP.Doc]
+ , tRows :: [[PP.Doc]]
+ }
+
+
+--------------------------------------------------------------------------------
+prettyTable
+ :: Theme -> Table -> PP.Doc
+prettyTable theme@Theme {..} Table {..} =
+ PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
+ lineIf (not isHeaderLess) (hcat2 headerHeight
+ [ themed themeTableHeader (PP.align w a (vpad headerHeight header))
+ | (w, a, header) <- zip3 columnWidths tAligns tHeaders
+ ]) <>
+ dashedHeaderSeparator theme columnWidths <$$>
+ joinRows
+ [ hcat2 rowHeight
+ [ PP.align w a (vpad rowHeight cell)
+ | (w, a, cell) <- zip3 columnWidths tAligns row
+ ]
+ | (rowHeight, row) <- zip rowHeights tRows
+ ] <$$>
+ lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <>
+ lineIf
+ (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption)
+ where
+ lineIf cond line = if cond then line <> PP.hardline else mempty
+
+ joinRows
+ | all (all isSimpleCell) tRows = PP.vcat
+ | otherwise = PP.vcat . intersperse ""
+
+ isHeaderLess = all PP.null tHeaders
+
+ headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)]
+ rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]]
+
+ columnWidths :: [Int]
+ columnWidths =
+ [ safeMax (map snd col)
+ | col <- transpose (headerDimensions : rowDimensions)
+ ]
+
+ rowHeights = map (safeMax . map fst) rowDimensions :: [Int]
+ headerHeight = safeMax (map fst headerDimensions) :: Int
+
+ vpad :: Int -> PP.Doc -> PP.Doc
+ vpad height doc =
+ let (actual, _) = PP.dimensions doc in
+ doc <> mconcat (replicate (height - actual) PP.hardline)
+
+ safeMax = foldr max 0
+
+ hcat2 :: Int -> [PP.Doc] -> PP.Doc
+ hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight)
+
+ spaces2 :: Int -> PP.Doc
+ spaces2 rowHeight =
+ mconcat $ intersperse PP.hardline $
+ replicate rowHeight (PP.string " ")
+
+
+--------------------------------------------------------------------------------
+isSimpleCell :: PP.Doc -> Bool
+isSimpleCell = (<= 1) . fst . PP.dimensions
+
+
+--------------------------------------------------------------------------------
+dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc
+dashedHeaderSeparator Theme {..} columnWidths =
+ mconcat $ intersperse (PP.string " ")
+ [ themed themeTableSeparator (PP.string (replicate w '-'))
+ | w <- columnWidths
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | This does not really belong in the module.
+themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc
+themed Nothing = id
+themed (Just (Theme.Style [])) = id
+themed (Just (Theme.Style codes)) = PP.ansi codes