lexer-applicative 1.1 → 1.1.1

raw patch · 4 files changed

+66/−21 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• lexer-applicative.cabal +1/−1
• src/Language/Lexer/Applicative.hs +27/−2
• tests/test.hs +28/−18

@@ -1,6 +1,16 @@ Changelog ========= +1.1.1+-----++Add `tokensEither`++1.1+---++Upgrade to srcloc 0.5+ 1.0.0.1 ------- 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                lexer-applicative-version:             1.1+version:             1.1.1 synopsis:            Simple lexer based on applicative regular expressions description:         Simple lexer based on applicative regular expressions homepage:            https://github.com/feuerbach/lexer-applicative

@@ -1,13 +1,14 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- | For an example, see -- <https://ro-che.info/articles/2015-01-02-lexical-analysis>-module Language.Lexer.Applicative (tokens, LexicalError(..)) where+module Language.Lexer.Applicative (tokens, tokensEither, LexicalError(..)) where  import Text.Regex.Applicative import Data.Loc import Data.List import Data.Typeable (Typeable) import Control.Exception+import System.IO.Unsafe (unsafePerformIO)  annotate   :: String -- ^ source file name@@ -21,7 +22,7 @@  -- | The lexical error exception data LexicalError = LexicalError !Pos-  deriving Typeable+  deriving (Eq, Typeable)  instance Show LexicalError where   show (LexicalError pos) = "Lexical error at " ++ displayPos pos@@ -68,3 +69,27 @@    re :: RE (Char, Pos, Pos) (Maybe token)   re = comap (\(c, _, _) -> c) $ (Just <$> pToken) <|> (Nothing <$ pJunk)++-- | 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+  where+    forceSpine :: [a] -> [a]+    forceSpine xs = foldr (const id) xs xs+{-# NOINLINE tokensEither #-}

@@ -18,24 +18,34 @@ badWhitespace = () <$ many (psym isSpace)  main = defaultMain $ testGroup "Tests"-  [ 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+  [ 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))+    ]   ]  -- orphan