sasha 0.1 → 0.2
raw patch · 8 files changed
+144/−101 lines, 8 filesdep ~QuickCheckdep ~basedep ~bytestring
Dependency ranges changed: QuickCheck, base, bytestring, containers, lattices, tasty, text, word8set
Files
- CHANGELOG.md +21/−0
- sasha.cabal +3/−2
- src/Sasha.hs +23/−22
- src/Sasha/Internal/ERE.hs +8/−1
- src/Sasha/TTH.hs +42/−36
- tests/Sasha/Example/SaTTH.hs +21/−17
- tests/Sasha/Example/Sasha.hs +20/−17
- tests/sasha-tests.hs +6/−6
CHANGELOG.md view
@@ -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.
sasha.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: sasha-version: 0.1+version: 0.2 author: Oleg Grenrus <oleg.grenrus@iki.fi> maintainer: Oleg Grenrus <oleg.grenrus@iki.fi> 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:
src/Sasha.hs view
@@ -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') ]
src/Sasha/Internal/ERE.hs view
@@ -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. --
src/Sasha/TTH.hs view
@@ -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)
tests/Sasha/Example/SaTTH.hs view
@@ -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 ||] ] )
tests/Sasha/Example/Sasha.hs view
@@ -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 ]
tests/sasha-tests.hs view
@@ -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)]