diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## GHC syntax highligher 0.0.1.0 + +* Initial release. diff --git a/GHC/SyntaxHighlighter.hs b/GHC/SyntaxHighlighter.hs new file mode 100644 --- /dev/null +++ b/GHC/SyntaxHighlighter.hs @@ -0,0 +1,480 @@ +-- | +-- Module : GHC.SyntaxHighlighter +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- The module allows you to decompose a 'Text' stream containing Haskell +-- source code into a stream of 'Text' chunks tagged with 'Token'. +-- +-- 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-unused-top-binds #-} + +module GHC.SyntaxHighlighter + ( Token (..) + , tokenizeHaskell ) +where + +import Control.Monad +import Data.Bits +import Data.List (unfoldr, foldl') +import Data.Text (Text) +import Data.Word (Word64) +import FastString (mkFastString) +import Module (newSimpleUnitId, ComponentId (..)) +import SrcLoc +import StringBuffer +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? + deriving (Eq, Ord, Enum, Bounded, Show) + +-- | Internal type containing line\/column combinations for start and end +-- positions of a code span. + +data Loc = Loc !Int !Int !Int !Int + deriving (Show) + +---------------------------------------------------------------------------- +-- High-level API + +-- | 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)] +tokenizeHaskell input = + case L.unP pLexer parseState of + L.PFailed {} -> Nothing + L.POk _ x -> Just (sliceInputStream input x) + where + location = mkRealSrcLoc (mkFastString "") 1 1 + buffer = stringToStringBuffer (T.unpack input) + parseState = L.mkPStatePure parserFlags buffer location + parserFlags = L.ParserFlags + { L.pWarningFlags = ES.empty + , L.pExtensionFlags = ES.empty + , L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")) + , L.pExtsBitmap = extsBitmap + } + +-- | Haskell lexer. + +pLexer :: L.P [(Token, Loc)] +pLexer = go + where + go = do + r <- L.lexer False return + case r of + L _ L.ITeof -> return [] + _ -> + case fixupToken r of + Nothing -> go + Just x -> (x:) <$> go + +-- | 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)) = + case tryFetchSpace txt l of + Nothing -> + let (txt', chunk) = fetchSpan txt l + in Just ((t, chunk), (txt', ts)) + Just (txt', chunk) -> + Just ((SpaceTok, chunk), (txt', tss)) + +-- | 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 _ = 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.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.ITinterruptible -> KeywordTok + L.ITunsafe -> KeywordTok + L.ITstdcallconv -> KeywordTok + L.ITccallconv -> 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.ITunit -> KeywordTok + L.ITsignature -> KeywordTok + L.ITdependency -> KeywordTok + L.ITrequires -> KeywordTok + -- Pragmas + L.ITinline_prag {} -> PragmaTok + L.ITspec_prag _ -> PragmaTok + L.ITspec_inline_prag {} -> PragmaTok + L.ITsource_prag _ -> PragmaTok + L.ITrules_prag _ -> PragmaTok + L.ITwarning_prag _ -> PragmaTok + L.ITdeprecated_prag _ -> PragmaTok + L.ITline_prag _ -> PragmaTok + 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 + L.ITcomplete_prag _ -> PragmaTok + L.ITclose_prag -> PragmaTok + L.IToptions_prag _ -> PragmaTok + L.ITinclude_prag _ -> PragmaTok + L.ITlanguage_prag -> PragmaTok + L.ITvect_prag _ -> PragmaTok + L.ITvect_scalar_prag _ -> PragmaTok + L.ITnovect_prag _ -> PragmaTok + L.ITminimal_prag _ -> PragmaTok + L.IToverlappable_prag _ -> PragmaTok + L.IToverlapping_prag _ -> PragmaTok + L.IToverlaps_prag _ -> PragmaTok + L.ITincoherent_prag _ -> PragmaTok + L.ITctype _ -> PragmaTok + -- Reserved symbols + L.ITdotdot -> SymbolTok + L.ITcolon -> SymbolTok + L.ITdcolon _ -> SymbolTok + L.ITequal -> SymbolTok + L.ITlam -> SymbolTok + L.ITlcase -> SymbolTok + L.ITvbar -> SymbolTok + L.ITlarrow _ -> SymbolTok + L.ITrarrow _ -> SymbolTok + L.ITat -> SymbolTok + L.ITtilde -> SymbolTok + L.ITtildehsh -> SymbolTok + L.ITdarrow _ -> SymbolTok + L.ITbang -> SymbolTok + L.ITbiglam -> SymbolTok + L.ITocurly -> SymbolTok + L.ITccurly -> SymbolTok + L.ITvocurly -> SymbolTok + L.ITvccurly -> SymbolTok + L.ITobrack -> SymbolTok + L.ITopabrack -> SymbolTok + L.ITcpabrack -> SymbolTok + L.ITcbrack -> SymbolTok + L.IToparen -> SymbolTok + L.ITcparen -> SymbolTok + L.IToubxparen -> SymbolTok + L.ITcubxparen -> SymbolTok + L.ITsemi -> SymbolTok + L.ITcomma -> SymbolTok + L.ITunderscore -> SymbolTok + L.ITbackquote -> SymbolTok + L.ITsimpleQuote -> SymbolTok + -- NOTE GHC thinks these are reserved symbols, but I classify them as + -- operators. + L.ITminus -> OperatorTok + L.ITdot -> OperatorTok + -- Identifiers + L.ITvarid _ -> VariableTok + L.ITconid _ -> ConstructorTok + L.ITvarsym _ -> OperatorTok + L.ITconsym _ -> OperatorTok + L.ITqvarid _ -> VariableTok + L.ITqconid _ -> ConstructorTok + L.ITqvarsym _ -> OperatorTok + L.ITqconsym _ -> OperatorTok + L.ITdupipvarid _ -> VariableTok + L.ITlabelvarid _ -> VariableTok + -- Basic types + L.ITchar _ _ -> CharTok + L.ITstring _ _ -> StringTok + L.ITinteger _ -> IntegerTok + L.ITrational _ -> RationalTok + L.ITprimchar _ _ -> CharTok + L.ITprimstring _ _ -> StringTok + L.ITprimint _ _ -> IntegerTok + L.ITprimword _ _ -> IntegerTok + L.ITprimfloat _ -> RationalTok + L.ITprimdouble _ -> RationalTok + -- Template Haskell extension tokens + L.ITopenExpQuote _ _ -> SymbolTok + L.ITopenPatQuote -> SymbolTok + L.ITopenDecQuote -> SymbolTok + L.ITopenTypQuote -> SymbolTok + 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 + -- Arrow notation + L.ITproc -> KeywordTok + L.ITrec -> KeywordTok + L.IToparenbar _ -> SymbolTok + L.ITcparenbar _ -> SymbolTok + L.ITlarrowtail _ -> SymbolTok + L.ITrarrowtail _ -> SymbolTok + L.ITLarrowtail _ -> SymbolTok + L.ITRarrowtail _ -> SymbolTok + -- Type application + L.ITtypeApp -> SymbolTok + -- Special + L.ITunknown _ -> OtherTok + L.ITeof -> OtherTok -- normally is not included in results + -- Documentation annotations + L.ITdocCommentNext _ -> CommentTok + L.ITdocCommentPrev _ -> CommentTok + L.ITdocCommentNamed _ -> CommentTok + L.ITdocSection _ _ -> CommentTok + L.ITdocOptions _ -> CommentTok + L.ITlineComment _ -> CommentTok + L.ITblockComment _ -> CommentTok + +---------------------------------------------------------------------------- +-- Text traversing + +-- | A type for 'Text' with line\/column location attached. + +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) + +-- | Try to fetch the rest of 'Text'' stream. + +tryFetchRest :: Text' -> Maybe (Text', Text) +tryFetchRest (Text' l c txt) = + if T.null txt + then Nothing + else Just (Text' l c "", txt) + +-- | Fetch 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 txt@(Text' _ _ original) l c = + let chunk = T.unfoldr f txt + f (Text' l' c' s) = do + guard (l' < l || c' < c) + (ch, s') <- T.uncons s + let (l'', c'') = case ch of + '\n' -> (l' + 1, 1) + '\t' -> (l', c' + 8 - ((c' - 1) `rem` 8)) + _ -> (l', c' + 1) + return (ch, Text' l'' c'' s') + in (Text' l c (T.drop (T.length chunk) original), chunk) + +---------------------------------------------------------------------------- +-- Exts bitmap hack + +-- | Extension bitmap we use in this library. + +extsBitmap :: Word64 +extsBitmap = mkExtsBitmap enabledExts +{-# NOINLINE extsBitmap #-} + +-- | Create extension bitmap similarly to how it's done in GHC. + +mkExtsBitmap :: [ExtBits] -> Word64 +mkExtsBitmap = foldl' f 0 + where + f w x = bit (fromEnum x) .|. w + +-- | Copied from GHC sources that are not yet available in the @ghc@ +-- package. + +data ExtBits + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ParrBit + | ArrowsBit + | ThBit + | ThQuotesBit + | IpBit + | OverloadedLabelsBit -- #x overloaded labels + | ExplicitForallBit -- the 'forall' keyword and '.' symbol + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | UnboxedSumsBit -- (# and #) + | DatatypeContextsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | InRulePragBit + | RawTokenStreamBit -- producing a token stream with all comments included + | SccProfilingOnBit + | HpcBit + | AlternativeLayoutRuleBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + | HexFloatLiteralsBit + | TypeApplicationsBit + | StaticPointersBit + | NumericUnderscoresBit + deriving Enum + +-- | Extension we enable for the best user experience. + +enabledExts :: [ExtBits] +enabledExts = + [ FfiBit + , InterruptibleFfiBit + , CApiFfiBit + , ParrBit + , ArrowsBit + , ThBit + , ThQuotesBit + , IpBit + , OverloadedLabelsBit + , ExplicitForallBit + , BangPatBit + , PatternSynonymsBit + , HaddockBit + , MagicHashBit + , RecursiveDoBit + , UnicodeSyntaxBit + , UnboxedTuplesBit + , UnboxedSumsBit + , DatatypeContextsBit + , TransformComprehensionsBit + , QqBit + , InRulePragBit + , RawTokenStreamBit + , SafeHaskellBit + , LambdaCaseBit + , BinaryLiteralsBit + , NegativeLiteralsBit + , HexFloatLiteralsBit + , TypeApplicationsBit + , StaticPointersBit + , NumericUnderscoresBit + ] diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2018 Mark Karpov + +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 Mark Karpov nor the names of 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 “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 HOLDERS 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,15 @@ +# GHC syntax highligher + +[![License FreeBSD](https://img.shields.io/badge/license-FreeBSD-brightgreen.svg)](http://opensource.org/licenses/BSD-2-Clause) +[![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) + +Syntax highlighter for Haskell using GHC itself as a library. + +## License + +Copyright © 2018 Mark Karpov + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/data/Forall.hs b/data/Forall.hs new file mode 100644 --- /dev/null +++ b/data/Forall.hs @@ -0,0 +1,2 @@ +x :: forall a. a +x = undefined diff --git a/data/Main.hs b/data/Main.hs new file mode 100644 --- /dev/null +++ b/data/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Data.Bits + +-- | Program's entry point. + +main :: IO () +main = return () diff --git a/data/TypeFamily.hs b/data/TypeFamily.hs new file mode 100644 --- /dev/null +++ b/data/TypeFamily.hs @@ -0,0 +1,3 @@ +type family All (c :: k -> Constraint) (xs :: [k]) :: Constraint where + All c '[] = () + All c (x ': xs) = (c x, All c xs) diff --git a/ghc-syntax-highlighter.cabal b/ghc-syntax-highlighter.cabal new file mode 100644 --- /dev/null +++ b/ghc-syntax-highlighter.cabal @@ -0,0 +1,57 @@ +name: ghc-syntax-highlighter +version: 0.0.1.0 +cabal-version: 1.18 +tested-with: GHC==8.4.2 +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: Correct syntax highlighter for Haskell using GHC itself +build-type: Simple +description: Correct syntax highlighter for Haskell using GHC itself. +extra-doc-files: CHANGELOG.md + , README.md +data-files: data/*.hs + +source-repository head + type: git + location: https://github.com/mrkkrp/ghc-syntax-highlighter.git + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: base >= 4.11 && < 5.0 + , ghc >= 8.4 && < 8.5 + , 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 + -Wnoncanonical-monadfail-instances + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Spec.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + build-depends: base >= 4.11 && < 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 diff --git a/tests/GHC/SyntaxHighlighterSpec.hs b/tests/GHC/SyntaxHighlighterSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GHC/SyntaxHighlighterSpec.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.SyntaxHighlighterSpec + ( spec ) +where + +import Data.Text (Text) +import GHC.SyntaxHighlighter +import Test.Hspec +import qualified Data.Text.IO as T + +spec :: Spec +spec = describe "tokenizeHaskell" $ do + it "parses a basic module" (withFile "data/Main.hs" basicModule) + it "parses a type family" (withFile "data/TypeFamily.hs" typeFamily) + it "parses an explicit forall" (withFile "data/Forall.hs" explicitForall) + +withFile :: FilePath -> [(Token, Text)] -> Expectation +withFile path toks = do + 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") + ] + +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") + ] + +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") + ] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}