diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## GHC syntax highlighter 0.0.7.0 + +* Uses `ghc-lib-parser-9.0.1.x`. + ## GHC syntax highlighter 0.0.6.0 * Uses `ghc-lib-parser-8.10.x`. diff --git a/GHC/SyntaxHighlighter.hs b/GHC/SyntaxHighlighter.hs --- a/GHC/SyntaxHighlighter.hs +++ b/GHC/SyntaxHighlighter.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} + -- | -- Module : GHC.SyntaxHighlighter -- Copyright : © 2018–present Mark Karpov @@ -12,54 +18,61 @@ -- -- This library uses GHC's lexer, so the result is guaranteed to be 100% -- correct, as if it was parsed by GHC itself. - -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} - module GHC.SyntaxHighlighter - ( Token (..) - , Loc (..) - , tokenizeHaskell - , tokenizeHaskellLoc ) + ( Token (..), + Loc (..), + tokenizeHaskell, + tokenizeHaskellLoc, + ) where import Control.Monad import Data.List (foldl', unfoldr) import Data.Maybe (isJust) import Data.Text (Text) -import DynFlags -import FastString (mkFastString) -import Fingerprint (fingerprint0) +import qualified Data.Text as T +import qualified GHC.Data.EnumSet as ES +import GHC.Data.FastString (mkFastString) +import GHC.Data.StringBuffer +import GHC.Driver.Session as DynFlags import GHC.LanguageExtensions +import qualified GHC.Parser.Lexer as L +import GHC.Settings +import GHC.Types.SrcLoc +import GHC.Utils.Fingerprint (fingerprint0) import GHC.Version (cProjectVersion) -import SrcLoc -import StringBuffer -import ToolSettings -import qualified Data.Text as T -import qualified EnumSet as ES -import qualified Lexer as L ---------------------------------------------------------------------------- -- Data types -- | Token types that are used as tags to mark spans of source code. - data Token - = KeywordTok -- ^ Keyword - | PragmaTok -- ^ Pragmas - | SymbolTok -- ^ Symbols (punctuation that is not an operator) - | VariableTok -- ^ Variable name (term level) - | ConstructorTok -- ^ Data\/type constructor - | OperatorTok -- ^ Operator - | CharTok -- ^ Character - | StringTok -- ^ String - | IntegerTok -- ^ Integer - | RationalTok -- ^ Rational number - | CommentTok -- ^ Comment (including Haddocks) - | SpaceTok -- ^ Space filling - | OtherTok -- ^ Something else? + = -- | Keyword + KeywordTok + | -- | Pragmas + PragmaTok + | -- | Symbols (punctuation that is not an operator) + SymbolTok + | -- | Variable name (term level) + VariableTok + | -- | Data\/type constructor + ConstructorTok + | -- | Operator + OperatorTok + | -- | Character + CharTok + | -- | String + StringTok + | -- | Integer + IntegerTok + | -- | Rational number + RationalTok + | -- | Comment (including Haddocks) + CommentTok + | -- | Space filling + SpaceTok + | -- | Something else? + OtherTok deriving (Eq, Ord, Enum, Bounded, Show) -- | Start and end positions of a span. The arguments of the data @@ -71,7 +84,6 @@ -- * Column number of end position of a span -- -- @since 0.0.2.0 - data Loc = Loc !Int !Int !Int !Int deriving (Eq, Ord, Show) @@ -80,32 +92,33 @@ -- | Tokenize Haskell source code. If the code cannot be parsed, return -- 'Nothing'. Otherwise return the original input tagged by 'Token's. +-- 'Nothing' is rarely returned if ever, because it looks like the lexer is +-- capable of interpreting almost any text as a stream of GHC tokens. -- -- The parser does not require the input source code to form a valid Haskell -- program, so as long as the lexer can decompose your input (most of the -- time), it'll return something in 'Just'. - tokenizeHaskell :: Text -> Maybe [(Token, Text)] tokenizeHaskell input = sliceInputStream input <$> tokenizeHaskellLoc input -- | Replace 'Loc' locations with actual chunks of input 'Text'. - sliceInputStream :: Text -> [(Token, Loc)] -> [(Token, Text)] sliceInputStream input toks = unfoldr sliceOnce (initText' input, toks) where sliceOnce (txt, []) = do (txt', chunk) <- tryFetchRest txt return ((SpaceTok, chunk), (txt', [])) - sliceOnce (txt, tss@((t, l):ts)) = + sliceOnce (txt, tss@((t, l) : ts)) = case tryFetchSpace txt l of Nothing -> let (txt', chunk) = fetchSpan txt l t' = case t of - CommentTok -> if isHeaderPragma chunk - then PragmaTok - else CommentTok + CommentTok -> + if isHeaderPragma chunk + then PragmaTok + else CommentTok tok -> tok - in Just ((t', chunk), (txt', ts)) + in Just ((t', chunk), (txt', ts)) Just (txt', chunk) -> Just ((SpaceTok, chunk), (txt', tss)) @@ -113,41 +126,43 @@ -- locations of corresponding spans in the given input stream. -- -- @since 0.0.2.0 - tokenizeHaskellLoc :: Text -> Maybe [(Token, Loc)] tokenizeHaskellLoc input = case L.unP pLexer parseState of L.PFailed {} -> Nothing - L.POk _ x -> Just x + L.POk _ x -> Just x where location = mkRealSrcLoc (mkFastString "") 1 1 buffer = stringToStringBuffer (T.unpack input) parseState = L.mkPStatePure parserFlags buffer location parserFlags = L.mkParserFlags (foldl' xopt_set initialDynFlags enabledExts) - initialDynFlags = DynFlags - { warningFlags = ES.empty - , generalFlags = ES.fromList - [ Opt_Haddock - , Opt_KeepRawTokenStream - ] - , extensions = [] - , extensionFlags = ES.empty - , safeHaskell = Sf_Safe - , language = Just Haskell2010 - , ghcNameVersion = GhcNameVersion - { ghcNameVersion_programName = "ghc" - , ghcNameVersion_projectVersion = cProjectVersion + initialDynFlags = + DynFlags + { warningFlags = ES.empty, + generalFlags = + ES.fromList + [ Opt_Haddock, + Opt_KeepRawTokenStream + ], + extensions = [], + extensionFlags = ES.empty, + safeHaskell = Sf_Safe, + language = Just Haskell2010, + ghcNameVersion = + GhcNameVersion + { ghcNameVersion_programName = "ghc", + ghcNameVersion_projectVersion = cProjectVersion + }, + fileSettings = FileSettings {}, + toolSettings = + ToolSettings + { toolSettings_opt_P_fingerprint = fingerprint0, + toolSettings_pgm_F = "" + }, + platformMisc = PlatformMisc {} } - , fileSettings = FileSettings {} - , toolSettings = ToolSettings - { toolSettings_opt_P_fingerprint = fingerprint0 - , toolSettings_pgm_F = "" - } - , platformMisc = PlatformMisc {} - } -- | Haskell lexer. - pLexer :: L.P [(Token, Loc)] pLexer = go where @@ -155,89 +170,93 @@ r <- L.lexer False return case r of L _ L.ITeof -> return [] - _ -> + _ -> case fixupToken r of Nothing -> go - Just x -> (x:) <$> go + Just x -> (x :) <$> go -- | Convert @'Located' 'L.Token'@ representation to a more convenient for -- us form. - fixupToken :: Located L.Token -> Maybe (Token, Loc) fixupToken (L srcSpan tok) = (classifyToken tok,) <$> srcSpanToLoc srcSpan -- | Convert 'SrcSpan' to 'Loc'. - srcSpanToLoc :: SrcSpan -> Maybe Loc -srcSpanToLoc (RealSrcSpan rss) = - let start = realSrcSpanStart rss - end = realSrcSpanEnd rss - in if start == end - then Nothing -- NOTE Some magic auto-generated tokens that do not - -- actually appear in the input stream. Drop them. - else Just $ Loc (srcLocLine start) - (srcLocCol start) - (srcLocLine end) - (srcLocCol end) +srcSpanToLoc (RealSrcSpan s _) = + let srcSpanSLine = srcSpanStartLine s + srcSpanSCol = srcSpanStartCol s + srcSpanELine = srcSpanEndLine s + srcSpanECol = srcSpanEndCol s + start = (srcSpanSLine, srcSpanSCol) + end = (srcSpanELine, srcSpanECol) + in if start == end + then Nothing -- NOTE Some magic auto-generated tokens that do not + -- actually appear in the input stream. Drop them. + else + Just $ + Loc + srcSpanSLine + srcSpanSCol + srcSpanELine + srcSpanECol srcSpanToLoc _ = Nothing -- | Classify a 'L.Token' in terms of 'Token'. - classifyToken :: L.Token -> Token classifyToken = \case -- Keywords - L.ITas -> KeywordTok - L.ITcase -> KeywordTok - L.ITclass -> KeywordTok - L.ITdata -> KeywordTok - L.ITdefault -> KeywordTok - L.ITderiving -> KeywordTok - L.ITdo -> KeywordTok - L.ITelse -> KeywordTok - L.IThiding -> KeywordTok - L.ITforeign -> KeywordTok - L.ITif -> KeywordTok - L.ITimport -> KeywordTok - L.ITin -> KeywordTok - L.ITinfix -> KeywordTok - L.ITinfixl -> KeywordTok - L.ITinfixr -> KeywordTok - L.ITinstance -> KeywordTok - L.ITlet -> KeywordTok - L.ITmodule -> KeywordTok - L.ITnewtype -> KeywordTok - L.ITof -> KeywordTok + L.ITas -> KeywordTok + L.ITcase -> KeywordTok + L.ITclass -> KeywordTok + L.ITdata -> KeywordTok + L.ITdefault -> KeywordTok + L.ITderiving -> KeywordTok + L.ITdo _ -> KeywordTok + L.ITelse -> KeywordTok + L.IThiding -> KeywordTok + L.ITforeign -> KeywordTok + L.ITif -> KeywordTok + L.ITimport -> KeywordTok + L.ITin -> KeywordTok + L.ITinfix -> KeywordTok + L.ITinfixl -> KeywordTok + L.ITinfixr -> KeywordTok + L.ITinstance -> KeywordTok + L.ITlet -> KeywordTok + L.ITmodule -> KeywordTok + L.ITnewtype -> KeywordTok + L.ITof -> KeywordTok L.ITqualified -> KeywordTok - L.ITthen -> KeywordTok - L.ITtype -> KeywordTok - L.ITwhere -> KeywordTok - L.ITforall _ -> KeywordTok - L.ITexport -> KeywordTok - L.ITlabel -> KeywordTok - L.ITdynamic -> KeywordTok - L.ITsafe -> KeywordTok + L.ITthen -> KeywordTok + L.ITtype -> KeywordTok + L.ITwhere -> KeywordTok + L.ITforall _ -> KeywordTok + L.ITexport -> KeywordTok + L.ITlabel -> KeywordTok + L.ITdynamic -> KeywordTok + L.ITsafe -> KeywordTok L.ITinterruptible -> KeywordTok - L.ITunsafe -> KeywordTok + L.ITunsafe -> KeywordTok L.ITstdcallconv -> KeywordTok L.ITccallconv -> KeywordTok - L.ITcapiconv -> KeywordTok + L.ITcapiconv -> KeywordTok L.ITprimcallconv -> KeywordTok L.ITjavascriptcallconv -> KeywordTok - L.ITmdo -> KeywordTok - L.ITfamily -> KeywordTok - L.ITrole -> KeywordTok - L.ITgroup -> KeywordTok - L.ITby -> KeywordTok - L.ITusing -> KeywordTok - L.ITpattern -> KeywordTok - L.ITstatic -> KeywordTok - L.ITstock -> KeywordTok - L.ITanyclass -> KeywordTok - L.ITvia -> KeywordTok - L.ITunit -> KeywordTok + L.ITmdo _ -> KeywordTok + L.ITfamily -> KeywordTok + L.ITrole -> KeywordTok + L.ITgroup -> KeywordTok + L.ITby -> KeywordTok + L.ITusing -> KeywordTok + L.ITpattern -> KeywordTok + L.ITstatic -> KeywordTok + L.ITstock -> KeywordTok + L.ITanyclass -> KeywordTok + L.ITvia -> KeywordTok + L.ITunit -> KeywordTok L.ITsignature -> KeywordTok L.ITdependency -> KeywordTok - L.ITrequires -> KeywordTok + L.ITrequires -> KeywordTok -- Pragmas L.ITinline_prag {} -> PragmaTok L.ITspec_prag _ -> PragmaTok @@ -250,7 +269,6 @@ L.ITcolumn_prag _ -> PragmaTok L.ITscc_prag _ -> PragmaTok L.ITgenerated_prag _ -> PragmaTok - L.ITcore_prag _ -> PragmaTok L.ITunpack_prag _ -> PragmaTok L.ITnounpack_prag _ -> PragmaTok L.ITann_prag _ -> PragmaTok @@ -276,6 +294,7 @@ L.ITvbar -> SymbolTok L.ITlarrow _ -> SymbolTok L.ITrarrow _ -> SymbolTok + L.ITlolly -> SymbolTok L.ITat -> SymbolTok L.ITtilde -> SymbolTok L.ITdarrow _ -> SymbolTok @@ -299,9 +318,11 @@ L.ITunderscore -> SymbolTok L.ITbackquote -> SymbolTok L.ITsimpleQuote -> SymbolTok + L.ITpercent -> SymbolTok -- NOTE GHC thinks these are reserved symbols, but I classify them as -- operators. L.ITminus -> OperatorTok + L.ITprefixminus -> OperatorTok L.ITdot -> OperatorTok -- Identifiers L.ITvarid _ -> VariableTok @@ -333,13 +354,11 @@ L.ITcloseQuote _ -> SymbolTok L.ITopenTExpQuote _ -> SymbolTok L.ITcloseTExpQuote -> SymbolTok - L.ITidEscape _ -> SymbolTok - L.ITparenEscape -> SymbolTok - L.ITidTyEscape _ -> SymbolTok - L.ITparenTyEscape -> SymbolTok L.ITtyQuote -> SymbolTok L.ITquasiQuote _ -> SymbolTok L.ITqQuasiQuote _ -> SymbolTok + L.ITdollar -> SymbolTok + L.ITdollardollar -> SymbolTok -- Arrow notation L.ITproc -> KeywordTok L.ITrec -> KeywordTok @@ -367,29 +386,26 @@ -- Text traversing -- | A type for 'Text' with line\/column location attached. - -data Text' = Text' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !Text +data Text' + = Text' + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Text deriving (Show) -- | Create 'Text'' from 'Text'. - initText' :: Text -> Text' initText' = Text' 1 1 -- | Try to fetch white space before start of span at 'Loc'. - tryFetchSpace :: Text' -> Loc -> Maybe (Text', Text) tryFetchSpace txt (Loc sl sc _ _) = let (txt', r) = reachLoc txt sl sc - in if T.null r - then Nothing - else Just (txt', r) + in if T.null r + then Nothing + else Just (txt', r) -- | Try to fetch the rest of 'Text'' stream. - tryFetchRest :: Text' -> Maybe (Text', Text) tryFetchRest (Text' l c txt) = if T.null txt @@ -397,18 +413,18 @@ else Just (Text' l c "", txt) -- | Fetch a span at 'Loc'. - fetchSpan :: Text' -> Loc -> (Text', Text) fetchSpan txt (Loc _ _ el ec) = reachLoc txt el ec -- | Reach given line\/column location and return 'Text' that has been -- traversed. - -reachLoc - :: Text' - -> Int -- ^ Line number to reach - -> Int -- ^ Column number to reach - -> (Text', Text) +reachLoc :: + Text' -> + -- | Line number to reach + Int -> + -- | Column number to reach + Int -> + (Text', Text) reachLoc txt@(Text' _ _ original) l c = let chunk = T.unfoldr f txt f (Text' l' c' s) = do @@ -417,15 +433,14 @@ let (l'', c'') = case ch of '\n' -> (l' + 1, 1) '\t' -> (l', c' + 8 - ((c' - 1) `rem` 8)) - _ -> (l', c' + 1) + _ -> (l', c' + 1) return (ch, Text' l'' c'' s') - in (Text' l c (T.drop (T.length chunk) original), chunk) + in (Text' l c (T.drop (T.length chunk) original), chunk) ---------------------------------------------------------------------------- -- Pragmas detection -- | Detect file header pragma. - isHeaderPragma :: Text -> Bool isHeaderPragma txt0 = isJust $ do txt1 <- T.stripStart <$> T.stripPrefix "{-#" txt0 @@ -435,34 +450,33 @@ -- Language extensions -- | Language extensions we enable by default. - enabledExts :: [Extension] enabledExts = - [ ForeignFunctionInterface - , InterruptibleFFI - , CApiFFI - , Arrows - , TemplateHaskell - , TemplateHaskellQuotes - , ImplicitParams - , OverloadedLabels - , ExplicitForAll - , BangPatterns - , PatternSynonyms - , MagicHash - , RecursiveDo - , UnicodeSyntax - , UnboxedTuples - , UnboxedSums - , DatatypeContexts - , TransformListComp - , QuasiQuotes - , LambdaCase - , BinaryLiterals - , NegativeLiterals - , HexFloatLiterals - , TypeApplications - , StaticPointers - , NumericUnderscores - , StarIsType + [ ForeignFunctionInterface, + InterruptibleFFI, + CApiFFI, + Arrows, + TemplateHaskell, + TemplateHaskellQuotes, + ImplicitParams, + OverloadedLabels, + ExplicitForAll, + BangPatterns, + PatternSynonyms, + MagicHash, + RecursiveDo, + UnicodeSyntax, + UnboxedTuples, + UnboxedSums, + DatatypeContexts, + TransformListComp, + QuasiQuotes, + LambdaCase, + BinaryLiterals, + NegativeLiterals, + HexFloatLiterals, + TypeApplications, + StaticPointers, + NumericUnderscores, + StarIsType ] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/ghc-syntax-highlighter.svg?style=flat)](https://hackage.haskell.org/package/ghc-syntax-highlighter) [![Stackage Nightly](http://stackage.org/package/ghc-syntax-highlighter/badge/nightly)](http://stackage.org/nightly/package/ghc-syntax-highlighter) [![Stackage LTS](http://stackage.org/package/ghc-syntax-highlighter/badge/lts)](http://stackage.org/lts/package/ghc-syntax-highlighter) -[![Build Status](https://travis-ci.org/mrkkrp/ghc-syntax-highlighter.svg?branch=master)](https://travis-ci.org/mrkkrp/ghc-syntax-highlighter) +![CI](https://github.com/mrkkrp/ghc-syntax-highlighter/workflows/CI/badge.svg?branch=master) This is a syntax highlighter library for Haskell using lexer of GHC itself. @@ -25,97 +25,6 @@ precision so that many tokens end up combined and the end result is typically still hard to read. -## API - -The API is extremely simple: - -```haskell --- | Token types that are used as tags to mark spans of source code. - -data Token - = KeywordTok -- ^ Keyword - | PragmaTok -- ^ Pragmas - | SymbolTok -- ^ Symbols (punctuation that is not an operator) - | VariableTok -- ^ Variable name (term level) - | ConstructorTok -- ^ Data\/type constructor - | OperatorTok -- ^ Operator - | CharTok -- ^ Character - | StringTok -- ^ String - | IntegerTok -- ^ Integer - | RationalTok -- ^ Rational number - | CommentTok -- ^ Comment (including Haddocks) - | SpaceTok -- ^ Space filling - | OtherTok -- ^ Something else? - deriving (Eq, Ord, Enum, Bounded, Show) - --- | Tokenize Haskell source code. If the code cannot be parsed, return --- 'Nothing'. Otherwise return the original input tagged by 'Token's. --- --- The parser does not require the input source code to form a valid Haskell --- program, so as long as the lexer can decompose your input (most of the --- time), it'll return something in 'Just'. - -tokenizeHaskell :: Text -> Maybe [(Token, Text)] -``` - -So given a simple program: - -```haskell -module Main (main) where - -import Data.Bits - --- | Program's entry point. - -main :: IO () -main = return () -``` - -It outputs something like this: - -```haskell -basicModule :: [(Token, Text)] -basicModule = - [ (KeywordTok,"module") - , (SpaceTok," ") - , (ConstructorTok,"Main") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"main") - , (SymbolTok,")") - , (SpaceTok," ") - , (KeywordTok,"where") - , (SpaceTok,"\n\n") - , (KeywordTok,"import") - , (SpaceTok," ") - , (ConstructorTok,"Data.Bits") - , (SpaceTok,"\n\n") - , (CommentTok,"-- | Program's entry point.") - , (SpaceTok,"\n\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (ConstructorTok,"IO") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (VariableTok,"return") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") - ] -``` - -`Nothing` is rarely returned if ever, because it looks like the lexer is -capable of interpreting almost any text as a stream of GHC tokens. - ## How to use it in your blog Depends on your markdown processor. If you're an [`mmark`][mmark] user, good @@ -128,6 +37,11 @@ [skylighting][skylighting] is what Pandoc uses. And from what I can tell it's hardcoded to use only that library for highlighting, so some creativity may be necessary to get it work. + +## Limitations + +CPP directives are not lexed correctly, because the GHC parser is not +designed to parse them. ## Contribution diff --git a/data/LambdaCase.hs b/data/LambdaCase.hs --- a/data/LambdaCase.hs +++ b/data/LambdaCase.hs @@ -1,4 +1,4 @@ foo :: Foo -> Maybe Bar foo = \case Foo -> Just Bar - _ -> Nothing + _ -> Nothing diff --git a/data/Main.hs b/data/Main.hs --- a/data/Main.hs +++ b/data/Main.hs @@ -3,6 +3,5 @@ import Data.Bits -- | Program's entry point. - main :: IO () main = return () diff --git a/data/TypeFamily.hs b/data/TypeFamily.hs --- a/data/TypeFamily.hs +++ b/data/TypeFamily.hs @@ -1,3 +1,3 @@ type family All (c :: k -> Constraint) (xs :: [k]) :: Constraint where - All c '[] = () + All c '[] = () All c (x ': xs) = (c x, All c xs) diff --git a/ghc-syntax-highlighter.cabal b/ghc-syntax-highlighter.cabal --- a/ghc-syntax-highlighter.cabal +++ b/ghc-syntax-highlighter.cabal @@ -1,56 +1,62 @@ -name: ghc-syntax-highlighter -version: 0.0.6.0 -cabal-version: 1.18 -tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 -license: BSD3 -license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/ghc-syntax-highlighter -bug-reports: https://github.com/mrkkrp/ghc-syntax-highlighter/issues -category: Text -synopsis: Syntax highlighter for Haskell using lexer of GHC itself -build-type: Simple -description: Syntax highlighter for Haskell using lexer of GHC itself. -extra-doc-files: CHANGELOG.md - , README.md -data-files: data/*.hs +cabal-version: 1.18 +name: ghc-syntax-highlighter +version: 0.0.7.0 +license: BSD3 +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +tested-with: ghc ==8.8.4 ghc ==8.10.4 ghc ==9.0.1 +homepage: https://github.com/mrkkrp/ghc-syntax-highlighter +bug-reports: https://github.com/mrkkrp/ghc-syntax-highlighter/issues +synopsis: Syntax highlighter for Haskell using lexer of GHC itself +description: Syntax highlighter for Haskell using lexer of GHC itself. +category: Text +build-type: Simple +data-files: data/*.hs +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/mrkkrp/ghc-syntax-highlighter.git + type: git + location: https://github.com/mrkkrp/ghc-syntax-highlighter.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: base >= 4.12 && < 5.0 - , ghc-lib-parser >= 8.10 && < 8.11 - , text >= 0.2 && < 1.3 - exposed-modules: GHC.SyntaxHighlighter - if flag(dev) - ghc-options: -Wall -Werror -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + exposed-modules: GHC.SyntaxHighlighter + default-language: Haskell2010 + build-depends: + base >=4.13 && <5.0, + ghc-lib-parser >=9.0 && <9.1, + text >=0.2 && <1.3 + if flag(dev) + ghc-options: + -Wall -Werror -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + + else + ghc-options: -O2 -Wall + test-suite tests - main-is: Spec.hs - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: base >= 4.12 && < 5.0 - , ghc-syntax-highlighter - , text >= 0.2 && < 1.3 - , hspec >= 2.0 && < 3.0 - other-modules: GHC.SyntaxHighlighterSpec - build-tools: hspec-discover >= 2.0 && < 3.0 - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tools: hspec-discover >=2.0 && <3.0 + hs-source-dirs: tests + other-modules: GHC.SyntaxHighlighterSpec + default-language: Haskell2010 + build-depends: + base >=4.13 && <5.0, + ghc-syntax-highlighter, + text >=0.2 && <1.3, + hspec >=2.0 && <3.0 + + if flag(dev) + ghc-options: -Wall -Werror + + else + ghc-options: -O2 -Wall diff --git a/tests/GHC/SyntaxHighlighterSpec.hs b/tests/GHC/SyntaxHighlighterSpec.hs --- a/tests/GHC/SyntaxHighlighterSpec.hs +++ b/tests/GHC/SyntaxHighlighterSpec.hs @@ -1,13 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -module GHC.SyntaxHighlighterSpec - ( spec ) -where +module GHC.SyntaxHighlighterSpec (spec) where import Data.Text (Text) +import qualified Data.Text.IO as T import GHC.SyntaxHighlighter import Test.Hspec -import qualified Data.Text.IO as T spec :: Spec spec = describe "tokenizeHaskell" $ do @@ -19,209 +17,209 @@ withFile :: FilePath -> [(Token, Text)] -> Expectation withFile path toks = do - txt <- T.readFile path - tokenizeHaskell txt `shouldBe` Just toks + txt <- T.readFile path + tokenizeHaskell txt `shouldBe` Just toks ---------------------------------------------------------------------------- -- Expected token streams basicModule :: [(Token, Text)] basicModule = - [ (KeywordTok,"module") - , (SpaceTok," ") - , (ConstructorTok,"Main") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"main") - , (SymbolTok,")") - , (SpaceTok," ") - , (KeywordTok,"where") - , (SpaceTok,"\n\n") - , (KeywordTok,"import") - , (SpaceTok," ") - , (ConstructorTok,"Data.Bits") - , (SpaceTok,"\n\n") - , (CommentTok,"-- | Program's entry point.") - , (SpaceTok,"\n\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (ConstructorTok,"IO") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (VariableTok,"return") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") + [ (KeywordTok, "module"), + (SpaceTok, " "), + (ConstructorTok, "Main"), + (SpaceTok, " "), + (SymbolTok, "("), + (VariableTok, "main"), + (SymbolTok, ")"), + (SpaceTok, " "), + (KeywordTok, "where"), + (SpaceTok, "\n\n"), + (KeywordTok, "import"), + (SpaceTok, " "), + (ConstructorTok, "Data.Bits"), + (SpaceTok, "\n\n"), + (CommentTok, "-- | Program's entry point."), + (SpaceTok, "\n"), + (VariableTok, "main"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (ConstructorTok, "IO"), + (SpaceTok, " "), + (SymbolTok, "("), + (SymbolTok, ")"), + (SpaceTok, "\n"), + (VariableTok, "main"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (VariableTok, "return"), + (SpaceTok, " "), + (SymbolTok, "("), + (SymbolTok, ")"), + (SpaceTok, "\n") ] typeFamily :: [(Token, Text)] typeFamily = - [ (KeywordTok,"type") - , (SpaceTok," ") - , (KeywordTok,"family") - , (SpaceTok," ") - , (ConstructorTok,"All") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"c") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (VariableTok,"k") - , (SpaceTok," ") - , (SymbolTok,"->") - , (SpaceTok," ") - , (ConstructorTok,"Constraint") - , (SymbolTok,")") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"xs") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (SymbolTok,"[") - , (VariableTok,"k") - , (SymbolTok,"]") - , (SymbolTok,")") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (ConstructorTok,"Constraint") - , (SpaceTok," ") - , (KeywordTok,"where") - , (SpaceTok,"\n ") - , (ConstructorTok,"All") - , (SpaceTok," ") - , (VariableTok,"c") - , (SpaceTok," ") - , (SymbolTok,"'") - , (SymbolTok,"[") - , (SymbolTok,"]") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n ") - , (ConstructorTok,"All") - , (SpaceTok," ") - , (VariableTok,"c") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"x") - , (SpaceTok," ") - , (SymbolTok,"'") - , (SymbolTok,":") - , (SpaceTok," ") - , (VariableTok,"xs") - , (SymbolTok,")") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (SymbolTok,"(") - , (VariableTok,"c") - , (SpaceTok," ") - , (VariableTok,"x") - , (SymbolTok,",") - , (SpaceTok," ") - , (ConstructorTok,"All") - , (SpaceTok," ") - , (VariableTok,"c") - , (SpaceTok," ") - , (VariableTok,"xs") - , (SymbolTok,")") - , (SpaceTok,"\n") + [ (KeywordTok, "type"), + (SpaceTok, " "), + (KeywordTok, "family"), + (SpaceTok, " "), + (ConstructorTok, "All"), + (SpaceTok, " "), + (SymbolTok, "("), + (VariableTok, "c"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (VariableTok, "k"), + (SpaceTok, " "), + (SymbolTok, "->"), + (SpaceTok, " "), + (ConstructorTok, "Constraint"), + (SymbolTok, ")"), + (SpaceTok, " "), + (SymbolTok, "("), + (VariableTok, "xs"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (SymbolTok, "["), + (VariableTok, "k"), + (SymbolTok, "]"), + (SymbolTok, ")"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (ConstructorTok, "Constraint"), + (SpaceTok, " "), + (KeywordTok, "where"), + (SpaceTok, "\n "), + (ConstructorTok, "All"), + (SpaceTok, " "), + (VariableTok, "c"), + (SpaceTok, " "), + (SymbolTok, "'"), + (SymbolTok, "["), + (SymbolTok, "]"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (SymbolTok, "("), + (SymbolTok, ")"), + (SpaceTok, "\n "), + (ConstructorTok, "All"), + (SpaceTok, " "), + (VariableTok, "c"), + (SpaceTok, " "), + (SymbolTok, "("), + (VariableTok, "x"), + (SpaceTok, " "), + (SymbolTok, "'"), + (SymbolTok, ":"), + (SpaceTok, " "), + (VariableTok, "xs"), + (SymbolTok, ")"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (SymbolTok, "("), + (VariableTok, "c"), + (SpaceTok, " "), + (VariableTok, "x"), + (SymbolTok, ","), + (SpaceTok, " "), + (ConstructorTok, "All"), + (SpaceTok, " "), + (VariableTok, "c"), + (SpaceTok, " "), + (VariableTok, "xs"), + (SymbolTok, ")"), + (SpaceTok, "\n") ] explicitForall :: [(Token, Text)] explicitForall = - [ (VariableTok,"x") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (KeywordTok,"forall") - , (SpaceTok," ") - , (VariableTok,"a") - , (OperatorTok,".") - , (SpaceTok," ") - , (VariableTok,"a") - , (SpaceTok,"\n") - , (VariableTok,"x") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (VariableTok,"undefined") - , (SpaceTok,"\n") + [ (VariableTok, "x"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (KeywordTok, "forall"), + (SpaceTok, " "), + (VariableTok, "a"), + (OperatorTok, "."), + (SpaceTok, " "), + (VariableTok, "a"), + (SpaceTok, "\n"), + (VariableTok, "x"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (VariableTok, "undefined"), + (SpaceTok, "\n") ] lambdaCase :: [(Token, Text)] lambdaCase = - [ (VariableTok,"foo") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (ConstructorTok,"Foo") - , (SpaceTok," ") - , (SymbolTok,"->") - , (SpaceTok," ") - , (ConstructorTok,"Maybe") - , (SpaceTok," ") - , (ConstructorTok,"Bar") - , (SpaceTok,"\n") - , (VariableTok,"foo") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (SymbolTok,"\\") - , (SymbolTok,"case") - , (SpaceTok,"\n ") - , (ConstructorTok,"Foo") - , (SpaceTok," ") - , (SymbolTok,"->") - , (SpaceTok," ") - , (ConstructorTok,"Just") - , (SpaceTok," ") - , (ConstructorTok,"Bar") - , (SpaceTok,"\n ") - , (SymbolTok,"_") - , (SpaceTok," ") - , (SymbolTok,"->") - , (SpaceTok," ") - , (ConstructorTok,"Nothing") - , (SpaceTok,"\n") + [ (VariableTok, "foo"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (ConstructorTok, "Foo"), + (SpaceTok, " "), + (SymbolTok, "->"), + (SpaceTok, " "), + (ConstructorTok, "Maybe"), + (SpaceTok, " "), + (ConstructorTok, "Bar"), + (SpaceTok, "\n"), + (VariableTok, "foo"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (SymbolTok, "\\"), + (SymbolTok, "case"), + (SpaceTok, "\n "), + (ConstructorTok, "Foo"), + (SpaceTok, " "), + (SymbolTok, "->"), + (SpaceTok, " "), + (ConstructorTok, "Just"), + (SpaceTok, " "), + (ConstructorTok, "Bar"), + (SpaceTok, "\n "), + (SymbolTok, "_"), + (SpaceTok, " "), + (SymbolTok, "->"), + (SpaceTok, " "), + (ConstructorTok, "Nothing"), + (SpaceTok, "\n") ] pragmas :: [(Token, Text)] pragmas = - [ (PragmaTok,"{-# LANGUAGE OverloadedStrings #-}") - , (SpaceTok,"\n") - , (PragmaTok,"{-# OPTIONS_GHC -fno-warn-unused-matches #-}") - , (SpaceTok,"\n\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"::") - , (SpaceTok," ") - , (ConstructorTok,"IO") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") - , (VariableTok,"main") - , (SpaceTok," ") - , (SymbolTok,"=") - , (SpaceTok," ") - , (VariableTok,"return") - , (SpaceTok," ") - , (SymbolTok,"(") - , (SymbolTok,")") - , (SpaceTok,"\n") + [ (PragmaTok, "{-# LANGUAGE OverloadedStrings #-}"), + (SpaceTok, "\n"), + (PragmaTok, "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"), + (SpaceTok, "\n\n"), + (VariableTok, "main"), + (SpaceTok, " "), + (SymbolTok, "::"), + (SpaceTok, " "), + (ConstructorTok, "IO"), + (SpaceTok, " "), + (SymbolTok, "("), + (SymbolTok, ")"), + (SpaceTok, "\n"), + (VariableTok, "main"), + (SpaceTok, " "), + (SymbolTok, "="), + (SpaceTok, " "), + (VariableTok, "return"), + (SpaceTok, " "), + (SymbolTok, "("), + (SymbolTok, ")"), + (SpaceTok, "\n") ]