sasha 0 → 0.1
raw patch · 5 files changed
+54/−218 lines, 5 filesdep +word8setdep ~basedep ~lattices
Dependencies added: word8set
Dependency ranges changed: base, lattices
Files
- CHANGELOG.md +3/−0
- sasha.cabal +9/−5
- src/Sasha/Internal/ERE.hs +13/−13
- src/Sasha/Internal/Word8Set.hs +21/−192
- src/Sasha/TTH.hs +8/−8
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1++- Use `word8set` package.
sasha.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: sasha-version: 0+version: 0.1 author: Oleg Grenrus <oleg.grenrus@iki.fi> maintainer: Oleg Grenrus <oleg.grenrus@iki.fi> synopsis: A staged lexer generator@@ -14,9 +14,12 @@ 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+extra-source-files:+ CHANGELOG.md+ example.json +tested-with: GHC ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.2+ source-repository head type: git location: https://github.com/phadej/sasha.git@@ -35,14 +38,15 @@ import: common hs-source-dirs: src build-depends:- , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0+ , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 , bytestring ^>=0.10.12.1 || ^>=0.11.3.1 , containers ^>=0.6.4.1- , lattices ^>=2.1+ , lattices >=2.1 && <2.2 || ^>=2.2 , QuickCheck ^>=2.14.2 , template-haskell , th-letrec ^>=0.1 , wide-word ^>=0.1.4.0+ , word8set ^>=0.1 exposed-modules: Sasha
src/Sasha/Internal/ERE.hs view
@@ -45,25 +45,25 @@ 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 Data.Bits (shiftR, (.&.), (.|.))+import Data.Char (ord)+import Data.Foldable (toList)+import Data.Set (Set)+import Data.String (IsString (..))+import Data.Word (Word8)+import Data.Word8Set (Word8Set)+import Test.QuickCheck (Arbitrary (..)) +import qualified Data.Set as Set+import qualified Data.Word8Set as W8S import qualified Test.QuickCheck as QC-import qualified Data.Set as Set-import qualified Sasha.Internal.Word8Set as W8S ------------------------------------------------------------------------------- -- Doctest ------------------------------------------------------------------------------- -- $setup--- >>> :set -XOverloadedStrings +-- >>> :set -XOverloadedStrings -- >>> import Control.Monad (void) -- >>> import Data.Foldable (traverse_) -- >>> import Data.List (sort)@@ -300,7 +300,7 @@ [ (20, EREUnion <$> arbitrary <*> pure Set.empty) , (1, pure eps) , (1, pure empty)- ] + ] | otherwise = QC.oneof [ do p <- arbPartition (n - 1)@@ -308,7 +308,7 @@ , do p <- arbPartition (n - 1) appends <$> traverse arb p- + , star <$> arb (n - 1) , complement <$> arb (n - 1) ]
src/Sasha/Internal/Word8Set.hs view
@@ -1,156 +1,18 @@ {-# 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 Data.Word8Set (Word8Set) +import qualified Data.Bits as Bits+import qualified Data.Word8Set as W8S+ 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. -- -- @@@ -160,59 +22,26 @@ 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--------------------------------------------------------------------------------+ | W8S.null ws+ = [|| False ||] -findMin :: Word8Set -> Word8-findMin (W8S xs) = fromIntegral (Bits.countTrailingZeros xs)+ | W8S.isFull ws + = [|| True ||] -findMax :: Word8Set -> Word8-findMax (W8S xs) = fromIntegral (255 - Bits.countLeadingZeros xs)+ | W8S.size ws == 1+ = [|| $$c == $$(liftTyped (W8S.findMin ws)) ||] ----------------------------------------------------------------------------------- List--------------------------------------------------------------------------------+ | W8S.size ws == 2+ = [|| $$c == $$(liftTyped (W8S.findMin ws)) || $$c == $$(liftTyped (W8S.findMax ws)) ||] -elems :: Word8Set -> [Word8]-elems = toList+ -- continuos range+ | Just (l, r) <- W8S.isRange ws + = [|| $$(liftTyped l) <= $$c && $$c <= $$(liftTyped r) ||] -toList :: Word8Set -> [Word8]-toList xs = [ w8 | w8 <- [0x00..0xff], member w8 xs]+ -- low chars+ | Word256 0 0 0 x <- W8S.toWord256 ws+ = [|| $$c < 64 && Bits.testBit ($$(liftTyped x) :: Word64) (fromIntegral ($$c :: Word8)) ||] -fromList :: [Word8] -> Word8Set-fromList w8s = W8S $ foldl' (\acc w8 -> Bits.setBit acc (fromIntegral w8)) Bits.zeroBits w8s+ -- fallback+ | otherwise+ = [|| W8S.member $$c $$(liftTyped ws) ||]
src/Sasha/TTH.hs view
@@ -29,19 +29,19 @@ import Control.Monad (forM) import Data.List (sortOn) import Data.Map (Map)-import Data.Maybe (listToMaybe)+import Data.Maybe (isJust, listToMaybe) import Data.Ord (Down (..)) import Data.Word (Word8)+import Data.Word8Set (Word8Set) import Language.Haskell.TTH.LetRec (letrecE) import qualified Data.ByteString as BS import qualified Data.Map.Strict as Map+import qualified Data.Word8Set as W8S import qualified Language.Haskell.TH as TH import Sasha.Internal.ERE-import Sasha.Internal.Word8Set (Word8Set)--import qualified Sasha.Internal.Word8Set as W8S+import Sasha.Internal.Word8Set (memberCode) -- | Lexer grammar specification: tag codes and regular expressions. type SaTTH tag = [(Code Q tag, ERE)]@@ -110,7 +110,7 @@ -> Code Q BS.ByteString -> Code Q (Maybe (tag, Int)) caseAnalysis acc pfx c sfx = caseTTH [|| () ||]- [ (W8S.memberCode c ws, body)+ [ (memberCode c ws, body) | (ws, mnext, modify) <- nexts , let body = case mnext of@@ -139,9 +139,9 @@ 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+ | W8S.size ws < 2 = MeasLite ws+ | isJust (W8S.isRange ws) = MeasCont (Down (W8S.size ws)) ws+ | otherwise = MeasSize (W8S.size ws) ws ------------------------------------------------------------------------------- -- Aliases