dawgdic (empty) → 0.1.0
raw patch · 31 files changed
+4206/−0 lines, 31 filesdep +basedep +binarydep +bitvec
Dependencies added: base, binary, bitvec, criterion, dawgdic, deepseq, hashable, hspec, primitive, text, vector, vector-binary, vector-hashtables
Files
- CHANGELOG.md +5/−0
- COPYING +10/−0
- LICENSE +30/−0
- README.md +275/−0
- bench/Main.hs +100/−0
- dawgdic.cabal +177/−0
- src-trace/Data/DAWG/Trace.hs +18/−0
- src/Data/DAWG/Completer.hs +96/−0
- src/Data/DAWG/DAWG.hs +58/−0
- src/Data/DAWG/Dictionary.hs +79/−0
- src/Data/DAWG/Guide.hs +55/−0
- src/Data/DAWG/Internal/BaseType.hs +57/−0
- src/Data/DAWG/Internal/BaseUnit.hs +78/−0
- src/Data/DAWG/Internal/Completer.hs +302/−0
- src/Data/DAWG/Internal/DAWG.hs +141/−0
- src/Data/DAWG/Internal/DAWGBuilder.hs +730/−0
- src/Data/DAWG/Internal/DAWGUnit.hs +131/−0
- src/Data/DAWG/Internal/Dictionary.hs +177/−0
- src/Data/DAWG/Internal/DictionaryBuilder.hs +759/−0
- src/Data/DAWG/Internal/DictionaryExtraUnit.hs +104/−0
- src/Data/DAWG/Internal/DictionaryUnit.hs +119/−0
- src/Data/DAWG/Internal/Guide.hs +77/−0
- src/Data/DAWG/Internal/GuideBuilder.hs +195/−0
- src/Data/DAWG/Internal/GuideUnit.hs +68/−0
- src/Data/DAWG/Internal/LinkTable.hs +62/−0
- src/Data/DAWG/Internal/Stack.hs +64/−0
- src/Data/Primitive/PrimArray/Combinators.hs +43/−0
- test/Data/DAWG/BuildSpec.hs +47/−0
- test/Data/DAWG/CompleterSpec.hs +81/−0
- test/Data/DAWG/DictionarySpec.hs +67/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for `dawgdic`++## 0.1.0 -- 2025-08-28++* First version. Released on an unsuspecting world.
+ COPYING view
@@ -0,0 +1,10 @@+Copyright (c) 2009-2012, Susumu Yata+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. +- Neither the name of the University of Tokushima nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2025, Andrey Prokopenko++Original work written in C++ belongs to Susumi Yata (c) 2009-2025.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,275 @@+# dawgdic++## Overview++**dawgdic** is a library for building and accessing +dictionaries implemented with directed acyclic word +graphs (DAWG).++This is a ported version of [C++ dawgdic library](https://github.com/s-yata/dawgdic).++## Features++This library offers `DAWG`, `Dictionary`, `Guide` and `Completer` data types as well as their builders. ++- `DAWG` represents word graph. It is provided as intermediate data structure.+- `Dictionary` represents compact layout for `DAWG`. It offers API to check the presence of the word and associated value in the graph. Also it could be stored into a file and loaded from file.+- `Guide` is being used as a tree-like index to get the faster navigation through the dictionary. Also could be stored into a file and loaded from file.++Input characters must be in range 0-255.++This port does not contain `RankedGuide` and `RankedCompleter` (yet).++### Comparison with other DAWG libraries++- dictionary file size, in bytes:++| package/lexicon size (words) | 2.6K | 26K | 370K |+| ------------------------------ | ------ | ------- | -------- |+| dawg: Data.DAWG.Dynamic | 370868 | 2823660 | 29933964 |+| dawg: Data.DAWG.Static | 133138 | 1030578 | 11128690 |+| dawg-ord: Data.DAWG.Int | N/A | N/A | N/A |+| dawg-ord: Data.DAWG.Ord | N/A | N/A | N/A |+| packed-dawg: Data.DAWG.Packed | 15619 | 128491 | 1481671 |+| dawgdic: Data.DAWG.Dictionary | 3088 | 141328 | 1603600 |+| dawgdic: Guide (w/ Dictionary) | 4640 | 212000 | 2405408 |++- features:++| feature | dawg | dawg-ord | packed-dawg | dawgdic |+| ---------------- | ------- | -------- | ------------ | ------- |+| build from list | + | + | + | + |+| persistence | + | - | + | + |+| insert | Dynamic | + | - | Builder |+| delete key | Dynamic | + | - | - |+| follow character | Static | ~edges | lookupPrefix | + |+| lookup value | + | + | - | + |+| member | ~lookup | ~lookup | + | + |+| keys | + | + | + | + |+| values | + | + | - | + |+| toList (assocs) | + | + | - | + |+| complete word | ~submap | - | ~toList | + |+| fuzzy search | - | - | - | - |+| max size | N/A | N/A | 2^22 nodes | N/A |+++## Installation++Add `dawgdic` dependency to your project and run `cabal build`.+++## Building and Querying++Building DAWG from lexicon of words and ignoring insertion failures is as simple as this:++```haskell+>>> import Data.DAWG.DAWG+>>> dawg <- fromAscList . lines =<< readFile "/path/to/lexicon"+```++Otherwise, consider mutable builder. It could also be useful if words are associated with values.++```haskell+buildOrError content = do+ dawgBuilder <- new+ forM_ content \(word, value) -> do+ result <- insert word (Just value) dawgBuilder+ unless result $ error "Insert failed"+ freeze dawgBuilder+```++Building dictionary and guide:++```+>>> import qualified Data.DAWG.Dictionary as D+>>> import qualified Data.DAWG.Guide as G+>>> dict <- D.build' dawg+>>> guide <- G.build' dawg dict+```++Saving dictionary and guide:++```+>>> D.write "dict.dawg" dict+>>> G.write "guide.dawg" guide+```++Loading dictionary and guide:++```+>>> dict <- D.load "dict.dawg"+>>> guide <- G.load "guide.dawg"+```++Consider using `Completer` for auto-complete-like queries or if you need to obtain lexicon back from `Dictionary` and `Guide`.++## Benchmarks++### Utilities++```+Benchmark default(μs)+------------------------------------- ------------+Utilities/10/Dawg.fromAscList 5549.76+Utilities/10/Dict.build' 26981.64+Utilities/10/Dict.contains 22.46+Utilities/10/Dict.lookup 22.68+Utilities/10/Dict.follow 22.42+Utilities/10/Guide.build' 76.81+Utilities/10/Completer.completeKeys 385.35+------------------------------------- ------------+Utilities/100/Dawg.fromAscList 66486.21+Utilities/100/Dict.build' 194881.38+Utilities/100/Dict.contains 326.16+Utilities/100/Dict.lookup 323.45+Utilities/100/Dict.follow 319.86+Utilities/100/Guide.build' 782.24+Utilities/100/Completer.completeKeys 7016.36+------------------------------------- ------------+Utilities/1000/Dawg.fromAscList 888061.61+Utilities/1000/Dict.build' 1659798.44+Utilities/1000/Dict.contains 3627.54+Utilities/1000/Dict.lookup 3638.10+Utilities/1000/Dict.follow 3564.64+Utilities/1000/Guide.build' 7992.73+Utilities/1000/Completer.completeKeys 82343.20+------------------------------------- ------------+```++### How to reproduce:++- Install `bench-show`:++```+cabal install bench-show --overwrite-policy=always+```++- Run and wait (it might take around `3m` to complete):++```+time cabal bench +RTS "-N4 -A64m -n4m -qb0" -RTS --benchmark-options="--output bench.html --csv results.csv"+```++- Generate report:++```+bench-show --presentation=Solo report results.csv+```++### Comparison++```+Benchmark default(μs)+------------------------------ -----------+10/dawgdic.follow 21.04+10/dawg.follow 85.41+10/dawg-ord.follow 110.42+10/packed-dawg.follow 147.30+100/dawgdic.follow 311.05+100/dawg.follow 1367.81+100/dawg-ord.follow 1774.78+100/packed-dawg.follow 2098.12+1000/dawgdic.follow 3273.02+1000/dawg.follow 18842.47+1000/dawg-ord.follow 21992.03+1000/packed-dawg.follow 28938.01+------------------------------ -----------+10/dawgdic.lookup value 21.74+10/dawg.lookup value 61.89+10/dawg-ord.lookup value 209.93+100/dawgdic.lookup value 290.13+100/dawg.lookup value 847.27+100/dawg-ord.lookup value 2973.35+1000/dawgdic.lookup value 3551.44+1000/dawg.lookup value 14217.29+1000/dawg-ord.lookup value 40111.28+10/dawgdic.member 21.02+------------------------------ -----------+10/dawg.member 56.43+10/dawg-ord.member 191.74+10/packed-dawg.member 173.97+100/dawgdic.member 343.32+100/dawg.member 873.70+100/dawg-ord.member 2863.96+100/packed-dawg.member 2200.33+1000/dawgdic.member 9288.22+1000/dawg.member 13878.72+1000/dawg-ord.member 31428.47+1000/packed-dawg.member 29089.83+------------------------------ -----------+10/dawgdic.keys 108.33+10/dawg.keys 100.23+10/dawg-ord.keys 160.51+10/packed-dawg.keys 50.50+100/dawgdic.keys 1392.78+100/dawg.keys 1413.00+100/dawg-ord.keys 2324.99+100/packed-dawg.keys 692.23+1000/dawgdic.keys 15628.83+1000/dawg.keys 16541.79+1000/dawg-ord.keys 27612.77+1000/packed-dawg.keys 7415.48+------------------------------ -----------+10/dawgdic.values 52.26+10/dawg.values 72.29+10/dawg-ord.values 134.79+100/dawgdic.values 616.02+100/dawg.values 1060.87+100/dawg-ord.values 1794.82+1000/dawgdic.values 6457.32+1000/dawg.values 11734.25+1000/dawg-ord.values 21532.54+------------------------------ -----------+10/dawgdic.toList 107.26+10/dawg.toList 116.89+10/dawg-ord.toList 202.35+100/dawgdic.toList 1367.87+100/dawg.toList 1608.26+100/dawg-ord.toList 2898.26+1000/dawgdic.toList 16334.34+1000/dawg.toList 18578.59+1000/dawg-ord.toList 36360.44+------------------------------ -----------+10/dawgdic.complete word 367.97+10/dawg.complete word 248.14+10/packed-dawg.complete word 303.69+100/dawgdic.complete word 6151.51+100/dawg.complete word 4494.85+100/packed-dawg.complete word 4913.83+1000/dawgdic.complete word 71152.49+1000/dawg.complete word 58222.76+1000/packed-dawg.complete word 60828.53+------------------------------ -----------+```++### How to reproduce:++- Install `bench-show`:++```+cabal install bench-show --overwrite-policy=always+```++- Run and wait (it might take around `7m` to complete):++```+time cabal bench +RTS "-N4 -A64m -n4m -qb0" -RTS --benchmark-options="--output bench.html --csv results.csv"+```++- Generate report:++```+bench-show --presentation=Solo report results.csv+```++## Contributing++In cases of issues please attach callstack, provide minimal dictionary lexicon and provide logs with enabled tracing.++```+cabal build -ftrace+```++## Acknowledgments++- [Susumu Yata](https://github.com/s-yata) as original author of C++ library.
+ bench/Main.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE BangPatterns #-}+module Main (main) where++import Control.Exception (evaluate)+import Criterion.Main (bench, bgroup, defaultMain, nf, nfIO)+import Data.List (sort)+import Data.Maybe (listToMaybe)++import qualified Data.DAWG.DAWG as Dawg+import qualified Data.DAWG.Dictionary as Dict+import qualified Data.DAWG.Guide as G+import qualified Data.DAWG.Completer as C++-- ** Dataset preparation++-- | Helper function to generate @lexicon.<N>.txt@. Use 'generateAll' instead. It will take a minute to generate input for benchmarks.+generateN :: FilePath -> Int -> IO ()+generateN fullLexiconPath n = do+ let outputLexiconFile = concat ["lexicon.", show n, ".txt"]+ alphabet = ['a' .. 'z']++ go _ws [] = return ()+ go ws (char : restAlphabet) = do+ let allCurrent = takeWhile ((== (Just char)) . listToMaybe) ws+ current = take n allCurrent+ restWords = drop (length allCurrent) ws+ appendFile outputLexiconFile $ unlines current+ go restWords restAlphabet++ writeFile outputLexiconFile "" -- refresh+ words' <- lines <$> readFile fullLexiconPath+ go (sort words') alphabet++-- | Helper function to generate @lexicon.<N>.v.txt@ from @lexicon.<N>.txt@. Use 'generateAllValues' instead. It will take a couple minutes to generate input for comparison benchmarks.+generateValue :: FilePath -> Int -> IO ()+generateValue lexiconPath n = do+ contents <- lines <$> readFile lexiconPath+ let size = length contents+ values = reverse [1 .. size]+ toLine (w, v) = concat [w, "\t", show v]+ lexiconValPath = (<> ".v.txt") . reverse . drop 4 . reverse $ lexiconPath+ writeFile lexiconValPath $ unlines (toLine <$> zip contents values)++-- | @fullLexiconPath@ should be the relative or absolute local path to the file @words_alpha.txt@+-- from <https://github.com/dwyl/english-words/tree/master>.+-- Consider downloading and unpacking @words_alpha.zip@.+generateAll fullLexiconPath = mapM_ (generateN fullLexiconPath) [10, 100, 1000]++-- ** Utilities++-- | Benchmark inputs were produced via 'generateAll' function.+--+-- Revision: @20f5cc9@.+readLexicon :: Int -> IO [String]+readLexicon n = do+ let !lexiconFile = concat ["data/lexicon.", show n, ".txt"]+ lines <$> readFile lexiconFile++dawgFromAscListBench lexicon = do+ !_dawg <- Dawg.fromAscList lexicon+ pure ()++dictContainsBench !dict lexicon =+ let go dict !w = Dict.contains w dict+ in go dict <$> lexicon++dictLookupBench !dict lexicon =+ let go dict !w = Dict.lookup w dict+ in go dict <$> lexicon++dictFollowBench !dict lexicon =+ let go dict !w = Dict.follow w Dict.root dict+ in go dict <$> lexicon++completerCompleteKeysBench !dict !guide lexicon =+ let go !w = C.completeKeys w dict guide+ in concatMap go lexicon++utilities n = do+ !lexiconN <- evaluate =<< readLexicon n+ !dawg <- evaluate =<< Dawg.fromAscList lexiconN+ !dict <- evaluate =<< Dict.build' dawg+ !guide <- evaluate =<< G.build' dawg dict+ return $ bgroup (show n)+ [ bench "Dawg.fromAscList" $ nfIO (dawgFromAscListBench lexiconN)+ , bench "Dict.build'" $ nfIO (Dict.build' dawg)+ , bench "Dict.contains" $ nf (dictContainsBench dict) lexiconN+ , bench "Dict.lookup" $ nf (dictLookupBench dict) lexiconN+ , bench "Dict.follow" $ nf (dictFollowBench dict) lexiconN+ , bench "Guide.build'" $ nfIO (G.build' dawg dict)+ , bench "Completer.completeKeys" $ nf (completerCompleteKeysBench dict guide) lexiconN+ ]++-- ** Main++main :: IO ()+main = do+ let inputs = [10, 100, 1000]+ utilitiesBench <- mapM utilities inputs+ defaultMain [ bgroup "Utilities" utilitiesBench ]
+ dawgdic.cabal view
@@ -0,0 +1,177 @@+cabal-version: 3.12+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'dawgdic' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: dawgdic++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0++-- A short (one-line) description of the package.+synopsis: Generation and traversal of compressed directed acyclic dawg graphs++-- A longer description of the package.+description: Generation and traversal of compressed directed acyclic dawg graphs++-- The license under which the package is released.+license: BSD-3-Clause++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Andrey Prokopenko++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: persiantiger@yandex.ru++-- A copyright notice.+-- copyright:+category: Data+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md+ COPYING+ README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++common warnings+ ghc-options: -Wall++flag trace+ description: Enable tracing+ manual: True+ default: False++library+ -- Import common warning flags.+ import: warnings++ default-extensions: BlockArguments+ , DeriveAnyClass+ , DerivingStrategies+ , ImplicitParams+ , LambdaCase+ , OverloadedStrings+ , RecordWildCards+ , StrictData++ -- Modules exported by the library.+ exposed-modules: Data.Primitive.PrimArray.Combinators+ Data.DAWG.Internal.BaseType+ Data.DAWG.Internal.BaseUnit+ Data.DAWG.Internal.Completer+ Data.DAWG.Internal.DAWG+ Data.DAWG.Internal.DAWGBuilder+ Data.DAWG.Internal.DAWGUnit+ Data.DAWG.Internal.Dictionary+ Data.DAWG.Internal.DictionaryBuilder+ Data.DAWG.Internal.DictionaryExtraUnit+ Data.DAWG.Internal.DictionaryUnit+ Data.DAWG.Internal.Guide+ Data.DAWG.Internal.GuideBuilder+ Data.DAWG.Internal.GuideUnit+ Data.DAWG.Internal.LinkTable+ Data.DAWG.Internal.Stack+ Data.DAWG.Completer+ Data.DAWG.DAWG+ Data.DAWG.Dictionary+ Data.DAWG.Guide++ if flag(trace)+ cpp-options: -Dtrace+ hs-source-dirs: src-trace+ exposed-modules: Data.DAWG.Trace++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends: base >= 4.17.2.1 && < 4.25.0.0+ , binary+ , bitvec+ , deepseq+ , hashable+ , primitive+ , vector+ , vector-binary+ , vector-hashtables++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: GHC2021++ ghc-options: -O2++benchmark dawgdic-bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ ghc-options: -O2 -rtsopts+ build-depends: base+ , criterion+ , dawgdic+ default-language: Haskell2010++test-suite spec+ -- Import common warning flags.+ import: warnings++ -- Base language which the package is written in.+ default-language: GHC2021++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: Spec.hs++ -- Test dependencies.+ build-depends:+ base >= 4.17.2.1 && < 4.25.0.0+ , dawgdic+ , hashable+ , hspec+ , text+ , vector++ -- https://github.com/haskell/cabal/issues/3708+ build-tool-depends:+ hspec-discover:hspec-discover >=2.5.5 && <2.9++ other-modules:+ Data.DAWG.BuildSpec+ Data.DAWG.CompleterSpec+ Data.DAWG.DictionarySpec
+ src-trace/Data/DAWG/Trace.hs view
@@ -0,0 +1,18 @@+module Data.DAWG.Trace where++import Control.Monad.Primitive (PrimMonad)+import System.IO.Unsafe+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.Vector.Hashtables as HT++traceIO :: PrimMonad m => String -> m ()+traceIO str = HT.unsafeIOToPrim . putStrLn $ str++traceWith :: forall a b m. PrimMonad m => (b -> IO ()) -> a -> m ()+traceWith action a = (HT.unsafeIOToPrim . action . unsafeCoerce) a++tracePure :: String -> a -> a+tracePure str a = unsafePerformIO do+ traceIO str+ pure $! a
+ src/Data/DAWG/Completer.hs view
@@ -0,0 +1,96 @@+{-|+Module: Data.DAWG.Completer+Description: Exports Completer API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Completer+ ( -- * Completer+ -- $usage+ Completer (..)+ , start+ , next+ , keyToString+ , value+ , completeKeys+ , keys+ , values+ , toList+ ) where++import Data.DAWG.Internal.Completer+++-- $usage+--+-- Consider following lexicon:+--+-- @+-- an+-- and+-- appear+-- apple+-- bin+-- can+-- cat+-- @+--+-- 1. Build DAWG.+--+-- >>> import qualified Data.DAWG.DAWG as Dawg+-- >>> contents <- lines <$> readFile "lexicon.txt"+-- >>> dawg <- Dawg.build' contents+--+-- 2. Build Dictionary.+--+-- >>> import qualified Data.DAWG.Dictionary as Dict+-- >>> dict <- Dict.build' dawg+--+-- 3. Build Guide.+--+-- >>> import qualified Data.DAWG.Guide as G+-- >>> guide <- G.build' dawg dict+--+-- From now on it is possible to perform completion requests via 'completeKeys'.+-- To get more control over completion, consider using 'Completer' directly.+--+-- Start completion for @"a"@. First, let's find the dictionary index to start with.+--+-- >>> let Just dictIndex = Dict.followPrefixLength "a" 1 Dict.root dict+--+-- Begin completing. Prepare 'Completer' to traverse the dictionary using guide.+--+-- >>> let c_started = start dictIndex "a" dict guide+--+-- Get next completion result+--+-- >>> let mc_next = next c_started+-- >>> :t mc_next+-- Maybe Completer+--+-- When it is 'Nothing' there is nothing to complete in this dictionary.+--+-- >>> let Just c_next = mc_next+--+-- The completion, i.e. the remainder for the requested prefix is stored in 'completerKey'.+-- To retrieve it from 'Completer' use 'keyToString':+--+-- >>> completeKey c_next+-- "n"+--+-- To get the next completion result, run 'next' once more.+--+-- >>> let Just c_next1 = next c_next+-- >>> completeKey c_next1+-- "nd"+--+-- Consider lexicon where each word has associated value with it.+-- To obtain the value for the current completion, use 'value'.+--+-- >>> value c_next1+-- 0+--+-- @0@ is equivalent to empty value or its absence.+--+--
+ src/Data/DAWG/DAWG.hs view
@@ -0,0 +1,58 @@+{-|+Module: Data.DAWG.DAWG+Description: Exports DAWG API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.DAWG+ ( -- * DAWG+ -- $doc+ DAWG(..)++ -- ** Building DAWG+ -- $usage++ , new+ , insert+ , insertWithLength+ , freeze+ , fromAscList+ -- ** Helpers+ , root+ , empty+ , child+ , sibling+ , value+ , isLeaf+ , label+ , isMerging+ , size+ ) where++import Data.DAWG.Internal.DAWGBuilder (new, insert, insertWithLength, freeze, fromAscList)+import Data.DAWG.Internal.DAWG++-- $doc+--+-- This module offers DAWG.++-- $usage+--+-- To build DAWG from sorted list of words, ignoring all words that could not be inserted due to cycles, e.g. "banana", use 'fromAscList':+--+-- >>> import Data.DAWG.DAWG+-- >>> dawg <- fromAscList . lines =<< readFile "/path/to/lexicon"+-- >>>+--+-- To get more control over inserting (i.e. inspecting insertion results), use following sequence:+--+-- >>> dawgBuilder <- new+-- >>>+-- >>> :{+-- forM_ content \(word, value) -> do+-- result <- insert word (Just value) dawgBuilder+-- unless result $ error "Insert failed"+-- >>> :}+-- >>> dawg <- freeze dawgBuilder+-- >>>
+ src/Data/DAWG/Dictionary.hs view
@@ -0,0 +1,79 @@+{-|+Module: Data.DAWG.Dictionary+Description: Exports Dictionary API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Dictionary+ ( -- * Dictionary+ -- $doc+ Dictionary(..)++ -- ** Building+ -- $usage++ , build+ , build'+ , freeze++ -- ** Basic operations++ , root+ , hasValue+ , value+ , contains+ , containsPrefixLength+ , member+ , lookup+ , lookupPrefixLength+ , followChar+ , follow+ , followPrefixLength++ -- ** Loading and saving++ , read+ , write+ ) where++import Data.DAWG.Internal.DictionaryBuilder (build, build', freeze)+import Data.DAWG.Internal.Dictionary+ ( Dictionary (..)+ , root+ , hasValue+ , value+ , contains+ , containsPrefixLength+ , member+ , lookup+ , lookupPrefixLength+ , followChar+ , follow+ , followPrefixLength+ , read+ , write+ )+import Prelude hiding (read, lookup)++-- $doc+--+-- This module offers Dictionary.++-- $usage+--+-- Dictionary could be built from 'Data.DAWG.DAWG.DAWG':+--+-- >>> dict <- build' dawg+--+-- If build failed, error will be raised.+-- Alternatively, use combination of 'build' and 'freeze'.+--+-- Once dictionary is ready it could be saved locally:+--+-- >>> write "myDictionary.dawg" dict+--+-- And later loaded back:+--+-- >>> dict <- read "myDictionary.dawg"+--
+ src/Data/DAWG/Guide.hs view
@@ -0,0 +1,55 @@+{-|+Module: Data.DAWG.Guide+Description: Exports Guide API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Guide+ ( -- * Guide+ -- $doc++ -- ** Building+ -- $usage++ Guide (..)+ , build+ , build'++ -- ** Basic operations++ , empty+ , child+ , sibling++ -- ** Loading and saving++ , read+ , write+ ) where++import Data.DAWG.Internal.GuideBuilder (build, build')+import Data.DAWG.Internal.Guide (Guide (..), empty, child, sibling, read, write)++import Prelude hiding (read)++-- $doc+--+-- This module offers Guide.++-- $usage+--+-- Guide could be built from 'Data.DAWG.DAWG.DAWG' and 'Data.DAWG.Dictionary.Dictionary':+--+-- >>> guide <- build' dawg dict+--+-- If build failed, error will be raised. Alternatively, use 'build'.+--+-- Once guide is ready it could be saved locally:+--+-- >>> write "myGuide.dawg" guide+--+-- And later loaded back:+--+-- >>> guide <- read "myGuide.dawg"+--
+ src/Data/DAWG/Internal/BaseType.hs view
@@ -0,0 +1,57 @@+{-|+Module: Data.DAWG.Internal.BaseType+Description: Exports base types used across the library.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.BaseType where++import Control.Monad.Primitive (PrimState)+import Data.Bits+import Data.Int+import Data.Word++import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Unboxed.Mutable as UVM+import qualified Data.Vector.Mutable as UM+import qualified Data.Vector.Hashtables as HT++-- ** Base Types++-- | unsigned char (8-bit).+type UCharType = Word8++-- | char (8-bit).+type CharType = Int8++-- | 32-bit unsigned integer.+type BaseType = Word32++-- | 32-bit mix function. <http://web.archive.org/19991104155419/www.concentric.net/~Ttwang/tech/inthash.htm>+hashBaseType :: BaseType -> Int+hashBaseType u =+ let !k0 = (complement u) + (u .<<. 15)+ !k1 = k0 .^. (k0 .>>. 12)+ !k2 = k1 + (k1 .<<. 2)+ !k3 = k2 .^. (k2 .>>. 4)+ !k4 = k3 * 2057 -- k4 = k3 + (k3 .<<. 3) + (k3 .<<. 11)+ !k5 = k4 .^. (k4 .>>. 16)+ in fromIntegral k5+{-# INLINE hashBaseType #-}++-- | 32-bit integer.+type ValueType = Int32++-- | 32 or 64-bit unsigned integer.+type SizeType = Word++-- | Alias for unboxed mutable vector.+type ObjectPool = UVM.MVector++-- | Alias for vector hashtable with unboxed keys and unboxed values.+type UUHT m k v = HT.Dictionary (PrimState m) UV.MVector k UV.MVector v++-- | Alias for vector hashtable with unboxed keys and unboxed nested 'UUHT' (with given keys and values) as values.+type UHHT m k v = HT.Dictionary (PrimState m) UV.MVector k UM.MVector (UUHT m k v)+
+ src/Data/DAWG/Internal/BaseUnit.hs view
@@ -0,0 +1,78 @@+{-|+Module: Data.DAWG.Internal.BaseUnit+Description: Exports base unit used in dawg.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.BaseUnit where++import Data.Binary+import Data.Bits+import Data.Hashable (Hashable (..))+import Data.Primitive.Types (Prim)+import Data.Vector.Unboxed.Mutable (Unbox)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV++-- ** Base Unit++-- | Base unit. Used as a base for DAWG and DAWG builder.+newtype BaseUnit = BaseUnit { base :: BaseType }+ deriving newtype (Eq, Prim, Read, Binary)++instance Show BaseUnit where+ show !b = concat+ [ "(", show $ base b+ , ",", show $ child b+ , ",", show $ hasSibling b+ , ",", show $ isState b+ , ",", show $ value b+ , ")"+ ]++newtype instance UV.MVector s BaseUnit = MV_BaseUnit (UV.MVector s BaseType)+newtype instance UV.Vector BaseUnit = V_BaseUnit (UV.Vector BaseType)++deriving newtype instance V.MVector UV.MVector BaseUnit+deriving newtype instance VG.Vector UV.Vector BaseUnit+deriving newtype instance Unbox BaseUnit++instance Hashable BaseUnit where+ -- 32-bit mix function+ -- http://www.concentric.net/~Ttwang/tech/inthash.htm+ hash (BaseUnit !u) = hashBaseType u+ {-# INLINE hash #-}++ hashWithSalt s u = hash s .^. hash u+ {-# INLINE hashWithSalt #-}++-- | Empty base unit. Equivalent to @0@.+empty :: BaseUnit+empty = BaseUnit 0+{-# INLINE empty #-}++-- | Gets a child unit or @0@.+child :: BaseUnit -> BaseType+child u = base u .>>. 2+{-# INLINE child #-}++-- | Checks whether base unit has a sibling or not.+hasSibling :: BaseUnit -> Bool+hasSibling u = (base u .&. 1) /= 0+{-# INLINE hasSibling #-}++-- | Gets a value associated with a base unit or @0@.+value :: BaseUnit -> ValueType+value u = fromIntegral $! base u .>>. 1+{-# INLINE value #-}++-- | Checks whether base unit is a state or not.+isState :: BaseUnit -> Bool+isState !u = (base u .&. 2) /= 0+{-# INLINE isState #-}
+ src/Data/DAWG/Internal/Completer.hs view
@@ -0,0 +1,302 @@+{-|+Module: Data.DAWG.Internal.Completer+Description: Exports completer as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE CPP #-}+module Data.DAWG.Internal.Completer where++import Control.Monad.ST (runST)+import Data.Char+import Data.Vector.Unboxed (Vector)+import GHC.Stack (HasCallStack)++import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.Dictionary (Dictionary (..))+import Data.DAWG.Internal.Guide (Guide (..))+import Data.DAWG.Internal.Stack++import qualified Data.Vector.Unboxed as Vector+import qualified Data.Vector.Unboxed.Mutable as VM++import qualified Data.DAWG.Internal.Dictionary as Dict+import qualified Data.DAWG.Internal.Guide as Guide++#ifdef trace+import System.IO.Unsafe+import Data.DAWG.Trace+#endif++-- ** Completer++-- | Use 'Completer' to perform completion requests by given word prefixes. It accumulates data during traversing dictionary via associated guide. Resulted completion could be accessed via 'keyToString' helper.+data Completer = Completer+ { completerDictionary :: !Dictionary+ , completerGuide :: !Guide+ , completerKey :: !(Vector UCharType)+ , completerIndexStack :: !Stack_+ , completerLastIndex :: !BaseType+ }++-- | Starts completion process for 'Completer' with a 'Dictionary' index and word prefix. For basic usage pass @0@ (dictionary 'Data.DAWG.Internal.Dictionary.root' index) as index.+-- For more complex scenarios different 'Dictionary' indexes could be used here too.+start :: HasCallStack => BaseType -> String -> Dictionary -> Guide -> Completer+start !ix !prefix !dict !guide =+#ifdef trace+ unsafePerformIO do+ traceIO $ concat [ "-completer:start ix ", show ix, " prefix ", prefix, " l ", show $ length prefix ]+ pure $!+#endif+ let !gsize = guideSize guide+ prefix' = Vector.map (fromIntegral @_ @UCharType . ord) $ Vector.fromList prefix++ !nc = Completer+ { completerDictionary = dict+ , completerGuide = guide+ , completerKey = runST do+ let l = Vector.length prefix'+ v <- Vector.unsafeThaw prefix'+ v' <- VM.grow v 1+ VM.unsafeWrite v' l 0+ Vector.unsafeFreeze v'+ , completerIndexStack = if gsize /= 0 then Elem ix EndOfStack else EndOfStack+ , completerLastIndex = 0+ }+ in nc+{-# INLINE start #-}++-- | Retrieves next completion.+-- If present, 'Completer' will be returned. 'Nothing', otherwise.+next :: HasCallStack => Completer -> Maybe Completer+next !c =+ let withNonEmptyStack comp action = case completerIndexStack comp of+ EndOfStack -> Nothing+ Elem !ix _rest -> action ix comp+ {-# INLINE withNonEmptyStack #-}+ + withNonRootLastIndex !ix !comp action =+ case completerLastIndex comp /= Dict.root of+ True -> action ix comp+ False -> findTerminal ix comp+ {-# INLINE withNonRootLastIndex #-}++ withChildLabel !ix comp =+#ifdef trace+ unsafePerformIO do+ let !childLabel = fromIntegral . Guide.child ix $! completerGuide comp+ putStrLn $ concat+ [ "next ix ", show ix, " lastIx ", show $ completerLastIndex comp+ , " childLabel ", show childLabel]+ pure $!+#else+ let !childLabel = fromIntegral . Guide.child ix $! completerGuide comp in+#endif+ if childLabel /= 0+ then followTerminal childLabel ix comp+ else go ix comp+ {-# INLINE withChildLabel #-}++ go :: HasCallStack => BaseType -> Completer -> Maybe Completer+ go !ix' !c' =+ let !siblingLabel = fromIntegral . Guide.sibling ix' $! completerGuide c'+ !ksize = Vector.length (completerKey c')+ !nkey = if ksize > 1+ then runST do+ v <- Vector.unsafeThaw . Vector.init . Vector.init $! completerKey c'+ v' <- VM.grow v 1+ VM.unsafeWrite v' (ksize - 2) 0+ Vector.unsafeFreeze v'+ else completerKey c'+ -- drop last element+ !nstack = case completerIndexStack c' of+ EndOfStack -> EndOfStack+ Elem !_ix !rest -> rest+ !nc = c' { completerKey = nkey, completerIndexStack = nstack }+ in case nstack of+ EndOfStack -> Nothing+ Elem !pix !_rest -> if siblingLabel /= 0+ then followTerminal siblingLabel pix nc+ else go pix nc++ followTerminal !label' !ix' !c' =+ case follow label' ix' c' of+ Nothing -> Nothing+ Just (!nextIx, !nextC) -> findTerminal nextIx nextC+ {-# INLINE followTerminal #-}++ nextByIx !ix comp =+#ifdef trace+ unsafePerformIO do+ traceIO $ concat+ [ "next ix ", show ix, " lastIx ", show $ completerLastIndex comp]+ pure $!+#endif+ withNonRootLastIndex ix comp withChildLabel+ {-# INLINE nextByIx #-}+ in withNonEmptyStack c nextByIx+{-# INLINE next #-}++-- | Retrieves a completion result from 'Completer' as 'String'.+keyToString :: HasCallStack => Completer -> String+keyToString = fmap (chr . fromIntegral) . safeInit . Vector.toList . completerKey+ where+ safeInit [] = []+ safeInit xs = init xs+ {-# INLINE safeInit #-}+{-# INLINE keyToString #-}+ +-- | Retrieves a value associated+-- with the last visited index by 'Completer' from the 'Dictionary'.+value :: HasCallStack => Completer -> ValueType+value c = Dict.value (completerLastIndex c) (completerDictionary c)+{-# INLINE value #-}++-- | Retrieve all completion results by given @prefix@+-- from 'Dictionary' via associated 'Guide'. Consider following lexicon:+--+-- @+-- a+-- an+-- and+-- appear+-- apple+-- bin+-- can+-- cat+-- @+--+-- Once dictionary and guide are ready, call 'completeKeys':+--+-- >>> completeKeys "a" dict guide+-- ["a", "an", "and", "appear", "apple"]+--+completeKeys :: String -> Dictionary -> Guide -> [String]+completeKeys prefix dict guide = + let !l = fromIntegral $ length prefix+ goDict acc !dictIx =+ case Dict.followPrefixLength prefix l dictIx dict of+ Nothing -> acc+ Just !nextDictIx ->+ let !nc = start nextDictIx "" dict guide+ !nacc = goNext acc nc+ in goDict nacc nextDictIx+ goNext acc !comp = case next comp of+ Nothing -> acc+ Just !nc ->+ let !nextWord = concat [prefix, keyToString nc]+ !nacc = nextWord : acc+ in goNext nacc nc+ in goDict [] Dict.root+{-# INLINE completeKeys #-}++-- | Apply completer to entire lexicon, starting with a function+-- that will handle dictionary traversal following the first character of the word.+completeLexicon+ :: forall a. (Char -> Completer -> a)+ -> Dictionary+ -> Guide+ -> [a]+completeLexicon completerSelector dict guide =+ let goDict dict' guide' !firstChar =+ let prefix = chr $ fromIntegral firstChar+ in case Dict.followChar firstChar 0 dict' of+ Nothing -> []+ Just !nextDictIx ->+ let !nc = start nextDictIx "" dict' guide'+ in goNext [] prefix nc++ goNext acc prefix comp = case next comp of+ Nothing -> acc+ Just !nc ->+ let !next' = completerSelector prefix nc+ !nacc = next' : acc+ in goNext nacc prefix nc++ -- FIXME: optimise it even further+ in concatMap (goDict dict guide) [(1 :: CharType) .. 127]+{-# INLINE completeLexicon #-}++-- | Traverses the entire DAWG, returns only words in no particular order.+keys :: Dictionary -> Guide -> [String]+keys dict guide =+ let selectWord prefix comp = prefix : keyToString comp+ in completeLexicon selectWord dict guide++-- | Traverses the entire DAWG, returns only values associated with words.+-- Considering the unboxed nature of dictionary units, if there is no value associated with+-- a word, it returns @0@.+values :: Dictionary -> Guide -> [ValueType]+values dict guide =+ let selectValue _prefix = value+ in completeLexicon selectValue dict guide++-- | Traverses the entire DAWG, returns list of pairs+-- where key is a word and value is 32-bit integer.+-- In absence of value, @0@ will be returned.+toList :: Dictionary -> Guide -> [(String, ValueType)]+toList dict guide =+ let selectPair prefix comp =+ let !k = prefix : keyToString comp+ !v = value comp+ in (k, v)+ in completeLexicon selectPair dict guide++-- ** Helpers++-- | Helper function that is being used in 'next'.+-- Follows a given char within the 'Dictionary'+-- and performs necessary transformations to 'Completer'.+follow :: HasCallStack => CharType -> BaseType -> Completer -> Maybe (BaseType, Completer)+follow !label !ix !c =+ case Dict.followChar label ix (completerDictionary c) of+ Nothing -> Nothing+ Just !nextIx ->+ let !ksize = Vector.length (completerKey c)+ !oldStack = completerIndexStack c+ !nkey = appendKeyLabel label ksize (completerKey c)+ !nc = c { completerKey = nkey, completerIndexStack = Elem nextIx oldStack }+ in Just (nextIx, nc)+{-# INLINE follow #-}++-- | Helper function to identify the terminal occurence.+-- Returns 'Completer' if there was an occurence. 'Nothing', otherwise.+findTerminal :: HasCallStack => BaseType -> Completer -> Maybe Completer+findTerminal !ix !c+ | Dict.hasValue ix (completerDictionary c) =+ let !nc = c { completerLastIndex = ix }+ in Just nc+ | otherwise =+ let !label = fromIntegral $! Guide.child ix $! completerGuide c+ in case Dict.followChar label ix (completerDictionary c) of+ Nothing -> Nothing+ Just !nextIx ->+ let !ksize = Vector.length (completerKey c)+ !oldStack = completerIndexStack c+ !nkey = appendKeyLabel label ksize (completerKey c)+ !nc = c { completerKey = nkey+ , completerIndexStack = Elem nextIx oldStack+ }+ in findTerminal nextIx nc++appendKeyLabel :: CharType -> Int -> Vector UCharType -> Vector UCharType+appendKeyLabel !label !ksize !key = runST do+ v <- Vector.unsafeThaw key+ let (!delta, !deltaIx) = if ksize >= 1 then (1, ksize - 1) else (2, ksize)+ v' <- VM.grow v delta+ VM.unsafeWrite v' deltaIx $ fromIntegral label+ VM.unsafeWrite v' (deltaIx + 1) 0+ Vector.unsafeFreeze v'+{-# INLINE appendKeyLabel #-}++-- | Dump completer state to stdout.+dump :: HasCallStack => String -> Completer -> IO ()+dump prefix Completer{..} = do+ let msg = unlines $ fmap ((prefix <> " ") <>)+ [ "ksize " <> (show $ Vector.length $ completerKey) <> " " <> show completerKey+ , concat+ ["issize ", (show $ size $ completerIndexStack), " ", show completerIndexStack]+ , "lastIx " <> show completerLastIndex+ ]+ putStrLn msg
+ src/Data/DAWG/Internal/DAWG.hs view
@@ -0,0 +1,141 @@+{-|+Module: Data.DAWG.Internal.DAWG+Description: Exports dawg as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.DAWG where++import Control.DeepSeq (NFData)+import Control.Monad (forM_)+import Data.Bit (Bit (..))+import Data.Char+import Data.Maybe (fromMaybe)+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)++import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.BaseUnit (BaseUnit (..))++import qualified Data.Vector.Unboxed as UV++import qualified Data.DAWG.Internal.BaseUnit as BU+++-- ** DAWG++-- | Represents directed acycclic word graph (DAWG), the core data type of this package.+-- Could be built from the input lexicon (list of words).+-- Mostly it is used to generate separate 'Data.DAWG.Internal.Dictionary.Dictionary'+-- (for querying words and searching associated values)+-- and 'Data.DAWG.Internal.Guide' (for faster completions).+--+data DAWG = DAWG+ { dawgBasePool :: BasePool -- ^ Pool of base units.+ , dawgLabelPool :: LabelPool -- ^ Pool of characters.+ , dawgFlagPool :: FlagPool -- ^ Pool of bits.+ , dawgNumOfStates :: SizeType -- ^ Number of states.+ , dawgNumOfMergedTransitions :: SizeType -- ^ Number of merged transitions.+ , dawgNumOfMergedStates :: SizeType -- ^ Number of merged states.+ , dawgNumOfMergingStates :: SizeType -- ^ Number of merging states.+ }+ deriving (Generic, NFData)+++-- | Wrapper around a vector of base units.+newtype BasePool = BasePool { unBasePool :: UV.Vector BaseUnit }+ deriving newtype NFData++-- | Wrapper around a vector of chars.+newtype LabelPool = LabelPool { unLabelPool :: UV.Vector UCharType }+ deriving newtype NFData++-- | Wrapper around 'BitPool'.+newtype FlagPool = FlagPool { unFlagPool :: BitPool }+ deriving newtype NFData++-- | Wrapper around a vector of bits.+newtype BitPool = BitPool { unBitPool :: UV.Vector Bit }+ deriving newtype NFData++-- | Root dawg index. Equivalent to @0@.+root :: BaseType+root = 0+{-# INLINE root #-}++-- | Constructs an empty dawg.+empty :: DAWG+empty = DAWG+ { dawgBasePool = BasePool UV.empty+ , dawgLabelPool = LabelPool UV.empty+ , dawgFlagPool = FlagPool (BitPool UV.empty)+ , dawgNumOfStates = 1+ , dawgNumOfMergedTransitions = 0+ , dawgNumOfMergedStates = 0+ , dawgNumOfMergingStates = 0+ }+{-# INLINE empty #-}++-- | Gets a child by given dawg index.+child :: HasCallStack => BaseType -> DAWG -> BaseType+child !ix = BU.child . (UV.! fromIntegral ix) . unBasePool . dawgBasePool+{-# INLINE child #-}++-- | Gets a sibling by given dawg index.+sibling :: HasCallStack => BaseType -> DAWG -> BaseType+sibling !ix !dawg =+ let hasSibling' = BU.hasSibling . (UV.! fromIntegral ix) . unBasePool . dawgBasePool+ itHasSibling = hasSibling' dawg+ in if itHasSibling then ix + 1 else root+{-# INLINE sibling #-}++-- | Gets a value by given dawg index.+value :: HasCallStack => BaseType -> DAWG -> ValueType+value !ix = BU.value . (UV.! fromIntegral ix) . unBasePool . dawgBasePool+{-# INLINE value #-}++-- | Checks whether the given dawg index is leaf or not.+isLeaf :: HasCallStack => BaseType -> DAWG -> Bool+isLeaf !ix = (== '\0') . chr . fromIntegral . label ix+{-# INLINE isLeaf #-}++-- | Gets a label by given dawg index.+label :: HasCallStack => BaseType -> DAWG -> UCharType+label !ix = (UV.! fromIntegral ix) . unLabelPool . dawgLabelPool+{-# INLINE label #-}++-- | Checks whether given dawg index is merging or not.+isMerging :: HasCallStack => BaseType -> DAWG -> Bool+isMerging !ix = unBit . (UV.! fromIntegral ix) . unBitPool . unFlagPool . dawgFlagPool+{-# INLINE isMerging #-}++-- | Gets a size of a dawg.+size :: DAWG -> SizeType+size = fromIntegral . UV.length . unBasePool . dawgBasePool+{-# INLINE size #-}++-- ** Helpers++-- | Dump dawg state to stdout.+dump :: DAWG -> IO ()+dump DAWG{..} = do+ putStrLn "base_pool"+ let BasePool bpool = dawgBasePool+ LabelPool lpool = dawgLabelPool+ !bs = UV.length bpool+ !ls = UV.length lpool+ !ms = max bs ls++ putStrLn $ concat [ "b(" <> show bs <> ")\tl(" <> show ls <> ")" ]+ + forM_ [0 .. ms - 1] \ix -> do+ let !b = fromMaybe (BaseUnit 0) (bpool UV.!? ix)+ !l = fromMaybe 0 (lpool UV.!? ix)+ putStrLn $ concat+ [ show b, "\t", show (chr $ fromIntegral l), " (", show l, ")" ]++ putStrLn $ "num_of_states : " <> show dawgNumOfStates+ putStrLn $ "num_of_merged_transitions : " <> show dawgNumOfMergedTransitions+ putStrLn $ "num_of_merged_states : " <> show dawgNumOfMergedStates+ putStrLn $ "num_of_merging_states : " <> show dawgNumOfMergingStates
+ src/Data/DAWG/Internal/DAWGBuilder.hs view
@@ -0,0 +1,730 @@+{-|+Module: Data.DAWG.Internal.DAWGBuilder+Description: Exports dawg builder as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE CPP #-}+module Data.DAWG.Internal.DAWGBuilder where++import Control.Monad (forM_, when, unless)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Bit (Bit (..))+import Data.Bits+import Data.Char+import Data.Maybe (fromMaybe)+import Data.Primitive.MutVar+import Data.Vector (Vector)+import GHC.Stack (HasCallStack)+import Prelude hiding (init)++import Data.Primitive.PrimArray.Combinators+import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.BaseUnit (BaseUnit (..), base, hasSibling, isState)+import Data.DAWG.Internal.DAWG+ (DAWG (..), BasePool (..), BitPool (..), FlagPool (..), LabelPool (..))+import Data.DAWG.Internal.DAWGUnit (DAWGUnit (..))+import Data.DAWG.Internal.Stack++import qualified Data.DAWG.Internal.BaseUnit as BaseUnit+import qualified Data.DAWG.Internal.DAWGUnit as DawgUnit++import qualified Data.Primitive.PrimArray.Utils as A+import qualified Data.Vector as Vector+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V++#ifdef trace+import Data.DAWG.Trace+#endif++-- ** DAWG Builder++-- | A mutable builder of 'Data.DAWG.Internal.DAWG.DAWG'.+newtype DAWGBuilder m = DBRef { getDBRef :: MutVar (PrimState m) (DAWGBuilder_ m) }++-- | Builder of DAWG. Do not access directly. Use 'DAWGBuilder' instead.+data DAWGBuilder_ m = DAWGBuilder+ { dawgBuilderBasePool :: ObjectPool (PrimState m) BaseUnit -- ^ Pool of base units.+ , dawgBuilderLabelPool :: ObjectPool (PrimState m) UCharType -- ^ Pool of labels.+ , dawgBuilderFlagPool :: ObjectPool (PrimState m) Bit -- ^ Pool of bit flags to store merges.+ , dawgBuilderUnitPool :: ObjectPool (PrimState m) DAWGUnit -- ^ Pool of dawg units.+ , dawgBuilderHashTable :: ObjectPool (PrimState m) BaseType -- ^ Supportive pool of hashes.+ , dawgBuilderUnfixedUnits :: Stack (PrimState m) -- ^ Supportive stack to keep track of for unfixed units.+ , dawgBuilderUnusedUnits :: Stack (PrimState m) -- ^ Supportive stack to keep track of unused units+ , dawgBuilderRefs :: !(IntArray (PrimState m)) -- ^ Array which holds a few numbers: 'numOfStates', 'numOfMergedTransitions', 'numOfMergingStates'.+ }++numOfStates, numOfMergedTransitions, numOfMergingStates :: Int++-- | Use it as index for 'dawgBuilderRefs' to get number of states.+numOfStates = 0+{-# INLINE numOfStates #-}++-- | Use it as index for 'dawgBuilderRefs' to get number of merged transitions.+numOfMergedTransitions = 1+{-# INLINE numOfMergedTransitions #-}++-- | Use it as index for 'dawgBuilderRefs' to get number of merging states.+numOfMergingStates = 2+{-# INLINE numOfMergingStates #-}++-- | Creates a new empty 'DAWGBuilder'. +new :: PrimMonad m => m (DAWGBuilder m)+new = do+ dawgBuilderHashTable <- V.new 0+ dawgBuilderBasePool <- V.new 0 + dawgBuilderLabelPool <- V.new 0+ dawgBuilderFlagPool <- V.new 0+ dawgBuilderUnitPool <- V.new 0+ dawgBuilderUnfixedUnits <- StackRef <$> newMutVar EndOfStack+ dawgBuilderUnusedUnits <- StackRef <$> newMutVar EndOfStack+ dawgBuilderRefs <- A.replicate 3 0+ dawgBuilderRefs <~ numOfStates $ 1+ let db = DAWGBuilder{..}+ getDBRef <- newMutVar db+ pure DBRef {..} +{-# INLINE new #-}++-- | Initializes empty 'DAWGBuilder' with the root index and the beginning of the word.+init+ :: PrimMonad m+ => DAWGBuilder m -> m ()+init dbref = do+ do+ let initHtSize = 1 .<<. 8+ resize dbref initHtSize++ !_ <- allocateUnit dbref+ !_ <- allocateTransition dbref+ db <- readMutVar (getDBRef dbref)+ dawgBuilderUnitPool db <~~ 0 $ DawgUnit.setLabel DawgUnit.empty 0xFF+ push 0 (dawgBuilderUnfixedUnits db)+{-# INLINE init #-}++-- | Inserts a word with optional value associated to it into 'DAWGBuilder'.+-- Pass 'Nothing' as value if there is no value associated with the word.+-- Returns 'False' if word was not inserted.+insert+ :: HasCallStack+ => PrimMonad m+ => Vector Char+ -> Maybe ValueType+ -> DAWGBuilder m+ -> m Bool+insert ks mValue db = do+ let v = fromMaybe 0 mValue+ if not (Vector.null ks || ks == Vector.singleton '\0' || v < 0)+ then do+ let ks' = Vector.takeWhile (/= '\0') ks+ l = Vector.length ks'+ insertKey ks' l v db+ else pure False+{-# INLINE insert #-}++-- | Like 'insertKey' but it also performs input validation.+-- Returns 'False' if word was not inserted.+insertWithLength+ :: HasCallStack+ => PrimMonad m+ => Vector Char+ -> Int+ -> ValueType+ -> DAWGBuilder m+ -> m Bool+insertWithLength ks l v db =+ if not (Vector.null ks || ks == Vector.singleton '\0' || v < 0)+ then if (Vector.notElem '\0' ks)+ then insertKey ks l v db+ else pure False+ else pure False+{-# INLINE insertWithLength #-}++-- | Inserts a word (@key@) with its @length@ and associated @value@ into 'DAWGBuilder'.+-- Pass @0@ if there is no value associated with the word.+-- Returns 'False' if word was not inserted.+insertKey+ :: HasCallStack+ => PrimMonad m+ => Vector Char -- ^ Entire word as vector of keys.+ -> Int -- ^ Prefix length.+ -> ValueType -- ^ Value.+ -> DAWGBuilder m+ -> m Bool+insertKey ks l v dbref@DBRef{..} = do+ do+ db <- readMutVar getDBRef+ let !htsize = V.length $ dawgBuilderHashTable db+ when (htsize == 0) $ init dbref++ -- Find separate unit+ let findSeparateUnit (!ix, !keyPos)+ | keyPos > fromIntegral l = pure $ Just (ix, keyPos)+ | otherwise = do+ db <- readMutVar getDBRef+ !u0 <- dawgBuilderUnitPool db !~ ix+ let !childIx = DawgUnit.child u0+ if childIx == 0+ then pure $ Just (ix, keyPos)+ else do+ let !keyLabel = if keyPos < fromIntegral l then ks Vector.! keyPos else '\0'+ !u' <- dawgBuilderUnitPool db !~ childIx+ let !unitLabel = DawgUnit.label u'+#ifdef trace+ traceIO $ concat+ [ "findSeparateUnit ix ", show ix+ , " keyPos ", show keyPos+ , " keyLabel ", show keyLabel+ , " (", show $ ord keyLabel+ , ") unitLabel ",show $ chr $ fromIntegral unitLabel+ , " (", show unitLabel, ")"+ ]+#endif+ if ord keyLabel < fromIntegral unitLabel+ then pure Nothing+ else if ord keyLabel > fromIntegral unitLabel+ then do+ dawgBuilderUnitPool db <~~ childIx $ DawgUnit.setHasSibling u' True+ fixUnits childIx dbref+ pure $ Just (ix, keyPos)+ else findSeparateUnit (childIx, succ keyPos)++ addNewUnit (!ix, !keyPos)+ | keyPos > fromIntegral l = pure (ix, keyPos)+ | otherwise = do+ let keyLabel = if keyPos < fromIntegral l then ks Vector.! keyPos else '\0'+ childIx <- allocateUnit dbref+ ndb <- readMutVar getDBRef+ !u <- dawgBuilderUnitPool ndb !~ ix+ let setState !u' = if DawgUnit.child u == 0+ then DawgUnit.setIsState u' True+ else u'+ !nu = setState+ $! flip DawgUnit.setSibling (DawgUnit.child u)+ $! flip DawgUnit.setLabel (fromIntegral $! ord keyLabel)+ $! DawgUnit.empty++ dawgBuilderUnitPool ndb <~~ childIx $ nu+ dawgBuilderUnitPool ndb <~~ ix $ DawgUnit.setChild u childIx+ push childIx (dawgBuilderUnfixedUnits ndb)++ addNewUnit (childIx, succ keyPos)+ + findSeparateUnit (0, 0) >>= \case+ Nothing -> pure False+ Just (!ix, !keyPos) -> do+ (!lastIx, _) <- addNewUnit (ix, keyPos)+ ndb <- readMutVar getDBRef+ lu <- dawgBuilderUnitPool ndb !~ lastIx+ dawgBuilderUnitPool ndb <~~ lastIx $ DawgUnit.setChild lu (fromIntegral v)++#ifdef trace+ do+ traceWith dump dbref+#endif+ pure True++-- | Generates 'Data.DAWG.Internal.DAWG.DAWG' out of 'DAWGBuilder'.+-- Once this function is called, 'DAWGBuilder' must not be used anymore.+freeze+ :: HasCallStack+ => PrimMonad m => DAWGBuilder m -> m DAWG+freeze dbref@DBRef{..} = do+ do+ db0 <- readMutVar getDBRef+ let !htsize = V.length $ dawgBuilderHashTable db0+ when (htsize == 0) $ init dbref+#ifdef trace+ traceIO "freeze"+#endif+ fixUnits 0 dbref++ db <- readMutVar getDBRef+ unit0 <- dawgBuilderUnitPool db !~ 0+#ifdef trace+ traceIO $ "freeze: u0 " <> show unit0+#endif+ dawgBuilderBasePool db <~~ 0 $ BaseUnit $ DawgUnit.base unit0+ dawgBuilderLabelPool db <~~ 0 $ DawgUnit.label unit0++#ifdef trace+ b0 <- dawgBuilderBasePool db !~ 0+ traceIO $ "freeze: b0 " <> show b0+#endif++ fbasePool <- VG.unsafeFreeze $ dawgBuilderBasePool db+ flabelPool <- VG.unsafeFreeze $ dawgBuilderLabelPool db+ fflagPool <- VG.unsafeFreeze $ dawgBuilderFlagPool db+ fnumOfStates <- dawgBuilderRefs db ! numOfStates+ fnumOfMergedTransitions <- dawgBuilderRefs db ! numOfMergedTransitions+ fnumOfMergingStates <- dawgBuilderRefs db ! numOfMergingStates+ + let numOfTransitions = VG.length fbasePool - 1+ numOfMergedStates = numOfTransitions + fnumOfMergedTransitions + 1 - fnumOfStates++ pure DAWG+ { dawgBasePool = BasePool fbasePool+ , dawgLabelPool = LabelPool flabelPool+ , dawgFlagPool = FlagPool $ BitPool fflagPool+ , dawgNumOfStates = fromIntegral fnumOfStates+ , dawgNumOfMergedTransitions = fromIntegral fnumOfMergedTransitions+ , dawgNumOfMergedStates = fromIntegral numOfMergedStates+ , dawgNumOfMergingStates = fromIntegral fnumOfMergingStates+ }+{-# INLINE freeze #-}++-- | Builds entire 'Data.DAWG.Internal.DAWG.DAWG' from a lexicon. Lexicon *must be* sorted.+fromAscList :: HasCallStack => PrimMonad m => [String] -> m DAWG+fromAscList lexicon = do+ db <- new+ forM_ lexicon \w -> do+ insert (Vector.fromList w) Nothing db+ freeze db+{-# INLINE fromAscList #-}++-- ** Helpers++-- | Gets a unit from an object pool.+allocateUnit+ :: HasCallStack+ => PrimMonad m+ => DAWGBuilder m -> m BaseType+allocateUnit DBRef{..} = do+ !db <- readMutVar getDBRef+ (!index, !ndb) <- readMutVar (getStackRef $ dawgBuilderUnusedUnits db) >>= \case+ -- no unused units left+ EndOfStack -> do+ newUnitPool <- V.grow (dawgBuilderUnitPool db) 1+ let !index = pred $ V.length newUnitPool+ !nextDb = db { dawgBuilderUnitPool = newUnitPool }+ dawgBuilderUnitPool nextDb <~~ fromIntegral index $ DawgUnit.empty+ pure (fromIntegral index, nextDb)+ Elem !index !stack -> do+ writeMutVar (getStackRef $ dawgBuilderUnusedUnits db) stack+ pure (index, db)+ writeMutVar getDBRef ndb+ pure index++-- | Adds free unit index to the stack of unused units.+freeUnit :: HasCallStack => PrimMonad m => DAWGBuilder_ m -> BaseType -> m ()+freeUnit db !ix = do+ prevStack <- readMutVar (getStackRef $ dawgBuilderUnusedUnits db)+ let !stack = Elem ix prevStack+ writeMutVar (getStackRef $ dawgBuilderUnusedUnits db) stack+{-# INLINE freeUnit #-}++-- | Gets a transition from object pools.+allocateTransition+ :: HasCallStack+ => PrimMonad m => DAWGBuilder m -> m BaseType+allocateTransition DBRef{..} = do+ db <- readMutVar getDBRef+ newFlagPool <- V.grow (dawgBuilderFlagPool db) 1+ newFlagPool <~~ fromIntegral (V.length newFlagPool - 1) $ 0++ newBasePool <- V.grow (dawgBuilderBasePool db) 1+ newBasePool <~~ fromIntegral (V.length newBasePool - 1) $ BaseUnit.empty++ newLabelPool <- V.grow (dawgBuilderLabelPool db) 1+ newLabelPool <~~ fromIntegral (V.length newLabelPool - 1) $ 0++ let !lastIx = V.length newLabelPool - 1+ !ndb = db+ { dawgBuilderFlagPool = newFlagPool+ , dawgBuilderBasePool = newBasePool+ , dawgBuilderLabelPool = newLabelPool+ }+ writeMutVar getDBRef ndb+ pure (fromIntegral lastIx)++-- | Recursively fix units starting from a given index.+fixUnits+ :: HasCallStack+ => PrimMonad m+ => BaseType -> DAWGBuilder m -> m ()+fixUnits !index dbref@DBRef{..} = do+ let countSiblings !acc 0 = pure acc+ countSiblings !(acc :: Int) !ix = do+ db <- readMutVar getDBRef+ unit' <- dawgBuilderUnitPool db !~ ix+ countSiblings (succ acc) (DawgUnit.sibling unit')++ -- this operation potentially mutates dawg builder:+ -- re-read its content after its usage+ getTransitionIndex !siblings !ix !tix = if ix < siblings+ then do+ !nextTix <- allocateTransition dbref+ getTransitionIndex siblings (succ ix) nextTix+ else pure tix++ goBaseLabel (0 :: BaseType) !tix = pure tix+ goBaseLabel !ix !tix = do+ db <- readMutVar getDBRef+ !unit' <- dawgBuilderUnitPool db !~ ix+ let !nextIx = DawgUnit.sibling unit'++ dawgBuilderBasePool db <~~ tix $ (BaseUnit $ DawgUnit.base unit')+ dawgBuilderLabelPool db <~~ tix $ DawgUnit.label unit'+ goBaseLabel nextIx (pred tix)++ deleteFixedUnits !_ 0 = pure ()+ deleteFixedUnits !db !current = do+ !unit' <- dawgBuilderUnitPool db !~ current+ let !next = DawgUnit.sibling unit'+#ifdef trace+ traceIO $ concat+ [ "-deleteFixedUnit cur ", show current+ , " next ", show next]+#endif+ freeUnit db current+ deleteFixedUnits db next++ goStack = do+ db <- readMutVar getDBRef+ top (dawgBuilderUnfixedUnits db) >>= \case+ Nothing -> pure ()+ Just !unfixedIx -> do+ unless (unfixedIx == index) do+#ifdef trace+ traceIO ("goStack ix " <> show index <> " uix " <> show unfixedIx)+ traceWith dump dbref+#endif+ pop (dawgBuilderUnfixedUnits db)++ numOfStates' <- dawgBuilderRefs db ! numOfStates+ let !htsize = V.length $ dawgBuilderHashTable db+ when (numOfStates' >= htsize - (htsize .>>. 2)) do+ expandHashTable dbref++ numOfSiblings <- countSiblings 0 unfixedIx+ (hashId, matchedIx) <- findUnit unfixedIx dbref+#ifdef trace+ traceIO $ concat+ [ "goStack unfixedIx ", show unfixedIx+ , " hashId ", show hashId+ , " matchedIx ", show matchedIx+ ]+#endif++ nextMatchedIx <- if matchedIx /= 0+ then do+ prevNumOfMergedTransitions <- dawgBuilderRefs db ! numOfMergedTransitions+ let !nextNumOfMergedTransitions = prevNumOfMergedTransitions + numOfSiblings+ dawgBuilderRefs db <~ numOfMergedTransitions $ nextNumOfMergedTransitions+ flag' <- dawgBuilderFlagPool db !~ matchedIx++ -- Records a merging state.+ when (flag' == 0) do+ prevMergingStates <- dawgBuilderRefs db ! numOfMergingStates + dawgBuilderRefs db <~ numOfMergingStates $ prevMergingStates + 1+ dawgBuilderFlagPool db <~~ matchedIx $ 1+ pure matchedIx+ else do+ !startTransitionIndex <- getTransitionIndex numOfSiblings 0 0+#ifdef trace+ traceIO $ concat+ [ "goStack matchedIx 0 nos ", show numOfSiblings+ , " start tix ", show startTransitionIndex ]+#endif+ -- re-read from mutable variable+ ndb <- readMutVar getDBRef+ !transitionIndex <- goBaseLabel unfixedIx startTransitionIndex+#ifdef trace+ traceIO $ concat+ [ "goStack matchedIx 0 nos ", show numOfSiblings+ , " end tix ", show transitionIndex ]+#endif+ let newMatchedIx = succ transitionIndex+ dawgBuilderHashTable ndb <~~ hashId $ newMatchedIx+ prevStates <- dawgBuilderRefs ndb ! numOfStates+ dawgBuilderRefs ndb <~ numOfStates $ prevStates + 1+ pure newMatchedIx++ -- Delete fixed units+ ndb <- readMutVar getDBRef+ deleteFixedUnits ndb unfixedIx++ top (dawgBuilderUnfixedUnits ndb) >>= \case+ Nothing -> pure ()+ Just !nextUnfixedIx -> do+#ifdef trace+ traceIO $ concat+ [ "goStack setChild unfixedIx ", show nextUnfixedIx+ , " matchedIx ", show nextMatchedIx+ ]+#endif++ dawgBuilderUnitPool ndb !<~~ nextUnfixedIx+ $! flip DawgUnit.setChild nextMatchedIx++ writeMutVar getDBRef ndb+ goStack++#ifdef trace+ traceIO ("fixUnits ix " <> show index)+#endif+ goStack+ readMutVar getDBRef >>= \ldb -> do+ pop (dawgBuilderUnfixedUnits ldb)+ writeMutVar getDBRef ldb++-- | Expands supportive hash table by doubling its size.+expandHashTable+ :: PrimMonad m+ => DAWGBuilder m -> m ()+expandHashTable dbref@DBRef{..} = do+ do+ db0 <- readMutVar getDBRef+ let !htsize = V.length $ dawgBuilderHashTable db0+ !newSize = htsize .<<. 1++ newHt <- V.replicate newSize 0+ let !db1 = db0 { dawgBuilderHashTable = newHt }+ writeMutVar getDBRef db1++ db <- readMutVar getDBRef+ let go !ix !base'+ | ix == 0 = pure ()+ | otherwise = do+ label' <- dawgBuilderLabelPool db !~ fromIntegral ix+ when (label' == 0 || isState base') do+ let !bix = fromIntegral ix+ !hashId <- findTransition bix dbref+ dawgBuilderHashTable db <~~ fromIntegral hashId $ fromIntegral ix++ V.iforM_ (dawgBuilderBasePool db) go+#ifdef trace+ traceIO $ "expandHashTable done"+#endif+{-# INLINE expandHashTable #-}++-- | Finds suitable transition index.+findTransition+ :: PrimMonad m+ => BaseType -> DAWGBuilder m -> m BaseType+findTransition !index dbref@DBRef{..} = do+ db <- readMutVar getDBRef+ let !htsize = V.length $ dawgBuilderHashTable db+ !unit' <- hashTransition index dbref+ let !startHashId = unit' `mod` fromIntegral htsize++ go !hid = do+ transitionId <- dawgBuilderHashTable db !~ hid+#ifdef trace+ traceIO $ concat ["-findTransition ix ", show index, " hid ", show hid, " tid ", show transitionId]+#endif+ if transitionId == 0+ then pure hid+ else do+ let !htsize' = V.length $ dawgBuilderHashTable db+ go (succ hid `mod` fromIntegral htsize')++ go startHashId+{-# INLINE findTransition #-}++-- | Finds suitable hash id as well as transition index for the given unit.+findUnit+ :: PrimMonad m+ => BaseType -> DAWGBuilder m -> m (BaseType, BaseType)+findUnit !unitIndex dbref@DBRef{..} = do+ db <- readMutVar getDBRef+ let !htsize0 = V.length $ dawgBuilderHashTable db+ !unit' <- hashUnit unitIndex dbref+ let !hashId = unit' `mod` fromIntegral htsize0++ findInTable !hid = do+ let !htsize = V.length $ dawgBuilderHashTable db+ transitionId <- dawgBuilderHashTable db !~ hid+#ifdef trace+ traceIO $ concat+ ["-findUnit uix ", show unitIndex+ , " hid ", show hid+ , " tix ", show transitionId+ ]+#endif+ if transitionId == 0+ then pure (hid, 0)+ else areEqual unitIndex transitionId dbref >>= \case+ True -> do+#ifdef trace+ traceIO $ concat+ ["--areEqual uix ", show unitIndex, " tix ", show transitionId]+#endif+ pure (hid, transitionId)+ False -> findInTable (succ hid `mod` fromIntegral htsize)+#ifdef trace+ traceIO $ concat+ ["-findUnit uix ", show unitIndex+ , " start hid ", show hashId+ , " ht.size ", show htsize0+ ]+#endif+ findInTable hashId+{-# INLINE findUnit #-}++-- | Checks whether unit index matches with transition index or not.+areEqual+ :: PrimMonad m+ => BaseType -> BaseType -> DAWGBuilder m -> m Bool+areEqual !unitIndex !transitionIndex !DBRef{..} = do+ db <- readMutVar getDBRef+ !startUnit <- dawgBuilderUnitPool db !~ unitIndex+ let !startIx = DawgUnit.sibling startUnit+#ifdef trace+ traceIO $ concat+ [ "--areEqual start ", show startIx, " tix ", show transitionIndex]+#endif++ -- Mismatch: at this point there should be no siblings in associated base pool+ let goUnit !tix 0 = do+#ifdef trace+ base' <- dawgBuilderBasePool db !~ tix+ traceIO $ concat+ [ "--areEqual 0 tix ", show tix+ , " b ", show (base base')+ , " b.hs ", show (hasSibling base')+ ]+#endif+ pure (tix, False)+ goUnit !tix !uix = do+#ifdef trace+ traceIO $ concat [ "goUnit tix ", show tix, " uix ", show uix]+#endif+ base' <- dawgBuilderBasePool db !~ tix+ let !baseHasSibling = hasSibling base'+ if not baseHasSibling+ then pure (tix, True)+ else do+ !unit <- dawgBuilderUnitPool db !~ uix+ goUnit (succ tix) (DawgUnit.sibling unit)++ goBack !tix 0 = pure (tix, True)+ goBack !tix !(uix :: BaseType) = do+ !unit' <- dawgBuilderUnitPool db !~ uix+ !base' <- dawgBuilderBasePool db !~ tix+ !label' <- dawgBuilderLabelPool db !~ tix+#ifdef trace+ traceIO $ concat+ [ "goBack tix ", show tix+ , " uix ", show uix+ , " u ", show unit'+ , " tr ", show (base base')+ ," l ", show (chr $ fromIntegral label'), " (", show label', ")"+ ]+#endif+ if DawgUnit.base unit' /= base base' || DawgUnit.label unit' /= label'+ then pure (tix, False)+ else goBack (pred tix) (fromIntegral $ DawgUnit.sibling unit')++ (outTransitionIndex, inTransitionMismatch) <-+ goUnit (fromIntegral transitionIndex) (fromIntegral startIx)++ if inTransitionMismatch+ then pure False+ else snd <$> goBack outTransitionIndex (fromIntegral unitIndex)+{-# INLINE areEqual #-}++-- | Calculates a hash value from a transition.+hashTransition :: forall m. PrimMonad m => BaseType -> DAWGBuilder m -> m BaseType+hashTransition !ix DBRef{..} = do+ db <- readMutVar getDBRef+ let go !hv (0 :: BaseType) = pure hv+ go !hv !ix' = do+ !bu <- dawgBuilderBasePool db !~ ix'+#ifdef trace+ traceIO (concat [ "--hashTransition ix ", show ix', " hv ", show hv, " b ", show bu])+#endif+ let !itHasSibling = hasSibling bu+ !base' = base bu+ !label' <- fromIntegral @_ @BaseType <$> dawgBuilderLabelPool db !~ ix'+ let !newHashValue = hv .^. hashBaseType ((label' .<<. 24) .^. fromIntegral base')+ if itHasSibling then go newHashValue (succ ix') else pure newHashValue+ fromIntegral <$> go 0 ix+{-# INLINE hashTransition #-}++-- | Calculates a hash value from a unit.+hashUnit+ :: forall m. PrimMonad m+ => BaseType -> DAWGBuilder m -> m BaseType+hashUnit !ix DBRef{..} = do+ db <- readMutVar getDBRef++ let go :: BaseType -> BaseType -> m BaseType+ go !hv 0 = pure hv+ go !hv !ix' = do+ !u <- dawgBuilderUnitPool db !~ ix'+#ifdef trace+ traceIO (concat [ "--hashUnit ix ", show ix', " hv ", show hv, " u ", show u])+#endif+ let !base' = DawgUnit.base u+ !label' = DawgUnit.label u+ !newHashValue = hv .^. fromIntegral+ (hashBaseType ((fromIntegral label' .<<. 24) .^. fromIntegral base'))+ !next = fromIntegral $! DawgUnit.sibling u+ go newHashValue next++ go 0 (fromIntegral ix)+{-# INLINE hashUnit #-}++-- | Dump builder to stdout.+dump :: DAWGBuilder IO -> IO ()+dump DBRef{..} = do+ db <- readMutVar getDBRef+ + let !bs = V.length $ dawgBuilderBasePool db+ !ls = V.length $ dawgBuilderLabelPool db+ !us = V.length $ dawgBuilderUnitPool db+ !ms = maximum [bs, ls, us]++ putStrLn $ concat [ "b(", show bs, ")\tl(", show ls, ")\tu(", show us, ")" ]++ forM_ [0 .. ms - 1] \i -> do+ !b <- fromMaybe (BaseUnit 0) <$> (V.readMaybe (dawgBuilderBasePool db) i)+ !l <- fromMaybe 0 <$> (V.readMaybe (dawgBuilderLabelPool db) i)+ !u <- fromMaybe DawgUnit.empty <$> (V.readMaybe (dawgBuilderUnitPool db) i)++ putStrLn $ concat+ [ show b, "\t", show (chr $ fromIntegral l), " ", show l, "\t", show u+ ]++ let topStr stack = readMutVar (getStackRef $ stack db) >>= \case+ EndOfStack -> pure ""+ Elem el _ -> pure $ show el++ unfixed <- topStr dawgBuilderUnfixedUnits+ unused <- topStr dawgBuilderUnusedUnits+ let !htsize = V.length $ dawgBuilderHashTable db++ putStrLn $ "unfixed : " <> unfixed+ putStrLn $ "unused : " <> unused+ putStrLn $ "ht.size : " <> show htsize++-- ** HashTable helper++-- | Resizes a vector to a given size.+--+-- * If new size is lesser than the table one, it shrinks the table.+-- * If new size is greater than the table one, it allocates empty units in the vector to fit new size.+-- * Otherwise, it does not do anything.+--+-- See it as an equivalent to @std::vector.resize()@.+resize :: PrimMonad m => DAWGBuilder m -> Int -> m ()+resize DBRef{..} newSize = do+ db <- readMutVar getDBRef+ let !htsize = V.length $ dawgBuilderHashTable db+#ifdef trace+ traceIO $ concat ["--resize old ", show htsize, " new ", show newSize]+#endif+ newHt <- case compare htsize newSize of+ LT -> do+ newHt <- V.grow (dawgBuilderHashTable db) (newSize - htsize)+ forM_ [htsize .. pred newSize] \ix -> do+ newHt <~~ fromIntegral ix $ 0+ pure newHt+ EQ -> pure (dawgBuilderHashTable db)+ GT -> pure (V.unsafeSlice 0 newSize (dawgBuilderHashTable db))+ let !ndb = db { dawgBuilderHashTable = newHt }+ writeMutVar getDBRef ndb+{-# INLINE resize #-}+
+ src/Data/DAWG/Internal/DAWGUnit.hs view
@@ -0,0 +1,131 @@+{-|+Module: Data.DAWG.Internal.DAWGUnit+Description: Exports dawg unit used in dawg and dawg builder as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.DAWGUnit where++import Data.Binary+import Data.Bits+import Data.Char+import Data.Vector.Unboxed.Mutable (Unbox)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV++-- ** DAWG Unit++-- | Unit of a 'Data.DAWG.Internal.DAWGBuilder.DAWGBuilder'. Contains following information:+--+-- * child (4 bytes);+-- * sibling (4 bytes);+-- * label (0-255);+-- * is state flag (0-1);+-- * has sibling flag (0-1).+--+-- Constructed as unboxed tuple of all its properties.+newtype DAWGUnit = DAWGUnit+ { unDawgUnit+ :: ( BaseType -- child+ , BaseType -- sibling+ , UCharType -- label+ , Bool -- isState+ , Bool -- hasSibling+ )+ }+ deriving newtype (Binary)++instance Show DAWGUnit where+ show u@(DAWGUnit (c, s, l, is, hs)) =+ concat+ [ "(", show c, ",", show s, ",'"+ , pure (chr $ fromIntegral l), "' (", show l, "),"+ , showBool is, ",", showBool hs, ") b ", show (base u)+ ]+ where+ showBool x = if x then "1" else "0"+ {-# INLINE showBool #-}+ {-# INLINE show #-}++newtype instance UV.MVector s DAWGUnit = MV_DAWGUnit (UV.MVector s (BaseType, BaseType, UCharType, Bool, Bool))+newtype instance UV.Vector DAWGUnit = V_DAWGUnit (UV.Vector (BaseType, BaseType, UCharType, Bool, Bool))++deriving newtype instance V.MVector UV.MVector DAWGUnit+deriving newtype instance VG.Vector UV.Vector DAWGUnit+deriving newtype instance Unbox DAWGUnit++-- | Empty unit. Equivalent to @0@.+empty :: DAWGUnit+empty = DAWGUnit (0, 0, 0, False, False)+{-# INLINE empty #-}++-- | Gets a value of a unit. Synonym for 'child'.+value :: DAWGUnit -> ValueType+value = fromIntegral . child+{-# INLINE value #-}++-- | Calculates a base value of a unit.+base :: DAWGUnit -> BaseType+base u =+ if label u == fromIntegral (ord '\0')+ then (child u .<<. 1) .|. (if hasSibling u then 1 else 0)+ else (child u .<<. 2)+ .|. (if isState u then 2 else 0)+ .|. (if hasSibling u then 1 else 0)+{-# INLINE base #-}++-- | Gets a child from the unit.+child :: DAWGUnit -> BaseType+child (DAWGUnit (!c, !_, !_, !_, !_)) = c+{-# INLINE child #-}++-- | Gets a sibling from the unit.+sibling :: DAWGUnit -> BaseType+sibling (DAWGUnit (!_, !s, !_, !_, !_)) = s+{-# INLINE sibling #-}++-- | Gets a label from the unit.+label :: DAWGUnit -> UCharType+label (DAWGUnit (!_, !_, !l, !_, !_)) = l+{-# INLINE label #-}++-- | Checks whether a unit is a state or not.+isState :: DAWGUnit -> Bool+isState (DAWGUnit (!_, !_, !_, !is, !_)) = is+{-# INLINE isState #-}++-- | Checks whether a unit has a sibling or not.+hasSibling :: DAWGUnit -> Bool+hasSibling (DAWGUnit (!_, !_, !_, !_, !hs)) = hs+{-# INLINE hasSibling #-}++-- | Sets a child to the unit.+setChild :: DAWGUnit -> BaseType -> DAWGUnit+setChild (DAWGUnit (!_, !s, !l, !is, !hs)) !c = DAWGUnit (c, s, l, is, hs)+{-# INLINE setChild #-}++-- | Sets a sibling to the unit.+setSibling :: DAWGUnit -> BaseType -> DAWGUnit+setSibling (DAWGUnit (!c, !_, !l, !is, !hs)) !s = DAWGUnit (c, s, l, is, hs)+{-# INLINE setSibling #-}++-- | Sets a label to the unit.+setLabel :: DAWGUnit -> UCharType -> DAWGUnit+setLabel (DAWGUnit (!c, !s, !_, !is, !hs)) !l = DAWGUnit (c, s, l, is, hs)+{-# INLINE setLabel #-}++-- | Sets a flag @isState@ to the unit.+setIsState :: DAWGUnit -> Bool -> DAWGUnit+setIsState (DAWGUnit (!c, !s, !l, !_, !hs)) !is = DAWGUnit (c, s, l, is, hs)+{-# INLINE setIsState #-}++-- | Sets a flag @hasSibling@ to the unit.+setHasSibling :: DAWGUnit -> Bool -> DAWGUnit+setHasSibling (DAWGUnit (!c, !s, !l, !is, !_)) !hs = DAWGUnit (c, s, l, is, hs)+{-# INLINE setHasSibling #-}
+ src/Data/DAWG/Internal/Dictionary.hs view
@@ -0,0 +1,177 @@+{-|+Module: Data.DAWG.Internal.Dictionary+Description: Exports dictionary as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE CPP #-}+module Data.DAWG.Internal.Dictionary where++import Control.DeepSeq (NFData)+import Control.Monad (forM_)+import Data.Binary+import Data.Bits+import Data.Char+import Data.Vector.Binary ()+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)++import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.DictionaryUnit (DictionaryUnit)++import qualified Data.Binary as Binary+import qualified Data.Vector.Unboxed as UV++import qualified Data.DAWG.Internal.DictionaryUnit as DictionaryUnit++#ifdef trace+import Data.DAWG.Trace+#endif++-- ** Dictionary++-- | Dictionary.+--+-- * Each unit is stored in 4 bytes.+-- * Size is stored in unsigned int.+data Dictionary = Dictionary+ { dictionaryUnits :: UV.Vector DictionaryUnit -- ^ Array of dictionary units.+ , dictionarySize :: SizeType -- ^ Size of the dictionary.+ } deriving (Generic, Binary, NFData)++-- | Root dictionary index. Equivalent to @0@.+root :: BaseType+root = 0+{-# INLINE root #-}++-- | Checks whether dictionary unit has value by given index.+hasValue :: HasCallStack => BaseType -> Dictionary -> Bool+hasValue !ix d = DictionaryUnit.hasLeaf (dictionaryUnits d UV.! fromIntegral ix)+{-# INLINE hasValue #-}++-- | Gets a value of dictionary unit by given index.+value :: HasCallStack => BaseType -> Dictionary -> ValueType+value !ix d = DictionaryUnit.value (dictionaryUnits d UV.! fromIntegral oix)+ where+ !oix = ix .^. DictionaryUnit.offset (dictionaryUnits d UV.! fromIntegral ix)+{-# INLINE value #-}++-- | Load dictionary from a file.+read :: HasCallStack => FilePath -> IO Dictionary+read = Binary.decodeFile++-- | Save dictionary to a file.+write :: HasCallStack => FilePath -> Dictionary -> IO ()+write = Binary.encodeFile++-- | Alias for 'contains'.+member :: HasCallStack => String -> Dictionary -> Bool+member = contains+{-# INLINE member #-}++-- | Checks that the word contains in the dictionary.+contains :: HasCallStack => String -> Dictionary -> Bool+contains !key d =+ case follow key root d of+ Nothing -> False+ Just ix -> hasValue ix d+{-# INLINE contains #-}++-- | Similarly to 'contains' it checks that the word prefix+-- (provided as word and separate length)+-- contains in the dictionary. +containsPrefixLength :: HasCallStack => String -> SizeType -> Dictionary -> Bool+containsPrefixLength !k !l d =+ case followPrefixLength k l root d of+ Nothing -> False+ Just !ix -> hasValue ix d+{-# INLINE containsPrefixLength #-}++-- | Performs lookup and retrieves value associated with the word+-- if it is present in the dictionary.+--+-- * If the word is contained in the dictionary but there is no value associated with it,+-- @Just 0@ will be returned.+-- * Otherwise, returns 'Nothing' if there is no such word in the dictionary.+lookup :: HasCallStack => String -> Dictionary -> Maybe ValueType+lookup !k d =+ case follow k root d of+ Nothing -> Nothing+ Just ix -> DictionaryUnit.value <$> (dictionaryUnits d UV.!? fromIntegral ix)+{-# INLINE lookup #-}++-- | Similarlty to 'lookup', it performs lookup of the word prefix+-- (provided as word and separate length)+-- and retrieves value associated with the word+-- if it is present in the dictionary.+--+-- If the word is contained in the dictionary but there is no value associated with it,+-- @Just 0@ will be returned.+lookupPrefixLength :: HasCallStack => String -> SizeType -> Dictionary -> Maybe ValueType+lookupPrefixLength !k !l d =+ case followPrefixLength k l root d of+ Nothing -> Nothing+ Just !ix -> DictionaryUnit.value <$> (dictionaryUnits d UV.!? fromIntegral ix)+{-# INLINE lookupPrefixLength #-}++-- | Follows the character by dictionary index of the previous character.+-- If there is a child unit, returns its index.+--+followChar :: HasCallStack => CharType -> BaseType -> Dictionary -> Maybe BaseType+followChar !l !ix d =+ let !lb = fromIntegral l+ !u = dictionaryUnits d UV.! fromIntegral ix+ !nextIx = (ix .^. DictionaryUnit.offset u) .^. lb+ !nu = dictionaryUnits d UV.! fromIntegral nextIx+#ifdef trace+ !debugStr = concat+ [ "-follow l ", show $ chr $ fromIntegral l+ , " ix ", show ix, " nextIx ", show nextIx+ , " u ", show u, " nu ", show nu+ ]+#endif+ in+#ifdef trace+ tracePure debugStr $+#endif+ if DictionaryUnit.label nu /= lb then Nothing else Just nextIx+{-# INLINE followChar #-}++-- | Recursively follows the word starting from its beginning.+-- If at any point there is no index while following is not finished, returns 'Nothing'.+-- Otherwise, returns a dictionary index associated with a last word character.+follow :: HasCallStack => String -> BaseType -> Dictionary -> Maybe BaseType+follow [] !ix _d = Just ix+follow (!c : cs) !ix d = if ord c == 0+ then Just ix+ else case followChar (fromIntegral . ord $ c) ix d of+ Nothing -> Nothing+ Just !nextIx -> follow cs nextIx d+{-# INLINE follow #-}++-- | Same as 'follow' but for word prefix.+followPrefixLength+ :: HasCallStack => String -> SizeType -> BaseType -> Dictionary -> Maybe BaseType+followPrefixLength !cs !l !ix d =+ let !cs' = UV.fromList (fmap (fromIntegral . ord) cs)+ follow' !ix' [] = Just ix'+ follow' !ix' (!i : is) =+#ifdef trace+ tracePure (concat ["-followLength ix ", show i, " l ", show l]) $!+#endif+ case followChar (cs' UV.! i) ix' d of+ Nothing -> Nothing+ Just !nIx -> follow' nIx is+ in follow' ix [0 .. pred (fromIntegral l)]+{-# INLINE followPrefixLength #-}++-- | Dump dictionary to stdout.+dump :: HasCallStack => Dictionary -> IO ()+dump d = do+ putStrLn "dictionary"+ putStrLn $ concat ["i\tu(", show $ dictionarySize d, ")"]+ + forM_ [0 .. (dictionarySize d) - 1] \ix -> do+ putStrLn $ concat+ [show ix, "\t", show $ dictionaryUnits d UV.! fromIntegral ix]
+ src/Data/DAWG/Internal/DictionaryBuilder.hs view
@@ -0,0 +1,759 @@+{-|+Module: Data.DAWG.Internal.DictionaryBuilder+Description: Exports dictionary builder as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE CPP #-}+module Data.DAWG.Internal.DictionaryBuilder where++import Control.Monad (forM_, when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Bits+import Data.Char+import Data.Maybe (fromMaybe)+import Data.Primitive.MutVar+import GHC.Stack (HasCallStack)++import Data.Primitive.PrimArray.Combinators+import Data.DAWG.Internal.BaseType (BaseType, UCharType, SizeType, UUHT, UHHT, ObjectPool)+import Data.DAWG.Internal.DictionaryExtraUnit (DictionaryExtraUnit (..))+import Data.DAWG.Internal.DictionaryUnit (DictionaryUnit (..))+import Data.DAWG.Internal.Dictionary (Dictionary (..))+import Data.DAWG.Internal.DAWG (DAWG (..))++import qualified Data.Primitive.PrimArray.Utils as A+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Hashtables as HT++import qualified Data.DAWG.Internal.DAWG as Dawg+import qualified Data.DAWG.Internal.DictionaryExtraUnit as Extra+import qualified Data.DAWG.Internal.DictionaryUnit as DictUnit+import qualified Data.DAWG.Internal.LinkTable as LT++#ifdef trace+import Data.DAWG.Trace+#endif++-- ** DAWG Dictionary Builder++-- | A mutable builder of 'Data.DAWG.Internal.Dictionary.Dictionary'.+newtype DictionaryBuilder m =+ DDBRef { getDDBRef :: MutVar (PrimState m) (DictionaryBuilder_ m) }++-- | Builder of Dictionary. Do not access directly. Use 'DictionaryBuilder' instead.+data DictionaryBuilder_ m = DictionaryBuilder+ { dawgDictionaryBuilderDawg :: DAWG -- ^ DAWG.+ , dawgDictionaryBuilderUnits :: ObjectPool (PrimState m) DictionaryUnit -- ^ Pool of dictionary units.+ , dawgDictionaryBuilderExtras :: UHHT m BaseType DictionaryExtraUnit -- ^ Table of extra blocks (of 256) which represents supportive circular linked list used.+ , dawgDictionaryBuilderLabels :: UUHT m SizeType UCharType+ , dawgDictionaryBuilderLinkTable :: LT.LinkTable m+ , dawgDictionaryBuilderRefs :: !(IntArray (PrimState m))+ }++unfixedIndex, numOfUnusedUnits :: Int++-- | Use it as index for 'dawgDictionaryBuilderRefs' to get the current unfixed index.+unfixedIndex = 0+{-# INLINE unfixedIndex #-}++-- | Use it as index for 'dawgDictionaryBuilderRefs' to get the number of unfixed units.+numOfUnusedUnits = 1+{-# INLINE numOfUnusedUnits #-}++-- | Upper mask.+upperMask :: BaseType+upperMask = complement (pred DictUnit.offsetMax)+{-# INLINE upperMask #-}++-- | Lower mask.+lowerMask :: BaseType+lowerMask = 0xFF+{-# INLINE lowerMask #-}++-- | Gets a current size of units.+numOfUnits :: DictionaryBuilder_ m -> BaseType+numOfUnits = fromIntegral . V.length . dawgDictionaryBuilderUnits+{-# INLINE numOfUnits #-}++-- | Gets a current size of blocks.+numOfBlocks :: PrimMonad m => DictionaryBuilder_ m -> m BaseType+numOfBlocks = fmap fromIntegral . HT.size . dawgDictionaryBuilderExtras+{-# INLINE numOfBlocks #-}++-- | Constant: @16@.+numOfUnfixedBlocks :: BaseType+numOfUnfixedBlocks = 16+{-# INLINE numOfUnfixedBlocks #-}++-- | Constant: @256@.+blockSize :: BaseType+blockSize = 256+{-# INLINE blockSize #-}++-- | Build dictionary from 'Data.DAWG.Internal.DAWG.DAWG'.+-- If build failed, it returns 'Nothing'.+build+ :: HasCallStack+ => PrimMonad m+ => DAWG -> m (Maybe (DictionaryBuilder m))+build !dawg = do+ !dref@DDBRef{..} <- new dawg+ !preDdb <- readMutVar getDDBRef+ let !ltsize = dawgNumOfMergingStates dawg + (dawgNumOfMergingStates dawg .>>. 1)+#ifdef trace+ traceIO ("build ltsize " <> show ltsize)+#endif+ LT.init (dawgDictionaryBuilderLinkTable preDdb) (fromIntegral ltsize)++#ifdef trace+ traceIO ("build reserveUnit 0")+ traceWith dump dref+#endif++ reserveUnit 0 dref+#ifdef trace+ traceWith dump dref+#endif+ -- after unit reservation most likely vectors are being resized+ !ddb <- readMutVar getDDBRef+ let units = dawgDictionaryBuilderUnits ddb++#ifdef trace+ traceIO ("build extra setIsUsed 0")+#endif+ modifyExtras ddb 0 $ Extra.setIsUsed+ !u0 <- units !~ 0+#ifdef trace+ traceIO ("build get unit[0] " <> show u0)+#endif+ let (!isOffsetSet, !u1) = DictUnit.setOffset 1 u0+ if not isOffsetSet+ then do+#ifdef trace+ traceIO $ "build: offset is not set for " <> show u0+#endif+ pure Nothing+ else do+#ifdef trace+ traceIO ("build set offset unit[0] " <> show u1)+#endif+ let !u2 = DictUnit.setLabel (fromIntegral $ ord '\0') u1+#ifdef trace+ traceIO ("build set label unit[0] " <> show u2)+#endif+ units <~~ 0 $ u2++ buildResult <- if (Dawg.size dawg > 1)+ then do+#ifdef trace+ traceIO ("build from dawg from 0")+#endif+ buildFromDawg Dawg.root 0 dref+ else pure True++#ifdef trace+ traceIO ("build result: " <> show buildResult)+#endif+ if not buildResult+ then pure Nothing+ else do+#ifdef trace+ traceIO "build fixAllBlocks"+#endif+ fixAllBlocks dref+#ifdef trace+ traceWith dump dref+#endif+ pure $! Just dref++-- | Build a dictionary from 'Data.DAWG.Internal.DAWG.DAWG' and freezes its result.+-- Throws an error when build fails.+build' :: HasCallStack => PrimMonad m => DAWG -> m Dictionary+build' dawg = build dawg >>= \case+ Just dict -> freeze dict+ Nothing -> error "failed to build dictionary"+{-# INLINE build' #-}++-- | Generates 'Data.DAWG.Internal.Dictionary.Dictionary' out of 'DictionaryBuilder'.+-- Once this function is called, 'DictionaryBuilder' must not be used anymore.+freeze :: PrimMonad m => DictionaryBuilder m -> m Dictionary+freeze DDBRef{..} = do+ ddb <- readMutVar getDDBRef+ dictionaryUnits <- VG.unsafeFreeze $! dawgDictionaryBuilderUnits ddb+ let dictionarySize = fromIntegral $! VG.length dictionaryUnits+ pure Dictionary{..}+{-# INLINE freeze #-}++-- ** Helpers++-- | Initialises a new 'DictionaryBuilder' from DAWG.+new :: HasCallStack => PrimMonad m => DAWG -> m (DictionaryBuilder m)+new !dawgDictionaryBuilderDawg = do+ !dawgDictionaryBuilderUnits <- V.new 0+ !dawgDictionaryBuilderExtras <- HT.initialize 0+ !dawgDictionaryBuilderLabels <- HT.initialize 0+ !dawgDictionaryBuilderLinkTable <- HT.initialize 0+ !dawgDictionaryBuilderRefs <- A.replicate 2 0+ dawgDictionaryBuilderRefs <~ unfixedIndex $ 0+#ifdef trace+ !uix <- dawgDictionaryBuilderRefs ! unfixedIndex+ traceIO ("new dictionary builder: uix " <> show uix)+#endif+ let d = DictionaryBuilder{..}+ DDBRef <$> newMutVar d+{-# INLINE new #-}++-- | Recursively build dictionary by traversing DAWG+-- starting from dawg index and dictionary index.+buildFromDawg+ :: HasCallStack+ => PrimMonad m => BaseType -> BaseType -> DictionaryBuilder m -> m Bool+buildFromDawg dawgIx dictIx dref@DDBRef{..} = do+#ifdef trace+ traceIO ("buildFromDawg dawgIx " <> show dawgIx <> " dictIx " <> show dictIx)+ traceWith dump dref+#endif++ ddb <- readMutVar getDDBRef+ let dawg = dawgDictionaryBuilderDawg ddb+ if Dawg.isLeaf dawgIx dawg+ then pure True+ else do+ let !dawgChildIx = Dawg.child dawgIx dawg+ whenMerging !ix action = do+#ifdef trace+ traceIO $ concat+ ["-whenMerging dawgChildIx ", show ix, " ", show $ Dawg.isMerging ix dawg]+#endif+ if not (Dawg.isMerging ix dawg)+ then pure Nothing+ else action++ withOffset !ix action = do+ !offset <- LT.find (dawgDictionaryBuilderLinkTable ddb) ix+#ifdef trace+ traceIO $ concat ["--withOffset dawgChildIx ", show ix, " offset ", show offset]+#endif+ if offset /= 0+ then action ix offset+ else pure Nothing++ withRenewedOffset !ix !offset = do+ let !renewedOffset = offset .^. dictIx+ if 0 == (renewedOffset .&. upperMask)+ || 0 == (renewedOffset .&. lowerMask)+ then do+ when (Dawg.isLeaf ix dawg) do+ dawgDictionaryBuilderUnits ddb !<~~ dictIx $! DictUnit.setHasLeaf+ !u <- dawgDictionaryBuilderUnits ddb !~ dictIx+ let (!_isSet, !nu) = DictUnit.setOffset renewedOffset u+ dawgDictionaryBuilderUnits ddb <~~ dictIx $ nu+ pure $! Just True+ else pure Nothing++ whenMerging dawgChildIx (withOffset dawgChildIx withRenewedOffset) >>= \case+ Just x -> pure x+ Nothing -> do+ offset <- arrangeChildNodes dawgIx dictIx dref+ if offset == 0+ then pure False+ else do+ when (Dawg.isMerging dawgChildIx dawg) do+ LT.insert (dawgDictionaryBuilderLinkTable ddb) dawgChildIx offset+ let go !ix+ | ix == 0 = pure True+ | otherwise = do+ let !l = Dawg.label ix dawg+ !dictChildIx = offset .^. fromIntegral @_ @BaseType l+#ifdef trace+ traceIO $ concat+ [ "--go ix ", show ix+ , " dictChildIx ", show dictChildIx+ , " offset ", show offset+ ]+#endif+ !buildResult <- buildFromDawg ix dictChildIx dref+ if not buildResult+ then pure False+ else do+ let !nextIx = Dawg.sibling ix dawg+ go nextIx++ go dawgChildIx++-- | Arrange child nodes for given dawg index and dictionary index.+arrangeChildNodes+ :: HasCallStack+ => PrimMonad m+ => BaseType -> BaseType -> DictionaryBuilder m -> m BaseType+arrangeChildNodes dawgIx dictIx dref@DDBRef{..} = do+ clearLabels dref+ ddb <- readMutVar getDDBRef++ labelSizeRef <- newMutVar (0 :: SizeType)++ let dawg = dawgDictionaryBuilderDawg ddb+ !dawgChildIx = Dawg.child dawgIx dawg++ collectChildLabels 0 = pure ()+ collectChildLabels !ix = do+#ifdef trace+ traceIO ("-collectChildLabels ix " <> show ix)+#endif+ l <- readMutVar labelSizeRef+ HT.insert (dawgDictionaryBuilderLabels ddb) l (Dawg.label ix dawg)+ modifyMutVar' labelSizeRef succ+ let !childIx = Dawg.sibling ix dawg+ collectChildLabels childIx++#ifdef trace+ traceIO $ concat+ [ "arrangeChildNodes dawgIx ", show dawgIx+ , " dawgChildIx ", show dawgChildIx+ , " dictIx ", show dictIx+ ]+#endif+ -- Arrange child nodes.+ collectChildLabels dawgChildIx++ -- Find a good offset.+ !offset <- findGoodOffset dictIx ddb+#ifdef trace+ traceIO $ concat [ "arrangeChildNodes dictIx ", show dictIx, " offset ", show offset]+#endif+ !offsetIsSet <- do+ !u <- dawgDictionaryBuilderUnits ddb !~ dictIx+ let (res, nu) = DictUnit.setOffset (dictIx .^. offset) u+ dawgDictionaryBuilderUnits ddb <~~ dictIx $ nu+ pure res+ if not offsetIsSet+ then pure 0+ else do+ l <- readMutVar labelSizeRef+ let populateChildNodes !i dawgChildIx'+ | i < fromIntegral l = do+ ddb1 <- readMutVar getDDBRef+ label <- fromMaybe 0 <$> HT.lookup (dawgDictionaryBuilderLabels ddb1) i+ let !dictChildIx = offset .^. fromIntegral @_ @BaseType label+ reserveUnit dictChildIx dref+ ddb2 <- readMutVar getDDBRef++#ifdef trace+ traceIO $ concat+ [ "-populateChildNodes i ", show i+ , " dawgChildIx ", show dawgChildIx'+ , " dawg_is_leaf ", show $ Dawg.isLeaf dawgChildIx' dawg+ , " dawg_value ", show $ Dawg.value dawgChildIx' dawg+ , " dictIx ", show dictIx, " dictChildIx ", show dictChildIx+ ]+#endif+ if Dawg.isLeaf dawgChildIx' dawg+ then do+ dawgDictionaryBuilderUnits ddb2 !<~~ dictIx $ DictUnit.setHasLeaf+ dawgDictionaryBuilderUnits ddb2 !<~~ dictChildIx $+ DictUnit.setValue $! Dawg.value dawgChildIx' dawg+ + else do+ dawgDictionaryBuilderUnits ddb2 !<~~ dictChildIx $+ DictUnit.setLabel label++ let !nextDawgChildIx = Dawg.sibling dawgChildIx' dawg+ populateChildNodes (succ i) nextDawgChildIx+ | otherwise = pure ()+ populateChildNodes 0 dawgChildIx+ ddb3 <- readMutVar getDDBRef+ modifyExtras ddb3 offset $! Extra.setIsUsed+ + pure offset++-- | Find a good offset for given dictionary index.+findGoodOffset+ :: HasCallStack+ => PrimMonad m => BaseType -> DictionaryBuilder_ m -> m BaseType+findGoodOffset ix ddb = do+ !unfixedIndex' <- fromIntegral <$> dawgDictionaryBuilderRefs ddb ! unfixedIndex+ let !numOfUnits' = numOfUnits ddb+#ifdef trace+ traceIO $ concat+ [ "-findGoodOffset ix ", show ix+ , " uix ", show unfixedIndex'+ , " num_of_units ", show numOfUnits'+ ]+#endif+ if numOfUnits' <= unfixedIndex'+ then pure $ numOfUnits' .|. (ix .&. lowerMask)+ else do+ let scanUnusedUnits shouldStop !uix+ | shouldStop && uix == unfixedIndex' =+ pure (numOfUnits' .|. (ix .&. lowerMask))+ | otherwise = do+ l0 <- fromMaybe 0 <$> HT.lookup (dawgDictionaryBuilderLabels ddb) 0+ let !offset = uix .^. fromIntegral l0+#ifdef trace+ traceIO $ concat+ [ "--scanUnusedUnits ix ", show ix+ , " uix ", show uix+ , " l ", show $ chr $ fromIntegral l0, " (", show l0, ")"+ , " offset ", show offset+ ]+#endif+ isGoodOffset ix offset ddb >>= \case+ True -> pure offset+ False -> do+ !ex <- extras ddb (fromIntegral uix)+ let !nuix = Extra.next ex+ scanUnusedUnits True nuix+ scanUnusedUnits False unfixedIndex'+{-# INLINE findGoodOffset #-}++-- | Recursively checks whether given offset is good for dictionanry index.+isGoodOffset+ :: HasCallStack+ => PrimMonad m => BaseType -> BaseType -> DictionaryBuilder_ m -> m Bool+isGoodOffset ix offset ddb = do+ !extra' <- extras ddb offset+ if Extra.isUsed extra' then pure False else do+ let !relativeOffset = ix .^. offset+ if (relativeOffset .&. lowerMask /= 0) && (relativeOffset .&. upperMask /= 0)+ then pure False else do+ lsize <- HT.size (dawgDictionaryBuilderLabels ddb)+ let findCollision !i+ | i >= lsize = pure True+ | otherwise = do+ l <- fromMaybe 0 <$> HT.lookup (dawgDictionaryBuilderLabels ddb) (fromIntegral i)+ !ex' <- extras ddb (offset .^. fromIntegral @_ @BaseType l)+ if Extra.isFixed ex'+ then pure False+ else findCollision (succ i)+ findCollision 1+{-# INLINE isGoodOffset #-}++-- | Reserve a new unit.+reserveUnit+ :: HasCallStack+ => PrimMonad m => BaseType -> DictionaryBuilder m -> m ()+reserveUnit ix dref = do+ do+ !ddb0 <- readMutVar (getDDBRef dref)+#ifdef trace+ !unfixedIndex' <- dawgDictionaryBuilderRefs ddb0 ! unfixedIndex+ traceIO $ concat+ [ "-reserveUnit ix ", show ix+ , " num_of_units ", show (numOfUnits ddb0)+ , " uix ", show unfixedIndex'+ ] +#endif+ when (numOfUnits ddb0 <= ix) do+ expandDictionary dref++ -- removes an unused unit from a circular linked list+ !ddb <- readMutVar (getDDBRef dref)+ !unfixedIndex' <- dawgDictionaryBuilderRefs ddb ! unfixedIndex++ when (ix == fromIntegral unfixedIndex') do+ ex' <- extras ddb ix+ let !nextUnfixedIx = Extra.next ex'+ dawgDictionaryBuilderRefs ddb <~ unfixedIndex $ fromIntegral nextUnfixedIx+ when (nextUnfixedIx == ix) do+ dawgDictionaryBuilderRefs ddb <~ unfixedIndex $ fromIntegral $ numOfUnits ddb++ !ex' <- extras ddb ix+ let !next' = Extra.next ex'+ !prev' = Extra.prev ex'++ modifyExtras ddb prev' $! Extra.setNext next'+ modifyExtras ddb next' $! Extra.setPrev prev'+ modifyExtras ddb ix $! Extra.setIsFixed+{-# INLINE reserveUnit #-}++-- | Expands dictionary by allocating a memory for new unit and block and aligning block elements.+expandDictionary :: HasCallStack => PrimMonad m => DictionaryBuilder m -> m ()+expandDictionary dref@DDBRef{..} = do+ (srcNumOfUnits, srcNumOfBlocks, destNumOfUnits, destNumOfBlocks) <- do+ !ddb <- readMutVar getDDBRef+ numOfBlocks' <- numOfBlocks ddb+ let !srcNumOfUnits = numOfUnits ddb+ !srcNumOfBlocks = numOfBlocks'++ !destNumOfUnits = srcNumOfUnits + blockSize+ !destNumOfBlocks = succ srcNumOfBlocks++#ifdef trace+ traceIO $ concat+ [ "--expandDictionary src_u ", show srcNumOfUnits+ , " src_b ", show srcNumOfBlocks+ , " dest_u ", show destNumOfUnits+ , " dest_b ", show destNumOfBlocks+ ]+#endif+ -- Fix old block+ when (numOfUnfixedBlocks < destNumOfBlocks) do+ fixBlock (srcNumOfBlocks - numOfUnfixedBlocks) dref++ -- dest - src+ !newUnits <- V.grow (dawgDictionaryBuilderUnits ddb)+ (fromIntegral blockSize)+ forM_ [srcNumOfUnits .. destNumOfUnits - 1] \ix -> do+ newUnits <~~ ix $ 0++ allocateExtras ddb destNumOfBlocks+ let extras' = dawgDictionaryBuilderExtras ddb+ !ddb' = ddb+ { dawgDictionaryBuilderUnits = newUnits+ , dawgDictionaryBuilderExtras = extras'+ }++ writeMutVar getDDBRef ddb'+ pure (srcNumOfUnits, srcNumOfBlocks, destNumOfUnits, destNumOfBlocks)++ !ddb1 <- readMutVar getDDBRef++ if numOfUnfixedBlocks < destNumOfBlocks+ then do+ numOfBlocks' <- numOfBlocks ddb1+ let !blockId = srcNumOfBlocks - numOfUnfixedBlocks+ !lastId = numOfBlocks' - 1++ swapBlocks ddb1 blockId lastId+ forM_ [srcNumOfUnits .. pred destNumOfUnits] \i -> do+ modifyExtras ddb1 i $! const Extra.empty++ else do+ numOfBlocks' <- numOfBlocks ddb1+ let !lastId = numOfBlocks' - 1+ clearBlock lastId ddb1++#ifdef trace+ extrasSize <- numOfBlocks ddb1+ traceIO $ concat+ [ "--expandDictionary units new size "+ , show (V.length (dawgDictionaryBuilderUnits ddb1))+ , " blocks new size ", show extrasSize]++#endif+ -- create a circular linked list for a new block+ !ddb2 <- readMutVar getDDBRef++ let setNeighbourBlocks !i = do+ modifyExtras ddb2 (pred i) $ Extra.setNext i+ modifyExtras ddb2 i $ Extra.setPrev (pred i)++ forM_ [succ srcNumOfUnits .. pred destNumOfUnits] setNeighbourBlocks+#ifdef trace+ traceIO ("---setNeighbourBlocks " <> show destNumOfUnits)+#endif+ !unfixedIndex' <- dawgDictionaryBuilderRefs ddb2 ! unfixedIndex+ let !uix = fromIntegral unfixedIndex'+#ifdef trace+ traceIO ("--expandDictionary uix " <> show uix)+#endif+ modifyExtras ddb2 srcNumOfUnits $ Extra.setPrev (pred destNumOfUnits)+ modifyExtras ddb2 (pred destNumOfUnits) $ Extra.setNext srcNumOfUnits++ -- Merge 2 circular linked lists+ unfixedIndexBlock <- extras ddb2 uix+ modifyExtras ddb2 srcNumOfUnits $ Extra.setPrev (Extra.prev unfixedIndexBlock)+ modifyExtras ddb2 (pred destNumOfUnits) $ Extra.setNext uix++ modifyExtras ddb2 (Extra.prev unfixedIndexBlock) $ Extra.setNext srcNumOfUnits+ modifyExtras ddb2 uix $ Extra.setPrev (pred destNumOfUnits)+ writeMutVar getDDBRef ddb2++-- | Fixes all blocks. If there is more than 16 blocks, only unfixed blocks will be fixed.+fixAllBlocks+ :: HasCallStack+ => PrimMonad m+ => DictionaryBuilder m -> m ()+fixAllBlocks dref@DDBRef{..} = do+#ifdef trace+ traceIO "-fixAllBlocks"+ traceWith dump dref+#endif+ ddb <- readMutVar getDDBRef+ numOfBlocks' <- numOfBlocks ddb+ let !begin = if numOfUnfixedBlocks < numOfBlocks'+ then numOfBlocks' - numOfUnfixedBlocks+ else 0+ !end = numOfBlocks'+#ifdef trace+ traceIO $ concat ["-fixAllBlocks begin ", show begin, " end ", show end]+#endif+ forM_ [begin .. pred end] \blockId -> do+ fixBlock blockId dref+{-# INLINE fixAllBlocks #-}++-- | Fix block by its id.+fixBlock+ :: HasCallStack+ => PrimMonad m => BaseType -> DictionaryBuilder m -> m ()+fixBlock blockId dref@DDBRef{..} = do+#ifdef trace+ traceIO $ concat [ "-fixBlock block ", show blockId ]+#endif+ ddb <- readMutVar getDDBRef+ let !begin = blockId * blockSize+ !end = begin + blockSize++ findUnusedOffsetForLabel !offset+ | offset /= end = do+ block <- extras ddb offset+ if not $ Extra.isUsed block+ then pure offset+ else findUnusedOffsetForLabel (succ offset)+ | otherwise = pure 0++ offset <- findUnusedOffsetForLabel begin+#ifdef trace+ traceIO $ concat [ "-fixBlock offset ", show offset ]+#endif++ -- Labels of unused units are modified+ let go !ix+ | ix /= end = do+ ddb1 <- readMutVar getDDBRef+#ifdef trace+ ex' <- extras ddb1 ix+ traceIO $ concat [ "-fixBlock ix ", show ix, " e ", show ex' ]+#endif+ Extra.isFixed <$> extras ddb1 ix >>= \case+ True -> pure ()+ False -> do+ reserveUnit ix dref+ ddb2 <- readMutVar getDDBRef+ dawgDictionaryBuilderUnits ddb2 !<~~ ix $ DictUnit.setLabel $!+ (fromIntegral @_ @UCharType $! ix .^. fromIntegral offset)+ numUnusedUnits' <- dawgDictionaryBuilderRefs ddb2 ! numOfUnusedUnits+ dawgDictionaryBuilderRefs ddb2 <~ numOfUnusedUnits $ succ numUnusedUnits'+ go (succ ix)+ | otherwise = pure ()+ go begin++-- | Remove all labels.+clearLabels :: PrimMonad m => DictionaryBuilder m -> m ()+clearLabels DDBRef{..} = do+ ddb <- readMutVar getDDBRef+ lkeys <- HT.keys (dawgDictionaryBuilderLabels ddb)+ VG.forM_ lkeys \label -> HT.delete (dawgDictionaryBuilderLabels ddb) label+{-# INLINE clearLabels #-}++-- | Dump dictionary builder to stdout.+dump :: DictionaryBuilder IO -> IO ()+dump DDBRef{..} = do+ ddb <- readMutVar getDDBRef++ !bs <- fromIntegral <$> numOfBlocks ddb+ !ls <- HT.size $ dawgDictionaryBuilderLabels ddb+ let !us = V.length $ dawgDictionaryBuilderUnits ddb+ !ms = maximum [us, bs * fromIntegral blockSize, ls]+ labelToString x = concat [ show $ chr $ fromIntegral x, " (", show x, ")" ]++ putStrLn $ concat [ "i\tu(", show us, ")\t\tb(", show bs, ")\t\t\tl(", show ls, ")"]++ forM_ [0 .. ms - 1] \i -> do+ !u <- maybe "" show <$> (V.readMaybe (dawgDictionaryBuilderUnits ddb) i)+ !b <- do+ b' <- extras ddb (fromIntegral i)+ if b' == Extra.empty then pure "" else pure $ show b'+ !l <- maybe "" labelToString <$> (HT.lookup (dawgDictionaryBuilderLabels ddb) $ fromIntegral i)++ when (any (/= mempty) [b, l] || u /= show DictUnit.empty) do+ putStrLn $ concat [ show i, "\t", u, "\t", b, "\t", l ]++ uix <- dawgDictionaryBuilderRefs ddb ! unfixedIndex+ uns <- dawgDictionaryBuilderRefs ddb ! numOfUnusedUnits++ putStrLn $ concat [ "unfixed : ", show uix ]+ putStrLn $ concat [ "num_unused_states : ", show uns ]++-- ** Dictionary extra/blocks helpers++-- | Gets the entire block (hashtable) by its id. Throws an error if the block is missing.+lookupBlock+ :: (HasCallStack, PrimMonad m)+ => DictionaryBuilder_ m -> BaseType -> m (UUHT m BaseType DictionaryExtraUnit)+lookupBlock ddb ix =+ HT.lookup (dawgDictionaryBuilderExtras ddb) (ix `div` blockSize) >>= \case+ Nothing -> error "Missing block"+ Just block -> pure block+{-# INLINE lookupBlock #-}++-- | Inserts a block by its index into the hashtable.+insertBlock+ :: PrimMonad m+ => DictionaryBuilder_ m -> UUHT m BaseType DictionaryExtraUnit -> BaseType -> m ()+insertBlock ddb block ix =+ HT.insert (dawgDictionaryBuilderExtras ddb) (ix `div` blockSize) block+{-# INLINE insertBlock #-}++-- | Swap two blocks by their ids. Both blocks should be present.+-- If at least one of blocks is missing, error will be thrown.+swapBlocks+ :: (HasCallStack, PrimMonad m)+ => DictionaryBuilder_ m -> BaseType -> BaseType -> m ()+swapBlocks ddb b1 b2 = do+ let getBlock blockId =+ HT.lookup (dawgDictionaryBuilderExtras ddb) blockId >>= \case+ Nothing -> error "Missing block"+ Just block -> pure block++ block1 <- getBlock b1+ block2 <- getBlock b2++ HT.insert (dawgDictionaryBuilderExtras ddb) b1 block2+ HT.insert (dawgDictionaryBuilderExtras ddb) b2 block1+{-# INLINE swapBlocks #-}++-- | Replaces the content of the block by its id with empty units.+clearBlock+ :: HasCallStack => PrimMonad m => BaseType -> DictionaryBuilder_ m -> m ()+clearBlock !blockId ddb = do+ block <- HT.lookup (dawgDictionaryBuilderExtras ddb) blockId >>= \case+ Nothing -> error "Missing block"+ Just block -> pure block+ bsize <- HT.size block+ when (bsize > 0) do+ forM_ [0 .. pred bsize] \ix -> do+ HT.insert block (fromIntegral ix `mod` blockSize) Extra.empty+{-# INLINE clearBlock #-}++-- | Get block content by its id.+extras+ :: forall m. HasCallStack+ => PrimMonad m+ => DictionaryBuilder_ m -> BaseType -> m DictionaryExtraUnit+extras !ddb !ix = do+ !block <- lookupBlock ddb ix+ fromMaybe Extra.empty <$> HT.lookup block (ix `mod` blockSize)+{-# INLINE extras #-}++-- | Modifies block content by its id and modifier function.+modifyExtras+ :: HasCallStack+ => PrimMonad m+ => DictionaryBuilder_ m+ -> BaseType -> (DictionaryExtraUnit -> DictionaryExtraUnit) -> m ()+modifyExtras !ddb !ix modifier = do+ !block <- lookupBlock ddb ix+ let f Nothing = Just $! modifier Extra.empty+ f (Just !x) = Just $! modifier x+ HT.alter block f (ix `mod` blockSize)+{-# INLINE modifyExtras #-}++-- | Allocates new empty blocks by provided size, if it is greater than 'numOfBlocks'.+allocateExtras+ :: HasCallStack+ => PrimMonad m+ => DictionaryBuilder_ m -> BaseType -> m ()+allocateExtras !ddb destSize = do+ srcSize <- numOfBlocks ddb+ when (srcSize < destSize) do+ forM_ [srcSize .. pred destSize] \ix -> do+ block <- HT.initialize 0+ forM_ [0 .. pred blockSize] \bix -> do+ HT.insert block bix Extra.empty+ HT.insert (dawgDictionaryBuilderExtras ddb) ix block+{-# INLINE allocateExtras #-}+
+ src/Data/DAWG/Internal/DictionaryExtraUnit.hs view
@@ -0,0 +1,104 @@+{-|+Module: Data.DAWG.Internal.DictionaryExtraUnit+Description: Exports dictionary extra unit as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.DictionaryExtraUnit where++import Data.Bits+import Data.Coerce+import Data.Vector.Unboxed.Mutable (Unbox)+import GHC.Generics (Generic)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV++-- ** DAWG Dictionary Extra Unit++-- | Extra unit for supportive circular linked list.+-- Used in 'Data.DAWG.Internal.DictionaryBuilder.DictionaryBuilder'.+-- Contains a following information:+--+-- * low values;+-- * high values.+--+-- Constructed as unboxed tuple of two bases.+newtype DictionaryExtraUnit = DictionaryExtraUnit+ { unExtraUnit+ :: ( BaseType -- lo values+ , BaseType -- hi values+ )+ }+ deriving (Generic, Eq)++instance Show DictionaryExtraUnit where+ show e@(DictionaryExtraUnit (lo, hi)) = concat+ [ "((", show lo, ",", show $ isFixed e, ",", show $ next e+ , "),(", show hi, ",", show $ isUsed e, ",", show $ prev e, "))"]+ {-# INLINE show #-}++newtype instance UV.MVector s DictionaryExtraUnit =+ MV_DictionaryExtraUnit (UV.MVector s (BaseType, BaseType))+newtype instance UV.Vector DictionaryExtraUnit =+ V_DictionaryExtraUnit (UV.Vector (BaseType, BaseType))++deriving newtype instance V.MVector UV.MVector DictionaryExtraUnit+deriving newtype instance VG.Vector UV.Vector DictionaryExtraUnit+deriving newtype instance Unbox DictionaryExtraUnit++-- | Empty unit. Equivalent to @0@.+empty :: DictionaryExtraUnit+empty = DictionaryExtraUnit (0, 0)+{-# INLINE empty #-}++-- | Sets @isFixed@ flag to 'DictionaryExtraUnit'.+setIsFixed :: DictionaryExtraUnit -> DictionaryExtraUnit+setIsFixed (DictionaryExtraUnit (!lo, !hi)) =+ DictionaryExtraUnit (lo .|. 1, hi)+{-# INLINE setIsFixed #-}++-- | Sets @next@ value (link to the next unit) to 'DictionaryExtraUnit'.+setNext+ :: BaseType -> DictionaryExtraUnit -> DictionaryExtraUnit+setNext !next' (DictionaryExtraUnit (!lo, !hi)) =+ DictionaryExtraUnit ((lo .&. 1) .|. (next' .<<. 1), hi)+{-# INLINE setNext #-}++-- | Sets @isUsed@ flag to 'DictionaryExtraUnit'.+setIsUsed :: DictionaryExtraUnit -> DictionaryExtraUnit+setIsUsed (DictionaryExtraUnit (!lo, !hi)) =+ DictionaryExtraUnit (lo, hi .|. 1)+{-# INLINE setIsUsed #-}++-- | Set @prev@ value (link to the previous unit) to 'DictionaryExtraUnit'.+setPrev+ :: BaseType -> DictionaryExtraUnit -> DictionaryExtraUnit+setPrev !prev' (DictionaryExtraUnit (!lo, !hi)) =+ DictionaryExtraUnit (lo, (hi .&. 1) .|. (prev' .<<. 1))+{-# INLINE setPrev #-}++-- | Checks whether the unit is fixed or not.+isFixed :: DictionaryExtraUnit -> Bool+isFixed = (== 1) . (.&. 1) . fst . coerce @_ @(BaseType, BaseType)+{-# INLINE isFixed #-}++-- | Gets the next unit.+next :: DictionaryExtraUnit -> BaseType+next = (.>>. 1) . fst . coerce @_ @(BaseType, BaseType)+{-# INLINE next #-}++-- | Checks whether the unit is used or not.+isUsed :: DictionaryExtraUnit -> Bool+isUsed = (== 1) . (.&. 1) . snd . coerce @_ @(BaseType, BaseType)+{-# INLINE isUsed #-}++-- | Gets the previous unit. +prev :: DictionaryExtraUnit -> BaseType+prev = (.>>. 1) . snd . coerce @_ @(BaseType, BaseType)+{-# INLINE prev #-}
+ src/Data/DAWG/Internal/DictionaryUnit.hs view
@@ -0,0 +1,119 @@+{-|+Module: Data.DAWG.Internal.DictionaryUnit+Description: Exports dictionary unit as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.DictionaryUnit where++import Data.Binary+import Data.Bits+import Data.Vector.Unboxed.Mutable (Unbox)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV++-- ** DAWG Dictionary Unit++-- | Unit of a 'Data.DAWG.Internal.Dictionary.Dictionary'+-- or a 'Data.DAWG.Internal.Dictionary.Builder.DictionaryBuilder'.+newtype DictionaryUnit = DictionaryUnit { base :: BaseType }+ deriving newtype (Eq, Ord, Num, Bits, Integral, Real, Enum, Binary)++instance Show DictionaryUnit where+ show u = concat+ [ "(", show $ base u, ",", show $ hasLeaf u, ",", show $ value u, ",", show $ label u, ",", show $ offset u, ")"]+ {-# INLINE show #-}++newtype instance UV.MVector s DictionaryUnit =+ MV_DictionaryUnit (UV.MVector s BaseType)+newtype instance UV.Vector DictionaryUnit = V_DictionaryUnit (UV.Vector BaseType)++deriving newtype instance V.MVector UV.MVector DictionaryUnit+deriving newtype instance VG.Vector UV.Vector DictionaryUnit+deriving newtype instance Unbox DictionaryUnit++-- | Empty unit. Equivalent to @0@.+empty :: DictionaryUnit+empty = 0+{-# INLINE empty #-}++-- | Maximal offset.+offsetMax :: BaseType+offsetMax = 1 .<<. 21+{-# INLINE offsetMax #-}++-- | @IS_LEAF@ bit.+isLeafBit :: BaseType+isLeafBit = 1 .<<. 31+{-# INLINE isLeafBit #-}++-- | @HAS_LEAF@ bit.+hasLeafBit :: BaseType+hasLeafBit = 1 .<<. 8+{-# INLINE hasLeafBit #-}++-- | @EXTENSION@ bit.+extensionBit :: BaseType+extensionBit = 1 .<<. 9+{-# INLINE extensionBit #-}++-- | Sets @HAS_LEAF@ bit to 'DictionaryUnit'.+setHasLeaf :: DictionaryUnit -> DictionaryUnit+setHasLeaf u = u .|. fromIntegral hasLeafBit+{-# INLINE setHasLeaf #-}++-- | Sets a value as @IS_LEAF@ bit to 'DictionaryUnit'.+setValue :: ValueType -> DictionaryUnit -> DictionaryUnit+setValue v u+ = u { base = fromIntegral v .|. isLeafBit }+{-# INLINE setValue #-}++-- | Sets a label to 'DictionaryUnit'.+setLabel :: UCharType -> DictionaryUnit -> DictionaryUnit+setLabel l u+ = (u .&. complement (0xFF :: DictionaryUnit)) .|. fromIntegral l+{-# INLINE setLabel #-}++-- | Sets an offset to a non-leaf unit. Returns flag as result of setting offset.+--+-- * 'True' if offset has been set to a non-leaf unit.+-- * 'False' if offset was not set.+--+setOffset :: BaseType -> DictionaryUnit -> (Bool, DictionaryUnit)+setOffset offset' (DictionaryUnit b)+ | offset' >= (offsetMax .<<. 8) = (False, DictionaryUnit b)+ | otherwise =+ let base0 = b .&. (isLeafBit .|. hasLeafBit .|. 0xFF)+ base1 = if offset' < offsetMax+ then base0 .|. (offset' .<<. 10)+ else base0 .|. (offset' .<<. 2) .|. extensionBit+ in (True, DictionaryUnit base1)+{-# INLINE setOffset #-}++-- | Checks whether @HAS_LEAF@ bit is set or not.+hasLeaf :: DictionaryUnit -> Bool+hasLeaf u = (base u .&. hasLeafBit) /= 0+{-# INLINE hasLeaf #-}++-- | Gets a value of 'DictionaryUnit'.+value :: DictionaryUnit -> ValueType+value (DictionaryUnit u)+ = fromIntegral (u .&. (complement isLeafBit))+{-# INLINE value #-}++-- | Gets a label of 'DictionaryUnit'.+label :: DictionaryUnit -> BaseType+label u = fromIntegral u .&. (isLeafBit .|. 0xFF)+{-# INLINE label #-}++-- | Calculates offset of 'DictionaryUnit'.+offset :: DictionaryUnit -> BaseType+offset (DictionaryUnit b)+ = (b .>>. 10) .<<. fromIntegral ((b .&. extensionBit) .>>. 6)+{-# INLINE offset #-}
+ src/Data/DAWG/Internal/Guide.hs view
@@ -0,0 +1,77 @@+{-|+Module: Data.DAWG.Internal.Guide+Description: Exports guide as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.Guide where++import Control.DeepSeq (NFData)+import Control.Monad (forM_)+import Data.Binary+import Data.Vector.Unboxed (Vector)+import Data.Vector.Binary ()+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)++import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.GuideUnit (GuideUnit)++import qualified Data.Binary as Binary+import qualified Data.Vector.Unboxed as Vector++import qualified Data.DAWG.Internal.GuideUnit as GuideUnit++-- ** Guide++-- | Guide. Together with 'Data.DAWG.Internal.Dictionary.Dictionary'+-- it provides efficient way to look word prefixes up (completion requests).+--+-- * Each unit is stored in 2 bytes.+-- * Guide size is stored in unsigned int.+--+data Guide = Guide+ { guideUnits :: Vector GuideUnit -- ^ Array of 'Data.DAWG.Internal.GuideUnit.GuideUnit'. Index is equal to 'Data.DAWG.Internal.Dictionary.Dictionary' index.+ , guideSize :: SizeType -- ^ Size of array. Stored separately.+ } deriving (Generic, Binary, NFData)++-- | Constructs an empty guide.+empty :: Guide+empty = Guide+ { guideUnits = Vector.empty+ , guideSize = 0+ }+{-# INLINE empty #-}++-- | Root guide index. Equivalent to @0@.+root :: BaseType+root = 0+{-# INLINE root #-}++-- | Gets a child by given guide index.+child :: HasCallStack => BaseType -> Guide -> UCharType+child !ix !g = GuideUnit.child (guideUnits g Vector.! fromIntegral ix)+{-# INLINE child #-}++-- | Gets a sibling by given guide index.+sibling :: HasCallStack => BaseType -> Guide -> UCharType+sibling !ix !g = GuideUnit.sibling (guideUnits g Vector.! fromIntegral ix)+{-# INLINE sibling #-}++-- | Load guide from a file.+read :: HasCallStack => FilePath -> IO Guide+read = Binary.decodeFile++-- | Save guide to a file.+write :: HasCallStack => FilePath -> Guide -> IO ()+write = Binary.encodeFile++-- | Dump guide to stdout.+dump :: HasCallStack => Guide -> IO ()+dump Guide{..} = do+ let gsize = Vector.length guideUnits+ putStrLn $ concat ["guide\t(", show gsize, ")"]+ forM_ [0 .. gsize - 1] \ix -> do+ putStrLn $ concat+ [show ix, "\t", show $ guideUnits Vector.! fromIntegral ix]
+ src/Data/DAWG/Internal/GuideBuilder.hs view
@@ -0,0 +1,195 @@+{-|+Module: Data.DAWG.Internal.GuideBuilder+Description: Exports guide builder as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE CPP #-}+module Data.DAWG.Internal.GuideBuilder where++import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Bits+import Data.Primitive.MutVar+import GHC.Stack (HasCallStack)++import Data.Primitive.PrimArray.Combinators+import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.DAWG+import Data.DAWG.Internal.Dictionary+import Data.DAWG.Internal.Guide (Guide (..))+import Data.DAWG.Internal.GuideUnit (GuideUnit (..))++import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV++import qualified Data.DAWG.Internal.DAWG as Dawg+import qualified Data.DAWG.Internal.Dictionary as Dict+import qualified Data.DAWG.Internal.GuideUnit as GuideUnit++#ifdef trace+import Data.Char+import Data.DAWG.Trace+#endif++-- ** Guide Builder++-- | A mutable builder of 'Data.DAWG.Internal.Guide.Guide'.+newtype GuideBuilder m = GRef { getGRef :: MutVar (PrimState m) (GuideBuilder_ m) }++-- | Builder of Guide. Do not acess directly. Use 'GuideBuilder' instead.+data GuideBuilder_ m = GuideBuilder+ { guideBuilderDawg :: DAWG -- ^ DAWG.+ , guideBuilderDictionary :: Dictionary -- ^ Dictionary.+ , guideBuilderUnits :: ObjectPool (PrimState m) GuideUnit -- ^ Pool of guide units.+ , guideBuilderIsFixedTable :: ObjectPool (PrimState m) UCharType -- ^ Pool of characters.+ }++-- | Build 'Data.DAWG.Internal.Guide.Guide'+-- from 'Data.DAWG.Internal.DAWG.DAWG' and 'Data.DAWG.Internal.Dictionary.Dictionary'.+-- Returns 'False' if build failed.+build :: HasCallStack => PrimMonad m => DAWG -> Dictionary -> m (Maybe Guide)+build dawg dict = do+ gref@GRef{..} <- new dawg dict+ resizeUnitsAndFlags gref++ gb <- readMutVar getGRef+ if dictionarySize (guideBuilderDictionary gb) == 1+ then freeze gb >>= pure . Just+ else do+ buildFromIndexes Dawg.root Dict.root gb >>= \case+ False -> pure Nothing+ True -> freeze gb >>= pure . Just+{-# INLINE build #-}++-- | Same as 'build' but throws an error if build fails.+build' :: HasCallStack => PrimMonad m => DAWG -> Dictionary -> m Guide+build' dawg dict = build dawg dict >>= \case+ Just guide -> pure guide+ Nothing -> error "failed to build guide"+{-# INLINE build' #-}++-- | Generates 'Data.DAWG.Internal.Guide.Guide' out of 'GuideBuilder'.+-- Once this function is called, 'GuideBuilder' must not be used anymore.+freeze :: PrimMonad m => GuideBuilder_ m -> m Guide+freeze gb = do+ funits <- UV.freeze $ guideBuilderUnits gb + let !guideUnits = (UV.fromList . UV.toList) funits+ let !guideSize = fromIntegral $ UV.length guideUnits+ pure Guide{..}+{-# INLINE freeze #-}++-- ** Helpers++-- | Initialises a new 'GuideBuilder' from DAWG and Dictionary.+new :: PrimMonad m => DAWG -> Dictionary -> m (GuideBuilder m)+new guideBuilderDawg guideBuilderDictionary = do+ guideBuilderUnits <- V.new 0+ guideBuilderIsFixedTable <- V.new 0+ let g = GuideBuilder{..}+ GRef <$> newMutVar g+{-# INLINE new #-}++-- | Resize both units and flags based on a dictionary size. If guide size is equal or greater than dictionary size, it will leave guide builder unchanged.+resizeUnitsAndFlags :: PrimMonad m => GuideBuilder m -> m ()+resizeUnitsAndFlags GRef{..} = do+ gb <- readMutVar getGRef+ let dictSize = fromIntegral $ dictionarySize $ guideBuilderDictionary gb+ unitsSize = V.length $ guideBuilderUnits gb+ flagsSize = V.length $ guideBuilderIsFixedTable gb+ newUnits <- V.grow (guideBuilderUnits gb)+ $ if unitsSize < dictSize then dictSize - unitsSize else 0+ newFlags <- V.grow (guideBuilderIsFixedTable gb)+ $ if flagsSize < dictSize then dictSize - flagsSize else 0+ let !ngb = gb { guideBuilderUnits = newUnits, guideBuilderIsFixedTable = newFlags }+ writeMutVar getGRef ngb+{-# INLINE resizeUnitsAndFlags #-}++-- | Build guide recursively from dawg index and dictionary index.+-- Returns 'Nothing' if fails.+buildFromIndexes :: PrimMonad m => BaseType -> BaseType -> GuideBuilder_ m -> m Bool+buildFromIndexes !dawgIx !dictIx !gb = do+#ifdef trace+ ifd <- isFixed dictIx gb+ traceIO $ concat+ ["buildGuide dawgIx ", show dawgIx+ , " dawgChildIx ", show $ Dawg.child dawgIx (guideBuilderDawg gb)+ , " dictIx ", show dictIx, " is_fixed_dix ", show ifd+ ]+#endif+ isFixed dictIx gb >>= \case+ True -> pure True+ False -> do+ setIsFixed dictIx gb++ -- finds the first non-terminal child.+ let !dawg = guideBuilderDawg gb+ !dict = guideBuilderDictionary gb+ !dawgChildIx = Dawg.child dawgIx dawg+ dawgChildIxRef <- newMutVar dawgChildIx+#ifdef trace+ traceIO $ concat+ [ "-buildGuide dawgChildIx ", show dawgChildIx+ , " l ", show $ chr $ fromIntegral $ Dawg.label dawgChildIx dawg+ , " (", show $ Dawg.label dawgChildIx dawg, ")"+ ]+#endif+ when (Dawg.label dawgChildIx dawg == 0) do+ writeMutVar dawgChildIxRef $! Dawg.sibling dawgChildIx dawg++ !dawgChildIx' <- readMutVar dawgChildIxRef+ if dawgChildIx' == 0+ then pure True+ else do+ guideBuilderUnits gb !<~~ dictIx+ $! GuideUnit.setChild $! Dawg.label dawgChildIx' dawg++ let go !ix !dictIx'+ | ix == 0 = pure True+ | otherwise = do+ let !childLabel = Dawg.label ix dawg+#ifdef trace+ traceIO $ concat+ ["-go dawgChildIx ", show ix, " dictChildIx ", show dictIx'+ , " childLabel ", show childLabel+ ]+#endif+ case Dict.followChar (fromIntegral childLabel) dictIx' dict of+ Nothing -> pure False+ Just dictChildIx -> do+#ifdef trace+ traceIO $ concat+ [ "-go follow dawgChildIx ", show ix+ , " dictChildIx ", show dictChildIx+ ]+#endif+ -- outer recursion loop+ buildFromIndexes ix dictChildIx gb >>= \case+ False -> pure False+ True -> do+ let !dawgSiblingIx = Dawg.sibling ix dawg+ !siblingLabel = Dawg.label dawgSiblingIx dawg+ when (dawgSiblingIx /= 0) do+ guideBuilderUnits gb !<~~ dictChildIx+ $! GuideUnit.setSibling siblingLabel++ go dawgSiblingIx dictIx'++ go dawgChildIx' dictIx+{-# INLINE buildFromIndexes #-}++-- | Sets dictionary unit as fixed by index.+setIsFixed :: PrimMonad m => BaseType -> GuideBuilder_ m -> m ()+setIsFixed !ix gb = do+ let setIsFixed' !v = v .|. (1 .<<. (fromIntegral ix `mod` 8))+ guideBuilderIsFixedTable gb !<~~ (fromIntegral ix `div` 8) $! setIsFixed'+{-# INLINE setIsFixed #-}++-- | Checks whether given dictionary index is fixed or not.+isFixed :: PrimMonad m => BaseType -> GuideBuilder_ m -> m Bool+isFixed !ix gb = do+ v <- guideBuilderIsFixedTable gb !~ (fromIntegral ix `div` 8)+ let x = v .&. (1 .<<. (fromIntegral ix `mod` 8))+ pure $ x /= 0+{-# INLINE isFixed #-}
+ src/Data/DAWG/Internal/GuideUnit.hs view
@@ -0,0 +1,68 @@+{-|+Module: Data.DAWG.Internal.GuideUnit+Description: Exports guide unit as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.GuideUnit where++import Control.DeepSeq (NFData)+import Data.Binary+import Data.Vector.Unboxed.Mutable (Unbox)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as V+import qualified Data.Vector.Unboxed as UV ++-- ** Guide Unit++-- | Unit of a 'Data.DAWG.Internal.Guide' or a 'Data.DAWG.Internal.GuideBuilder'.+-- Contains an information about child character and sibling character.+--+-- * Input characters should be mapped in the 0-255 range.+--+newtype GuideUnit = GuideUnit+ { unGuideUnit+ :: ( UCharType -- child+ , UCharType -- sibling+ )+ }+ deriving newtype (Show, Eq, Ord, Binary, NFData)++newtype instance UV.MVector s GuideUnit = MV_GuideUnit (UV.MVector s (UCharType, UCharType))+newtype instance UV.Vector GuideUnit = V_GuideUnit (UV.Vector (UCharType, UCharType))++deriving newtype instance V.MVector UV.MVector GuideUnit+deriving newtype instance VG.Vector UV.Vector GuideUnit+deriving newtype instance Unbox GuideUnit++-- | Empty unit. Equivalent to @0@.+empty :: GuideUnit+empty = GuideUnit (0, 0)+{-# INLINE empty #-}++-- | Gets the child character.+child :: GuideUnit -> UCharType+child (GuideUnit (!child', !_)) = child'+{-# INLINE child #-}++-- | Gets the sibling character.+sibling :: GuideUnit -> UCharType+sibling (GuideUnit (!_, !sibling')) = sibling'+{-# INLINE sibling #-}++-- | Sets a child character to the given unit.+setChild :: UCharType -> GuideUnit -> GuideUnit+setChild !newChild (GuideUnit (!_oldChild, !sibling')) =+ GuideUnit (newChild, sibling')+{-# INLINE setChild #-}++-- | Sets a sibling character to the given unit.+setSibling :: UCharType -> GuideUnit -> GuideUnit+setSibling !newSibling (GuideUnit (!child', !_oldSibling)) =+ GuideUnit (child', newSibling)+{-# INLINE setSibling #-}
+ src/Data/DAWG/Internal/LinkTable.hs view
@@ -0,0 +1,62 @@+{-|+Module: Data.DAWG.Internal.LinkTable+Description: Exports link table used to build dictionary as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE BangPatterns #-}+module Data.DAWG.Internal.LinkTable where++import Control.Monad (forM_, when)+import Control.Monad.Primitive (PrimMonad)+import Data.Maybe (fromMaybe)++import Data.DAWG.Internal.BaseType++import qualified Data.Vector.Hashtables as HT++-- ** 'LinkTable'++-- | Alias for 'UUHT' that holds a pair of index with offset as value+-- associated with a hash as a key.+type LinkTable m = UUHT m BaseType (BaseType, BaseType)++-- | Allocates a table space with given size.+init :: PrimMonad m => LinkTable m -> BaseType -> m ()+init ht size = do+ when (size > 0) $ forM_ [0 .. size - 1] \ix -> do+ HT.insert ht (fromIntegral ix) (0, 0)+{-# INLINE init #-}++-- | Stores index with offset into the table.+insert :: PrimMonad m => LinkTable m -> BaseType -> BaseType -> m ()+insert ht !ix !offset = do+ !hid <- findId ht ix+ HT.insert ht hid (ix, offset)+{-# INLINE insert #-}++-- | Find an offset that corresponds to a given index.+find :: PrimMonad m => LinkTable m -> BaseType -> m BaseType+find ht ix = do+ !hid <- findId ht ix+ HT.lookup ht hid >>= pure . fromMaybe 0 . fmap snd+{-# INLINE find #-}++-- ** Helpers++-- | Finds a hash associated with a given index.+findId :: PrimMonad m => LinkTable m -> BaseType -> m BaseType+findId ht !ix = do+ htsize <- HT.size ht+ let !startHid = fromIntegral (hashBaseType ix `mod` htsize)+ go !hid = do+ let !nextHid = succ hid `mod` fromIntegral htsize+ HT.lookup ht (fromIntegral hid) >>= \case+ Nothing -> pure hid+ Just result -> if fst result == ix || fst result == 0+ then pure hid+ else go nextHid+ go startHid+{-# INLINE findId #-}+
+ src/Data/DAWG/Internal/Stack.hs view
@@ -0,0 +1,64 @@+{-|+Module: Data.DAWG.Internal.Stack+Description: Exports stack data as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.Stack where++import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Primitive.MutVar++import Data.DAWG.Internal.BaseType++-- ** Stack++-- | Represents mutable stack. Used to build DAWG in 'Data.DAWG.Internal.DAWGBuilder.DAWGBuilder'.+-- Implements subset of @std::stack@ API.+newtype Stack m = StackRef { getStackRef :: MutVar m Stack_ }++-- | Represents immutable stack with explicit data constructors.+-- | For mutable version see 'Stack'.+data Stack_+ = Elem {-# UNPACK #-} !BaseType !Stack_+ | EndOfStack+ deriving Show++-- | Pushes given element to the stack.+push :: forall m. PrimMonad m => BaseType -> Stack (PrimState m) -> m ()+push v ref =+ let go = \case+ EndOfStack -> Elem v EndOfStack+ Elem !prev !st -> Elem v (Elem prev st)+ in modifyMutVar' (getStackRef ref) go+{-# INLINE push #-}++-- | Gets a single element from the given immutable stack if it is present.+-- Returns 'Nothing' otherwise. For mutable version see 'top'.+top_ :: Stack_ -> Maybe BaseType+top_ = \case+ EndOfStack -> Nothing+ Elem !el !_st -> Just el+{-# INLINE top_ #-}++-- | Gets a single element from the given mutable stack if it is present.+top :: forall m. PrimMonad m => Stack (PrimState m) -> m (Maybe BaseType)+top ref = readMutVar (getStackRef ref) >>= pure . top_+{-# INLINE top #-}++-- | Drops a single element from the given mutable stack.+-- If stack is empty, no changes will happen.+pop :: forall m. PrimMonad m => Stack (PrimState m) -> m ()+pop ref = readMutVar (getStackRef ref) >>= \case+ EndOfStack -> pure ()+ Elem !_el !st -> writeMutVar (getStackRef ref) st+{-# INLINE pop #-}++-- | Calculates size of the immutable stack.+size :: Stack_ -> Int+size EndOfStack = 0+size (Elem !_a rest) =+ let !prevStackSize = size rest+ in succ prevStackSize+{-# INLINE size #-}
+ src/Data/Primitive/PrimArray/Combinators.hs view
@@ -0,0 +1,43 @@+{-|+Module: Data.Primitive.PrimArray.Combinators+Description: Exports combinators used in mutable builders.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.Primitive.PrimArray.Combinators where++import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Vector.Generic.Mutable (MVector)+import GHC.Stack (HasCallStack)++import Data.DAWG.Internal.BaseType++import qualified Data.Primitive.PrimArray as A+import qualified Data.Vector.Generic.Mutable as V++-- | Alias for 'MutablePrimArray' @s@ 'Int'.+type IntArray s = A.MutablePrimArray s Int++-- | Infix version of @unsafeRead@.+(!~) :: (MVector v a, PrimMonad m, HasCallStack) => v (PrimState m) a -> BaseType -> m a+(!~) xs !i = V.read xs (fromIntegral i)++-- | Infix version of @unsafeWrite@.+(<~~) :: (MVector v a, PrimMonad m, HasCallStack) => v (PrimState m) a -> BaseType -> a -> m ()+(<~~) xs !i x = V.write xs (fromIntegral i) x++-- | Infix version of @modify@. Modifies element at the given position.+(!<~~) :: (MVector v a, PrimMonad m, HasCallStack) => v (PrimState m) a -> BaseType -> (a -> a) -> m ()+(!<~~) xs !i f = do+ !x <- xs !~ i+ let !nx = f x+ xs <~~ i $! nx++-- | Infix version of @writePrimArray@.+(<~) :: (PrimMonad m) => A.MutablePrimArray (PrimState m) Int -> Int -> Int -> m ()+(<~) = A.writePrimArray++-- | Infix version of @readPrimArray@.+(!) :: (PrimMonad m) => A.MutablePrimArray (PrimState m) Int -> Int -> m Int+(!) = A.readPrimArray
+ test/Data/DAWG/BuildSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE BlockArguments #-}+module Data.DAWG.BuildSpec where++import qualified Data.DAWG.DAWG as DAWG+import qualified Data.DAWG.Dictionary as Dict++import Control.Monad (forM_)+import Data.Maybe (isJust)+import Test.Hspec++import qualified Data.Vector as Vector++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "DAWG" do+ it "DAWG builds from words, DAWG contains words" do+ let insert' builder (k, ml, result) = do+ res <- case ml of+ Nothing -> DAWG.insert (Vector.fromList k) Nothing builder+ Just l -> DAWG.insertWithLength (Vector.fromList k) l 0 builder+ res `shouldBe` result+ contains' dict w = Dict.contains w dict `shouldBe` True+ dictDataset = ["apple", "cherry", "durian", "green", "mandarin"]+ dawgDataset =+ [ ("apple", Nothing, True)+ , ("cherry", Nothing, True)+ , ("banana", Nothing, False)+ , ("durian", Nothing, True)+ , ("green\0apple", Just 11, False)+ , ("green\0apple", Nothing, True)+ , ("mandarin orange", Just 8, True)+ , ("mandarin", Nothing, True)+ ]+ db <- DAWG.new+ forM_ dawgDataset \entry -> do+ insert' db entry+ dawg <- DAWG.freeze db++ mDictB <- Dict.build dawg+ isJust mDictB `shouldBe` True+ forM_ mDictB \dictB -> do+ dict <- Dict.freeze dictB+ forM_ dictDataset \entry -> do+ contains' dict entry
+ test/Data/DAWG/CompleterSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE BlockArguments #-}+module Data.DAWG.CompleterSpec where++import Data.DAWG.Internal.BaseType++import Data.DAWG.Completer (keyToString, start, next)++import qualified Data.DAWG.Completer as C+import qualified Data.DAWG.Guide as G+import qualified Data.DAWG.DAWG as DAWG+import qualified Data.DAWG.Dictionary as Dict++import Control.Monad (forM_)+import Data.Maybe (fromMaybe, isJust)+import Test.Hspec+import Text.Read (readMaybe)++import qualified Data.Vector as Vector++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Completer" do+ it "Builds a completer from a lexicon" do+ db <- DAWG.new+ contents <- readFile "data/lexicon"+ forM_ (lines contents) \l -> do+ let (w, strVal) = break (== '\t') l+ mVal = readMaybe . drop 1 $ strVal+ value = fromMaybe maxBound mVal :: ValueType+ DAWG.insert (Vector.fromList w) (Just value) db+ dawg <- DAWG.freeze db+ mDictB <- Dict.build dawg+ forM_ mDictB \dictBuilder -> do+ dict <- Dict.freeze dictBuilder+ Dict.write "lexicon.dic" dict+ isJust mDictB `shouldBe` True++ dict <- Dict.read "lexicon.dic"+ mGuide <- G.build dawg dict+ isJust mGuide `shouldBe` True+ forM_ mGuide \guide -> G.write "lexicon.gde" guide+ + it "Completes keys from a lexicon" do+ let completerResultFile = "completer-result"+ goNext w c = case next c of+ Nothing -> pure ()+ Just !nc -> do+ appendFile completerResultFile $ concat+ [ " ", w, keyToString nc, " = ", show $ C.value nc ]+ goNext w nc++ go :: BaseType -> String -> String -> Dict.Dictionary -> G.Guide -> IO ()+ go _dictIx _fullWord [] _dict _guide = pure ()+ go dictIx fw w d g = do+ case Dict.followPrefixLength w (fromIntegral $ length w) dictIx d of+ Nothing -> pure ()+ Just nextDictIx -> do+ let !nc = start nextDictIx "" d g+ goNext fw nc+ go nextDictIx fw w d g++ writeFile completerResultFile ""+ dict <- Dict.read "lexicon.dic"+ guide <- G.read "lexicon.gde"+ + contents <- readFile "data/query"+ forM_ (lines contents) \l -> do+ appendFile completerResultFile $ concat [ l, ":" ]+ go Dict.root l l dict guide+ appendFile completerResultFile "\n"++ True `shouldBe` True++ it "Checks results" do+ let completerResultFile = "completer-result"+ testResult <- readFile completerResultFile+ testExpectation <- readFile "data/completer-answer"+ testResult `shouldBe` testExpectation
+ test/Data/DAWG/DictionarySpec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BlockArguments #-}+module Data.DAWG.DictionarySpec where++import Data.DAWG.Internal.BaseType++import qualified Data.DAWG.DAWG as DAWG+import qualified Data.DAWG.Dictionary as Dict++import Control.Monad (forM_, when)+import Data.Char (ord)+import Data.Maybe (fromMaybe, isJust)+import Test.Hspec+import Text.Read (readMaybe)++import qualified Data.Vector as Vector++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Dictionary" do+ it "Builds a dictionary from a lexicon" do+ db <- DAWG.new+ contents <- readFile "data/lexicon"+ forM_ (lines contents) \l -> do+ let (w, strVal) = break (== '\t') l+ mVal = readMaybe . drop 1 $ strVal+ value = fromMaybe maxBound mVal :: ValueType+ DAWG.insert (Vector.fromList w) (Just value) db+ dawg <- DAWG.freeze db+ mDictB <- Dict.build dawg+ forM_ mDictB \dictBuilder -> do+ dict <- Dict.freeze dictBuilder+ Dict.write "lexicon.dic" dict+ isJust mDictB `shouldBe` True+ + it "Finds prefix keys from a lexicon" do+ let dictResultFile = "dictionary-result"+ + go _dictIx _word [] _dict = pure ()+ go dictIx w ((k, ix) : rest) d = do+ case Dict.followChar k dictIx d of+ Nothing -> pure ()+ Just nextDictIx -> do+ when (Dict.hasValue nextDictIx d) do+ appendFile dictResultFile $ concat+ [ " ", take (ix + 1) w, " = ", show $ Dict.value nextDictIx d, ";" ]+ go nextDictIx w rest d++ writeFile dictResultFile ""+ dict <- Dict.read "lexicon.dic"+ + contents <- readFile "data/query"+ forM_ (lines contents) \l -> do+ appendFile dictResultFile $ concat [ l, ":" ]+ let queries = zip ((fromIntegral . ord) <$> l) [0 .. length l - 1]+ go Dict.root l queries dict+ appendFile dictResultFile "\n"++ True `shouldBe` True++ it "Checks results" do+ let dictResultFile = "dictionary-result"+ testResult <- readFile dictResultFile+ testExpectation <- readFile "data/dictionary-answer"+ testResult `shouldBe` testExpectation
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}