diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for brick-skylighting + +## 0.1 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Jonathan Daugherty + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jonathan Daugherty nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ + +brick-skylighting +================= + +This package extends the [brick](https://github.com/jtdaugherty/brick) +library with syntax highlighting support using the +[Skylighting](https://github.com/jgm/skylighting) library. + +See the Haddock documentation for `Brick.Widgets.Skylighting` for API +details, and see the demonstration program in `programs` for a complete +working example. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brick-skylighting.cabal b/brick-skylighting.cabal new file mode 100644 --- /dev/null +++ b/brick-skylighting.cabal @@ -0,0 +1,56 @@ +name: brick-skylighting +version: 0.1 +synopsis: Show syntax-highlighted text in your Brick UI +description: This package provides a module to use Skylighting to perform + syntax highlighting and display the results in Brick-based + interfaces. +license: BSD3 +license-file: LICENSE +author: Jonathan Daugherty +maintainer: cygnus@foobox.com +copyright: Jonathan Daugherty 2018 +category: Graphics +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.18 +Homepage: https://github.com/jtdaugherty/brick-skylighting/ +Bug-reports: https://github.com/jtdaugherty/brick-skylighting/issues + +extra-doc-files: + README.md + +Source-Repository head + type: git + location: git://github.com/jtdaugherty/brick-skylighting.git + +Flag demos + Description: Build demonstration programs + Default: False + +library + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Brick.Widgets.Skylighting + + build-depends: base <= 5, + brick, + vty, + skylighting >= 0.6, + text, + containers + +executable brick-skylighting-demo + if !flag(demos) + Buildable: False + main-is: Demo.hs + ghc-options: -threaded -Wall + hs-source-dirs: programs + default-language: Haskell2010 + build-depends: base <= 5, + brick, + brick-skylighting, + vty, + skylighting >= 0.6, + text diff --git a/programs/Demo.hs b/programs/Demo.hs new file mode 100644 --- /dev/null +++ b/programs/Demo.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad (void) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Graphics.Vty as V +import qualified Skylighting as S + +import Brick +import Brick.Widgets.Center (hCenter) +import Brick.Widgets.Border (borderWithLabel, hBorder) + +import Brick.Widgets.Skylighting (simpleHighlight, attrMappingsForStyle) + +haskellProgram :: T.Text +haskellProgram = T.unlines + [ "module Main where" + , "" + , "data FooBar = Foo | Bar deriving (Eq, Read, Show)" + , "" + , "main :: IO ()" + , "main = do" + , " let f x = x * x" + , " return ()" + ] + +pythonProgram :: T.Text +pythonProgram = T.unlines + [ "import os.path" + , "" + , "if __name__ == \"__main__\":" + , " print('hello, world!')" + ] + +bashProgram :: T.Text +bashProgram = T.unlines + [ "FOO=1" + , "" + , "function print_foo {" + , " echo $FOO" + , "}" + , "" + , "print_foo" + ] + +programs :: [(T.Text, T.Text)] +programs = + [ (haskellProgram, "Haskell") + , (pythonProgram, "Python") + , (bashProgram, "Bash") + ] + +ui :: Int -> [Widget ()] +ui styleIndex = + [vBox $ usage : hBorder : header : progs] + where + usage = hCenter $ txt "q/esc:quit up/down:change theme" + header = hCenter $ txt $ "Theme: " <> (fst $ styles !! styleIndex) + progs = showProg <$> programs + showProg (progSrc, langName) = + (borderWithLabel (txt langName) $ simpleHighlight langName progSrc) + +styles :: [(T.Text, S.Style)] +styles = + [ ("espresso", S.espresso) + , ("kate", S.kate) + , ("breezeDark", S.breezeDark) + , ("pygments", S.pygments) + , ("tango", S.tango) + , ("haddock", S.haddock) + , ("monochrome", S.monochrome) + , ("zenburn", S.zenburn) + ] + +handleEvent :: Int -> BrickEvent () e -> EventM () (Next Int) +handleEvent i (VtyEvent (V.EvKey V.KUp [])) = continue $ (i + 1) `mod` length styles +handleEvent i (VtyEvent (V.EvKey V.KDown [])) = continue $ (i - 1) `mod` length styles +handleEvent i (VtyEvent (V.EvKey V.KEsc [])) = halt i +handleEvent i (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt i +handleEvent i _ = continue i + +app :: App Int e () +app = + App { appDraw = ui + , appAttrMap = \i -> attrMap V.defAttr $ + attrMappingsForStyle $ snd $ styles !! i + , appHandleEvent = handleEvent + , appChooseCursor = neverShowCursor + , appStartEvent = return + } + +main :: IO () +main = void $ defaultMain app 0 diff --git a/src/Brick/Widgets/Skylighting.hs b/src/Brick/Widgets/Skylighting.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Skylighting.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides an API for building Brick widgets to display +-- syntax-highlighted text using the Skylighting library. +-- +-- To use this module, you'll need to: +-- +-- * have some 'Text' you want to syntax-highlight. +-- * know the language in which the 'Text' is expressed. +-- * have a Skylighting 'Style' you'd like to use to determine the +-- colors, either from the Skylighting package or one of your own. +-- +-- To highlight some text in your user interface, use one of +-- the (increasingly finer-grained) highlighting functions +-- 'simpleHighlight', 'highlight', 'highlight'', or 'renderRawSource'. +-- +-- To actually see pretty colors, you'll need to update your +-- application's 'AttrMap' with name-to-color mappings. Those can be +-- built from a Skylighting 'Style' with 'attrMappingsForStyle' and then +-- appended to your 'attrMap' mapping list. +-- +-- The highlighted code widget produced by this module uses +-- 'highlightedCodeBlockAttr' as its base attribute and then uses +-- a specific attribute for each kind of Skylighting token as per +-- 'attrNameForTokenType'. +-- +-- See the @programs/Demo.hs@ program in this package for an example of a +-- complete program that uses this module. +module Brick.Widgets.Skylighting + ( -- * Highlighting functions + simpleHighlight + , highlight + , highlight' + , renderRawSource + + -- * Attributes + , attrMappingsForStyle + , attrNameForTokenType + , highlightedCodeBlockAttr + ) +where + +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Graphics.Vty as V + +import Brick + +import qualified Skylighting as Sky +import Skylighting (TokenType(..)) + +-- | The simplest way to highlight some text. If the specified language +-- does not have a corresponding Skylighting parser or if a parser is +-- found but fails to parse the input, the text is rendered as-is and +-- tab characters are converted to eight spaces. +simpleHighlight :: T.Text + -- ^ The Skylighting name of the language in which the + -- input text is written. + -> T.Text + -- ^ The text to be syntax-highlighted. + -> Widget n +simpleHighlight langName body = + case Sky.syntaxByName Sky.defaultSyntaxMap langName of + Nothing -> txt $ expandTabs body + Just syntax -> highlight syntax body + +-- | If you already have a 'Syntax' handy, this provides more control +-- than 'simpleHighlight'. +highlight :: Sky.Syntax + -- ^ The syntax to use to parse the input text. + -> T.Text + -- ^ The text to be syntax-highlighted. + -> Widget n +highlight = highlight' txt + +-- | If you already have a 'Syntax' handy and want to have control over +-- how each 'Text' token in the Skylighting AST gets converted to a +-- 'Widget', this provides more control than 'highlight', which just +-- defaults the text widget constructor to 'txt'. If the specified +-- parser fails to parse the input, the text is displayed as-is and tab +-- characters are converted to eight spaces. +highlight' :: (T.Text -> Widget n) + -- ^ The token widget constructor. + -> Sky.Syntax + -- ^ The syntax to use to parse the input text. + -> T.Text + -- ^ The text to be syntax-highlighted. + -> Widget n +highlight' renderToken syntax tx = + let cfg = Sky.TokenizerConfig (M.fromList [(Sky.sName syntax, syntax)]) False + expanded = expandTabs tx + result = Sky.tokenize cfg syntax tx + in case result of + Left _ -> txt expanded + Right tokLines -> renderRawSource renderToken tokLines + +expandTabs :: T.Text -> T.Text +expandTabs = T.replace "\t" (T.replicate 8 " ") + +-- | If you have already parsed your input text into Skylighting tokens, +-- this function is the best one to use. +renderRawSource :: (T.Text -> Widget n) + -- ^ The token widget constructor. + -> [Sky.SourceLine] + -- ^ The parsed input. + -> Widget n +renderRawSource renderToken ls = + withDefAttr highlightedCodeBlockAttr $ + vBox $ renderTokenLine renderToken <$> ls + +renderTokenLine :: (T.Text -> Widget n) -> Sky.SourceLine -> Widget n +renderTokenLine _ [] = str " " +renderTokenLine renderToken toks = + let renderSingle (ty, tx) = withDefAttr (attrNameForTokenType ty) $ renderToken tx + in hBox $ renderSingle <$> toks + +-- | The base attribute name for all syntax-highlighted renderings. +highlightedCodeBlockAttr :: AttrName +highlightedCodeBlockAttr = "highlightedCodeBlock" + +-- | The constructor for attribute names for each 'TokenType' in +-- Skylighting. +attrNameForTokenType :: TokenType -> AttrName +attrNameForTokenType ty = highlightedCodeBlockAttr <> attrName s + where + s = case ty of + KeywordTok -> "keyword" + DataTypeTok -> "dataType" + DecValTok -> "declaration" + BaseNTok -> "baseN" + FloatTok -> "float" + ConstantTok -> "constant" + CharTok -> "char" + SpecialCharTok -> "specialChar" + StringTok -> "string" + VerbatimStringTok -> "verbatimString" + SpecialStringTok -> "specialString" + ImportTok -> "import" + CommentTok -> "comment" + DocumentationTok -> "documentation" + AnnotationTok -> "annotation" + CommentVarTok -> "comment" + OtherTok -> "other" + FunctionTok -> "function" + VariableTok -> "variable" + ControlFlowTok -> "controlFlow" + OperatorTok -> "operator" + BuiltInTok -> "builtIn" + ExtensionTok -> "extension" + PreprocessorTok -> "preprocessor" + AttributeTok -> "attribute" + RegionMarkerTok -> "regionMarker" + InformationTok -> "information" + WarningTok -> "warning" + AlertTok -> "alert" + ErrorTok -> "error" + NormalTok -> "normal" + +-- | Given a Skylighting 'Style', build an equivalent list of +-- Brick-compatible 'AttrMap' entries. This will usually return +-- 256-color entries. +attrMappingsForStyle :: Sky.Style -> [(AttrName, V.Attr)] +attrMappingsForStyle sty = + (highlightedCodeBlockAttr, baseAttrFromPair (Sky.defaultColor sty, Sky.backgroundColor sty)) : + (mkTokenTypeEntry <$> (M.toList $ Sky.tokenStyles sty)) + +baseAttrFromPair :: (Maybe Sky.Color, Maybe Sky.Color) -> V.Attr +baseAttrFromPair (mf, mb) = + case (mf, mb) of + (Nothing, Nothing) -> V.defAttr + (Just f, Nothing) -> fg (tokenColorToVtyColor f) + (Nothing, Just b) -> bg (tokenColorToVtyColor b) + (Just f, Just b) -> (tokenColorToVtyColor f) `on` + (tokenColorToVtyColor b) + +tokenColorToVtyColor :: Sky.Color -> V.Color +tokenColorToVtyColor (Sky.RGB r g b) = V.rgbColor r g b + +mkTokenTypeEntry :: (Sky.TokenType, Sky.TokenStyle) -> (AttrName, V.Attr) +mkTokenTypeEntry (ty, tSty) = + let a = setStyle baseAttr + baseAttr = baseAttrFromPair (Sky.tokenColor tSty, Sky.tokenBackground tSty) + setStyle = + if Sky.tokenBold tSty then flip V.withStyle V.bold else id . + if Sky.tokenItalic tSty then flip V.withStyle V.standout else id . + if Sky.tokenUnderline tSty then flip V.withStyle V.underline else id + + in (attrNameForTokenType ty, a)