diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Roman Cheplyaka + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +Simple applicative lexer based on the article +[Lexical analysis with parser combinators][1] +and the [regex-applicative][2] library. + +[1]: https://ro-che.info/articles/2015-01-02-lexical-analysis> +[2]: http://hackage.haskell.org/package/regex-applicative-0.3.1/docs/Text-Regex-Applicative.html diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lexer-applicative.cabal b/lexer-applicative.cabal new file mode 100644 --- /dev/null +++ b/lexer-applicative.cabal @@ -0,0 +1,51 @@ +-- Initial lexer-applicative.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: lexer-applicative +version: 1.0 +synopsis: Simple lexer based on applicative regular expressions +description: Simple lexer based on applicative regular expressions +homepage: https://github.com/feuerbach/lexer-applicative +license: MIT +license-file: LICENSE +author: Roman Cheplyaka +maintainer: Roman Cheplyaka +-- copyright: +category: Language +build-type: Simple +extra-source-files: + README.md +cabal-version: >=1.10 + +Source-repository head + type: git + location: git://github.com/feuerbach/lexer-applicative.git + +library + exposed-modules: + Language.Lexer.Applicative + -- other-modules: + -- other-extensions: + build-depends: + base >=4.5 && < 5, + srcloc, + regex-applicative >= 0.3.1 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: + base >= 4 && < 5 + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , regex-applicative + , lexer-applicative + , srcloc diff --git a/src/Language/Lexer/Applicative.hs b/src/Language/Lexer/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lexer/Applicative.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +-- | For an example, see +-- +module Language.Lexer.Applicative (tokens, LexicalError(..)) where + +import Text.Regex.Applicative +import Data.Loc +import Data.List +import Data.Typeable (Typeable) +import Control.Exception + +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)) + +-- | The lexical error exception +data LexicalError = LexicalError !Pos + deriving Typeable + +instance Show LexicalError where + 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. +tokens + :: 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 + -> [L token] +tokens pToken pJunk src = go . annotate src + where + go l = case l of + [] -> [] + s@((_, pos1, _):_) -> + case findLongestPrefix re s of + Just (Just tok, rest) -> + let + pos2 = + case rest of + (_, _, p):_ -> p + [] -> case last s of (_, p, _) -> p + + in L (Loc pos1 pos2) tok : go rest + + Just (Nothing, rest) -> go rest + + Nothing -> throw $ LexicalError pos1 + + re :: RE (Char, Pos, Pos) (Maybe token) + re = comap (\(c, _, _) -> c) $ (Just <$> pToken) <|> (Nothing <$ pJunk) + +-- | Format a position +displayPos :: Pos -> String +displayPos (Pos src line col _) = + src ++ (colon . shows line . colon . shows (col+1)) "" + where + colon = (':' :) diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,23 @@ +import Test.Tasty +import Test.Tasty.HUnit + +import Language.Lexer.Applicative +import Text.Regex.Applicative +import Text.Regex.Applicative.Common +import Data.Char +import Data.Loc (L(..), Loc(..), Pos(..)) + +whitespace = () <$ some (psym isSpace) + +unloc (L l a) = (a, l) + +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 0 0) (Pos "-" 1 0 0)) + , (23, Loc (Pos "-" 2 1 3) (Pos "-" 2 2 4)) + , (456,Loc (Pos "-" 2 5 7) (Pos "-" 2 7 9)) + ] + ]