diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +## 0.2 + +- Change the API such that + + ```diff + - type Sasha tag = [(Tag, ERE)] + + type Sasha r = [(ERE, BS.ByteString -> BS.ByteString -> r)] + ``` + + This allows to write scanner actions more like in `alex`: + + ```haskell + [ someRegexp := \tok inp' -> ... + , another := \tok inp' -> ... + ] + ``` + + Similar change is also done in TTH interface. + +- Add `charSet :: Word8Set -> ERE` helper. + ## 0.1 - Use `word8set` package. diff --git a/sasha.cabal b/sasha.cabal --- a/sasha.cabal +++ b/sasha.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: sasha -version: 0.1 +version: 0.2 author: Oleg Grenrus maintainer: Oleg Grenrus synopsis: A staged lexer generator @@ -46,7 +46,7 @@ , template-haskell , th-letrec ^>=0.1 , wide-word ^>=0.1.4.0 - , word8set ^>=0.1 + , word8set ^>=0.1.1 exposed-modules: Sasha @@ -76,6 +76,7 @@ , deepseq , lattices , sasha + , template-haskell -- test dependencies build-depends: diff --git a/src/Sasha.hs b/src/Sasha.hs --- a/src/Sasha.hs +++ b/src/Sasha.hs @@ -13,6 +13,7 @@ eps, char, charRange, + charSet, utf8Char, anyChar, anyUtf8Char, @@ -28,41 +29,41 @@ digit, ) where -import Control.Applicative ((<|>)) -import Data.Maybe (listToMaybe) -import Data.Word (Word8) +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)] +-- | Lexer grammar specification: regular expression and result builder function +-- which takes a prefix (the matching part) and a suffix (the rest of input). +type Sasha r = [(ERE, BS.ByteString -> BS.ByteString -> r)] -- | 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 + :: forall r. r -- ^ no match value + -> Sasha r -- ^ scanner rules definitions + -> BS.ByteString -- ^ input + -> r -- ^ result +sasha noMatch grammar input0 = go noMatch 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' + -- Note: acc has to be lazy + go :: r -> Int -> BS.ByteString -> Sasha r -> r + go acc !_ !_ [] = acc + go acc !i !input ts = case BS.uncons input of + Nothing -> acc + Just (c, input') -> go (next accs acc) (i + 1) input' ts' where ts' = derivativeSasha c ts - acc' = listToMaybe [ (tag, pfx + 1) | (tag, ere) <- ts', nullable ere] + accs = [ case BS.splitAt (i + 1) input0 of (pfx, sfx) -> f pfx sfx | (ere, f) <- ts', nullable ere] -derivativeSasha :: Word8 -> Sasha tag -> Sasha tag + next [] x = x + next (x:_) _ = x + +derivativeSasha :: Word8 -> Sasha r -> Sasha r derivativeSasha c ts = - [ (t, ere') - | (t, ere) <- ts + [ (ere', f) + | (ere, f) <- ts , let ere' = derivative c ere , not (isEmpty ere') ] diff --git a/src/Sasha/Internal/ERE.hs b/src/Sasha/Internal/ERE.hs --- a/src/Sasha/Internal/ERE.hs +++ b/src/Sasha/Internal/ERE.hs @@ -18,6 +18,7 @@ eps, char, charRange, + charSet, utf8Char, anyChar, anyUtf8Char, @@ -118,7 +119,13 @@ -- | Character range. -- charRange :: Word8 -> Word8 -> ERE -charRange l u = EREUnion (W8S.range l u) Set.empty +charRange l u = charSet (W8S.range l u) + +-- | Character set. +-- +-- @since 0.2 +charSet :: Word8Set -> ERE +charSet s = EREUnion s Set.empty -- | Any character. -- diff --git a/src/Sasha/TTH.hs b/src/Sasha/TTH.hs --- a/src/Sasha/TTH.hs +++ b/src/Sasha/TTH.hs @@ -9,6 +9,7 @@ eps, char, charRange, + charSet, utf8Char, anyChar, anyUtf8Char, @@ -43,50 +44,54 @@ import Sasha.Internal.ERE import Sasha.Internal.Word8Set (memberCode) --- | Lexer grammar specification: tag codes and regular expressions. -type SaTTH tag = [(Code Q tag, ERE)] +-- | Lexer grammar specification: regular expression and result builder function +-- which takes a prefix (the matching part) and a suffix (the rest of input). +type SaTTH r = [(ERE, Code Q BS.ByteString -> Code Q BS.ByteString -> Code Q r)] +-- | Scan for a single token. +satth + :: forall r. Code Q r -- ^ no match value + -> SaTTH r -- ^ scanner rules definitions + -> Code Q (BS.ByteString -> r) -- ^ scanner code +satth noMatch rules = [|| \bs -> $$(satth' noMatch rules [|| bs ||]) bs ||] + -- | Generate a scanner code. -satth :: forall tag. SaTTH tag -> Code Q (BS.ByteString -> Maybe (tag, BS.ByteString, BS.ByteString)) -satth grammar0 = letrecE +satth' :: forall r. Code Q r -> SaTTH r -> Code Q BS.ByteString -> Code Q (BS.ByteString -> r) +satth' noMatch grammar0 input0 = letrecE (\_ -> "state") trans start where - grammar0' :: SaTTH' tag + grammar0' :: SaTTH' r grammar0' = - [ S i t ere - | (i, (t, ere)) <- zip [0..] grammar0 + [ S i f ere + | (i, (ere, f)) <- 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 :: Monad m => (SaTTH' r -> m (Code Q (R r))) -> m (Code Q (BS.ByteString -> r)) 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) - ||] + return [|| \input -> $$startCode $$noMatch (0 :: Int) input ||] - trans :: Monad m => (SaTTH' tag -> m (Code Q (R tag))) -> SaTTH' tag -> m (Code Q (R tag)) + trans :: Monad m => (SaTTH' r -> m (Code Q (R r))) -> SaTTH' r -> m (Code Q (R r)) trans _rec grammar | emptySashaTTH grammar = return [|| \ !acc _ _ -> acc ||] trans rec grammar = do -- if the input is not empty? - let grammarM1 :: Map (SaTTH' tag) Word8Set + let grammarM1 :: Map (SaTTH' r) 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 :: [(Word8Set, SaTTH' r, M r)] grammarM = - [ (c, grammar', makeM grammar') + [ (c, grammar', makeM input0 grammar') | (grammar', c) <- Map.toList grammarM1 ] @@ -99,32 +104,33 @@ return (ws, Next next, modify) -- sort next states - let nexts :: [(Word8Set, Next (Code Q (R tag)), M tag)] + let nexts :: [(Word8Set, Next (Code Q (R r)), M r)] nexts = sortOn (\(ws, _, _) -> meas ws) nexts0 -- transition case let caseAnalysis - :: Code Q (Maybe (tag, Int)) + :: Code Q r -> Code Q Int -> Code Q Word8 -> Code Q BS.ByteString - -> Code Q (Maybe (tag, Int)) - caseAnalysis acc pfx c sfx = caseTTH [|| () ||] + -> Code Q r + caseAnalysis acc pos c input' = caseTTH [|| () ||] [ (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 ||] + NextEps -> modify acc [|| $$pos + 1 ||] + Next next -> [|| let !pos' = $$pos + 1 in $$next $$(modify acc [|| pos' ||]) pos' $$input' ||] ] 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 ||]) + -- Note: acc should stay lazy + return $ TH.bindCode_ debugWarns [|| \ acc !_pos !input -> case BS.uncons input of + Nothing -> acc + Just (c, _input') -> $$(caseAnalysis [|| acc ||] [|| _pos ||] [|| c ||] [|| _input' ||]) ||] ------------------------------------------------------------------------------- @@ -153,20 +159,20 @@ -- * position -- * input -- -type R tag = Maybe (tag, Int) -> Int -> BS.ByteString -> Maybe (tag, Int) +type R r = r -> Int -> BS.ByteString -> r -- | Last accept modifier. -type M tag = Code Q (Maybe (tag, Int)) -> CodeQ Int -> CodeQ (Maybe (tag, Int)) +type M r = Code Q r -> CodeQ Int -> CodeQ r -makeM :: forall tag. SaTTH' tag -> M tag -makeM grammar acc pfx = case acc' of - Nothing -> acc - Just tag -> [|| Just ($$tag, $$pfx) ||] +makeM :: forall r. Code Q BS.ByteString -> SaTTH' r -> M r +makeM input0 grammar acc pos = case acc' of + Nothing -> acc + Just f -> [|| case BS.splitAt $$pos $$input0 of (_pfx, _sfx) -> $$(f [|| _pfx ||] [|| _sfx ||]) ||] where - acc' :: Maybe (Code Q tag) + acc' :: Maybe (Code Q BS.ByteString -> Code Q BS.ByteString -> Code Q r) acc' = listToMaybe - [ tag - | S _ tag ere <- grammar + [ f + | S _ f ere <- grammar , nullable ere ] @@ -193,7 +199,7 @@ ------------------------------------------------------------------------------- -- | We give each tag an integer, so we can order them. -data S tag = S !Int !(Code Q tag) !ERE +data S r = S !Int !(Code Q BS.ByteString -> Code Q BS.ByteString -> Code Q r) !ERE instance Show (S tag) where show (S i _ ere) = show (i, ere) diff --git a/tests/Sasha/Example/SaTTH.hs b/tests/Sasha/Example/SaTTH.hs --- a/tests/Sasha/Example/SaTTH.hs +++ b/tests/Sasha/Example/SaTTH.hs @@ -1,31 +1,35 @@ {-# LANGUAGE TemplateHaskell #-} --- {-# OPTIONS_GHC -ddump-splices #-} -module Sasha.Example.SaTTH where +{-# OPTIONS_GHC -ddump-splices #-} +module Sasha.Example.SaTTH (satthToken, satthUtf8) where import Algebra.Lattice ((/\)) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Sasha.Example.Token import Sasha.TTH +mkToken :: tag -> BS.ByteString -> BS.ByteString -> Maybe (tag, BS.ByteString, BS.ByteString) +mkToken tk pfx sfx = Just (tk, pfx, sfx) + satthToken :: BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString) satthToken = $$(satth + [|| Nothing ||] -- 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" + [ plus (unions (map utf8Char (" \t\r\n"))) := \ pfx sfx -> [|| mkToken TkSpace $$pfx $$sfx ||] + , "{" := \ pfx sfx -> [|| mkToken TkBraceOpen $$pfx $$sfx ||] + , "}" := \ pfx sfx -> [|| mkToken TkBraceClose $$pfx $$sfx ||] + , "[" := \ pfx sfx -> [|| mkToken TkBracketOpen $$pfx $$sfx ||] + , "]" := \ pfx sfx -> [|| mkToken TkBracketClose $$pfx $$sfx ||] + , "," := \ pfx sfx -> [|| mkToken TkComma $$pfx $$sfx ||] + , ":" := \ pfx sfx -> [|| mkToken TkColon $$pfx $$sfx ||] + , appends [ "\"", star (anyChar /\ complement (utf8Char '"')), "\"" ] := \ pfx sfx -> [|| mkToken TkString $$pfx $$sfx ||] + , plus digit := \ pfx sfx -> [|| mkToken TkNumber $$pfx $$sfx ||] + , "true" := \ pfx sfx -> [|| mkToken TkTrue $$pfx $$sfx ||] + , "false" := \ pfx sfx -> [|| mkToken TkFalse $$pfx $$sfx ||] + , "null" := \ pfx sfx -> [|| mkToken TkNull $$pfx $$sfx ||] ]) -satthUtf8 :: BS.ByteString -> Maybe ((), BS.ByteString, BS.ByteString) -satthUtf8 = $$(satth [ [|| () ||] := anyUtf8Char ] ) +satthUtf8 :: BS.ByteString -> Maybe BS.ByteString +satthUtf8 = $$(satth [|| Nothing ||] [ anyUtf8Char := \_ sfx -> [|| Just $$sfx ||] ] ) diff --git a/tests/Sasha/Example/Sasha.hs b/tests/Sasha/Example/Sasha.hs --- a/tests/Sasha/Example/Sasha.hs +++ b/tests/Sasha/Example/Sasha.hs @@ -2,30 +2,33 @@ import Algebra.Lattice ((/\)) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Sasha.Example.Token import Sasha +mkToken :: tag -> BS.ByteString -> BS.ByteString -> Maybe (tag, BS.ByteString, BS.ByteString) +mkToken tk pfx sfx = Just (tk, pfx, sfx) + -- | Lexer specification of JSON(like) tokens. -grammar :: Sasha Tk +grammar :: Sasha (Maybe (Tk, BS.ByteString, BS.ByteString)) 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" + [ plus (unions (map utf8Char (" \t\r\n"))) := mkToken TkSpace + , "{" := mkToken TkBraceOpen + , "}" := mkToken TkBraceClose + , "[" := mkToken TkBracketOpen + , "]" := mkToken TkBracketClose + , "," := mkToken TkComma + , ":" := mkToken TkColon + , appends [ "\"", star (anyChar /\ complement (utf8Char '"')), "\"" ] := mkToken TkString + , plus digit := mkToken TkNumber + , "true" := mkToken TkTrue + , "false" := mkToken TkFalse + , "null" := mkToken TkNull ] sashaToken :: BS.ByteString -> Maybe (Tk, BS.ByteString, BS.ByteString) -sashaToken = sasha grammar +sashaToken = sasha Nothing grammar -sashaUtf8 :: BS.ByteString -> Maybe ((), BS.ByteString, BS.ByteString) -sashaUtf8 = sasha [ () := anyUtf8Char ] +sashaUtf8 :: BS.ByteString -> Maybe BS.ByteString +sashaUtf8 = sasha Nothing [ anyUtf8Char := \_pfx sfx -> Just sfx ] diff --git a/tests/sasha-tests.hs b/tests/sasha-tests.hs --- a/tests/sasha-tests.hs +++ b/tests/sasha-tests.hs @@ -30,8 +30,8 @@ , 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 + [ B.bench "sasha" $ B.whnf (accepts sashaUtf8) input + , B.bench "satth" $ B.whnf (accepts satthUtf8) input #if MIN_VERSION_bytestring(0,11,2) , B.bench "bytestring" $ B.whnf BS.isValidUtf8 input #endif @@ -71,16 +71,16 @@ {-# INLINE tokens #-} accepts - :: (BS.ByteString -> Maybe (a, b, BS.ByteString)) -- ^ single token scanner - -> BS.ByteString -- ^ input + :: (BS.ByteString -> Maybe 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 + Nothing -> False + Just sfx -> go sfx {-# INLINE accepts #-} expectedJson :: [(Tk, BS.ByteString)]