lex-applicative (empty) → 0.0.0.0
raw patch · 9 files changed
+318/−0 lines, 9 filesdep +basedep +gaugedep +hs-functors
Dependencies added: base, gauge, hs-functors, lex-applicative, parser-combinators, regex-applicative, text, ucd, unicode-transforms, util
Files
- CHANGELOG.md +11/−0
- LICENSE +29/−0
- README.md +7/−0
- bench/Main.hs +7/−0
- lex-applicative.cabal +85/−0
- src/Data/TextPos.hs +15/−0
- src/Text/Lexer.hs +65/−0
- src/Text/Regex/Applicative/Lex.hs +95/−0
- test/Spec.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`lex-regex-applicative.hs` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/strake/lex-regex-applicative.hs/releases
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2019, M Farkas-Dyck+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,7 @@+# lex-regex-applicative.hs++[](https://travis-ci.org/strake/lex-regex-applicative.hs)+[](https://hackage.haskell.org/package/lex-regex-applicative.hs)+[](LICENSE)++See README for more info
+ bench/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Gauge.Main+++main :: IO ()+main = defaultMain [bench "const" (whnf const ())]
+ lex-applicative.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.2+name: lex-applicative+version: 0.0.0.0+synopsis: See README for more info+description: See README for more info+homepage: https://github.com/strake/lex-applicative.hs+bug-reports: https://github.com/strake/lex-applicative.hs/issues+license: BSD-3-Clause+license-file: LICENSE+author: M Farkas-Dyck+maintainer: strake888@gmail.com+copyright: 2019 M Farkas-Dyck+category: Parsing,Text+build-type: Simple+extra-doc-files: README.md+ , CHANGELOG.md+tested-with: GHC == 8.6.5++common c+ build-depends: base ^>= 4.12 || ^>= 4.13+ , util ^>= 0.1.15+ ghc-options: -Wall+ -Wcompat+ -Wredundant-constraints+ -Wno-name-shadowing+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ LambdaCase+ EmptyCase+ InstanceSigs+ PartialTypeSignatures+ PolyKinds+ ConstraintKinds+ FlexibleContexts+ FlexibleInstances+ MonadComprehensions+ StandaloneDeriving+ DeriveFunctor+ DeriveFoldable+ DeriveTraversable++library+ import: c+ hs-source-dirs: src+ exposed-modules: Data.TextPos+ , Text.Lexer+ , Text.Regex.Applicative.Lex+ build-depends: hs-functors ^>= 0.1.4+ , parser-combinators ^>= 1.2+ , regex-applicative ^>= 0.3.3+ , text ^>= 1.2.3+ , ucd ^>= 0.0.1.3+ , unicode-transforms ^>= 0.3.6++test-suite test+ import: c+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: lex-applicative+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N++benchmark bench+ import: c+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ build-depends: gauge+ , lex-applicative+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N++source-repository head+ type: git+ location: https://github.com/strake/lex-applicative.hs.git
+ src/Data/TextPos.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE StrictData #-}+module Data.TextPos where++data Pos = Pos+ { char :: Word+ , line :: Word+ , col :: Word+ } deriving (Eq, Ord, Read, Show)++move :: Char -> Pos -> Pos+move x = \ (Pos k m n) -> Pos (k+1) `uncurry` case x of+ '\n' -> (m+1, 0)+ '\r' -> (m, 0)+ '\b' -> (m, case n of 0 -> 0; _ -> n-1)+ _ -> (m, n+1)
+ src/Text/Lexer.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE RecordWildCards #-}+module Text.Lexer (Error (..), LexerSpec (token, space, blockComment, move, init), defaultLexerSpec, lex) where++import Prelude hiding (lex)+import Control.Applicative+import Control.Monad.Free (Free (..))+import qualified Data.Char as Char+import Data.Semigroup (Min (..), Max (..))+import qualified Data.TextPos as Text+import Text.Regex.Applicative (RE, findLongestPrefix')+import qualified Text.Regex.Applicative as RE+import Util++data LexerSpec p x t = LexerSpec+ { token :: RE x t+ , space :: RE x ()+ , blockComment :: RE x (RE x ())+ , move :: x -> p -> p+ , init :: p+ }++defaultLexerSpec :: LexerSpec Text.Pos Char t+defaultLexerSpec = LexerSpec+ { token = empty+ , space = () <$ many (RE.psym Char.isSpace)+ , blockComment = empty+ , move = Text.move+ , init = Text.Pos 0 1 0+ }++lex :: LexerSpec p x t -> [x] -> Free ((,,) (Min p, Max p) t) (Maybe (Error p))+lex LexerSpec {..} = go' [] . annotate move init+ where+ go bs = stripLongestPrefix' stripAnnotation (many space) & go' bs+ go' bs' xs@(AList p l) = case (bs', l) of+ ([], Nothing) -> Pure Nothing+ (_, Nothing) -> Pure (Just (Error p))+ (b:bs, Just (_, xs')) -> case findLongestPrefix' stripAnnotation (Nothing <$ b <|> Just <$> blockComment) xs of+ Just (Nothing, xs) -> (case bs of [] -> go; _ -> go') bs xs+ Just (Just b', xs) -> go' (b':bs') xs+ Nothing -> go' bs' xs'+ ([], Just _) -> case findLongestPrefix' stripAnnotation' (Left <$> blockComment <|> Right <$> token) (xs, p) of+ Just (Left b, (xs, _)) -> go' [b] xs+ Just (Right t, (xs, q)) -> Free ((Min p, Max q), t, go [] xs)+ Nothing -> Pure (Just (Error p))++data AList a b = AList { annotation :: a, stripAnnotation :: Maybe (b, AList a b) }+ deriving (Eq, Show)++stripAnnotation' :: (AList a b, a) -> Maybe (b, (AList a b, a))+stripAnnotation' = fst & \ (AList a l) -> fmap (flip (,) a) <$> l++annotate :: (a -> b -> b) -> b -> [a] -> AList b a+annotate f = go+ where+ go b = AList b . \ case+ [] -> Nothing+ a:as -> let b' = f a b in b' `seq` Just (a, go b' as)++newtype Error p = Error { errorPos :: p }+ deriving (Eq, Ord, Read, Show)++stripLongestPrefix' :: (xs -> Maybe (x, xs)) -> RE x a -> xs -> xs+stripLongestPrefix' uncons re = flip maybe snd <*> findLongestPrefix' uncons re
+ src/Text/Regex/Applicative/Lex.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE RecordWildCards #-}+module Text.Regex.Applicative.Lex (natural', natural, ident', ident, IdentSpec (..), defaultIdentSpec, string, esc, unicodepoint) where++import Control.Applicative.Combinators (between, count')+import Control.Monad ((>=>), guard, replicateM)+import qualified Data.Char.Properties.DerivedCore as UC+import Data.Foldable+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Normalize as T+import Numeric.Natural+import Text.Regex.Applicative hiding (string)+import qualified Text.Regex.Applicative as RE+import Util hiding (some)++natural' :: RE Char Natural+natural' = asum+ [ natural 10+ , traverse sym "0b" *> natural 2+ , traverse sym "0o" *> natural 8+ , traverse sym "0d" *> natural 10+ , traverse sym "0x" *> natural 16+ ]++natural :: Word -> RE Char Natural+natural = naturalWith some++naturalWith :: (RE Char Word -> RE Char [Word]) -> Word -> RE Char Natural+naturalWith f r = fromDigits r <$> f (digit' r)++fromDigits :: Integral a => Word -> [a] -> Natural+fromDigits r = foldl' (\ n w -> fromIntegral r*n + fromIntegral w) 0++digit' :: Word -> RE Char Word+digit' r = msym (digit >=> \ n -> n <$ guard (n < r))++ident' :: RE Char Text+ident' = ident defaultIdentSpec++ident :: IdentSpec -> RE Char Text+ident IdentSpec {..} = normalize . T.pack <$> start <:> many cont <++> (fmap asum . many) (med <:> some cont)+ where+ start = psym isStart+ cont = psym isContinue+ med = psym isMedial+ infixr 5 <:>, <++>+ (<:>) = liftA2 (:)+ (<++>) = liftA2 (++)++data IdentSpec = IdentSpec+ { isStart, isContinue, isMedial :: Char -> Bool+ , normalize :: Text -> Text }++defaultIdentSpec :: IdentSpec+defaultIdentSpec = IdentSpec+ { isStart = UC.isXIDStart <||> (∈ "_")+ , isContinue = UC.isXIDContinue <&&> (∉ "·\x0387") <||> (∈ "_\x05F3")+ , isMedial = (∈ "'-·\x0387\x058A\x05F4\x0F0B\x2010\x2027\x30A0\x30FB")+ , normalize = T.map normalizeIDMedial . T.normalize T.NFC+ } where+ normalizeIDMedial = \ case+ '\x058A' -> '-'+ '\x2010' -> '-'+ '\x30A0' -> '-'+ '\x0F0B' -> '·'+ '\x2027' -> '·'+ '\x30FB' -> '·'+ x -> x++string :: RE Char TL.Text+string = TL.pack <$> between (sym '"') (sym '"') (many xre)+ where xre = psym (∉ "\"\\") <|> sym '\\' *> (psym (∈ "\"\\") <|> esc)++esc :: RE Char Char+esc = asum+ [toEnum . fromIntegral <$ sym 'x' <*> naturalWith (replicateM 2) 16+ , sym 'u' *> between (sym '{') (sym '}') unicodepoint+ , '\x00' <$ sym '0'+ , '\x07' <$ sym 'a'+ , '\x08' <$ sym 'b'+ , '\x09' <$ sym 't'+ , '\x0A' <$ sym 'n'+ , '\x0B' <$ sym 'v'+ , '\x0C' <$ sym 'f'+ , '\x0D' <$ sym 'r'+ , '\x1B' <$ sym 'e'+ ]++unicodepoint :: RE Char Char+unicodepoint = (\ a b -> toEnum . fromIntegral $ 0x10000 * a + b)+ <$> asum [16 <$ RE.string "10", naturalWith (fmap pure) 16]+ <*> naturalWith (replicateM 4) 16+ <|> toEnum . fromIntegral <$> naturalWith (count' 0 4) 16
+ test/Spec.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn ("Test suite not yet implemented" :: String)