lexer-applicative 1.1.1 → 2.0

raw patch · 4 files changed

+359/−98 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• lexer-applicative.cabal +2/−1
• src/Language/Lexer/Applicative.hs +277/−64
• tests/test.hs +70/−33

@@ -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 ----- 

@@ -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:

@@ -1,25 +1,207 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}--- | For an example, see+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor, TypeFamilies #-}+-- | For some background, see -- <https://ro-che.info/articles/2015-01-02-lexical-analysis>-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))

@@ -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