diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 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 +version: 0.1 author: Oleg Grenrus maintainer: Oleg Grenrus 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 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 @@ -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) ] diff --git a/src/Sasha/Internal/Word8Set.hs b/src/Sasha/Internal/Word8Set.hs --- a/src/Sasha/Internal/Word8Set.hs +++ b/src/Sasha/Internal/Word8Set.hs @@ -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) ||] diff --git a/src/Sasha/TTH.hs b/src/Sasha/TTH.hs --- a/src/Sasha/TTH.hs +++ b/src/Sasha/TTH.hs @@ -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