sequitur 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+524/−133 lines, 7 filesdep +clockdep +criteriondep +optparse-applicativedep ~basedep ~containersnew-component:exe:sequitur-demo
Dependencies added: clock, criterion, optparse-applicative, text
Dependency ranges changed: base, containers
Files
- CHANGELOG.md +13/−0
- README.md +14/−8
- app/demo/Main.hs +67/−0
- bench/Main.hs +21/−0
- sequitur.cabal +59/−2
- src/Language/Grammar/Sequitur.hs +317/−115
- test/Spec.hs +33/−8
CHANGELOG.md view
@@ -8,4 +8,17 @@ ## Unreleased +## 0.2.0.0 - 2024-07-28++* add `decodeNonTerminalsToMonoid` function+* rename `RuleId` type to `NonTerminalSymbol`+* add a benchmark program `sequitur-bench` (Thanks to [MangoIV](https://github.com/MangoIV))+* change `Grammar` type from a type synonym to a `newtype`, and add instances of `Foldable`, `IsList`, and `IsString`+* introduce `IsTerminalSymbol` class synonym for absorbing the difference between `hashable` `<1.4.0.0` and `>=1.4.0.0`.+* use `ST` monad internally instead of arbitrary `PrimMonad` to allow GHC to inline `(>>=)` to produce more efficient code+* add `sequitur-demo` program+* add some sanity checks which are disabled by default+ ## 0.1.0.0 - 2024-07-13++* initial release
README.md view
@@ -1,12 +1,17 @@ # Haskell implementation of _SEQUITUR_ algorithm +Hackage:+[](https://hackage.haskell.org/package/sequitur)++Dev: [](https://github.com/msakai/haskell-sequitur/actions/workflows/build.yaml)+[](https://coveralls.io/github/msakai/haskell-sequitur?branch=main) ## About _SEQUITUR_ _SEQUITUR_ is a linear-time, online algorithm for producing a context-free grammar from an input sequence. The resulting grammar is a compact representation-of original sequence and can be used for data compression.+of the original sequence and can be used for data compression. Example: @@ -17,19 +22,19 @@ - `A` → `BB` - `B` → `abc` -_SEQUITUR_ consumes input symbols one-by-one and append each symbol at the end of the+_SEQUITUR_ consumes input symbols one-by-one and appends each symbol at the end of the grammar's start production (`S` in the above example), then substitutes repeating patterns in the given sequence with new rules. _SEQUITUR_ maintains two invariants: * **Digram Uniqueness**: _SEQUITUR_ ensures that no digram (a.k.a. bigram) occurs more than once in the grammar. If a digram- (e.g. `ab`) occurs twice, SEQUITUR introduce a fresh non-terminal- symbol (e.g. `M`) and a rule (e.g. `M` → `ab`) and replace- original occurences with the newly introduced non-terminals. One- exception is the cases where two occurrence overlap.+ (e.g. `ab`) occurs twice, SEQUITUR introduces a fresh non-terminal+ symbol (e.g. `M`) and a rule (e.g. `M` → `ab`) and replaces+ original occurrences with the newly introduced non-terminals. One+ exception is the cases where two occurrences overlap. * **Rule Utility**: If a non-terminal symbol occurs only once,- _SEQUITUR_ removes the associated rule and substitute the occurence+ _SEQUITUR_ removes the associated rule and substitutes the occurrence with the right-hand side of the rule. ## Usage@@ -37,7 +42,7 @@ ```console ghci> import Language.Grammar.Sequitur ghci> encode "baaabacaa"-fromList [(0,[NonTerminal 1,NonTerminal 2,NonTerminal 1,Terminal 'c',NonTerminal 2]),(1,[Terminal 'b',Terminal 'a']),(2,[Terminal 'a',Terminal 'a'])]+Grammar {unGrammar = fromList [(0,[NonTerminal 1,NonTerminal 2,NonTerminal 1,Terminal 'c',NonTerminal 2]),(1,[Terminal 'b',Terminal 'a']),(2,[Terminal 'a',Terminal 'a'])]} ``` The output represents the following grammar:@@ -57,3 +62,4 @@ Hierarchical Structure in Sequences: A linear-time algorithm](https://doi.org/10.1613/jair.374)," Journal of Artificial Intelligence Research, 7, 67-82.+- [nikitadanilov/sequuntur](https://github.com/nikitadanilov/sequuntur)
+ app/demo/Main.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Control.Monad+import qualified Data.IntMap.Strict as IntMap+import Data.List (intercalate)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Language.Grammar.Sequitur as Sequitur+import Options.Applicative+import System.Clock+import Text.Printf+++data Options+ = Options+ { optInputFile :: FilePath+ , optPrintGrammar :: Bool+ }++optionsParser :: Parser Options+optionsParser = Options+ <$> inputFile+ <*> printGrammar+ where+ inputFile = strArgument+ $ metavar "FILE"+ <> help "input filename"+ printGrammar = flag True False+ $ long "no-grammar"+ <> help "do not print resulting grammar"++parserInfo :: ParserInfo Options+parserInfo = info (optionsParser <**> helper)+ $ fullDesc+ <> header "sequitur-demo"++main :: IO ()+main = do+ opt <- execParser parserInfo++ -- To benchmark time without I/O, we read a file beforehand using strict I/O.+ s <- T.readFile (optInputFile opt)++ startCPU <- getTime ProcessCPUTime+ startWC <- getTime Monotonic++ builder <- Sequitur.newBuilder+ forM_ (T.unpack s) $ \c -> do+ Sequitur.add builder c+ Sequitur.Grammar m <- Sequitur.build builder++ endCPU <- getTime ProcessCPUTime+ endWC <- getTime Monotonic+ printf "cpu time = %.3fs\n" (durationSecs startCPU endCPU)+ printf "wall clock time = %.3fs\n" (durationSecs startWC endWC)++ when (optPrintGrammar opt) $ do+ forM_ (IntMap.toList m) $ \(r, body) -> do+ let f (Sequitur.Terminal c) = show c+ f (Sequitur.NonTerminal r') = show r'+ putStrLn $ show r ++ " -> " ++ intercalate " " (map f body)++ return ()++durationSecs :: TimeSpec -> TimeSpec -> Double+durationSecs start end = fromIntegral (toNanoSecs (end `diffTimeSpec` start)) / 10^(9::Int)
+ bench/Main.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Criterion (bench, bgroup, env, whnf)+import Criterion.Main (defaultMain)+import Data.Functor ((<&>))+import Language.Grammar.Sequitur (encode)+import Test.QuickCheck (Arbitrary (arbitrary), generate, vectorOf)++main :: IO ()+main = do+ defaultMain+ [ bgroup "encoding runs in linear time" do+ [500, 1_000 .. 100_000] <&> \x ->+ env+ do generate (vectorOf x (arbitrary @Char))+ do bench ("size: " <> show x) . whnf encode+ ]
sequitur.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sequitur-version: 0.1.0.0+version: 0.2.0.0 synopsis: Grammar-based compression algorithms SEQUITUR description: Please see the README on GitHub at <https://github.com/msakai/haskell-sequitur#readme> category: Formal Languages, Language, Natural Language Processing, NLP, Text, Compression@@ -17,7 +17,7 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple-extra-source-files:+extra-doc-files: README.md CHANGELOG.md @@ -25,6 +25,11 @@ type: git location: https://github.com/msakai/haskell-sequitur +flag build-example-programs+ description: Build example programs+ manual: True+ default: False+ library exposed-modules: Language.Grammar.Sequitur@@ -34,6 +39,14 @@ Paths_sequitur hs-source-dirs: src+ other-extensions:+ ConstraintKinds+ CPP+ DeriveGeneric+ FlexibleInstances+ LambdaCase+ ScopedTypeVariables+ TypeFamilies ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5@@ -43,6 +56,28 @@ , primitive >=0.7.3.0 && <0.10 default-language: Haskell2010 +executable sequitur-demo+ main-is: Main.hs+ other-modules:+ Paths_sequitur+ autogen-modules:+ Paths_sequitur+ hs-source-dirs:+ app/demo+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , clock >=0.8.3 && <0.9+ , containers >=0.6.4.1 && <0.7+ , optparse-applicative >=0.16.1.0 && <0.19+ , sequitur+ , text >=1.2.4.1 && <2.2+ default-language: Haskell2010+ if flag(build-example-programs)+ buildable: True+ else+ buildable: False+ test-suite sequitur-test type: exitcode-stdio-1.0 main-is: Spec.hs@@ -60,3 +95,25 @@ , hspec >=2.7.10 && <2.12 , sequitur default-language: Haskell2010++benchmark sequitur-bench+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -O2+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_sequitur+ autogen-modules:+ Paths_sequitur+ hs-source-dirs:+ bench+ other-extensions:+ BlockArguments+ NumericUnderscores+ TypeApplications+ build-depends:+ QuickCheck >=2.14.2 && <2.15+ , base+ , containers >=0.6.4.1 && <0.7+ , criterion >=1.5.13.0 && <1.7+ , sequitur
src/Language/Grammar/Sequitur.hs view
@@ -1,7 +1,11 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Grammar.Sequitur@@ -14,7 +18,7 @@ -- -- /SEQUITUR/ is a linear-time, online algorithm for producing a context-free -- grammar from an input sequence. The resulting grammar is a compact representation--- of original sequence and can be used for data compression.+-- of the original sequence and can be used for data compression. -- -- Example: --@@ -28,19 +32,19 @@ -- -- - @B@ → @abc@ ----- /SEQUITUR/ consumes input symbols one-by-one and append each symbol at the end of the+-- /SEQUITUR/ consumes input symbols one-by-one and appends each symbol at the end of the -- grammar's start production (@S@ in the above example), then substitutes repeating -- patterns in the given sequence with new rules. /SEQUITUR/ maintains two invariants: -- -- [/Digram Uniqueness/]: /SEQUITUR/ ensures that no digram -- (a.k.a. bigram) occurs more than once in the grammar. If a digram--- (e.g. @ab@) occurs twice, SEQUITUR introduce a fresh non-terminal--- symbol (e.g. @M@) and a rule (e.g. @M@ → @ab@) and replace--- original occurences with the newly introduced non-terminals. One--- exception is the cases where two occurrence overlap.+-- (e.g. @ab@) occurs twice, SEQUITUR introduces a fresh non-terminal+-- symbol (e.g. @M@) and a rule (e.g. @M@ → @ab@) and replaces the+-- original occurrences with the newly introduced non-terminal symbol.+-- One exception is the cases where two occurrences overlap. -- -- [/Rule Utility/]: If a non-terminal symbol occurs only once,--- /SEQUITUR/ removes the associated rule and substitute the occurence+-- /SEQUITUR/ removes the associated rule and substitutes the occurrence -- with the right-hand side of the rule. -- -- References:@@ -58,29 +62,34 @@ module Language.Grammar.Sequitur ( -- * Basic type definition- Grammar- , RuleId+ Grammar (..) , Symbol (..)+ , NonTerminalSymbol+ , IsTerminalSymbol - -- * High-level API+ -- * Construction++ -- ** High-level API --- -- Use these APIs if the entire sequence is given at once and you+ -- | Use 'encode' if the entire sequence is given at once and you -- only need to create a single grammar from it. , encode- , decode- , decodeLazy- , decodeToSeq- , decodeToMonoid - -- * Low-level monadic API+ -- ** Low-level monadic API --- -- Use these low-level monadic API if the input sequence is given- -- incrementally, or you want to re-construct grammar after you- -- receive additinal inputs.+ -- | Use these low-level monadic API if the input sequence is given+ -- incrementally, or you want to repeatedly construct grammars with+ -- newly added inputs. , Builder , newBuilder , add , build++ -- * Conversion to other types+ , decode+ , decodeToSeq+ , decodeToMonoid+ , decodeNonTerminalsToMonoid ) where import Control.Exception@@ -94,21 +103,42 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Primitive.MutVar+#if MIN_VERSION_primitive(0,8,0)+import Data.Primitive.PrimVar+#endif import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H import Data.Maybe import Data.Semigroup (Endo (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import Data.String (IsString (..)) import GHC.Generics (Generic)+#if MIN_VERSION_base(4,17,0)+import qualified GHC.IsList as IsList (IsList (..))+#else+import qualified GHC.Exts as IsList (IsList (..))+#endif import GHC.Stack --- TODO:------ * Use PrimVar after dropping support for primitive <0.8.0.0------ * Remove Eq requirements after dropping support for hashable <1.4.0.0+#if !MIN_VERSION_primitive(0,8,0) +type PrimVar s a = MutVar s a++{-# INLINE newPrimVar #-}+newPrimVar :: PrimMonad m => a -> m (PrimVar (PrimState m) a)+newPrimVar = newMutVar++{-# INLINE readPrimVar #-}+readPrimVar :: PrimMonad m => PrimVar (PrimState m) a -> m a+readPrimVar = readMutVar++{-# INLINE modifyPrimVar #-}+modifyPrimVar :: PrimMonad m => PrimVar (PrimState m) a -> (a -> a) -> m ()+modifyPrimVar = modifyMutVar'++#endif+ -- ------------------------------------------------------------------- sanityCheck :: Bool@@ -116,28 +146,104 @@ -- ------------------------------------------------------------------- --- | A non-terminal symbol is represented by an 'Int'.+-- | Non-terminal symbols are represented by 'Int'. -- -- The number @0@ is reserved for the start symbol of the grammar.-type RuleId = Int+type NonTerminalSymbol = Int --- | A symbol is either a terminal symbol (from user-specified type)--- or a non-terminal symbol which we represent using 'RuleId' type.+-- | Internal alias of 'NonTerminalSymbol'+type RuleId = NonTerminalSymbol++-- | A symbol is either a terminal symbol (from a user-specified type)+-- or a non-terminal symbol. data Symbol a- = NonTerminal !RuleId- | Terminal !a+ = NonTerminal !NonTerminalSymbol+ | Terminal a deriving (Eq, Ord, Show, Generic) instance (Hashable a) => Hashable (Symbol a) +-- | @since 0.2.0.0+instance Functor Symbol where+ fmap _ (NonTerminal rid) = NonTerminal rid+ fmap f (Terminal a) = Terminal (f a)+ type Digram a = (Symbol a, Symbol a) --- | A grammar is a mappping from non-terminal (left-hand side of the--- rule) to sequnce of symbols (right hand side of the rule).+-- | Since a grammar generated by /SEQUITUR/ has exactly one rule for+-- each non-terminal symbol, a grammar is represented as a mapping+-- from non-terminal symbols (left-hand sides of the rules) to+-- sequences of symbols (right-hand side of the rules). ----- Non-terminal is represented as a 'RuleId'.-type Grammar a = IntMap [Symbol a]+-- For example, a grammar+--+-- - @0@ → @1 1 2@+--+-- - @1@ → @2 2@+--+-- - @2@ → @a b c@+--+-- is represented as+--+-- @+-- Grammar (fromList+-- [ (0, [NonTerminal 1, NonTerminal 1, NonTerminal 2])+-- , (1, [NonTerminal 2, NonTerminal 2])+-- , (2, [Terminal \'a\', Terminal \'b\', Terminal \'c\'])+-- ])+-- @+--+-- Since a grammar generated by /SEQUITUR/ produces exactly one+-- sequence, we can identify the grammar with the produced+-- sequence. Therefore, 'Grammar' type is an instance of 'Foldable',+-- 'IsList.IsList', and 'IsString'.+newtype Grammar a = Grammar {unGrammar :: IntMap [Symbol a]}+ deriving (Eq, Show) +-- | @since 0.2.0.0+instance Functor Grammar where+ fmap f (Grammar m) = Grammar (fmap (map (fmap f)) m)++-- | @since 0.2.0.0+instance Foldable Grammar where+ foldMap = decodeToMonoid++-- | @since 0.2.0.0+instance IsTerminalSymbol a => IsList.IsList (Grammar a) where+ type Item (Grammar a) = a+ fromList = encode+ toList = decode++-- | @since 0.2.0.0+instance IsString (Grammar Char) where+ fromString = encode++-- | @IsTerminalSymbol@ is a class synonym for absorbing the difference+-- between @hashable@ @<1.4.0.0@ and @>=1.4.0.0@.+--+-- @hashable-1.4.0.0@ makes 'Eq' be a superclass of 'Hashable'.+-- Therefore we define+--+-- @+-- type IsTerminalSymbol a = Hashable a+-- @+--+-- on @hashable >=1.4.0.0@, while we define+--+-- @+-- type IsTerminalSymbol a = (Eq a, Hashable a)+-- @+--+-- on @hashable <1.4.0.0@.+--+-- Also, developers can temporarily add other classes (e.g. 'Show') to+-- ease debugging.+#if MIN_VERSION_hashable(1,4,0)+type IsTerminalSymbol a = Hashable a+#else+type IsTerminalSymbol a = (Eq a, Hashable a)+#endif+ -- ------------------------------------------------------------------- data Node s a@@ -171,19 +277,19 @@ Left rule -> Just rule Right _ -> Nothing -getPrev :: PrimMonad m => Node (PrimState m) a -> m (Node (PrimState m) a)+getPrev :: Node s a -> ST s (Node s a) getPrev node = readMutVar (nodePrev node) -getNext :: PrimMonad m => Node (PrimState m) a -> m (Node (PrimState m) a)+getNext :: Node s a -> ST s (Node s a) getNext node = readMutVar (nodeNext node) -setPrev :: PrimMonad m => Node (PrimState m) a -> Node (PrimState m) a -> m ()+setPrev :: Node s a -> Node s a -> ST s () setPrev node prev = writeMutVar (nodePrev node) prev -setNext :: PrimMonad m => Node (PrimState m) a -> Node (PrimState m) a -> m ()+setNext :: Node s a -> Node s a -> ST s () setNext node next = writeMutVar (nodeNext node) next -mkGuardNode :: PrimMonad m => RuleId -> m (Node (PrimState m) a)+mkGuardNode :: RuleId -> ST s (Node s a) mkGuardNode rid = do prevRef <- newMutVar undefined nextRef <- newMutVar undefined@@ -198,7 +304,7 @@ = Rule { ruleId :: {-# UNPACK #-} !RuleId , ruleGuardNode :: !(Node s a)- , ruleRefCounter :: {-# UNPACK #-} !(MutVar s Int)+ , ruleRefCounter :: {-# UNPACK #-} !(PrimVar s Int) } instance Eq (Rule s a) where@@ -207,45 +313,45 @@ instance Hashable (Rule s a) where hashWithSalt salt rule = hashWithSalt salt (ruleId rule) -getFirstNodeOfRule :: PrimMonad m => Rule (PrimState m) a -> m (Node (PrimState m) a)+getFirstNodeOfRule :: Rule s a -> ST s (Node s a) getFirstNodeOfRule rule = getNext (ruleGuardNode rule) -getLastNodeOfRule :: PrimMonad m => Rule (PrimState m) a -> m (Node (PrimState m) a)+getLastNodeOfRule :: Rule s a -> ST s (Node s a) getLastNodeOfRule rule = getPrev (ruleGuardNode rule) -mkRule :: PrimMonad m => RuleId -> m (Rule (PrimState m) a)+mkRule :: RuleId -> ST s (Rule s a) mkRule rid = do g <- mkGuardNode rid- refCounter <- newMutVar 0+ refCounter <- newPrimVar 0 return $ Rule rid g refCounter -newRule :: PrimMonad m => Builder (PrimState m) a -> m (Rule (PrimState m) a)+newRule :: Builder s a -> ST s (Rule s a) newRule s = do- rid <- readMutVar (sRuleIdCounter s)- modifyMutVar' (sRuleIdCounter s) (+ 1)+ rid <- readPrimVar (sRuleIdCounter s)+ modifyPrimVar (sRuleIdCounter s) (+ 1) rule <- mkRule rid- stToPrim $ H.insert (sRules s) rid rule+ H.insert (sRules s) rid rule return rule -- ------------------------------------------------------------------- --- | 'Builder' denotes a internal state of the /SEQUITUR/ algorithm.+-- | 'Builder' denotes an internal state of the /SEQUITUR/ algorithm. data Builder s a = Builder { sRoot :: !(Rule s a) , sDigrams :: !(H.HashTable s (Digram a) (Node s a)) , sRules :: !(H.HashTable s RuleId (Rule s a))- , sRuleIdCounter :: {-# UNPACK #-} !(MutVar s Int)+ , sRuleIdCounter :: {-# UNPACK #-} !(PrimVar s Int) , sDummyNode :: !(Node s a) } -- | Create a new 'Builder'. newBuilder :: PrimMonad m => m (Builder (PrimState m) a)-newBuilder = do+newBuilder = stToPrim $ do root <- mkRule 0- digrams <- stToPrim $ H.new- rules <- stToPrim $ H.new- counter <- newMutVar 1+ digrams <- H.new+ rules <- H.new+ counter <- newPrimVar 1 prevRef <- newMutVar undefined nextRef <- newMutVar undefined@@ -255,36 +361,38 @@ return $ Builder root digrams rules counter dummyNode -getRule :: (PrimMonad m, HasCallStack) => Builder (PrimState m) a -> RuleId -> m (Rule (PrimState m) a)-getRule s rid = stToPrim $ do+getRule :: HasCallStack => Builder s a -> RuleId -> ST s (Rule s a)+getRule s rid = do ret <- H.lookup (sRules s) rid case ret of Nothing -> error "getRule: invalid rule id" Just rule -> return rule -- | Add a new symbol to the end of grammar's start production,--- and perform normalization to keep the invariants of /SEQUITUR/ algorithm.-add :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> a -> m ()-add s a = do+-- and perform normalization to keep the invariants of the /SEQUITUR/ algorithm.+add :: (PrimMonad m, IsTerminalSymbol a) => Builder (PrimState m) a -> a -> m ()+add s a = stToPrim $ do lastNode <- getLastNodeOfRule (sRoot s) _ <- insertAfter s lastNode (Terminal a) _ <- check s lastNode- return ()+ when sanityCheck $ do+ checkDigramTable s+ checkRefCount s --- | Retrieve a grammar (as a persistent data structure) from 'Builder'\'s internal state.+-- | Retrieve a grammar (as a persistent data structure) from the 'Builder'\'s internal state. build :: (PrimMonad m) => Builder (PrimState m) a -> m (Grammar a)-build s = do+build s = stToPrim $ do root <- freezeGuardNode $ ruleGuardNode (sRoot s)- xs <- stToPrim $ H.toList (sRules s)+ xs <- H.toList (sRules s) m <- forM xs $ \(rid, rule) -> do ys <- freezeGuardNode (ruleGuardNode rule)- return $ (rid, ys)- return $ IntMap.insert 0 root $ IntMap.fromList m+ return (rid, ys)+ return $ Grammar $ IntMap.insert 0 root $ IntMap.fromList m -freezeGuardNode :: forall a m. (PrimMonad m) => Node (PrimState m) a -> m [Symbol a]+freezeGuardNode :: forall a s. Node s a -> ST s [Symbol a] freezeGuardNode g = f [] =<< getPrev g where- f :: [Symbol a] -> Node (PrimState m) a -> m [Symbol a]+ f :: [Symbol a] -> Node s a -> ST s [Symbol a] f ret node = do if isGuardNode node then return ret@@ -294,7 +402,7 @@ -- ------------------------------------------------------------------- -link :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> Node (PrimState m) a -> m ()+link :: IsTerminalSymbol a => Builder s a -> Node s a -> Node s a -> ST s () link s left right = do leftPrev <- getPrev left leftNext <- getNext left@@ -309,18 +417,18 @@ case (nodeSymbolMaybe rightPrev, nodeSymbolMaybe right, nodeSymbolMaybe rightNext) of (Just sym1, Just sym2, Just sym3) | sym1 == sym2 && sym2 == sym3 ->- stToPrim $ H.insert (sDigrams s) (sym2, sym3) right+ H.insert (sDigrams s) (sym2, sym3) right _ -> return () case (nodeSymbolMaybe leftPrev, nodeSymbolMaybe left, nodeSymbolMaybe leftNext) of (Just sym1, Just sym2, Just sym3) | sym1 == sym2 && sym2 == sym3 ->- stToPrim $ H.insert (sDigrams s) (sym1, sym2) leftPrev+ H.insert (sDigrams s) (sym1, sym2) leftPrev _ -> return () setNext left right setPrev right left -insertAfter :: (PrimMonad m, Eq a, Hashable a, HasCallStack) => Builder (PrimState m) a -> Node (PrimState m) a -> Symbol a -> m (Node (PrimState m) a)+insertAfter :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Symbol a -> ST s (Node s a) insertAfter s node sym = do prevRef <- newMutVar (sDummyNode s) nextRef <- newMutVar (sDummyNode s)@@ -334,22 +442,22 @@ Terminal _ -> return () NonTerminal rid -> do rule <- getRule s rid- modifyMutVar' (ruleRefCounter rule) (+ 1)+ modifyPrimVar (ruleRefCounter rule) (+ 1) return newNode -deleteDigram :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> m ()+deleteDigram :: IsTerminalSymbol a => Builder s a -> Node s a -> ST s () deleteDigram s n | isGuardNode n = return () | otherwise = do next <- getNext n unless (isGuardNode next) $ do- _ <- stToPrim $ H.mutate (sDigrams s) (nodeSymbol n, nodeSymbol next) $ \case+ _ <- H.mutate (sDigrams s) (nodeSymbol n, nodeSymbol next) $ \case Just n' | n /= n' -> (Just n', ()) _ -> (Nothing, ()) return () -check :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> m Bool+check :: IsTerminalSymbol a => Builder s a -> Node s a -> ST s Bool check s node | isGuardNode node = return False | otherwise = do@@ -357,7 +465,7 @@ if isGuardNode next then return False else do- ret <- stToPrim $ H.mutate (sDigrams s) (nodeSymbol node, nodeSymbol next) $ \case+ ret <- H.mutate (sDigrams s) (nodeSymbol node, nodeSymbol next) $ \case Nothing -> (Just node, Nothing) Just node' -> (Just node', Just node') case ret of@@ -370,7 +478,7 @@ match s node node' return True -match :: (PrimMonad m, Eq a, Hashable a, HasCallStack) => Builder (PrimState m) a -> Node (PrimState m) a -> Node (PrimState m) a -> m ()+match :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Node s a -> ST s () match s ss m = do mPrev <- getPrev m mNext <- getNext m@@ -389,7 +497,7 @@ node2 <- insertAfter s node1 (nodeSymbol ss2) substitute s m rule substitute s ss rule- stToPrim $ H.insert (sDigrams s) (nodeSymbol node1, nodeSymbol node2) node1+ H.insert (sDigrams s) (nodeSymbol node1, nodeSymbol node2) node1 return rule firstNode <- getFirstNodeOfRule rule@@ -397,7 +505,7 @@ Terminal _ -> return () NonTerminal rid -> do rule2 <- getRule s rid- freq <- readMutVar (ruleRefCounter rule2)+ freq <- readPrimVar (ruleRefCounter rule2) when (freq == 1) $ expand s firstNode rule2 when sanityCheck $ do@@ -408,11 +516,11 @@ Terminal _ -> return () NonTerminal rid -> do rule2 <- getRule s rid- freq <- readMutVar (ruleRefCounter rule2)+ freq <- readPrimVar (ruleRefCounter rule2) when (freq <= 1) $ error "Sequitur.match: non-first node with refCount <= 1" loop =<< getNext firstNode -deleteNode :: (PrimMonad m, Eq a, Hashable a, HasCallStack) => Builder (PrimState m) a -> Node (PrimState m) a -> m ()+deleteNode :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> ST s () deleteNode s node = do assert (not (isGuardNode node)) $ return () prev <- getPrev node@@ -423,9 +531,9 @@ Terminal _ -> return () NonTerminal rid -> do rule <- getRule s rid- modifyMutVar' (ruleRefCounter rule) (subtract 1)+ modifyPrimVar (ruleRefCounter rule) (subtract 1) -substitute :: (PrimMonad m, Eq a, Hashable a, HasCallStack) => Builder (PrimState m) a -> Node (PrimState m) a -> Rule (PrimState m) a -> m ()+substitute :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Rule s a -> ST s () substitute s node rule = do prev <- getPrev node deleteNode s =<< getNext prev@@ -437,7 +545,7 @@ _ <- check s next return () -expand :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> Rule (PrimState m) a -> m ()+expand :: IsTerminalSymbol a => Builder s a -> Node s a -> Rule s a -> ST s () expand s node rule = do left <- getPrev node right <- getNext node@@ -451,64 +559,158 @@ n <- getNext l let key = (nodeSymbol l, nodeSymbol n) when sanityCheck $ do- ret <- stToPrim $ H.lookup (sDigrams s) key- when (isJust ret) $ error ("Sequitur.expand: the digram is already in the table")- stToPrim $ H.insert (sDigrams s) key l- stToPrim $ H.delete (sRules s) (ruleId rule)+ ret <- H.lookup (sDigrams s) key+ when (isJust ret) $ error "Sequitur.expand: the digram is already in the table"+ H.insert (sDigrams s) key l+ H.delete (sRules s) (ruleId rule) -- ------------------------------------------------------------------- --- | Construct a grammer from a given sequence of symbols using /SEQUITUR/.-encode :: (Eq a, Hashable a) => [a] -> Grammar a+-- | Construct a grammar from a given sequence of symbols using /SEQUITUR/.+--+-- 'IsList.fromList' and 'fromString' can also be used.+encode :: IsTerminalSymbol a => [a] -> Grammar a encode xs = runST $ do e <- newBuilder mapM_ (add e) xs build e --- | Reconstruct a input sequence from a grammar.------ This is a left-inverse of 'encode'.------ This function is implemented as+-- | Reconstruct an input sequence from a grammar. ----- @--- decode = 'F.toList' . 'decodeToSeq'--- @+-- It is lazy in the sense that you can consume from the beginning+-- before constructing the entire sequence. This function is suitable+-- if you just need to access the resulting sequence only once and+-- from beginning to end. If you need to use the resulting sequence in+-- a more complex way, 'decodeToSeq' would be more suitable. ----- and provided just for convenience.--- For serious usage, use 'decodeToSeq' or 'decodeLazy'.+-- This is a left-inverse of 'encode', and is equivalent to 'F.toList'+-- of 'Foldable' class and 'IsList.toList' of 'IsList.IsList'. decode :: HasCallStack => Grammar a -> [a]-decode = F.toList . decodeToSeq+decode g = appEndo (decodeToMonoid (\a -> Endo (a :)) g) [] --- | A variant of 'decode' with possibly better performance.+-- | A variant of 'decode' in which the result type is 'Seq'. decodeToSeq :: HasCallStack => Grammar a -> Seq a decodeToSeq = decodeToMonoid Seq.singleton --- | A variant of 'decode' but you can consume from the beginning--- before constructing entire sequence.-decodeLazy :: HasCallStack => Grammar a -> [a]-decodeLazy g = appEndo (decodeToMonoid (\a -> Endo (a :)) g) []- -- | 'Monoid'-based folding over the decoded sequence. ----- This function is equivalent to the following definition, is more--- efficent due to the utilization of sharing.b+-- This function is equivalent to the following definition but is more+-- efficient due to the utilization of sharing. -- -- @ -- decodeToMonoid f = 'mconcat' . 'map' f . 'decode' -- @+--+-- This is equivalent to 'F.foldMap' of 'Foldable' class. decodeToMonoid :: (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m-decodeToMonoid e g = get 0 table+decodeToMonoid e g = get 0 (decodeNonTerminalsToMonoid e g)++-- | 'Monoid'-based folding over the decoded sequence of each non-terminal symbol.+--+-- For example, in the following grammar+--+-- @+-- g = Grammar (IntMap.fromList+-- [ (0, [NonTerminal 1, Terminal \'c\', NonTerminal 1])+-- , (1, [Terminal \'a\', Terminal \'b\'])+-- ])+-- @+--+-- non-terminal symbol @0@ and @1@ produces @"abcab"@ and @"ab"@ respectively.+-- Therefore, @'decodeNonTerminalsToMonoid' f@ yields+--+-- @+-- IntMap.fromList+-- [ (0, mconcat (map f "abcab"))+-- , (1, mconcat (map f "ab"))+-- ]+-- @+decodeNonTerminalsToMonoid :: (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> IntMap m+decodeNonTerminalsToMonoid e (Grammar m) = table where -- depends on the fact that fmap of IntMap is lazy- table = fmap (mconcat . map f) g+ table = fmap (mconcat . map f) m f (Terminal a) = e a f (NonTerminal r) = get r table - get r tbl =- case IntMap.lookup r tbl of- Nothing -> error ("rule " ++ show r ++ " is missing")- Just x -> x+get :: HasCallStack => RuleId -> IntMap x -> x+get r tbl =+ case IntMap.lookup r tbl of+ Nothing -> error ("rule " ++ show r ++ " is missing")+ Just x -> x++-- -------------------------------------------------------------------++checkDigramTable :: IsTerminalSymbol a => Builder s a -> ST s ()+checkDigramTable s = do+ checkDigramTable1 s+ checkDigramTable2 s++checkDigramTable1 :: IsTerminalSymbol a => Builder s a -> ST s ()+checkDigramTable1 s = do+ ds <- H.toList (sDigrams s)+ forM_ ds $ \((sym1, sym2), node1) -> do+ node2 <- getNext node1+ unless ((nodeData node1, nodeData node2) == (Right sym1, Right sym2)) $ do+ error "checkDigramTable1: an entry points to a different digram"+ let f n =+ case nodeData n of+ Right _ -> f =<< getPrev n+ Left rid -> do+ rule <- if rid == 0 then+ return (sRoot s)+ else do+ ret <- H.lookup (sRules s) rid+ case ret of+ Nothing -> error "checkDigramTable1: an entry points to a digram in an invalid rule"+ Just rule -> return rule+ unless (ruleGuardNode rule == n) $ do+ error "checkDigramTable1: an entry points to a digram in a inconsistent rule"+ f node1++checkDigramTable2 :: IsTerminalSymbol a => Builder s a -> ST s ()+checkDigramTable2 s = do+ rules <- H.toList (sRules s)+ forM_ (sRoot s : map snd rules) $ \rule -> do+ let f node1 = do+ node2 <- getNext node1+ unless (isGuardNode node2) $ do+ let sym1 = nodeSymbol node1+ sym2 = nodeSymbol node2+ normalCase = do+ ret <- H.lookup (sDigrams s) (sym1, sym2)+ case ret of+ Nothing -> error "checkDigramTable2: digram does not in the digram table"+ Just node | node1 /= node -> error "checkDigramTable2: digram entry points to a different node"+ Just _ -> return ()+ f node2+ if sym1 == sym2 then do+ node3 <- getNext node2+ case nodeData node3 of+ Right sym3 | sym1 == sym3 -> do+ ret <- H.lookup (sDigrams s) (sym1, sym2)+ case ret of+ Nothing -> error "checkDigramTable2: digram does not in the digram table"+ Just node | node1 /= node && node2 /= node -> error "checkDigramTable2: digram entry points to a different node"+ Just _ -> return ()+ f node3+ _ -> normalCase+ else do+ normalCase+ f =<< getFirstNodeOfRule rule++checkRefCount :: forall s a. Builder s a -> ST s ()+checkRefCount s = do+ Grammar m <- build s+ let occurences = IntMap.fromListWith (+) [(rid, 1) | body <- IntMap.elems m, NonTerminal rid <- body]+ f :: (RuleId, Rule s a) -> ST s ()+ f (_r, rule) = do+ actual <- readPrimVar (ruleRefCounter rule)+ let expected = IntMap.findWithDefault 0 (ruleId rule) occurences+ unless (actual == expected) $+ error ("rule " ++ show (ruleId rule) ++ " occurs " ++ show expected ++ " times,"+ ++ " but its reference counter is " ++ show actual)+ H.mapM_ f (sRules s) -- -------------------------------------------------------------------
test/Spec.hs view
@@ -1,6 +1,8 @@ import Control.Monad+import qualified Data.Foldable as F import qualified Data.Map.Strict as Map-import qualified Data.IntMap.Strict as IntMap+import Data.Monoid+import qualified Data.IntMap.Lazy as IntMap import qualified Data.IntSet as IntSet import Data.List (intercalate) import qualified Data.Set as Set@@ -12,7 +14,7 @@ main :: IO () main = hspec $ do describe "Sequitur.encode" $ do- let cases =+ let cases = map (\(name, m) -> (name, Grammar m)) [ ( "abab" , IntMap.fromList [(0, [NonTerminal 1, NonTerminal 1]), (1, [Terminal 'a', Terminal 'b'])] )@@ -50,17 +52,40 @@ s' = decode g in counterexample (reprGrammar g) $ counterexample s' $ s == s' + it "is lazy" $+ let g = Grammar $ IntMap.fromList [(0, [Terminal 'a', NonTerminal 1]), (1, undefined)]+ s = decode g+ in counterexample (reprGrammar g) $ head s `shouldBe` 'a'++ describe "Sequitur.decodeToSeq" $ do+ it "is equivalent to Sequitur.decode" $+ property $ forAll simpleString $ \s ->+ let g = encode s+ in counterexample (reprGrammar g) $ decode g === F.toList (decodeToSeq g)++ describe "Sequitur.decodeToMonoid" $ do+ it "can be used to compute length" $+ property $ forAll simpleString $ \s ->+ let g = encode s+ in counterexample (reprGrammar g) $ getSum (decodeToMonoid (\_ -> Sum 1) g) === length (decode g)++ describe "Sequitur.decodeNonTerminalsToMonoid" $ do+ it "is consistent with decode" $+ property $ forAll simpleString $ \s ->+ let g = encode s+ in counterexample (reprGrammar g) $ (decodeNonTerminalsToMonoid (\c -> [c]) g IntMap.! 0) === decode g+ simpleString :: Gen String simpleString = liftArbitrary (elements ['a'..'z']) reprGrammar :: Grammar Char -> String-reprGrammar grammar = "{" ++ intercalate ", " [show nt ++ " -> " ++ intercalate " " (map reprSymbol body) | (nt, body) <- IntMap.toAscList grammar] ++ "}"+reprGrammar (Grammar m) = "{" ++ intercalate ", " [show nt ++ " -> " ++ intercalate " " (map reprSymbol body) | (nt, body) <- IntMap.toAscList m] ++ "}" where reprSymbol (Terminal c) = [c] reprSymbol (NonTerminal x) = show x digramUniqueness :: Grammar Char -> Property-digramUniqueness g = conjoin+digramUniqueness (Grammar m) = conjoin [ counterexample (show ce) $ case Set.toList ps of [_] -> True@@ -71,14 +96,14 @@ where occurrences = Map.fromListWith Set.union [ (digram, Set.singleton (i,j))- | (i, body) <- IntMap.toList g, (j, digram) <- zip [(0::Int)..] (zip body (tail body))+ | (i, body) <- IntMap.toList m, (j, digram) <- zip [(0::Int)..] (zip body (drop 1 body)) ] ruleUtility :: Grammar Char -> Property-ruleUtility g = +ruleUtility (Grammar m) = conjoin [counterexample (show (r, n)) $ n >= 2 | (r, n) <- IntMap.toList occurrences] .&&.- IntMap.keysSet g === IntSet.insert 0 (IntMap.keysSet occurrences)+ IntMap.keysSet m === IntSet.insert 0 (IntMap.keysSet occurrences) where occurrences = IntMap.fromListWith (+)- [(r, (1::Int)) | body <- IntMap.elems g, NonTerminal r <- body]+ [(r, (1::Int)) | body <- IntMap.elems m, NonTerminal r <- body]