sasha (empty) → 0
raw patch · 12 files changed
+1657/−0 lines, 12 filesdep +QuickCheckdep +aesondep +array
Dependencies added: QuickCheck, aeson, array, base, bytestring, containers, deepseq, lattices, sasha, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, template-haskell, text, th-letrec, wide-word
Files
- LICENSE +30/−0
- example.json +4/−0
- sasha.cabal +84/−0
- src/Sasha.hs +68/−0
- src/Sasha/Internal/ERE.hs +455/−0
- src/Sasha/Internal/Word8Set.hs +218/−0
- src/Sasha/TTH.hs +232/−0
- tests/Sasha/Example/Alex.hs +363/−0
- tests/Sasha/Example/SaTTH.hs +31/−0
- tests/Sasha/Example/Sasha.hs +31/−0
- tests/Sasha/Example/Token.hs +25/−0
- tests/sasha-tests.hs +116/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Oleg Grenrus nor the names of other+ 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+OWNER 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.
+ example.json view
@@ -0,0 +1,4 @@+{+ "literals": [true, false, null],+ "numbers": [0, 123]+}
+ sasha.cabal view
@@ -0,0 +1,84 @@+cabal-version: 3.0+name: sasha+version: 0+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+synopsis: A staged lexer generator+description:+ Like @alex@, @sasha@ is lexer\/scanner generator; but it is using Typed Template Haskell.+ .+ The generated scanners are comparable in speed to @alex@ generated ones.++category: Lexing, Development+license: BSD-3-Clause+license-file: LICENSE+homepage: https://github.com/phadej/sasha+bug-reports: https://github.com/phadej/sasha/issues+extra-source-files: example.json+tested-with: GHC ==9.0.2 || ==9.2.5 || ==9.4.4++source-repository head+ type: git+ location: https://github.com/phadej/sasha.git++common common+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions:+ BangPatterns+ OverloadedStrings+ PatternSynonyms+ ScopedTypeVariables+ TypeApplications++library+ import: common+ hs-source-dirs: src+ build-depends:+ , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0+ , bytestring ^>=0.10.12.1 || ^>=0.11.3.1+ , containers ^>=0.6.4.1+ , lattices ^>=2.1+ , QuickCheck ^>=2.14.2+ , template-haskell+ , th-letrec ^>=0.1+ , wide-word ^>=0.1.4.0++ exposed-modules:+ Sasha+ Sasha.Internal.ERE+ Sasha.Internal.Word8Set+ Sasha.TTH++ x-docspec-options:+ -XOverloadedStrings --check-properties "--property-variables=c p r s t q"++test-suite sasha-tests+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: sasha-tests.hs+ other-modules:+ Sasha.Example.Alex+ Sasha.Example.Sasha+ Sasha.Example.SaTTH+ Sasha.Example.Token++ build-depends:+ , aeson+ , array+ , base+ , bytestring+ , deepseq+ , lattices+ , sasha++ -- test dependencies+ build-depends:+ , tasty ^>=1.4.3+ , tasty-bench ^>=0.3.2+ , tasty-hunit ^>=0.10.0.3+ , tasty-quickcheck ^>=0.10.2+ , text ^>=1.2.5.0 || ^>=2.0++ build-tool-depends: alex:alex ^>=3.2.7.1
+ src/Sasha.hs view
@@ -0,0 +1,68 @@+module Sasha (+ -- * Sasha the lexer++ -- | This is the ordinary Haskell (i.e. slow) interface.+ --+ -- The fast one is in "Sasha.TTH" module, but that requires @TemplateHaskell@.+ --+ Sasha,+ sasha,+ -- * ERE specification+ ERE,+ empty,+ eps,+ char,+ charRange,+ utf8Char,+ anyChar,+ anyUtf8Char,+ appends,+ unions,+ intersections,+ star,+ plus,+ string,+ utf8String,+ complement,+ satisfy,+ digit,+) where++import Control.Applicative ((<|>))+import Data.Maybe (listToMaybe)+import Data.Word (Word8)++import qualified Data.ByteString as BS++import Sasha.Internal.ERE++-- | Lexer grammar specification: tags and regular expressions.+type Sasha tag = [(tag, ERE)]++-- | Scan for a single token.+sasha+ :: forall tag. Sasha tag -- ^ scanner definition+ -> BS.ByteString -- ^ input+ -> Maybe (tag, BS.ByteString, BS.ByteString) -- ^ matched token, consumed bytestring, left over bytestring+sasha grammar input0 = finish <$> go Nothing 0 input0 grammar+ where+ finish :: (tag, Int) -> (tag, BS.ByteString, BS.ByteString)+ finish (tag, i) = case BS.splitAt i input0 of+ (pfx, sfx) -> (tag, pfx, sfx)++ go :: Maybe (tag, Int) -> Int -> BS.ByteString -> Sasha tag -> Maybe (tag, Int)+ go acc !_ _ [] = acc+ go acc !pfx input ts = case BS.uncons input of+ Nothing -> acc+ Just (c, sfx) -> go (acc' <|> acc) (pfx + 1) sfx ts'+ where+ ts' = derivativeSasha c ts+ acc' = listToMaybe [ (tag, pfx + 1) | (tag, ere) <- ts', nullable ere]++derivativeSasha :: Word8 -> Sasha tag -> Sasha tag+derivativeSasha c ts =+ [ (t, ere')+ | (t, ere) <- ts+ , let ere' = derivative c ere+ , not (isEmpty ere')+ ]
+ src/Sasha/Internal/ERE.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Sasha.Internal.ERE (+ ERE (..),+ -- * Construction+ --+ -- | Binary operators are+ --+ -- * '<>' for append+ -- * '\/' for union+ -- * '/\' for intersection+ --+ empty,+ eps,+ char,+ charRange,+ utf8Char,+ anyChar,+ anyUtf8Char,+ appends,+ unions,+ intersections,+ star,+ plus,+ string,+ utf8String,+ complement,+ everything,+ satisfy,+ digit,+ -- * Equivalence+ equivalent,+ -- * Derivative+ nullable,+ derivative,+ match,+ -- * Other+ isEmpty,+ isEverything,+ ) where++import Algebra.Lattice+ (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..))+import Data.Bits (shiftR, (.&.), (.|.))+import Data.Char (ord)+import Data.Foldable (toList)+import Data.Set (Set)+import Data.String (IsString (..))+import Data.Word (Word8)+import Sasha.Internal.Word8Set (Word8Set)+import Test.QuickCheck (Arbitrary (..))++import qualified Test.QuickCheck as QC+import qualified Data.Set as Set+import qualified Sasha.Internal.Word8Set as W8S++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XOverloadedStrings +-- >>> import Control.Monad (void)+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (sort)+-- >>> import Algebra.Lattice ((/\), (\/))+--+-- >>> import Test.QuickCheck ((===))+-- >>> import qualified Test.QuickCheck as QC+--+-------------------------------------------------------------------------------+-- ERE+-------------------------------------------------------------------------------++-- | Extended regular expression+--+data ERE+ = EREAppend [ERE] -- ^ Concatenation+ | EREUnion Word8Set (Set ERE) -- ^ Union+ | EREStar ERE -- ^ Kleene star+ | ERENot ERE -- ^ Complement+ deriving (Eq, Ord, Show)++-------------------------------------------------------------------------------+-- Smart constructor+-------------------------------------------------------------------------------++-- | Empty regex. Doesn't accept anything.+--+-- prop> match empty s === False+--+empty :: ERE+empty = EREUnion W8S.empty Set.empty++-- | Everything.+--+-- prop> match everything s === True+--+everything :: ERE+everything = complement empty++-- | Empty string. /Note:/ different than 'empty'.+--+-- prop> match eps s === null s+--+eps :: ERE+eps = EREAppend []++-- | Character.+--+char :: Word8 -> ERE+char c = EREUnion (W8S.singleton c) Set.empty++-- | Character range.+--+charRange :: Word8 -> Word8 -> ERE+charRange l u = EREUnion (W8S.range l u) Set.empty++-- | Any character.+--+anyChar :: ERE+anyChar = EREUnion W8S.full Set.empty++anyUtf8Char :: ERE+anyUtf8Char = unions+ [ charRange 0x00 0x7F+ , charRange 0xC2 0xDF <> charRange 0x80 0xBF+ , charRange 0xE0 0xE0 <> charRange 0xa0 0xBF <> charRange 0x80 0xBF+ , charRange 0xE1 0xEC <> charRange 0x80 0xBF <> charRange 0x80 0xBF+ , charRange 0xED 0xED <> charRange 0x80 0x9F <> charRange 0x80 0xBF+ , charRange 0xEE 0xEF <> charRange 0x80 0xBF <> charRange 0x80 0xBF+ , charRange 0xF0 0xF0 <> charRange 0x90 0xBF <> charRange 0x80 0xBF <> charRange 0x80 0xBF+ , charRange 0xF1 0xF3 <> charRange 0x80 0xBF <> charRange 0x80 0xBF <> charRange 0x80 0xBF+ , charRange 0xF4 0xF4 <> charRange 0x80 0x8f <> charRange 0x80 0xBF <> charRange 0x80 0xBF+ ]++-- | Concatenate regular expressions.+--+-- prop> r <> empty === empty+-- prop> empty <> r === empty+-- prop> ( r <> s) <> t === r <> (s <> t)+--+-- prop> r <> eps === r+-- prop> eps <> r === r+--+appends :: [ERE] -> ERE+appends rs0+ | elem empty rs1 = empty+ | otherwise = case rs1 of+ [r] -> r+ rs -> EREAppend rs+ where+ -- flatten one level of EREAppend+ rs1 = concatMap f rs0++ f (EREAppend rs) = rs+ f r = [r]++-- | Union of regular expressions.+--+-- prop> r \/ r === r+-- prop> r \/ s === s \/ r+-- prop> ( r \/ s) \/ t === r \/ (s \/ t)+--+-- prop> empty \/ r === r+-- prop> r \/ empty === r+--+-- prop> everything \/ r === everything+-- prop> r \/ everything === everything+--+unions :: [ERE] -> ERE+unions = uncurry mk . foldMap f where+ mk cs rss+ | Set.null rss = EREUnion cs Set.empty+ | Set.member everything rss = everything+ | W8S.null cs = case Set.toList rss of+ [] -> empty+ [r] -> r+ _ -> EREUnion cs rss+ | otherwise = EREUnion cs rss++ f (EREUnion cs rs) = (cs, rs)+ f r = (W8S.empty, Set.singleton r)++-- | Intersection of regular expressions.+--+-- prop> r /\ r === r+-- prop> r /\ s === s /\ r+-- prop> ( r /\ s) /\ t === r /\ (s /\ t)+--+-- prop> empty /\ r === empty+-- prop> r /\ empty === empty+--+-- prop> everything /\ r === r+-- prop> r /\ everything === r+--+intersections :: [ERE] -> ERE+intersections = complement . unions . map complement++-- | Complement.+--+-- prop> complement (complement r) === r+--+complement :: ERE -> ERE+complement r = case r of+ ERENot r' -> r'+ _ -> ERENot r++-- | Kleene star.+--+-- prop> star (star r) === star ( r)+--+-- prop> star eps === eps+-- prop> star empty === eps+-- prop> star anyChar === everything+--+-- prop> star (r \/ eps) === star r+-- prop> star (char c \/ eps) === star (char c)+-- prop> star (empty \/ eps) === eps+--+star :: ERE -> ERE+star r = case r of+ EREStar _ -> r+ EREAppend [] -> eps+ EREUnion cs rs+ | W8S.null cs, Set.null rs -> eps+ | W8S.isFull cs, Set.null rs -> everything+ | Set.member eps rs -> case Set.toList rs' of+ [] -> star (EREUnion cs Set.empty)+ [r'] | W8S.null cs -> star r'+ _ -> EREStar (EREUnion cs rs')+ where+ rs' = Set.delete eps rs+ _ -> EREStar r++-- | Kleene plus+--+-- @+-- 'plus' r = r <> 'star' r+-- @+plus :: ERE -> ERE+plus r = r <> star r++-- | Literal string.+--+string :: [Word8] -> ERE+string [] = eps+string [c] = EREUnion (W8S.singleton c) Set.empty+string cs = EREAppend $ map char cs++-- | UTF8 string+utf8String :: String -> ERE+utf8String = string . concatMap encodeCharUtf8++-- | UTF8 character, i.e. may match multiple bytes.+utf8Char :: Char -> ERE+utf8Char = string . encodeCharUtf8++satisfy :: (Word8 -> Bool) -> ERE+satisfy p = EREUnion (W8S.fromList [ x | x <- [ minBound .. maxBound], p x ]) Set.empty++digit :: ERE+digit = charRange (fromIntegral (ord '0')) (fromIntegral (ord '9'))++-------------------------------------------------------------------------------+-- derivative+-------------------------------------------------------------------------------++instance Semigroup ERE where+ r <> r' = appends [r, r']++instance Monoid ERE where+ mempty = eps+ mappend = (<>)+ mconcat = appends++instance Lattice ERE where+ r \/ r' = unions [r, r']+ r /\ r' = intersections [r, r']++instance BoundedJoinSemiLattice ERE where+ bottom = empty++instance BoundedMeetSemiLattice ERE where+ top = everything++-- | Uses 'utf8string'.+instance IsString ERE where+ fromString = utf8String++-- | Uses smart constructors.+instance Arbitrary ERE where+ arbitrary = QC.sized arb+ where+ arb n | n <= 1 = QC.frequency+ [ (20, EREUnion <$> arbitrary <*> pure Set.empty)+ , (1, pure eps)+ , (1, pure empty)+ ] + | otherwise = QC.oneof+ [ do+ p <- arbPartition (n - 1)+ unions <$> traverse arb p+ , do+ p <- arbPartition (n - 1)+ appends <$> traverse arb p+ + , star <$> arb (n - 1)+ , complement <$> arb (n - 1)+ ]++ shrink (EREAppend rs) = rs+ shrink (EREStar r) = r : map EREStar (shrink r)+ shrink (ERENot r) = r : map ERENot (shrink r)+ shrink _ = []++arbPartition :: Int -> QC.Gen [Int]+arbPartition k = case compare k 1 of+ LT -> pure []+ EQ -> pure [1]+ GT -> do+ first <- QC.chooseInt (1, k)+ rest <- arbPartition $ k - first+ QC.shuffle (first : rest)++++-------------------------------------------------------------------------------+-- derivative+-------------------------------------------------------------------------------++-- | We say that a regular expression r is nullable if the language it defines+-- contains the empty string.+--+-- >>> nullable eps+-- True+--+-- >>> nullable (star "x")+-- True+--+-- >>> nullable "foo"+-- False+--+-- >>> nullable (complement eps)+-- False+--+nullable :: ERE -> Bool+nullable (EREAppend rs) = all nullable rs+nullable (EREUnion _cs rs) = any nullable rs+nullable (EREStar _) = True+nullable (ERENot r) = not (nullable r)++-- | Intuitively, the derivative of a language \(\mathcal{L} \subset \Sigma^\star\)+-- with respect to a symbol \(a \in \Sigma\) is the language that includes only+-- those suffixes of strings with a leading symbol \(a\) in \(\mathcal{L}\).+--+derivative :: Word8 -> ERE -> ERE+derivative c (EREUnion cs rs) = unions $ derivativeChars c cs : [ derivative c r | r <- toList rs]+derivative c (EREAppend rs) = derivativeAppend c rs+derivative c rs@(EREStar r) = derivative c r <> rs+derivative c (ERENot r) = complement (derivative c r)++derivativeAppend :: Word8 -> [ERE] -> ERE+derivativeAppend _ [] = empty+derivativeAppend c [r] = derivative c r+derivativeAppend c (r:rs)+ | nullable r = unions [r' <> appends rs, rs']+ | otherwise = r' <> appends rs+ where+ r' = derivative c r+ rs' = derivativeAppend c rs++derivativeChars :: Word8 -> Word8Set -> ERE+derivativeChars c cs+ | c `W8S.member` cs = eps+ | otherwise = empty++match :: ERE -> [Word8] -> Bool+match ere [] = nullable ere+match ere (w:ws) = match (derivative w ere) ws++-------------------------------------------------------------------------------+-- isEmpty+-------------------------------------------------------------------------------++-- | Whether 'ERE' is (structurally) equal to 'empty'.+isEmpty :: ERE -> Bool+isEmpty (EREUnion cs rs) = W8S.null cs && Set.null rs+isEmpty _ = False++-- | Whether 'ERE' is (structurally) equal to 'everything'.+isEverything :: ERE -> Bool+isEverything (ERENot (EREUnion cs rs)) = W8S.null cs && Set.null rs+isEverything _ = False++-------------------------------------------------------------------------------+-- Utf8+-------------------------------------------------------------------------------++encodeCharUtf8 :: Char -> [Word8]+encodeCharUtf8 c+ | c <= '\x07F' = w8+ : []+ | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 )+ : (0x80 .|. (w8 .&. 0x3F))+ : []+ | c <= '\xD7FF' = (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : []+ | c <= '\xDFFF' = 0xEF : 0xBF : 0xBD -- U+FFFD+ : []+ | c <= '\xFFFF' = (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : []+ | otherwise = (0xf0 .|. w8ShiftR 18 )+ : (0x80 .|. (w8ShiftR 12 .&. 0x3F))+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : []+ where+ w8 :: Word8+ w8 = fromIntegral (ord c)++ w8ShiftR :: Int -> Word8+ w8ShiftR b = fromIntegral (shiftR (ord c) b)++-------------------------------------------------------------------------------+-- Equivalance+-------------------------------------------------------------------------------++equivalent :: ERE -> ERE -> Bool+equivalent x0 y0 = agree (x0, y0) && go mempty [(x0, y0)] []+ where+ -- we use two queues, so we can append chunks cheaply.+ go :: Set (ERE, ERE) -> [(ERE, ERE)] -> [[(ERE,ERE)]] -> Bool+ go !_ [] [] = True+ go acc [] (zs:zss) = go acc zs zss+ go acc (p@(x, y) : zs) zss+ | p `Set.member` acc = go acc zs zss+ -- if two regexps are structurally the same, we don't need to recurse.+ | x == y = go (Set.insert p acc) zs zss+ | all agree ps = go (Set.insert p acc) zs (ps : zss)+ | otherwise = False+ where+ cs = [minBound .. maxBound] :: [Word8]+ ps = map (\c -> (derivative c x, derivative c y)) cs++ agree :: (ERE, ERE) -> Bool+ agree (x, y) = nullable x == nullable y
+ src/Sasha/Internal/Word8Set.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Sasha.Internal.Word8Set (+ -- * Set type+ Word8Set,+ Key,++ -- * Construction+ empty,+ full,+ singleton,+ range,+ fromList,++ -- * Insertion+ insert,++ -- * Deletion+ delete,++ -- * Query+ member,+ memberCode,+ isSubsetOf,+ null,+ isFull,+ isSingleRange,+ size,++ -- * Combine+ union,+ intersection,+ complement,++ -- * Min\/Max+ findMin,+ findMax,+ -- * Conversion to List+ elems,+ toList,+) where++import Prelude+ (Bool (..), Eq ((==)), Int, Monoid (..), Ord, Semigroup (..),+ Show (showsPrec), fromIntegral, negate, otherwise, showParen, showString,+ ($), (&&), (+), (-), (.), (<), (<=), (>), (||), return)++import Data.Bits ((.&.), (.|.))+import Data.Foldable (foldl')+import Data.WideWord.Word256 (Word256 (..))+import Data.Word (Word64, Word8)+import Test.QuickCheck (Arbitrary (..))+import Algebra.Lattice+ (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..))++import Language.Haskell.TH.Syntax++import qualified Data.Bits as Bits++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++newtype Word8Set = W8S Word256+ deriving (Eq, Ord)++type Key = Word8++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Show Word8Set where+ showsPrec d xs = showParen (d > 10) $ showString "fromList " . showsPrec 11 (toList xs)++instance Lift Word8Set where+ liftTyped (W8S (Word256 a b c d)) =+ [|| W8S (Word256 a b c d) ||]++instance Semigroup Word8Set where+ (<>) = union++instance Monoid Word8Set where+ mempty = empty++instance Arbitrary Word8Set where+ arbitrary = do+ a <- arbitrary+ b <- arbitrary+ c <- arbitrary+ d <- arbitrary+ return (W8S (Word256 a b c d))++instance Lattice Word8Set where+ (\/) = union+ (/\) = intersection++instance BoundedJoinSemiLattice Word8Set where+ bottom = empty++instance BoundedMeetSemiLattice Word8Set where+ top = full++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++empty :: Word8Set+empty = W8S Bits.zeroBits++full :: Word8Set+full = W8S ones++ones :: Word256+ones = Bits.complement Bits.zeroBits++singleton :: Word8 -> Word8Set+singleton x = W8S (Bits.bit (fromIntegral x))++range :: Word8 -> Word8 -> Word8Set+range mi ma+ | mi <= ma = W8S $ Bits.shiftL (Bits.shiftR ones (fromIntegral (negate (1 + ma - mi)))) (fromIntegral mi)+ | otherwise = empty++-------------------------------------------------------------------------------+-- Insertion+-------------------------------------------------------------------------------++insert :: Word8 -> Word8Set -> Word8Set+insert x (W8S xs) = W8S (Bits.setBit xs (fromIntegral x))++-------------------------------------------------------------------------------+-- Deletion+-------------------------------------------------------------------------------++delete :: Word8 -> Word8Set -> Word8Set+delete x (W8S xs) = W8S (Bits.clearBit xs (fromIntegral x))++-------------------------------------------------------------------------------+-- Query+-------------------------------------------------------------------------------++null :: Word8Set -> Bool+null (W8S xs) = xs == Bits.zeroBits++isFull :: Word8Set -> Bool+isFull (W8S xs) = xs == ones++size :: Word8Set -> Int+size (W8S xs) = Bits.popCount xs++member :: Word8 -> Word8Set -> Bool+member x (W8S xs) = Bits.testBit xs (fromIntegral x)++-- | Optimized routing to check membership when 'Word8Set' is statically known.+--+-- @+-- 'memberCode' c ws = [||'member' $$c $$(liftTyped ws) ||]+-- @+--+memberCode :: Code Q Word8 -> Word8Set -> Code Q Bool+memberCode c ws+ -- simple cases+ | null ws = [|| False ||]+ | isFull ws = [|| True ||]+ | size ws == 1 = [|| $$c == $$(liftTyped (findMin ws)) ||]+ | size ws == 2 = [|| $$c == $$(liftTyped (findMin ws)) || $$c == $$(liftTyped (findMax ws)) ||]++ -- continuos range+ | isSingleRange ws = [|| $$(liftTyped (findMin ws)) <= $$c && $$c <= $$(liftTyped (findMax ws)) ||]++ -- low chars+ | W8S (Word256 0 0 0 x) <- ws = [|| $$c < 64 && Bits.testBit ($$(liftTyped x) :: Word64) (fromIntegral ($$c :: Word8)) ||]++ -- fallback+ | otherwise = [|| member $$c $$(liftTyped ws) ||]++isSubsetOf :: Word8Set -> Word8Set -> Bool+isSubsetOf a b = b == union a b++isSingleRange :: Word8Set -> Bool+isSingleRange (W8S 0) = True+isSingleRange (W8S ws) = Bits.popCount ws + Bits.countLeadingZeros ws + Bits.countTrailingZeros ws == 256++-------------------------------------------------------------------------------+-- Combine+-------------------------------------------------------------------------------++complement :: Word8Set -> Word8Set+complement (W8S xs) = W8S (Bits.complement xs)++union :: Word8Set -> Word8Set -> Word8Set+union (W8S xs) (W8S ys) = W8S (xs .|. ys)++intersection :: Word8Set -> Word8Set -> Word8Set+intersection (W8S xs) (W8S ys) = W8S (xs .&. ys)++-------------------------------------------------------------------------------+-- Min/Max+-------------------------------------------------------------------------------++findMin :: Word8Set -> Word8+findMin (W8S xs) = fromIntegral (Bits.countTrailingZeros xs)++findMax :: Word8Set -> Word8+findMax (W8S xs) = fromIntegral (255 - Bits.countLeadingZeros xs)++-------------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------------++elems :: Word8Set -> [Word8]+elems = toList++toList :: Word8Set -> [Word8]+toList xs = [ w8 | w8 <- [0x00..0xff], member w8 xs]++fromList :: [Word8] -> Word8Set+fromList w8s = W8S $ foldl' (\acc w8 -> Bits.setBit acc (fromIntegral w8)) Bits.zeroBits w8s
+ src/Sasha/TTH.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Sasha.TTH (+ -- * SaTTH, staged Sasha the lexer.+ SaTTH,+ satth,+ -- * ERE specification+ ERE,+ empty,+ eps,+ char,+ charRange,+ utf8Char,+ anyChar,+ anyUtf8Char,+ appends,+ unions,+ intersections,+ star,+ plus,+ string,+ utf8String,+ complement,+ satisfy,+ digit,+) where++import Language.Haskell.TH (Code, CodeQ, Exp, Q)++import Control.Monad (forM)+import Data.List (sortOn)+import Data.Map (Map)+import Data.Maybe (listToMaybe)+import Data.Ord (Down (..))+import Data.Word (Word8)+import Language.Haskell.TTH.LetRec (letrecE)++import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Language.Haskell.TH as TH++import Sasha.Internal.ERE+import Sasha.Internal.Word8Set (Word8Set)++import qualified Sasha.Internal.Word8Set as W8S++-- | Lexer grammar specification: tag codes and regular expressions.+type SaTTH tag = [(Code Q tag, ERE)]++-- | Generate a scanner code.+satth :: forall tag. SaTTH tag -> Code Q (BS.ByteString -> Maybe (tag, BS.ByteString, BS.ByteString))+satth grammar0 = letrecE+ (\_ -> "state")+ trans+ start+ where+ grammar0' :: SaTTH' tag+ grammar0' =+ [ S i t ere+ | (i, (t, ere)) <- zip [0..] grammar0+ ]++ start :: Monad m => (SaTTH' tag -> m (Code Q (R tag))) -> m (Code Q (BS.ByteString -> Maybe (tag, BS.ByteString, BS.ByteString)))+ start rec = do+ startCode <- rec grammar0'+ -- we assume that none of the tokens accepts an empty string,+ -- so we start without specifying last match.+ return [|| \input -> case $$startCode Nothing (0 :: Int) input of+ Nothing -> Nothing+ Just (tag, i) -> case BS.splitAt i input of+ (pfx, sfx) -> Just (tag, pfx, sfx)+ ||]++ trans :: Monad m => (SaTTH' tag -> m (Code Q (R tag))) -> SaTTH' tag -> m (Code Q (R tag))+ trans _rec grammar+ | emptySashaTTH grammar+ = return [|| \ !acc _ _ -> acc ||]++ trans rec grammar = do+ -- if the input is not empty?+ let grammarM1 :: Map (SaTTH' tag) Word8Set+ grammarM1 = Map.fromListWith W8S.union+ [ (derivativeSaTTH c grammar, W8S.singleton c)+ | c <- [ minBound .. maxBound ]+ ]++ -- non-empty map+ grammarM :: [(Word8Set, SaTTH' tag, M tag)]+ grammarM =+ [ (c, grammar', makeM grammar')+ | (grammar', c) <- Map.toList grammarM1+ ]++ -- next states+ nexts0 <- forM grammarM $ \(ws, grammar', modify) -> do+ if emptySashaTTH grammar' then return (ws, NextEmpty, modify)+ else if epsSashaTTH grammar' then return (ws, NextEps, modify)+ else do+ next <- rec grammar'+ return (ws, Next next, modify)++ -- sort next states+ let nexts :: [(Word8Set, Next (Code Q (R tag)), M tag)]+ nexts = sortOn (\(ws, _, _) -> meas ws) nexts0++ -- transition case+ let caseAnalysis+ :: Code Q (Maybe (tag, Int))+ -> Code Q Int+ -> Code Q Word8+ -> Code Q BS.ByteString+ -> Code Q (Maybe (tag, Int))+ caseAnalysis acc pfx c sfx = caseTTH [|| () ||]+ [ (W8S.memberCode c ws, body)++ | (ws, mnext, modify) <- nexts+ , let body = case mnext of+ NextEmpty -> acc+ NextEps -> modify acc [|| $$pfx + 1 ||]+ Next next -> [|| let !pfx' = $$pfx + 1 in $$next $$(modify acc [|| pfx' ||]) pfx' $$sfx ||]+ ]++ let debugWarns :: Q ()+ debugWarns = return ()++ return $ TH.bindCode_ debugWarns [|| \ !acc !_pfx !input -> case BS.uncons input of+ Nothing -> acc+ Just (c, _sfx) -> $$(caseAnalysis [|| acc ||] [|| _pfx ||] [|| c ||] [|| _sfx ||])+ ||]++-------------------------------------------------------------------------------+-- Sorting transitions+-------------------------------------------------------------------------------++data Meas+ = MeasLite Word8Set+ | MeasCont !(Down Int) !Word8Set+ | MeasSize !Int !Word8Set+ deriving (Eq, Ord)++meas :: Word8Set -> Meas+meas ws+ | W8S.size ws < 2 = MeasLite ws+ | W8S.isSingleRange ws = MeasCont (Down (W8S.size ws)) ws+ | otherwise = MeasSize (W8S.size ws) ws++-------------------------------------------------------------------------------+-- Aliases+-------------------------------------------------------------------------------++-- | Inner scanner function.+--+-- * previous match+-- * position+-- * input+--+type R tag = Maybe (tag, Int) -> Int -> BS.ByteString -> Maybe (tag, Int)++-- | Last accept modifier.+type M tag = Code Q (Maybe (tag, Int)) -> CodeQ Int -> CodeQ (Maybe (tag, Int))++makeM :: forall tag. SaTTH' tag -> M tag+makeM grammar acc pfx = case acc' of+ Nothing -> acc+ Just tag -> [|| Just ($$tag, $$pfx) ||]+ where+ acc' :: Maybe (Code Q tag)+ acc' = listToMaybe+ [ tag+ | S _ tag ere <- grammar+ , nullable ere+ ]++data Next a+ = NextEmpty+ | NextEps+ | Next a++-------------------------------------------------------------------------------+-- TTH extras+-------------------------------------------------------------------------------++caseTTH :: Code Q a -> [(Code Q Bool, CodeQ r)] -> Code Q r+caseTTH c guards = TH.unsafeCodeCoerce $ TH.caseE (TH.unTypeCode c)+ [ TH.match TH.wildP (TH.guardedB (go guards)) [] ]+ where+ go :: [(Code Q Bool, Code Q r)] -> [Q (TH.Guard, Exp)]+ go [] = []+ go [(_,b)] = [TH.normalGE [| otherwise |] (TH.unTypeCode b)]+ go ((g,b):gbs) = TH.normalGE (TH.unTypeCode g) (TH.unTypeCode b) : go gbs++-------------------------------------------------------------------------------+-- State+-------------------------------------------------------------------------------++-- | We give each tag an integer, so we can order them.+data S tag = S !Int !(Code Q tag) !ERE++instance Show (S tag) where+ show (S i _ ere) = show (i, ere)++instance Eq (S tag) where+ S i _ ere == S i' _ ere' = (i, ere) == (i', ere')++instance Ord (S tag) where+ compare (S i _ ere) (S i' _ ere') = compare (i, ere) (i', ere')++type SaTTH' tag = [S tag]++-------------------------------------------------------------------------------+-- Derivative+-------------------------------------------------------------------------------++derivativeSaTTH :: Word8 -> SaTTH' tag -> SaTTH' tag+derivativeSaTTH c ts =+ [ S i code ere''+ | S i code ere <- ts+ , let ere' = derivative c ere+ , let ere'' = simplifyERE ere'+ , not (equivalent empty ere'')+ ]++simplifyERE :: ERE -> ERE+simplifyERE ere+ | equivalent ere eps = eps+ | otherwise = ere++-- does it make sense to look further?+emptySashaTTH :: SaTTH' tag -> Bool+emptySashaTTH = null++epsSashaTTH :: SaTTH' tag -> Bool+epsSashaTTH grammar = and [ equivalent ere eps | S _ _ ere <- grammar ]
+ tests/Sasha/Example/Alex.hs view
@@ -0,0 +1,363 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 1 "Alex.x" #-}++module Sasha.Example.Alex (alexToken) where++import Data.Word (Word8)++import qualified Data.ByteString as BS++import Sasha.Example.Token+++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array.Base (unsafeAt)+import GHC.Exts+#else+import GlaExts+#endif+alex_tab_size :: Int+alex_tab_size = 8+alex_base :: AlexAddr+alex_base = AlexA#+ "\xf8\xff\xff\xff\x9e\xff\xff\xff\x9f\xff\xff\xff\x91\xff\xff\xff\x94\xff\xff\xff\x93\xff\xff\xff\xa8\xff\xff\xff\xa0\xff\xff\xff\x98\xff\xff\xff\xa1\xff\xff\xff\x01\x00\x00\x00\xa2\xff\xff\xff\x05\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+ "\x00\x00\x0d\x00\x0d\x00\x16\x00\x17\x00\x0d\x00\x01\x00\x02\x00\x09\x00\x07\x00\x03\x00\xff\xff\x04\x00\x0b\x00\x18\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0a\x00\x00\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\xff\xff\x13\x00\x00\x00\x00\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x12\x00\x0d\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+ "\xff\xff\x09\x00\x0a\x00\x65\x00\x65\x00\x0d\x00\x75\x00\x73\x00\x75\x00\x61\x00\x72\x00\x0a\x00\x6c\x00\x6c\x00\x6c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\x22\x00\x2c\x00\xff\xff\xff\xff\x22\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+ "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 24)+ [ AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAcc 11+ , AlexAcc 10+ , AlexAcc 9+ , AlexAcc 8+ , AlexAcc 7+ , AlexAcc 6+ , AlexAcc 5+ , AlexAcc 4+ , AlexAcc 3+ , AlexAcc 2+ , AlexAcc 1+ , AlexAcc 0+ ]++alex_actions = array (0 :: Int, 12)+ [ (11,alex_action_0)+ , (10,alex_action_1)+ , (9,alex_action_2)+ , (8,alex_action_3)+ , (7,alex_action_4)+ , (6,alex_action_5)+ , (5,alex_action_6)+ , (4,alex_action_7)+ , (3,alex_action_8)+ , (2,alex_action_9)+ , (1,alex_action_10)+ , (0,alex_action_11)+ ]++{-# LINE 32 "Alex.x" #-}++type AlexInput = BS.ByteString++alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte = BS.uncons++alexToken :: BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString)+alexToken bs = case alexScan bs 0 of+ AlexEOF -> Nothing+ AlexError _ -> Nothing+ AlexSkip bs' _ -> alexToken bs'+ AlexToken _ i tk -> case BS.splitAt i bs of+ (pfx, sfx) -> Just (tk, pfx, sfx)++alex_action_0 = TkSpace +alex_action_1 = TkBraceOpen +alex_action_2 = TkBraceClose +alex_action_3 = TkBracketOpen +alex_action_4 = TkBracketClose +alex_action_5 = TkColon +alex_action_6 = TkComma +alex_action_7 = TkString +alex_action_8 = TkNumber +alex_action_9 = TkTrue +alex_action_10 = TkFalse +alex_action_11 = TkNull +{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine+++++++++++++++++++-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ > 706+#define GTE(n,m) (tagToEnum# (n >=# m))+#define EQ(n,m) (tagToEnum# (n ==# m))+#else+#define GTE(n,m) (n >=# m)+#define EQ(n,m) (n ==# m)+#endif++++++++++++++++++++data AlexAddr = AlexA# Addr#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+#if __GLASGOW_HASKELL__ >= 901+ int16ToInt#+#endif+ (indexInt16OffAddr# arr off)+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt32OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+#if __GLASGOW_HASKELL__ >= 901+ int32ToInt#+#endif+ (indexInt32OffAddr# arr off)+#endif+++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input__ (I# (sc))+ = alexScanUser undefined input__ (I# (sc))++alexScanUser user__ input__ (I# (sc))+ = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of+ (AlexNone, input__') ->+ case alexGetByte input__ of+ Nothing ->++++ AlexEOF+ Just _ ->++++ AlexError input__'++ (AlexLastSkip input__'' len, _) ->++++ AlexSkip input__'' len++ (AlexLastAcc k input__''' len, _) ->++++ AlexToken input__''' len (alex_actions ! k)+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user__ orig_input len input__ s last_acc =+ input__ `seq` -- strict in the input+ let+ new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))+ in+ new_acc `seq`+ case alexGetByte input__ of+ Nothing -> (new_acc, input__)+ Just (c, new_input) ->++++ case fromIntegral c of { (I# (ord_c)) ->+ let+ base = alexIndexInt32OffAddr alex_base s+ offset = (base +# ord_c)+ check = alexIndexInt16OffAddr alex_check offset++ new_s = if GTE(offset,0#) && EQ(check,ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of+ -1# -> (new_acc, input__)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)+ -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+ new_input new_s new_acc+ }+ where+ check_accs (AlexAccNone) = last_acc+ check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len))+ check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len))++++++++++++++data AlexLastAcc+ = AlexNone+ | AlexLastAcc !Int !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc user+ = AlexAccNone+ | AlexAcc Int+ | AlexAccSkip+++++++++++++++++++++++++++++
+ tests/Sasha/Example/SaTTH.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Sasha.Example.SaTTH where++import Algebra.Lattice ((/\))++import qualified Data.ByteString as BS++import Sasha.Example.Token+import Sasha.TTH++satthToken :: BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString)+satthToken = $$(satth+ -- Lexer specification of JSON(like) tokens.+ [ [|| TkSpace ||] := plus (unions (map utf8Char (" \t\r\n")))+ , [|| TkBraceOpen ||] := "{"+ , [|| TkBraceClose ||] := "}"+ , [|| TkBracketOpen ||] := "["+ , [|| TkBracketClose ||] := "]"+ , [|| TkComma ||] := ","+ , [|| TkColon ||] := ":"+ , [|| TkString ||] := appends [ "\"", star (anyChar /\ complement (utf8Char '"')), "\"" ]+ , [|| TkNumber ||] := plus digit+ , [|| TkTrue ||] := "true"+ , [|| TkFalse ||] := "false"+ , [|| TkNull ||] := "null"+ ])+++satthUtf8 :: BS.ByteString -> Maybe ((), BS.ByteString, BS.ByteString)+satthUtf8 = $$(satth [ [|| () ||] := anyUtf8Char ] )
+ tests/Sasha/Example/Sasha.hs view
@@ -0,0 +1,31 @@+module Sasha.Example.Sasha (sashaToken, sashaUtf8) where++import Algebra.Lattice ((/\))++import qualified Data.ByteString as BS++import Sasha.Example.Token+import Sasha++-- | Lexer specification of JSON(like) tokens.+grammar :: Sasha Tk+grammar =+ [ TkSpace := plus (unions (map utf8Char (" \t\r\n")))+ , TkBraceOpen := "{"+ , TkBraceClose := "}"+ , TkBracketOpen := "["+ , TkBracketClose := "]"+ , TkComma := ","+ , TkColon := ":"+ , TkString := appends [ "\"", star (anyChar /\ complement (utf8Char '"')), "\"" ]+ , TkNumber := plus digit+ , TkTrue := "true"+ , TkFalse := "false"+ , TkNull := "null"+ ]++sashaToken :: BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString)+sashaToken = sasha grammar++sashaUtf8 :: BS.ByteString -> Maybe ((), BS.ByteString, BS.ByteString)+sashaUtf8 = sasha [ () := anyUtf8Char ]
+ tests/Sasha/Example/Token.hs view
@@ -0,0 +1,25 @@+module Sasha.Example.Token where++import Control.DeepSeq (NFData (rnf))++data Tk+ = TkErr+ | TkSpace+ | TkBraceOpen+ | TkBraceClose+ | TkBracketOpen+ | TkBracketClose+ | TkComma+ | TkColon+ | TkString+ | TkNumber+ | TkTrue+ | TkFalse+ | TkNull+ deriving (Eq, Show)++instance NFData Tk where+ rnf !_ = ()++pattern (:=) :: a -> b -> (a, b)+pattern x := y = (x, y)
+ tests/sasha-tests.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Data.Either (isRight)+import System.Environment (getArgs, withArgs)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (label, testProperty, (===))++import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as TE+import qualified Test.Tasty.Bench as B++import Sasha.Example.Alex+import Sasha.Example.Sasha+import Sasha.Example.SaTTH+import Sasha.Example.Token++main :: IO ()+main = do+ input <- BS.readFile "example.json"+ args <- getArgs+ case args of+ "bench" : args' -> withArgs args' $ B.defaultMain+ [ B.bgroup "json"+ [ B.bench "sasha" $ B.nf (tokens sashaToken) input+ , B.bench "alex" $ B.nf (tokens alexToken) input+ , B.bench "satth" $ B.nf (tokens satthToken) input+ , B.bench "aeson" $ B.nf (A.decodeStrict @A.Value) input+ ]+ , B.bgroup "utf8"+ [ B.bench "sasha" $ B.whnf (accepts sashaToken) input+ , B.bench "satth" $ B.whnf (accepts satthToken) input+#if MIN_VERSION_bytestring(0,11,2)+ , B.bench "bytestring" $ B.whnf BS.isValidUtf8 input+#endif+ ]+ ]++ _ -> defaultMain $ testGroup "sasha-json"+ [ testGroup "json"+ [ testCase "sasha" $ tokens sashaToken input @?= expectedJson+ , testCase "satth" $ tokens satthToken input @?= expectedJson+ , testCase "alex" $ tokens alexToken input @?= expectedJson+ ]+ , testGroup "utf8"+ [ testProperty "sasha" $ \w8s ->+ let bs = BS.pack w8s+ isValid = isRight (TE.decodeUtf8' bs)+ in label (show isValid) $ accepts sashaUtf8 bs === isValid++ , testProperty "sasha" $ \w8s ->+ let bs = BS.pack w8s+ isValid = isRight (TE.decodeUtf8' bs)+ in label (show isValid) $ accepts satthUtf8 bs === isValid+ ]+ ]++tokens+ :: (BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString)) -- ^ single token scanner+ -> BS.ByteString -- ^ input+ -> [(Tk, BS.ByteString)] -- ^ result list of tokens+tokens scan = go+ where+ go !bs+ | BS.null bs = []+ | otherwise = case scan bs of+ Nothing -> [(TkErr, bs)]+ Just (tk, pfx, sfx) -> (tk, pfx) : go sfx+{-# INLINE tokens #-}++accepts+ :: (BS.ByteString -> Maybe (a, b, BS.ByteString)) -- ^ single token scanner+ -> BS.ByteString -- ^ input+ -> Bool+accepts scan = go+ where+ go !bs+ | BS.null bs = True+ | otherwise = case scan bs of+ Nothing -> False+ Just (_, _, sfx) -> go sfx+{-# INLINE accepts #-}++expectedJson :: [(Tk, BS.ByteString)]+expectedJson =+ [ TkBraceOpen := "{"+ , TkSpace := "\n "+ , TkString := "\"literals\""+ , TkColon := ":"+ , TkSpace := " "+ , TkBracketOpen := "["+ , TkTrue := "true"+ , TkComma := ","+ , TkSpace := " "+ , TkFalse := "false"+ , TkComma := ","+ , TkSpace := " "+ , TkNull := "null"+ , TkBracketClose := "]"+ , TkComma := ","+ , TkSpace := "\n "+ , TkString := "\"numbers\""+ , TkColon := ":"+ , TkSpace := " "+ , TkBracketOpen := "["+ , TkNumber := "0"+ , TkComma := ","+ , TkSpace := " "+ , TkNumber := "123"+ , TkBracketClose := "]"+ , TkSpace := "\n"+ , TkBraceClose := "}"+ , TkSpace := "\n"+ ]