diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,4 @@ +[0.1.0.0] -- April 2022 +[0.1.0.0]: https://github.com/mordae/snack/compare/initial...0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# snack + +**Strict ByteString Parser Combinator** + +- Simple. Feel free to contribute. +- Fast. Sometimes faster then Attoparsec. +- ASCII. Good enough for IETF formats. +- Also Text. But quite slower. + +Example: + +```haskell +import Data.ByteString (ByteString) +import qualified Data.ByteString.Parser.Char8 as BSP + +parseList :: BSP.Parser [ByteString] +parseList = (token `BSP.wrap` BSP.skipSpace) `BSP.sepBy` BSP.char ',' + where token = BSP.takeWhile isToken + isToken c = inRange 'a' 'z' c || + inRange 'A' 'Z' c || + inRange '0' '9' c || + c == '_' || c == '-' + +main :: IO () +main = do + putStrLn $ show $ BSP.runParser parseList "monkey, wrench, bananas" + putStrLn $ show $ BSP.runParser parseList "^quux" + putStrLn $ show $ BSP.runParser (parseList <* BSP.endOfInput) "^quux" + +-- Will output: +-- Just (["monkey","wrench","bananas"],"") +-- Just ([""],"^quux") +-- Nothing +``` diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,400 @@ +-- | +-- Module : Bench +-- License : CC0-1.0 +-- +-- Maintainer : mordae@anilinux.org +-- Stability : unstable +-- Portability : non-portable (ghc) +-- + +{-# OPTIONS_GHC -ddump-to-file -ddump-stg-from-core -ddump-cmm-opt -dsuppress-all -dppr-cols=200 #-} + +module Main + ( main + ) +where + import Data.String.Conversions + + import Control.Applicative + import Data.Either + import Data.Maybe + + import Data.Text (Text) + import Data.ByteString (ByteString) + + import Criterion.Main + + import qualified Data.ByteString.Parser.Char8 as SC + import qualified Data.Attoparsec.ByteString.Char8 as AC + import qualified Data.Text.Parser as ST + import qualified Data.Attoparsec.Text as AT + + + main :: IO () + main = defaultMain + [ bgroup "media" + [ bench "Data.ByteString.Parser.Char8" $ nf scMedia (cs $! sampleMedia) + , bench "Data.Attoparsec.ByteString" $ nf acMedia (cs $! sampleMedia) + , bench "Data.Text.Parser" $ nf stMedia (cs $! sampleMedia) + , bench "Data.Attoparsec.Text" $ nf atMedia (cs $! sampleMedia) + ] + , bgroup "kv" + [ bench "Data.ByteString.Parser.Char8" $ nf scKeyValue (cs $! sampleKeyValue) + , bench "Data.Attoparsec.ByteString" $ nf acKeyValue (cs $! sampleKeyValue) + , bench "Data.Text.Parser" $ nf stKeyValue (cs $! sampleKeyValue) + , bench "Data.Attoparsec.Text" $ nf atKeyValue (cs $! sampleKeyValue) + ] + ] + + + + type Media a = (a, a, [(a, a)], Float) + + sampleMedia :: String + sampleMedia = "text/html, text/plain;q=0.7" + + + sampleKeyValue :: String + sampleKeyValue = "lst = \"\\\"first\\\", \\\"second\\\", \\\"third\\\"\"" + + + {-# NOINLINE scMedia #-} + scMedia :: ByteString -> Maybe [Media ByteString] + scMedia = SC.parseOnly (pMediaList <* SC.endOfInput) + where + pMedia :: SC.Parser (Media ByteString) + pMediaList = pMedia `SC.sepBy` pSeparator + pMedia = do + mainType <- pToken + subType <- (SC.char '/' *> pToken) <|> pure "" + + (qs, params) <- partitionEithers <$> SC.many (SC.eitherP pQuality pParameter) + + let quality = fromMaybe 1.0 . listToMaybe $ qs + + return (mainType, subType, params, quality) + + pParameter :: SC.Parser (ByteString, ByteString) + pParameter = do + _ <- SC.takeWhile SC.isSpace + _ <- SC.char ';' + name <- pToken + _ <- SC.char '=' + value <- pValue + return (name, value) + + pQuality :: SC.Parser Float + pQuality = do + _ <- SC.takeWhile SC.isSpace + _ <- SC.char ';' + _ <- pSpaced $ SC.char 'q' + _ <- SC.char '=' + SC.fractional + + pToken :: SC.Parser ByteString + pToken = pSpaced $ SC.takeTill1 isSpecial + + pSeparator :: SC.Parser Char + pSeparator = pSpaced $ SC.char ',' + + pValue :: SC.Parser ByteString + pValue = pToken <|> pQuotedStr + + pQuotedStr :: SC.Parser ByteString + pQuotedStr = pSpaced $ pQuoted $ SC.takeWhile isStrChar + + pSpaced :: SC.Parser a -> SC.Parser a + pSpaced p = p `SC.wrap` SC.takeWhile SC.isSpace + + pQuoted :: SC.Parser a -> SC.Parser a + pQuoted p = SC.char '"' *> p <* SC.char '"' + + isStrChar :: (Char -> Bool) + isStrChar c = c /= '\\' && c /= '"' + + isSpecial :: (Char -> Bool) + isSpecial c = c <= ' ' + || c == '(' || c == ')' + || c == '<' || c == '>' + || c == '@' || c == ',' || c == ';' + || c == ':' || c == '\\' + || c == '"' || c == '/' + || c == '[' || c == ']' + || c == '?' || c == '=' + + + + {-# NOINLINE acMedia #-} + acMedia :: ByteString -> Either String [Media ByteString] + acMedia = AC.parseOnly (pMediaList <* AC.endOfInput) + where + pMedia :: AC.Parser (Media ByteString) + pMediaList = pMedia `AC.sepBy` pSeparator + pMedia = do + mainType <- pToken + subType <- (AC.char '/' *> pToken) <|> pure "" + + (qs, params) <- partitionEithers <$> AC.many' (AC.eitherP pQuality pParameter) + + let quality = fromMaybe 1.0 . listToMaybe $ qs + + return (mainType, subType, params, quality) + + pParameter :: AC.Parser (ByteString, ByteString) + pParameter = do + _ <- AC.skipSpace + _ <- AC.char ';' + name <- pToken + _ <- AC.char '=' + value <- pValue + return (name, value) + + pQuality :: AC.Parser Float + pQuality = do + _ <- AC.skipSpace + _ <- AC.char ';' + _ <- pSpaced $ AC.char 'q' + _ <- AC.char '=' + AC.rational + + pToken :: AC.Parser ByteString + pToken = pSpaced $ AC.takeTill isSpecial + + pSeparator :: AC.Parser Char + pSeparator = pSpaced $ AC.char ',' + + pValue :: AC.Parser ByteString + pValue = pToken <|> pQuotedStr + + pQuotedStr :: AC.Parser ByteString + pQuotedStr = pSpaced $ pQuoted $ AC.takeWhile isStrChar + + pSpaced :: AC.Parser a -> AC.Parser a + pSpaced p = AC.skipSpace *> p <* AC.skipSpace + + pQuoted :: AC.Parser a -> AC.Parser a + pQuoted p = AC.char '"' *> p <* AC.char '"' + + isStrChar :: (Char -> Bool) + isStrChar c = c /= '\\' && c /= '"' + + isSpecial :: (Char -> Bool) + isSpecial c = c <= ' ' + || c == '(' || c == ')' + || c == '<' || c == '>' + || c == '@' || c == ',' || c == ';' + || c == ':' || c == '\\' + || c == '"' || c == '/' + || c == '[' || c == ']' + || c == '?' || c == '=' + + + {-# NOINLINE stMedia #-} + stMedia :: Text -> Maybe [Media Text] + stMedia = ST.parseOnly (pMediaList <* ST.endOfInput) + where + pMedia :: ST.Parser (Media Text) + pMediaList = pMedia `ST.sepBy` pSeparator + pMedia = do + mainType <- pToken + subType <- (ST.char '/' *> pToken) <|> pure "" + + (qs, params) <- partitionEithers <$> ST.many (ST.eitherP pQuality pParameter) + + let quality = fromMaybe 1.0 . listToMaybe $ qs + + return (mainType, subType, params, quality) + + pParameter :: ST.Parser (Text, Text) + pParameter = do + _ <- ST.takeWhile ST.isSpace + _ <- ST.char ';' + name <- pToken + _ <- ST.char '=' + value <- pValue + return (name, value) + + pQuality :: ST.Parser Float + pQuality = do + _ <- ST.takeWhile ST.isSpace + _ <- ST.char ';' + _ <- pSpaced $ ST.char 'q' + _ <- ST.char '=' + ST.fractional + + pToken :: ST.Parser Text + pToken = pSpaced $ ST.takeTill1 isSpecial + + pSeparator :: ST.Parser Char + pSeparator = pSpaced $ ST.char ',' + + pValue :: ST.Parser Text + pValue = pToken <|> pQuotedStr + + pQuotedStr :: ST.Parser Text + pQuotedStr = pSpaced $ pQuoted $ ST.takeWhile isStrChar + + pSpaced :: ST.Parser a -> ST.Parser a + pSpaced p = p `ST.wrap` ST.takeWhile ST.isSpace + + pQuoted :: ST.Parser a -> ST.Parser a + pQuoted p = ST.char '"' *> p <* ST.char '"' + + isStrChar :: (Char -> Bool) + isStrChar c = c /= '\\' && c /= '"' + + isSpecial :: (Char -> Bool) + isSpecial c = c <= ' ' + || c == '(' || c == ')' + || c == '<' || c == '>' + || c == '@' || c == ',' || c == ';' + || c == ':' || c == '\\' + || c == '"' || c == '/' + || c == '[' || c == ']' + || c == '?' || c == '=' + + + + {-# NOINLINE atMedia #-} + atMedia :: Text -> Either String [Media Text] + atMedia = AT.parseOnly (pMediaList <* AT.endOfInput) + where + pMedia :: AT.Parser (Media Text) + pMediaList = pMedia `AT.sepBy` pSeparator + pMedia = do + mainType <- pToken + subType <- (AT.char '/' *> pToken) <|> pure "" + + (qs, params) <- partitionEithers <$> AT.many' (AT.eitherP pQuality pParameter) + + let quality = fromMaybe 1.0 . listToMaybe $ qs + + return (mainType, subType, params, quality) + + pParameter :: AT.Parser (Text, Text) + pParameter = do + _ <- AT.skipSpace + _ <- AT.char ';' + name <- pToken + _ <- AT.char '=' + value <- pValue + return (name, value) + + pQuality :: AT.Parser Float + pQuality = do + _ <- AT.skipSpace + _ <- AT.char ';' + _ <- pSpaced $ AT.char 'q' + _ <- AT.char '=' + AT.rational + + pToken :: AT.Parser Text + pToken = pSpaced $ AT.takeTill isSpecial + + pSeparator :: AT.Parser Char + pSeparator = pSpaced $ AT.char ',' + + pValue :: AT.Parser Text + pValue = pToken <|> pQuotedStr + + pQuotedStr :: AT.Parser Text + pQuotedStr = pSpaced $ pQuoted $ AT.takeWhile isStrChar + + pSpaced :: AT.Parser a -> AT.Parser a + pSpaced p = AT.skipSpace *> p <* AT.skipSpace + + pQuoted :: AT.Parser a -> AT.Parser a + pQuoted p = AT.char '"' *> p <* AT.char '"' + + isStrChar :: (Char -> Bool) + isStrChar c = c /= '\\' && c /= '"' + + isSpecial :: (Char -> Bool) + isSpecial c = c <= ' ' + || c == '(' || c == ')' + || c == '<' || c == '>' + || c == '@' || c == ',' || c == ';' + || c == ':' || c == '\\' + || c == '"' || c == '/' + || c == '[' || c == ']' + || c == '?' || c == '=' + + + scKeyValue :: ByteString -> Maybe (ByteString, ByteString) + scKeyValue = SC.parseOnly (pKeyValue <* SC.endOfInput) + where + pKeyValue = do + _ <- SC.skipSpace + key <- SC.takeWhile1 isToken + _ <- SC.skipSpace + _ <- SC.skipSpace + '=' <- SC.char '=' + _ <- SC.skipSpace + _ <- SC.char '"' + val <- SC.scan False scanString + _ <- SC.char '"' + return (key, val) + + + acKeyValue :: ByteString -> Either String (ByteString, ByteString) + acKeyValue = AC.parseOnly (pKeyValue <* AC.endOfInput) + where + pKeyValue = do + _ <- AC.skipSpace + key <- AC.takeWhile1 isToken + _ <- AC.skipSpace + '=' <- AC.char '=' + _ <- AC.skipSpace + _ <- AC.char '"' + val <- AC.scan False scanString + _ <- AC.char '"' + return (key, val) + + + stKeyValue :: Text -> Maybe (Text, Text) + stKeyValue = ST.parseOnly (pKeyValue <* ST.endOfInput) + where + pKeyValue = do + _ <- ST.skipSpace + key <- ST.takeWhile1 isToken + _ <- ST.skipSpace + _ <- ST.skipSpace + '=' <- ST.char '=' + _ <- ST.skipSpace + _ <- ST.char '"' + val <- ST.scan False scanString + _ <- ST.char '"' + return (key, val) + + + atKeyValue :: Text -> Either String (Text, Text) + atKeyValue = AT.parseOnly (pKeyValue <* AT.endOfInput) + where + pKeyValue = do + _ <- AT.skipSpace + key <- AT.takeWhile1 isToken + _ <- AT.skipSpace + '=' <- AT.char '=' + _ <- AT.skipSpace + _ <- AT.char '"' + val <- AT.scan False scanString + _ <- AT.char '"' + return (key, val) + + + scanString :: Bool -> Char -> Maybe Bool + scanString True _ = Just False + scanString False '"' = Nothing + scanString False '\\' = Just True + scanString False _ = Just False + + + isToken :: Char -> Bool + isToken c = ('A' <= c && c <= 'Z') + || ('a' <= c && c <= 'z') + || ('0' <= c && c <= '9') + || ('_' == c) + || ('-' == c) + + +-- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/ByteString/Parser.hs b/lib/Data/ByteString/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Parser.hs @@ -0,0 +1,337 @@ +-- | +-- Module : Data.ByteString.Parser +-- License : CC0-1.0 +-- +-- Maintainer : mordae@anilinux.org +-- Stability : unstable +-- Portability : non-portable (ghc) +-- +-- This module provides a parser for 'ByteString'. +-- +-- * If you\'d like to parse ASCII text, you might want to take a look at +-- "Data.ByteString.Parser.Char8". It reuses the same 'Parser', but +-- provides functions working with 'Char' instead of 'Word8' as well as +-- more string utilities. +-- +-- * If you\'d like to parse Unicode text, look instead at the +-- "Data.Text.Parser". Is is slower, but in a way more correct. +-- + +module Data.ByteString.Parser + ( Parser(..) + , parseOnly + + -- * Bytes + , byte + , notByte + , anyByte + , satisfy + , peekByte + + -- * Strings + , string + , Data.ByteString.Parser.take + , scan + , runScanner + , Data.ByteString.Parser.takeWhile + , takeWhile1 + , takeTill + , takeTill1 + + -- * Combinators + , provided + , choice + , Snack.Combinators.count + , optional + , eitherP + , option + , many + , many1 + , manyTill + , sepBy + , sepBy1 + , wrap + , match + + -- * End Of Input + , takeByteString + , endOfInput + , atEnd + + -- * Miscelaneous + -- | + -- These are all generic methods, but since I sometimes forget about them, + -- it is nice to have them listed here for reference what writing parsers. + , Control.Applicative.empty + , pure + , guard + , when + , unless + , void + ) +where + import Prelude hiding (null, length, splitAt, take) + + import Control.Applicative + import Control.Monad + + import Data.Maybe + import Data.Word + + import Data.ByteString as BS + import Data.ByteString.Unsafe as BS + + import Snack.Combinators + + + newtype Parser a = + Parser + { runParser :: ByteString -> Maybe (a, ByteString) + } + + instance Functor Parser where + {-# INLINE fmap #-} + fmap fn Parser{runParser} = Parser \inp -> + case runParser inp of + Just (res, rest) -> Just (fn res, rest) + Nothing -> Nothing + + instance Applicative Parser where + {-# INLINE pure #-} + pure x = Parser \inp -> Just (x, inp) + + {-# INLINE (<*>) #-} + (Parser runFn) <*> (Parser runArg) = Parser \inp -> + case runFn inp of + Nothing -> Nothing + Just (fn, rest) -> + case runArg rest of + Nothing -> Nothing + Just (x, rest') -> Just (fn x, rest') + + instance Alternative Parser where + {-# INLINE empty #-} + empty = Parser \_ -> Nothing + + {-# INLINE (<|>) #-} + (Parser runLeft) <|> (Parser runRight) = Parser \inp -> + case runLeft inp of + Just r -> Just r + Nothing -> runRight inp + + instance Monad Parser where + {-# INLINE (>>=) #-} + (Parser runLeft) >>= right = Parser \inp -> + case runLeft inp of + Nothing -> Nothing + Just (x, more) -> runParser (right x) more + + instance MonadPlus Parser + + instance MonadFail Parser where + {-# INLINE CONLIKE fail #-} + fail _ = mzero + + + -- | + -- Discards the remaining input and returns just the parse result. + -- You might want to combine it with 'endOfInput' for the best effect. + -- + -- Example: + -- + -- @ + -- parseOnly (pContacts \<* endOfInput) bstr + -- @ + -- + {-# INLINE CONLIKE parseOnly #-} + parseOnly :: Parser a -> ByteString -> Maybe a + parseOnly par = \inp -> fst <$> runParser par inp + + + -- | + -- Accepts a single, matching byte. + -- + {-# INLINE CONLIKE byte #-} + byte :: Word8 -> Parser Word8 + byte c = satisfy (c ==) + + + -- | + -- Accepts a single, differing byte. + -- + {-# INLINE CONLIKE notByte #-} + notByte :: Word8 -> Parser Word8 + notByte c = satisfy (c /=) + + + -- | + -- Accepts a single byte. + -- + {-# INLINE anyByte #-} + anyByte :: Parser Word8 + anyByte = Parser \inp -> + if null inp + then Nothing + else Just (unsafeHead inp, unsafeTail inp) + + + -- | + -- Accepts a single byte matching the predicate. + -- + {-# INLINE CONLIKE satisfy #-} + satisfy :: (Word8 -> Bool) -> Parser Word8 + satisfy isOk = Parser \inp -> + if null inp + then Nothing + else let c = unsafeHead inp + in if isOk c + then Just (c, unsafeTail inp) + else Nothing + + + -- | + -- Peeks ahead, but does not consume. + -- + -- Be careful, peeking behind end of the input fails. + -- You might want to check using 'atEnd' beforehand. + -- + {-# INLINE peekByte #-} + peekByte :: Parser Word8 + peekByte = Parser \inp -> + if null inp + then Nothing + else Just (unsafeHead inp, inp) + + + -- | + -- Accepts a matching string. + -- + {-# INLINE CONLIKE string #-} + string :: ByteString -> Parser ByteString + string str = Parser \inp -> + let (pfx, sfx) = splitAt (length str) inp + in case pfx == str of + True -> Just (pfx, sfx) + False -> Nothing + + + -- | + -- Accepts given number of bytes. + -- Fails when not enough bytes are available. + -- + {-# INLINE CONLIKE take #-} + take :: Int -> Parser ByteString + take n = Parser \inp -> + if n > length inp + then Nothing + else Just (splitAt n inp) + + + -- | + -- Scans ahead statefully and then accepts whatever bytes the scanner liked. + -- Scanner returns 'Nothing' to mark end of the acceptable extent. + -- + {-# INLINE CONLIKE scan #-} + scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString + scan state scanner = fst <$> runScanner state scanner + + + -- | + -- Like 'scan', but also returns the final scanner state. + -- + {-# INLINE CONLIKE runScanner #-} + runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s) + runScanner state scanner = Parser \inp -> + let (state', n) = scanBytes state scanner 0 (unpack inp) + (res, more) = splitAt n inp + in Just ((res, state'), more) + + + {-# INLINE scanBytes #-} + scanBytes :: s -> (s -> Word8 -> Maybe s) -> Int -> [Word8] -> (s, Int) + scanBytes !state _scanner !n [] = (state, n) + scanBytes !state scanner !n (x:more) = + case scanner state x of + Just state' -> scanBytes state' scanner (succ n) more + Nothing -> (state, n) + + + -- | + -- Efficiently consume as long as the input bytes match the predicate. + -- An inverse of 'takeTill'. + -- + {-# INLINE CONLIKE takeWhile #-} + takeWhile :: (Word8 -> Bool) -> Parser ByteString + takeWhile test = takeTill (not . test) + + + -- | + -- Like 'Data.ByteString.Parser.takeWhile', but requires at least a single byte. + -- + {-# INLINE CONLIKE takeWhile1 #-} + takeWhile1 :: (Word8 -> Bool) -> Parser ByteString + takeWhile1 test = provided (not . null) $ + Data.ByteString.Parser.takeWhile test + + + -- | + -- Efficiently consume until a byte matching the predicate is found. + -- An inverse of 'Data.ByteString.Parser.takeWhile'. + -- + {-# INLINE CONLIKE takeTill #-} + takeTill :: (Word8 -> Bool) -> Parser ByteString + takeTill test = Parser \inp -> + let n = fromMaybe (length inp) $ findIndex test inp + in Just (splitAt n inp) + + + -- | + -- Same as 'takeTill', but requires at least a single byte. + -- + {-# INLINE CONLIKE takeTill1 #-} + takeTill1 :: (Word8 -> Bool) -> Parser ByteString + takeTill1 test = provided (not . null) $ + Data.ByteString.Parser.takeTill test + + + -- | + -- Makes the parser not only return the result, but also the original + -- matched extent. + -- + {-# INLINE CONLIKE match #-} + match :: Parser a -> Parser (ByteString, a) + match par = Parser \inp -> + case runParser par inp of + Nothing -> Nothing + Just (x, more) -> + let n = length more + in Just ((BS.take n inp, x), more) + + + -- | + -- Accept whatever input remains. + -- + {-# INLINE takeByteString #-} + takeByteString :: Parser ByteString + takeByteString = Parser \inp -> Just (inp, mempty) + + + -- | + -- Accepts end of input and fails if we are not there yet. + -- + {-# INLINE endOfInput #-} + endOfInput :: Parser () + endOfInput = Parser \case + inp | null inp -> Just ((), inp) + _otherwise -> Nothing + + + -- | + -- Returns whether we are at the end of the input yet. + -- + {-# INLINE atEnd #-} + atEnd :: Parser Bool + atEnd = Parser \inp -> Just (null inp, inp) + + +-- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/ByteString/Parser.hs-boot b/lib/Data/ByteString/Parser.hs-boot new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Parser.hs-boot @@ -0,0 +1,14 @@ +module Data.ByteString.Parser +where + import Control.Applicative + import Data.ByteString (ByteString) + + newtype Parser a = + Parser + { runParser :: ByteString -> Maybe (a, ByteString) + } + + instance Functor Parser + instance Applicative Parser + instance Alternative Parser + instance Monad Parser diff --git a/lib/Data/ByteString/Parser/Char8.hs b/lib/Data/ByteString/Parser/Char8.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Parser/Char8.hs @@ -0,0 +1,335 @@ +-- | +-- Module : Data.ByteString.Parser.Char8 +-- License : CC0-1.0 +-- +-- Maintainer : mordae@anilinux.org +-- Stability : unstable +-- Portability : non-portable (ghc) +-- +-- This module provides a parser for ASCII 'ByteString'. +-- + +module Data.ByteString.Parser.Char8 + ( Parser(..) + , parseOnly + + -- * Characters + , char + , notChar + , anyChar + , satisfy + , space + , isSpace + , skipSpace + , peekChar + + -- * Strings + , string + , stringCI + , Data.ByteString.Parser.Char8.take + , scan + , runScanner + , inRange + , notInRange + , Data.ByteString.Parser.Char8.takeWhile + , takeWhile1 + , takeTill + , takeTill1 + + -- * Numbers + , signed + , decimal + , hexadecimal + , octal + , fractional + + -- * Combinators + , provided + , choice + , Data.ByteString.Parser.count + , optional + , eitherP + , option + , many + , many1 + , manyTill + , sepBy + , sepBy1 + , wrap + , match + + -- * End Of Input + , takeByteString + , endOfInput + , atEnd + + -- * Miscelaneous + -- | + -- These are all generic methods, but since I sometimes forget about them, + -- it is nice to have them listed here for reference what writing parsers. + , Control.Applicative.empty + , pure + , guard + , when + , unless + , void + ) +where + import Prelude hiding (null, length, splitAt, take) + + import Control.Applicative + import Control.Monad + + import Data.Maybe + import Data.Word + import GHC.Base (unsafeChr) + + import Data.ByteString as BS + import Data.ByteString.Unsafe as BS + + import Snack.Combinators + + import Data.ByteString.Parser ( Parser(..), parseOnly + , string, count, match + , takeByteString, endOfInput, atEnd + ) + + import qualified Data.ByteString.Lex.Fractional as LF + import qualified Data.ByteString.Lex.Integral as LI + + + -- | + -- Accepts a single, matching ASCII character. + -- + {-# INLINE CONLIKE char #-} + char :: Char -> Parser Char + char c = satisfy (c ==) + + + -- | + -- Accepts a single, differing ASCII character. + -- + {-# INLINE CONLIKE notChar #-} + notChar :: Char -> Parser Char + notChar c = satisfy (c /=) + + + -- | + -- Accepts a single character. + -- + {-# INLINE anyChar #-} + anyChar :: Parser Char + anyChar = Parser \inp -> + if null inp + then Nothing + else Just (w2c (unsafeHead inp), unsafeTail inp) + + + -- | + -- Accepts a single character matching the predicate. + -- + {-# INLINE CONLIKE satisfy #-} + satisfy :: (Char -> Bool) -> Parser Char + satisfy isOk = Parser \inp -> + if null inp + then Nothing + else let c = w2c (unsafeHead inp) + in if isOk c + then Just (c, unsafeTail inp) + else Nothing + + + -- | + -- Accepts a single ASCII white space character. + -- See 'isSpace' for details. + -- + {-# INLINE space #-} + space :: Parser Char + space = satisfy isSpace + + + -- | + -- Accepts multiple ASCII white space characters. + -- See 'isSpace' for details. + -- + {-# INLINE skipSpace #-} + skipSpace :: Parser () + skipSpace = void $ Data.ByteString.Parser.Char8.takeWhile isSpace + + + -- | + -- True for any of the @[' ', '\\t', '\\n', '\\v', '\\f', '\\r']@ characters. + -- + -- Please note that "Data.Text.Parser" re-exports 'Data.Char.isString', that + -- considers more unicode codepoints, making it significantly slower. + -- + {-# INLINE isSpace #-} + isSpace :: Char -> Bool + isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') + + + -- | + -- Peeks ahead, but does not consume. + -- + -- Be careful, peeking behind end of the input fails. + -- You might want to check using 'atEnd' beforehand. + -- + {-# INLINE peekChar #-} + peekChar :: Parser Char + peekChar = Parser \inp -> + if null inp + then Nothing + else Just (w2c (unsafeHead inp), inp) + + + -- | + -- Accepts a matching string. + -- Matching is performed in a case-insensitive manner under ASCII. + -- + {-# INLINE CONLIKE stringCI #-} + stringCI :: ByteString -> Parser ByteString + stringCI str = Parser \inp -> + let (pfx, sfx) = splitAt (length str) inp + in case toCaseFold pfx == toCaseFold str of + True -> Just (pfx, sfx) + False -> Nothing + + + -- | + -- Perform simple ASCII case folding. + -- + {-# INLINE toCaseFold #-} + toCaseFold :: ByteString -> ByteString + toCaseFold = BS.map foldCase + where foldCase w | 65 <= w && w <= 90 = w + 32 + foldCase w = w + + + -- | + -- Accepts given number of characters. + -- Fails when not enough characters are available. + -- + {-# INLINE CONLIKE take #-} + take :: Int -> Parser ByteString + take n = Parser \inp -> + if n > length inp + then Nothing + else Just (splitAt n inp) + + + -- | + -- Scans ahead statefully and then accepts whatever bytes the scanner liked. + -- Scanner returns 'Nothing' to mark end of the acceptable extent. + -- + {-# INLINE CONLIKE scan #-} + scan :: s -> (s -> Char -> Maybe s) -> Parser ByteString + scan state scanner = fst <$> runScanner state scanner + + + -- | + -- Like 'scan', but also returns the final scanner state. + -- + {-# INLINE CONLIKE runScanner #-} + runScanner :: s -> (s -> Char -> Maybe s) -> Parser (ByteString, s) + runScanner state scanner = Parser \inp -> loop inp state 0 + where + loop inp !st !n = + case n >= length inp of + True -> Just ((inp, st), mempty) + False -> + case unsafeIndex inp n of + w -> + case scanner st (w2c w) of + Nothing -> Just ((unsafeTake n inp, st), unsafeDrop n inp) + Just st' -> loop inp st' (succ n) + + + -- | + -- Efficiently consume as long as the input characters match the predicate. + -- An inverse of 'takeTill'. + -- + {-# INLINE CONLIKE takeWhile #-} + takeWhile :: (Char -> Bool) -> Parser ByteString + takeWhile test = takeTill (not . test) + + + -- | + -- Like 'takeWhile', but requires at least a single character. + -- + {-# INLINE CONLIKE takeWhile1 #-} + takeWhile1 :: (Char -> Bool) -> Parser ByteString + takeWhile1 test = provided (not . null) $ + Data.ByteString.Parser.Char8.takeWhile test + + + -- | + -- Efficiently consume until a character matching the predicate is found. + -- An inverse of 'Data.ByteString.Parser.Char8.takeWhile'. + -- + {-# INLINE CONLIKE takeTill #-} + takeTill :: (Char -> Bool) -> Parser ByteString + takeTill test = Parser \inp -> + let n = fromMaybe (length inp) $ findIndex (test . w2c) inp + in Just (splitAt n inp) + + + -- | + -- Same as 'takeTill', but requires at least a single character. + -- + {-# INLINE CONLIKE takeTill1 #-} + takeTill1 :: (Char -> Bool) -> Parser ByteString + takeTill1 test = provided (not . null) $ + Data.ByteString.Parser.Char8.takeTill test + + + -- | + -- Accepts optional @\'+\'@ or @\'-\'@ character and then applies it to + -- the following parser result. + -- + {-# INLINE signed #-} + signed :: (Num a) => Parser a -> Parser a + signed runNumber = (char '-' *> fmap negate runNumber) + <|> (char '+' *> runNumber) + <|> (runNumber) + + + -- | + -- Accepts an integral number in the decimal format. + -- + {-# INLINE decimal #-} + decimal :: (Integral a) => Parser a + decimal = Parser LI.readDecimal + + + -- | + -- Accepts an integral number in the hexadecimal format in either case. + -- Does not look for @0x@ or similar prefixes. + -- + {-# INLINE hexadecimal #-} + hexadecimal :: (Integral a) => Parser a + hexadecimal = Parser LI.readHexadecimal + + + -- | + -- Accepts an integral number in the octal format. + -- + {-# INLINE octal #-} + octal :: (Integral a) => Parser a + octal = Parser LI.readOctal + + + -- | + -- Accepts a fractional number as a decimal optinally followed by a colon + -- and the fractional part. Does not support exponentiation. + -- + {-# INLINE fractional #-} + fractional :: (Fractional a) => Parser a + fractional = Parser LF.readDecimal + + + {-# INLINE w2c #-} + w2c :: Word8 -> Char + w2c = unsafeChr . fromIntegral + + +-- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/Text/Parser.hs b/lib/Data/Text/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/Parser.hs @@ -0,0 +1,335 @@ +-- | +-- Module : Data.Text.Parser +-- License : CC0-1.0 +-- +-- Maintainer : mordae@anilinux.org +-- Stability : unstable +-- Portability : non-portable (ghc) +-- +-- This module provides a parser for Unicode 'Text'. +-- + +module Data.Text.Parser + ( Parser(..) + , parseOnly + + -- * Characters + , char + , notChar + , anyChar + , satisfy + , space + , isSpace + , skipSpace + , peekChar + + -- * Strings + , string + , stringCI + , Data.Text.Parser.take + , scan + , runScanner + , inRange + , notInRange + , Data.Text.Parser.takeWhile + , takeWhile1 + , takeTill + , takeTill1 + + -- * Numbers + , signed + , decimal + , hexadecimal + , octal + , fractional + + -- * Combinators + , provided + , choice + , Snack.Combinators.count + , optional + , eitherP + , option + , many + , many1 + , manyTill + , sepBy + , sepBy1 + , wrap + , match + + -- * End Of Input + , takeText + , endOfInput + , atEnd + + -- * Miscelaneous + -- | + -- These are all generic methods, but since I sometimes forget about them, + -- it is nice to have them listed here for reference what writing parsers. + , Control.Applicative.empty + , pure + , guard + , when + , unless + , void + ) +where + import Prelude hiding (null, length, splitAt, take) + + import Control.Applicative + import Control.Monad + + import Data.Char + import Data.Maybe + + import Data.Text as T + import Data.Text.Unsafe as T + import Data.Text.Encoding as T + + import qualified Data.ByteString as BS + import qualified Data.ByteString.Parser.Char8 as BSP + + import Snack.Combinators + + + newtype Parser a = + Parser + { runParser :: Text -> Maybe (a, Text) + } + + instance Functor Parser where + {-# INLINE fmap #-} + fmap fn Parser{runParser} = Parser \inp -> + case runParser inp of + Just (res, rest) -> Just (fn res, rest) + Nothing -> Nothing + + instance Applicative Parser where + {-# INLINE pure #-} + pure x = Parser \inp -> Just (x, inp) + + {-# INLINE (<*>) #-} + (Parser runFn) <*> (Parser runArg) = Parser \inp -> + case runFn inp of + Nothing -> Nothing + Just (fn, rest) -> + case runArg rest of + Nothing -> Nothing + Just (x, rest') -> Just (fn x, rest') + + instance Alternative Parser where + {-# INLINE empty #-} + empty = Parser \_ -> Nothing + + {-# INLINE (<|>) #-} + (Parser runLeft) <|> (Parser runRight) = Parser \inp -> + case runLeft inp of + Just r -> Just r + Nothing -> runRight inp + + instance Monad Parser where + {-# INLINE (>>=) #-} + (Parser runLeft) >>= right = Parser \inp -> + case runLeft inp of + Nothing -> Nothing + Just (x, more) -> runParser (right x) more + + instance MonadPlus Parser + + instance MonadFail Parser where + {-# INLINE CONLIKE fail #-} + fail _ = mzero + + + {-# INLINE CONLIKE parseOnly #-} + parseOnly :: Parser a -> Text -> Maybe a + parseOnly par = \inp -> fst <$> runParser par inp + + + {-# INLINE CONLIKE satisfy #-} + satisfy :: (Char -> Bool) -> Parser Char + satisfy isOk = Parser \inp -> + if null inp + then Nothing + else let c = unsafeHead inp + in if isOk c + then Just (c, unsafeTail inp) + else Nothing + + + {-# INLINE CONLIKE string #-} + string :: Text -> Parser Text + string str = Parser \inp -> + let (pfx, sfx) = splitAt (length str) inp + in case pfx == str of + True -> Just (pfx, sfx) + False -> Nothing + + + {-# INLINE CONLIKE take #-} + take :: Int -> Parser Text + take n = Parser \inp -> + if n > length inp + then Nothing + else Just (splitAt n inp) + + + {-# INLINE CONLIKE scan #-} + scan :: s -> (s -> Char -> Maybe s) -> Parser Text + scan state scanner = fst <$> runScanner state scanner + + + -- | + -- Like 'scan', but also returns the final scanner state. + -- + {-# INLINE CONLIKE runScanner #-} + runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s) + runScanner state scanner = Parser \inp -> loop inp state 0 + where + loop inp !st !n = + case n >= lengthWord8 inp of + True -> Just ((inp, st), mempty) + False -> + case iter inp n of + Iter c n' -> + case scanner st c of + Nothing -> Just ((takeWord8 n inp, st), dropWord8 n inp) + Just st' -> loop inp st' (n + n') + + + {-# INLINE CONLIKE takeWhile #-} + takeWhile :: (Char -> Bool) -> Parser Text + takeWhile test = takeTill (not . test) + + + {-# INLINE CONLIKE takeWhile1 #-} + takeWhile1 :: (Char -> Bool) -> Parser Text + takeWhile1 test = provided (not . null) $ + Data.Text.Parser.takeWhile test + + + {-# INLINE CONLIKE takeTill #-} + takeTill :: (Char -> Bool) -> Parser Text + takeTill test = Parser \inp -> + let n = fromMaybe (length inp) $ findIndex test inp + in Just (splitAt n inp) + + + {-# INLINE CONLIKE takeTill1 #-} + takeTill1 :: (Char -> Bool) -> Parser Text + takeTill1 test = provided (not . null) $ + Data.Text.Parser.takeTill test + + + {-# INLINE CONLIKE match #-} + match :: Parser a -> Parser (Text, a) + match par = Parser \inp -> + case runParser par inp of + Nothing -> Nothing + Just (x, more) -> + let n = length more + in Just ((T.take n inp, x), more) + + + {-# INLINE takeText #-} + takeText :: Parser Text + takeText = Parser \inp -> Just (inp, mempty) + + + {-# INLINE endOfInput #-} + endOfInput :: Parser () + endOfInput = Parser \case + inp | null inp -> Just ((), inp) + _otherwise -> Nothing + + + {-# INLINE atEnd #-} + atEnd :: Parser Bool + atEnd = Parser \inp -> Just (null inp, inp) + + + {-# INLINE CONLIKE char #-} + char :: Char -> Parser Char + char c = satisfy (c ==) + + + {-# INLINE space #-} + space :: Parser Char + space = satisfy isSpace + + + {-# INLINE skipSpace #-} + skipSpace :: Parser () + skipSpace = void $ Data.Text.Parser.takeWhile isSpace + + + {-# INLINE CONLIKE notChar #-} + notChar :: Char -> Parser Char + notChar c = satisfy (c /=) + + + {-# INLINE anyChar #-} + anyChar :: Parser Char + anyChar = Parser \inp -> + if null inp + then Nothing + else Just (unsafeHead inp, unsafeTail inp) + + + {-# INLINE peekChar #-} + peekChar :: Parser Char + peekChar = Parser \inp -> + if null inp + then Nothing + else Just (unsafeHead inp, inp) + + + {-# INLINE CONLIKE stringCI #-} + stringCI :: Text -> Parser Text + stringCI str = Parser \inp -> + let (pfx, sfx) = splitAt (length str) inp + in case toCaseFold pfx == toCaseFold str of + True -> Just (pfx, sfx) + False -> Nothing + + + {-# INLINE signed #-} + signed :: (Num a) => Parser a -> Parser a + signed runNumber = (char '-' *> fmap negate runNumber) + <|> (char '+' *> runNumber) + <|> (runNumber) + + + {-# INLINE CONLIKE unsafeWithUtf8 #-} + unsafeWithUtf8 :: BSP.Parser a -> Parser a + unsafeWithUtf8 bspar = Parser \inp -> + let bstr = encodeUtf8 inp + in case BSP.runParser bspar bstr of + Nothing -> Nothing + Just (x, more) -> + let n = lengthWord8 inp - BS.length more + in Just (x, dropWord8 n inp) + + + {-# INLINE decimal #-} + decimal :: (Integral a) => Parser a + decimal = unsafeWithUtf8 BSP.decimal + + + {-# INLINE hexadecimal #-} + hexadecimal :: (Integral a) => Parser a + hexadecimal = unsafeWithUtf8 BSP.hexadecimal + + + {-# INLINE octal #-} + octal :: (Integral a) => Parser a + octal = unsafeWithUtf8 BSP.octal + + + {-# INLINE fractional #-} + fractional :: (Fractional a) => Parser a + fractional = unsafeWithUtf8 BSP.fractional + + +-- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/Text/Parser.hs-boot b/lib/Data/Text/Parser.hs-boot new file mode 100644 --- /dev/null +++ b/lib/Data/Text/Parser.hs-boot @@ -0,0 +1,14 @@ +module Data.Text.Parser +where + import Control.Applicative + import Data.Text (Text) + + newtype Parser a = + Parser + { runParser :: Text -> Maybe (a, Text) + } + + instance Functor Parser + instance Applicative Parser + instance Alternative Parser + instance Monad Parser diff --git a/lib/Snack/Combinators.hs b/lib/Snack/Combinators.hs new file mode 100644 --- /dev/null +++ b/lib/Snack/Combinators.hs @@ -0,0 +1,224 @@ +-- | +-- Module : Snack.Combinators +-- License : CC0-1.0 +-- +-- Maintainer : mordae@anilinux.org +-- Stability : unstable +-- Portability : non-portable (ghc) +-- + +module Snack.Combinators + ( provided + , choice + , count + , eitherP + , option + , many1 + , manyTill + , sepBy + , sepBy1 + , wrap + , inRange + , notInRange + ) +where + import Control.Applicative + import Data.Maybe + + import {-# SOURCE #-} qualified Data.ByteString.Parser as BSP + import {-# SOURCE #-} qualified Data.Text.Parser as TP + + + -- | + -- Fails if the value returned by the parser does not conform to the + -- predicate. Generalized form of 'Data.ByteString.Parser.Char8.string'. + -- + -- Example: + -- + -- @ + -- pInput = takeWhile isLetter `provided` (odd . length) + -- @ + -- + {-# INLINE CONLIKE provided #-} + {-# SPECIALIZE provided :: (a -> Bool) -> BSP.Parser a -> BSP.Parser a #-} + {-# SPECIALIZE provided :: (a -> Bool) -> TP.Parser a -> TP.Parser a #-} + provided :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m a + provided test par = do + x <- par + if test x + then pure x + else Control.Applicative.empty + + + -- | + -- Tries various parsers, one by one. Alias for 'asum'. + -- + -- Example: + -- + -- @ + -- pExpression = choice [ pConstant + -- , pVariable + -- , pBinaryOperation + -- , pFunctionApplication + -- ] + -- @ + -- + {-# INLINE CONLIKE choice #-} + {-# SPECIALIZE choice :: [BSP.Parser a] -> BSP.Parser a #-} + {-# SPECIALIZE choice :: [TP.Parser a] -> TP.Parser a #-} + choice :: (Alternative f) => [f a] -> f a + choice = asum + + + -- | + -- Replicates the parser given number of times, collecting the results + -- in a list. Fails if any instance of the parser fails. + -- + -- Example: + -- + -- @ + -- pFourWords = (:) \<$\> word \<*\> count 3 (blank *> word) + -- where word = takeWhile1 isLetter + -- blank = takeWhile1 isSpace + -- @ + -- + {-# INLINE CONLIKE count #-} + {-# SPECIALIZE count :: Int -> BSP.Parser a -> BSP.Parser [a] #-} + {-# SPECIALIZE count :: Int -> TP.Parser a -> TP.Parser [a] #-} + count :: (Monad m) => Int -> m a -> m [a] + count n p = Prelude.sequence (Prelude.replicate n p) + + + -- | + -- Captures first parser as @Left@ or the second as @Right@. + -- + {-# INLINE CONLIKE eitherP #-} + {-# SPECIALIZE eitherP :: BSP.Parser a -> BSP.Parser b -> BSP.Parser (Either a b) #-} + {-# SPECIALIZE eitherP :: TP.Parser a -> TP.Parser b -> TP.Parser (Either a b) #-} + eitherP :: (Alternative f) => f a -> f b -> f (Either a b) + eitherP left right = (Left <$> left) <|> (Right <$> right) + + + -- | + -- Shortcut for 'optional' with a default value. + -- + -- Example: + -- + -- @ + -- data Contact = + -- Contact + -- { contactName :: Text + -- , contactEmail :: Maybe Text + -- } + -- + -- pContact = Contact \<$\> pFullName \<*\> option pEmail + -- @ + -- + {-# INLINE CONLIKE option #-} + {-# SPECIALIZE option :: a -> BSP.Parser a -> BSP.Parser a #-} + {-# SPECIALIZE option :: a -> TP.Parser a -> TP.Parser a #-} + option :: (Alternative f) => a -> f a -> f a + option dfl par = fromMaybe dfl <$> optional par + + + -- | + -- Like 'many1', but requires at least one match. + -- + {-# INLINE many1 #-} + {-# SPECIALIZE many1 :: BSP.Parser a -> BSP.Parser [a] #-} + {-# SPECIALIZE many1 :: TP.Parser a -> TP.Parser [a] #-} + many1 :: (Alternative f) => f a -> f [a] + many1 = some + + + -- | + -- Like 'many', but stops once the second parser matches the input ahead. + -- + -- Example: + -- + -- @ + -- pBodyLines = pLine `manyTill` pEnd + -- where pLine = takeTill (== '\n') + -- pEnd = string "\n.\n" + -- @ + -- + {-# INLINE CONLIKE manyTill #-} + {-# SPECIALIZE manyTill :: BSP.Parser a -> BSP.Parser a -> BSP.Parser [a] #-} + {-# SPECIALIZE manyTill :: TP.Parser a -> TP.Parser a -> TP.Parser [a] #-} + manyTill :: (Alternative f) => f a -> f a -> f [a] + manyTill par stop = loop + where loop = (stop *> pure []) <|> ((:) <$> par <*> loop) + + + -- | + -- Similar to 'many', but interleaves the first parser with the second. + -- + -- Example: + -- + -- @ + -- pLines = pLine `sepBy` char '\n' + -- @ + -- + {-# INLINE CONLIKE sepBy #-} + {-# SPECIALIZE sepBy :: BSP.Parser a -> BSP.Parser b -> BSP.Parser [a] #-} + {-# SPECIALIZE sepBy :: TP.Parser a -> TP.Parser b -> TP.Parser [a] #-} + sepBy :: (Alternative f) => f a -> f b -> f [a] + sepBy par sep = sepBy1 par sep <|> pure [] + + + -- | + -- Like 'sepBy', but requires at least one match. + -- + {-# INLINE CONLIKE sepBy1 #-} + {-# SPECIALIZE sepBy1 :: BSP.Parser a -> BSP.Parser b -> BSP.Parser [a] #-} + {-# SPECIALIZE sepBy1 :: TP.Parser a -> TP.Parser b -> TP.Parser [a] #-} + sepBy1 :: (Alternative f) => f a -> f b -> f [a] + sepBy1 par sep = loop + where loop = (:) <$> par <*> ((sep *> loop) <|> pure []) + + + -- | + -- Wraps the parser from both sides. + -- + -- Example: + -- + -- @ + -- pToken = takeWhile1 (inClass "A-Za-z0-9_") `wrap` takeWhile isSpace + -- @ + -- + {-# INLINE CONLIKE wrap #-} + {-# SPECIALIZE wrap :: BSP.Parser a -> BSP.Parser b -> BSP.Parser a #-} + {-# SPECIALIZE wrap :: TP.Parser a -> TP.Parser b -> TP.Parser a #-} + wrap :: (Applicative f) => f a -> f b -> f a + wrap par wrapper = wrapper *> par <* wrapper + + + -- | + -- Tests whether the character lies within given range. + -- + -- Definition: + -- + -- @ + -- inRange lo hi = \c -> (lo <= c && c <= hi) + -- @ + -- + {-# INLINE CONLIKE inRange #-} + inRange :: Char -> Char -> Char -> Bool + inRange lo hi = \c -> (lo <= c && c <= hi) + + + -- | + -- Negation of 'inRange'. + -- + -- Definition: + -- + -- @ + -- notInRange lo hi = \c -> (c <= lo || hi <= c) + -- @ + -- + {-# INLINE CONLIKE notInRange #-} + notInRange :: Char -> Char -> Char -> Bool + notInRange lo hi = \c -> (lo >= c || c >= hi) + + +-- vim:set ft=haskell sw=2 ts=2 et: diff --git a/snack.cabal b/snack.cabal new file mode 100644 --- /dev/null +++ b/snack.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: snack +version: 0.1.0.0 +license: MIT +license-file: LICENSE +copyright: Jan Hamal Dvořák +maintainer: mordae@anilinux.org +author: Jan Hamal Dvořák +homepage: https://github.com/mordae/snack#readme +bug-reports: https://github.com/mordae/snack/issues +synopsis: Strict ByteString Parser Combinator +description: Simple parser combinator for strict ByteString values. +category: Text, Parsing +build-type: Simple +extra-source-files: + README.md + Changelog.md + +source-repository head + type: git + location: https://github.com/mordae/snack.git + +library + exposed-modules: + Data.ByteString.Parser + Data.ByteString.Parser.Char8 + Data.Text.Parser + + hs-source-dirs: lib + other-modules: Snack.Combinators + default-language: GHC2021 + default-extensions: BlockArguments LambdaCase + ghc-options: + -Wall -Wcompat -Wincomplete-uni-patterns -Wunused-packages + -Wincomplete-record-updates -Widentities -Wredundant-constraints + + build-depends: + base >=4.13 && <5, + bytestring >=0.11, + bytestring-lexing >=0.5, + text >=2.0 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: bench + default-language: Haskell2010 + default-extensions: BlockArguments LambdaCase OverloadedStrings + ghc-options: + -Wall -Wcompat -Wincomplete-uni-patterns -Wunused-packages + -Wincomplete-record-updates -Widentities -Wredundant-constraints + + build-depends: + attoparsec >=0.13, + base >=4 && <5, + bytestring >=0.11, + criterion, + snack, + string-conversions, + text >=2.0