diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ Changelog ========= +2.0 +--- + +This is a major redesign of the API. Notable changes: + +- The lexer now supports parsing the longest prefix/shortest suffix + (see `longestShortest`) +- Instead of throwing an exception, we return a stream. The stream can be + consumed directly, converted to a list or either-error-list of tokens. + 1.1.1 ----- diff --git a/lexer-applicative.cabal b/lexer-applicative.cabal --- a/lexer-applicative.cabal +++ b/lexer-applicative.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: lexer-applicative -version: 1.1.1 +version: 2.0 synopsis: Simple lexer based on applicative regular expressions description: Simple lexer based on applicative regular expressions homepage: https://github.com/feuerbach/lexer-applicative @@ -33,6 +33,7 @@ regex-applicative >= 0.3.1 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall test-suite test default-language: diff --git a/src/Language/Lexer/Applicative.hs b/src/Language/Lexer/Applicative.hs --- a/src/Language/Lexer/Applicative.hs +++ b/src/Language/Lexer/Applicative.hs @@ -1,25 +1,207 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} --- | For an example, see +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor, TypeFamilies #-} +-- | For some background, see -- -module Language.Lexer.Applicative (tokens, tokensEither, LexicalError(..)) where +module Language.Lexer.Applicative + ( + -- * Building a Lexer + Lexer(..) + , token + , whitespace + -- ** Building Recognizers + , Recognizer + , longest + , longestShortest + -- * Running a Lexer + , runLexer + -- ** Working with a token stream + , TokenStream(..) + , streamToList + , streamToEitherList + , LexicalError(..) + ) where import Text.Regex.Applicative import Data.Loc import Data.List import Data.Typeable (Typeable) +import Data.Monoid +import Data.Function import Control.Exception -import System.IO.Unsafe (unsafePerformIO) +import GHC.Exts -annotate - :: String -- ^ source file name - -> String -- ^ contents - -> [(Char, Pos, Pos)] -- ^ the character, its position, and the previous position -annotate src s = snd $ mapAccumL f (startPos src, startPos src) s - where - f (pos, prev_pos) ch = - let pos' = advancePos pos ch - in pos' `seq` ((pos', pos), (ch, pos, prev_pos)) +---------------------------------------------------------------------- +-- Lexer +---------------------------------------------------------------------- +-- | A 'Lexer' specification consists of two recognizers: one for +-- meaningful tokens and one for whitespace and comments. +-- +-- Although you can construct 'Lexer's directly, it is more convenient to +-- build them with 'token', 'whitespace', and the 'Monoid' instance like this: +-- +-- @ +-- myLexer :: 'Lexer' MyToken +-- myLexer = 'mconcat' +-- [ 'token' ('longest' myToken) +-- , 'whitespace' ('longest' myWhiteSpace) +-- , 'whitespace' ('longestShortest' myComment) +-- ] +-- @ +data Lexer tok = Lexer + { lexerTokenRE :: Recognizer tok + , lexerWhitespaceRE :: Recognizer () + } + deriving Functor + +instance Monoid (Lexer tok) where + mempty = Lexer mempty mempty + Lexer t1 w1 `mappend` Lexer t2 w2 = Lexer (t1 <> t2) (w1 <> w2) + +-- | Build a lexer with the given token recognizer and no (i.e. 'mempty') +-- whitespace recognizer. +-- +-- 'token' is a monoid homomorphism: +-- +-- @'token' a '<>' 'token' b = 'token' (a '<>' b)@ +token :: Recognizer tok -> Lexer tok +token r = Lexer r mempty + +-- | Build a lexer with the given whitespace recognizer and no (i.e. 'mempty') +-- token recognizer. +-- +-- 'whitespace' is a monoid homomorphism: +-- +-- @'whitespace' a '<>' 'whitespace' b = 'whitespace' (a '<>' b)@ +whitespace :: Recognizer a -> Lexer tok +whitespace r = Lexer mempty (() <$ r) + +---------------------------------------------------------------------- +-- Recognizer +---------------------------------------------------------------------- + +-- | A token recognizer +-- +-- 'Recognizer' values are constructed by functions like 'longest' and +-- 'longestShortest', combined with `mappend`, and used by 'token' and +-- 'whitespace'. +-- +-- When a recognizer returns without consuming any characters, a lexical +-- error is signaled. +newtype Recognizer tok = Recognizer (RE Char (RE Char tok)) + deriving Functor + +instance Monoid (Recognizer tok) where + mempty = Recognizer empty + mappend (Recognizer r1) (Recognizer r2) = Recognizer (r1 <|> r2) + +-- | When scanning a next token, the regular expression will compete with +-- the other 'Recognizer's of its 'Lexer'. If it wins, its result +-- will become the next token. +-- +-- 'longest' has the following properties: +-- +-- * @'longest' (r1 '<|>' r2) = 'longest' r1 '<>' 'longest' r2@ +-- +-- * @'longest' r = 'longestShortest' 'const' r ('const' '$' 'pure' ())@ +longest + :: RE Char tok + -> Recognizer tok +longest re = longestShortest const re (const $ pure ()) + +-- | This is a more sophisticated recognizer than 'longest'. +-- +-- It recognizes a token consisting of a prefix and a suffix, where prefix +-- is chosen longest, and suffix is chosen shortest. +-- +-- An example would be a C block comment +-- +-- >/* comment text */ +-- +-- The naive +-- +-- @'longest' ('string' "\/*" '*>' 'many' 'anySym' '*>' 'string' "*\/")@ +-- +-- doesn't work because it consumes too much: in +-- +-- >/* xxx */ yyy /* zzz */ +-- +-- it will treat the whole line as a comment. +-- +-- This is where 'longestShortest' comes in handy: +-- +-- @ +-- 'longestShortest' +-- (\\_ _ -> ()) -- don't care about the comment text +-- ('string' "\/*") +-- (\\_ -> 'many' 'anySym' '*>' 'string' "*\/") +-- @ +-- +-- Operationally, the prefix regex first competes with other 'Recognizer's +-- for the longest match. If it wins, then the shortest match for the +-- suffix regex is found, and the two results are combined with the given +-- function to produce a token. +-- +-- The two regular expressions combined must consume some input, or else +-- 'LexicalError' is thrown. However, any one of them may return without +-- consuming input. +-- +-- \* * * +-- +-- Once the prefix regex wins, the choice is committed; the suffix regex +-- must match or else a 'LexicalError' is thrown. Therefore, +-- +-- @ +-- 'longestShortest' f pref suff1 +-- '<>' +-- 'longestShortest' f pref suff2 +-- = +-- 'longestShortest' f pref suff1 +-- @ +-- +-- and is not the same as +-- +-- @'longestShortest' f pref (suff1 '<|>' suff2)@ +-- +-- The following holds, however: +-- +-- @ +-- 'longestShortest' f pref1 suff +-- '<>' +-- 'longestShortest' f pref2 suff +-- = +-- 'longestShortest' f (pref1 '<|>' pref2) suff +-- @ +-- +-- \* * * +-- +-- Passing the result of prefix into both suffix and combining function may +-- seem superfluous; indeed we could get away with +-- +-- @'RE' 'Char' pref -> (pref -> 'RE' 'Char' tok) -> 'Recognizer' tok@ +-- +-- or even +-- +-- @'RE' 'Char' ('RE' 'Char' tok) -> 'Recognizer' tok@ +-- +-- This is done purely for convenience and readability; the intention is +-- that @pref@ passed into suffix is used to customize the regular +-- expression which would still return only its part of the token, and then +-- the function will combine the two parts. Of course, you don't need to +-- follow this recommendation. Thanks to parametricity, all three versions +-- are equivalent. +longestShortest + :: (pref -> suff -> tok) + -> RE Char pref -- ^ regex for the longest prefix + -> (pref -> RE Char suff) -- ^ regex for the shortest suffix + -> Recognizer tok +longestShortest f prefRE suffRE = + Recognizer $ + (\pref -> f pref <$> suffRE pref) <$> prefRE + +---------------------------------------------------------------------- +-- Running a Lexer +---------------------------------------------------------------------- + -- | The lexical error exception data LexicalError = LexicalError !Pos deriving (Eq, Typeable) @@ -28,68 +210,99 @@ show (LexicalError pos) = "Lexical error at " ++ displayPos pos instance Exception LexicalError --- | The lexer. --- --- In case of a lexical error, throws the 'LexicalError' exception. --- This may seem impure compared to using 'Either', but it allows to --- consume the token list lazily. --- --- Both token and whitespace regexes consume as many characters as possible --- (the maximal munch rule). When a regex returns without consuming any --- characters, a lexical error is signaled. -tokens - :: forall token. - RE Char token -- ^ regular expression for tokens - -> RE Char () -- ^ regular expression for whitespace and comments +-- | A stream of tokens +data TokenStream tok + = TsToken tok (TokenStream tok) + | TsEof + | TsError LexicalError + deriving (Eq, Functor, Show) + +instance IsList (TokenStream tok) where + type Item (TokenStream tok) = tok + toList = streamToList + fromList = foldr TsToken TsEof + +-- | Convert a 'TokenStream' to a list of tokens. Turn 'TsError' into +-- a runtime 'LexicalError' exception. +streamToList :: TokenStream tok -> [tok] +streamToList stream = + case stream of + TsToken t stream' -> t : streamToList stream' + TsEof -> [] + TsError e -> throw e + +-- | Convert a 'TokenStream' into either a token list or a 'LexicalError'. +-- This function may be occasionally useful, but in general its use is +-- discouraged because it needs to force the whole stream before returning +-- a result. +streamToEitherList :: TokenStream tok -> Either LexicalError [tok] +streamToEitherList = + sequence . + fix (\rec stream -> + case stream of + TsToken t stream' -> Right t : rec stream' + TsEof -> [] + TsError e -> [Left e] + ) + +-- | Run a lexer on a string and produce a lazy stream of tokens +runLexer + :: forall tok. + Lexer tok -- ^ lexer specification -> String -- ^ source file name (used in locations) -> String -- ^ source text - -> [L token] -tokens pToken pJunk src = go . annotate src + -> TokenStream (L tok) +runLexer (Lexer (Recognizer pToken) (Recognizer pJunk)) src = go . annotate src where go l = case l of - [] -> [] + [] -> TsEof s@((_, pos1, _):_) -> + let + -- last position in the stream + -- in this branch s is non-empty, so this is safe + last_pos :: Pos + last_pos = case last s of (_, p, _) -> p + in case findLongestPrefix re s of - -- If the longest match is empty, we have a lexical error - Just (v, (_, pos1', _):_) | pos1' == pos1 -> - throw $ LexicalError pos1 - Just (Just tok, rest) -> - let - pos2 = - case rest of + Nothing -> TsError (LexicalError pos1) + + Just (shortest_re, rest1) -> + + case findShortestPrefix shortest_re rest1 of + Nothing -> TsError . LexicalError $ + case rest1 of (_, _, p):_ -> p - [] -> case last s of (_, p, _) -> p + [] -> last_pos - in L (Loc pos1 pos2) tok : go rest + -- If the combined match is empty, we have a lexical error + Just (_, (_, pos1', _):_) | pos1' == pos1 -> + TsError $ LexicalError pos1 - Just (Nothing, rest) -> go rest + Just (Just tok, rest) -> + let + pos2 = + case rest of + (_, _, p):_ -> p + [] -> last_pos - Nothing -> throw $ LexicalError pos1 + in TsToken (L (Loc pos1 pos2) tok) (go rest) - re :: RE (Char, Pos, Pos) (Maybe token) - re = comap (\(c, _, _) -> c) $ (Just <$> pToken) <|> (Nothing <$ pJunk) + Just (Nothing, rest) -> go rest --- | Like `tokens`, but returns 'Left' instead of throwing an exception. --- --- This function may be useful occasionally, but most of the time you --- should be using 'tokens' instead. If you want to catch 'LexicalError', --- catch it /after/ you plug 'tokens' into a parser, not /before/, like this --- function does. -tokensEither - :: forall token. - RE Char token -- ^ regular expression for tokens - -> RE Char () -- ^ regular expression for whitespace and comments - -> String -- ^ source file name (used in locations) - -> String -- ^ source text - -> Either LexicalError [L token] -tokensEither pToken pJunk src = - unsafePerformIO - . try - . evaluate - . forceSpine - . tokens pToken pJunk src + extend :: RE Char a -> RE (Char, Pos, Pos) a + extend = comap (\(c, _, _) -> c) + + re :: RE (Char, Pos, Pos) (RE (Char, Pos, Pos) (Maybe tok)) + re = extend . fmap extend $ + ((Just <$>) <$> pToken) <|> ((Nothing <$) <$> pJunk) + +annotate + :: String -- ^ source file name + -> String -- ^ contents + -> [(Char, Pos, Pos)] -- ^ the character, its position, and the previous position +annotate src s = snd $ mapAccumL f (startPos src, startPos src) s where - forceSpine :: [a] -> [a] - forceSpine xs = foldr (const id) xs xs -{-# NOINLINE tokensEither #-} + f (pos, prev_pos) ch = + let pos' = advancePos pos ch + in pos' `seq` ((pos', pos), (ch, pos, prev_pos)) diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedLists #-} import Test.Tasty import Test.Tasty.HUnit @@ -6,46 +6,83 @@ import Text.Regex.Applicative import Text.Regex.Applicative.Common import Data.Char -import Data.Loc (L(..), Loc(..), Pos(..)) +import Data.Monoid +import Data.Loc import Control.Exception import Control.DeepSeq -whitespace = () <$ some (psym isSpace) +ws = whitespace $ longest $ some (psym isSpace) +-- this is bad, because it accepts an empty string +badWhitespace = whitespace $ longest $ many (psym isSpace) +word = longestToken $ many $ psym isAlpha + +longestToken = token . longest + +tokens l n s = streamToList $ runLexer l n s +tokensEither l n s = streamToEitherList $ runLexer l n s + unloc (L l a) = (a, l) --- this is bad, because it accepts an empty string -badWhitespace = () <$ many (psym isSpace) +-- This recognizes C-style block comments like /* ... */, +-- but also matching delimiters like /*** ... ***/ (to make it more fun) +blockComment = token $ + longestShortest + (,) + ((++) <$> string "/" <*> many (sym '*')) + (\start -> (++) <$> many anySym <*> string (reverse start)) main = defaultMain $ testGroup "Tests" - [ testGroup "tokens" - [ testCase "Empty string" $ - tokens (empty :: RE Char Int) empty "-" "" @=? [] - , testCase "Space- and newline-separated numbers" $ - unloc <$> tokens decimal whitespace "-" "1\n 23 456" @?= - [ (1, Loc (Pos "-" 1 1 0) (Pos "-" 1 1 0)) - , (23, Loc (Pos "-" 2 2 3) (Pos "-" 2 3 4)) - , (456,Loc (Pos "-" 2 6 7) (Pos "-" 2 8 9)) - ] - , testCase "Nullable parser, no error" $ do - r <- try . evaluate $ tokens decimal badWhitespace "-" "31 45" - case r of - Right (_ :: [L Int]) -> return () - Left (e :: SomeException) -> assertFailure $ show e - , testCase "Nullable parser, error" $ do - r <- try . evaluate . force $ tokens decimal badWhitespace "-" "31? 45" - case r of - Right (_ :: [L Int]) -> assertFailure "No error?" - Left (LexicalError p) -> p @?= Pos "-" 1 3 2 - ] - -- end testGroup "tokens" - - , testGroup "tokensEither" - [ testCase "Returns Right upon success" $ do - tokensEither decimal empty "-" "1" @=? Right [L (Loc (Pos "-" 1 1 0) (Pos "" 1 1 0)) 1] - , testCase "Returns Left upon failure" $ do - tokensEither decimal empty "-" "a" @=? Left (LexicalError (Pos "-" 1 1 0)) - ] + [ testCase "Empty string" $ + tokens (longestToken (empty :: RE Char Int) <> whitespace mempty) "-" "" @=? [] + , testCase "Space- and newline-separated numbers" $ + unloc <$> tokens (longestToken decimal <> ws) "-" "1\n 23 456" @?= + [ (1, Loc (Pos "-" 1 1 0) (Pos "-" 1 1 0)) + , (23, Loc (Pos "-" 2 2 3) (Pos "-" 2 3 4)) + , (456,Loc (Pos "-" 2 6 7) (Pos "-" 2 8 9)) + ] + , testCase "Nullable parser, no error" $ do + let r = tokensEither (longestToken decimal <> badWhitespace) "-" "31 45" + case r of + Right (_ :: [L Int]) -> return () + Left e -> assertFailure $ show e + , testCase "Nullable parser, error" $ do + let r = tokensEither (longestToken decimal <> badWhitespace) "-" "31? 45" + case r of + Right (_ :: [L Int]) -> assertFailure "No error?" + Left (LexicalError p) -> p @?= Pos "-" 1 3 2 + , testCase "No matches, error" $ do + tokensEither (longestToken decimal) "-" " " @?= Left (LexicalError (Pos "-" 1 1 0)) + , testCase "No matches after a recognized token" $ do + fmap unloc (runLexer (longestToken decimal <> ws) "-" "2 x") @?= + TsToken (2 :: Int, Loc (Pos "-" 1 1 0) (Pos "-" 1 1 0)) (TsError $ LexicalError (Pos "-" 1 3 2)) + , testCase "streamToList throws an exception upon failure" $ do + r :: Either LexicalError [L ()] <- try . evaluate . force $ tokens mempty "-" " " + r @?= Left (LexicalError (Pos "-" 1 1 0)) + , testCase "longestShortest (success)" $ + fmap (map unLoc) + (tokensEither ((Left <$> blockComment) <> (Right <$> word) <> ws) + "-" + "/* xxx */ yyy /*** abc ***/ ef") + @?= + Right [Left ("/*"," xxx */"),Right "yyy",Left ("/***"," abc ***/"),Right "ef"] + , testCase "longestShortest (failure of shortest; end of stream)" $ + (tokensEither (whitespace $ longestShortest (\_ _ -> ()) (string "abc") (const empty)) + "-" + "abc" :: Either LexicalError [L ()]) + @?= + Left (LexicalError (Pos "-" 1 3 2)) + , testCase "longestShortest (failure of shortest; not end of stream)" $ + (tokensEither (whitespace $ longestShortest (\_ _ -> ()) (string "abc") (const empty)) + "-" + "abc " :: Either LexicalError [L ()]) + @?= + Left (LexicalError (Pos "-" 1 3 2)) + , testCase "instance IsList TokenStream" $ do + let r :: TokenStream Int + r = fmap unLoc $ runLexer (longestToken decimal <> ws) "-" "1 2 3" + [1,2,3] <- return r -- testing pattern match, i.e. toList + r @?= [1,2,3] -- testing fromList ] -- orphan