dawgdic 0.1.0 → 1.0.0

raw patch · 26 files changed

+1557/−486 lines, 26 filesdep +QuickCheckdep +bytestringdep +containersdep −vector-binarynew-component:exe:dawgdicPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, bytestring, containers, optparse-applicative, vector-algorithms

Dependencies removed: vector-binary

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +40/−35
• app/Main.hs +143/−0
• bench/Main.hs +11/−3
• dawgdic.cabal +33/−9
• src-trace/Data/DAWG/Trace.hs +0/−18
• src/Data/DAWG/Completer.hs +1/−1
• src/Data/DAWG/Internal/Completer.hs +36/−58
• src/Data/DAWG/Internal/DAWGBuilder.hs +2/−128
• src/Data/DAWG/Internal/Dictionary.hs +40/−24
• src/Data/DAWG/Internal/DictionaryBuilder.hs +1/−152
• src/Data/DAWG/Internal/DictionaryUnit.hs +7/−1
• src/Data/DAWG/Internal/Guide.hs +22/−4
• src/Data/DAWG/Internal/GuideBuilder.hs +4/−36
• src/Data/DAWG/Internal/GuideUnit.hs +10/−1
• src/Data/DAWG/Internal/RankedCompleter.hs +361/−0
• src/Data/DAWG/Internal/RankedCompleterCandidate.hs +52/−0
• src/Data/DAWG/Internal/RankedCompleterNode.hs +71/−0
• src/Data/DAWG/Internal/RankedGuide.hs +53/−0
• src/Data/DAWG/Internal/RankedGuideBuilder.hs +265/−0
• src/Data/DAWG/Internal/RankedGuideLink.hs +64/−0
• src/Data/DAWG/RankedCompleter.hs +93/−0
• src/Data/DAWG/RankedGuide.hs +56/−0
• test/Data/DAWG/CompleterSpec.hs +20/−16
• test/Data/DAWG/DictionarySpec.hs +9/−0
• test/Data/DAWG/RankedCompleterSpec.hs +155/−0

@@ -1,5 +1,13 @@ # Revision history for `dawgdic` +## 1.0.0 -- 2026-01-10++* Remove all traces from the code (see [#30](https://github.com/swamp-agr/dawgdic/pull/30)).+* **Breaking change**: ensure binary compatibility across two implementations via custom `Binary` instances for `Dictionary`, `Guide` and `RankedGuide` (see [#29](https://github.com/swamp-agr/dawgdic/pull/29)). +* Port missing `RankedGuide` from C++ (see [#26](https://github.com/swamp-agr/dawgdic/pull/26)).+* **Breaking change**: include `Dictionary` in `Guide` (see [#25](https://github.com/swamp-agr/dawgdic/pull/25)).+* Port `dawgdic-find` and `dawgdic-build` binaries from C++ to a single executable with sub-commands (see [#23](https://github.com/swamp-agr/dawgdic/pull/23)).+ ## 0.1.0 -- 2025-08-28  * First version. Released on an unsuspecting world.

@@ -108,32 +108,35 @@ ### 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-------------------------------------- ------------+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              293.73+Utilities/10/RankedCompleter.completeKeys       3437.14+------------------------------------------- ------------+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             5157.75+Utilities/100/RankedCompleter.completeKeys      66817.64+------------------------------------------- ------------+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           56788.87+Utilities/1000/RankedCompleter.completeKeys   1333117.49+------------------------------------------- ------------ ```  ### How to reproduce:@@ -230,15 +233,15 @@ 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+10/dawgdic.complete word            305.66+10/dawg.complete word               240.24+10/packed-dawg.complete word        315.09+100/dawgdic.complete word          5341.40+100/dawg.complete word             4497.49+100/packed-dawg.complete word      4866.73+1000/dawgdic.complete word        59699.40+1000/dawg.complete word           55223.88+1000/packed-dawg.complete word    59961.42 ------------------------------ ----------- ``` @@ -267,6 +270,8 @@ In cases of issues please attach callstack, provide minimal dictionary lexicon and provide logs with enabled tracing.  ```+git pull+git switch traces cabal build -ftrace ``` 

@@ -0,0 +1,143 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Control.Monad (forM_, when)+import Data.Char (ord)+import qualified Data.Vector as Vector+import Options.Applicative+import Text.Read (readMaybe)++import qualified Data.DAWG.Internal.DAWGBuilder as DB+import Data.DAWG.Completer (keyToString, start, next)+import qualified Data.DAWG.Completer as C+import qualified Data.DAWG.DAWG as DAWG+import qualified Data.DAWG.Dictionary as Dict+import qualified Data.DAWG.Guide as Guide++main :: IO ()+main = execParser (info (commands <**> helper) idm) >>= run++-- ** CLI++data WithGuide = WithGuide | WithRankedGuide++data Opts = Opts+  { lexiconPath :: FilePath+  , tabSeparator :: Bool+  , withGuide :: Maybe WithGuide+  , dictionaryPath :: FilePath+  }++data Command = Build Opts | Find Opts++commands :: Parser Command+commands = subparser+  (command "build" (info buildOpts (progDesc "Build dictionary from lexicon"))+  <> (command "find" (info findOpts (progDesc "Find words in dictionary"))))+  where+    buildOpts = Build <$> opts+    findOpts = Find <$> opts+    opts = Opts+      <$> strOption+        (  long "lexicon"+        <> short 'l'+        <> metavar "FILE"+        <> help "Lexicon path")+      <*> switch+        (  long "tab-separated"+        <> short 't'+        <> help "Use tab as separator")+      <*> optional (guideOpts <|> rankedGuideOpts)+      <*> strOption+        (  long "dictionary"+        <> short 'd'+        <> metavar "FILE"+        <> help "Dictionary path")+    guideOpts = flag' WithGuide+      (long "guide" <> short 'g' <> help "Build dictionary with guide")+    rankedGuideOpts = flag' WithRankedGuide+      (long "ranked-guide" <> short 'r' <> help "Build dictionary with ranked-guide")+      +run :: Command -> IO ()+run = \case+  Build Opts{..} -> do+    contents <- readFile lexiconPath++    let check !n+          | n < 0 = 0+          | otherwise = n++        toKeyValue !line =+          let (w, strVal) = break (== '\t') line+              mVal = readMaybe . drop 1 $ strVal+          in (w, check <$> mVal)++        makeLexicon = if tabSeparator+          then fmap toKeyValue+          else fmap (\x -> (x, Nothing))++        lexicon = makeLexicon (lines contents)++    db <- DB.new+    forM_ lexicon \(w, mVal)  -> do+      DB.insert (Vector.fromList w) mVal db+    dawg <- DAWG.freeze db+    dict <- Dict.build' dawg++    case withGuide of+      Nothing -> Dict.write dictionaryPath dict+      Just WithGuide -> do+        guide <- Guide.build' dawg dict+        Dict.write dictionaryPath dict+        Guide.write ("guide." <> dictionaryPath) guide+      Just WithRankedGuide -> error "not implemented yet"+    +  Find Opts{..} -> do+    contents <- readFile lexiconPath+    case withGuide of+      Nothing -> do+        let 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+                    putStr $ concat+                      [ " ", take (ix + 1) w, " = ", show $ Dict.value nextDictIx d, ";" ]+                  go nextDictIx w rest d++        dict <- Dict.read dictionaryPath+        forM_ (lines contents) \l -> do+          putStr $ concat [l, ":"]+          let queries = zip ((fromIntegral . ord) <$> l) [0 .. length l - 1]+          go Dict.root l queries dict+          putStr "\n"++      Just WithGuide -> do+        let goNext w c = case next c of+              Nothing -> pure ()+              Just !nc -> do+                putStr $ concat+                  [ " ", w, keyToString nc, " = ", show $ C.value nc ]+                goNext w nc++            go _dictIx _fullWord [] _guide = pure ()+            go dictIx fw w g = do+              let d = Guide.guideDictionary g+              case Dict.followPrefixLength w (fromIntegral $ length w) dictIx d of+                Nothing -> pure ()+                Just nextDictIx -> do+                  let !nc = start nextDictIx "" g+                  goNext fw nc+                  go nextDictIx fw w g+        dict <- Dict.read dictionaryPath+        guide <- Guide.read $ "guide." <> dictionaryPath+        forM_ (lines contents) \l -> do+          putStr $ concat [l, ":"]+          go Dict.root l l guide+          putStr "\n"+        +      Just WithRankedGuide -> error "not implemented yet"

@@ -9,7 +9,9 @@ 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.RankedGuide as RG import qualified Data.DAWG.Completer as C+import qualified Data.DAWG.RankedCompleter as RC  -- ** Dataset preparation @@ -72,15 +74,20 @@   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+completerCompleteKeysBench !guide lexicon =+  let go !w = C.completeKeys w guide   in concatMap go lexicon +rankedCompleterCompleteKeysBench !guide lexicon =+  let go !w = RC.completeKeys w 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+  !rguide <- evaluate =<< RG.build' dawg dict   return $ bgroup (show n)     [ bench "Dawg.fromAscList" $ nfIO (dawgFromAscListBench lexiconN)     , bench "Dict.build'" $ nfIO (Dict.build' dawg)@@ -88,7 +95,8 @@     , 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+    , bench "Completer.completeKeys" $ nf (completerCompleteKeysBench guide) lexiconN+    , bench "RankedCompleter.completeKeys" $ nf (rankedCompleterCompleteKeysBench rguide) lexiconN     ]  -- ** Main

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0+version:            1.0.0  -- A short (one-line) description of the package. synopsis: Generation and traversal of compressed directed acyclic dawg graphs@@ -56,8 +56,8 @@ common warnings     ghc-options: -Wall -flag trace-     description: Enable tracing+flag exe+     description: Build executable      manual: True      default: False @@ -90,16 +90,19 @@                       Data.DAWG.Internal.GuideBuilder                       Data.DAWG.Internal.GuideUnit                       Data.DAWG.Internal.LinkTable+                      Data.DAWG.Internal.RankedCompleter+                      Data.DAWG.Internal.RankedCompleterCandidate+                      Data.DAWG.Internal.RankedCompleterNode+                      Data.DAWG.Internal.RankedGuide+                      Data.DAWG.Internal.RankedGuideBuilder+                      Data.DAWG.Internal.RankedGuideLink                       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+                      Data.DAWG.RankedCompleter+                      Data.DAWG.RankedGuide      -- Modules included in this library but not exported.     -- other-modules:@@ -111,11 +114,13 @@     build-depends:    base  >= 4.17.2.1 && < 4.25.0.0                     , binary                     , bitvec+                    , bytestring                     , deepseq                     , hashable                     , primitive+                    , containers                     , vector-                    , vector-binary+                    , vector-algorithms                     , vector-hashtables      -- Directories containing source files.@@ -161,9 +166,13 @@     -- Test dependencies.     build-depends:                   base  >= 4.17.2.1 && < 4.25.0.0+                , binary+                , bytestring+                , containers                 , dawgdic                 , hashable                 , hspec+                , QuickCheck                 , text                 , vector @@ -175,3 +184,18 @@       Data.DAWG.BuildSpec       Data.DAWG.CompleterSpec       Data.DAWG.DictionarySpec+      Data.DAWG.RankedCompleterSpec++executable dawgdic+  main-is: app/Main.hs+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >= 4.17.2.1 && < 4.25.0.0+    , optparse-applicative+    , vector+  default-language: Haskell2010+  if flag(exe)+    build-depends:+      dawgdic+  else+    buildable: False

@@ -1,18 +0,0 @@-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

@@ -61,7 +61,7 @@ -- -- Begin completing. Prepare 'Completer' to traverse the dictionary using guide. ----- >>> let c_started = start dictIndex "a" dict guide+-- >>> let c_started = start dictIndex "a" guide -- -- Get next completion result --

@@ -5,7 +5,6 @@ License: BSD-3-Clause Stability: experimental -}-{-# LANGUAGE CPP #-} module Data.DAWG.Internal.Completer where  import Control.Monad.ST (runST)@@ -24,37 +23,30 @@ 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+  { completerGuide :: !Guide   , completerKey :: !(Vector UCharType)   , completerIndexStack :: !Stack_   , completerLastIndex :: !BaseType   } +-- | Helper to access a 'Dictionary' from a 'Completer'.+completerDictionary :: Completer -> Dictionary+completerDictionary = guideDictionary . completerGuide+{-# INLINE completerDictionary #-}+ -- | 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+start :: HasCallStack => BaseType -> String -> Guide -> Completer+start !ix !prefix !guide  =       let !gsize = guideSize guide           prefix' = Vector.map (fromIntegral @_ @UCharType . ord) $ Vector.fromList prefix            !nc = Completer-           { completerDictionary = dict-           , completerGuide = guide+           { completerGuide = guide            , completerKey = runST do                let l = Vector.length prefix'                v <- Vector.unsafeThaw prefix'@@ -83,16 +75,7 @@       {-# 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@@ -127,12 +110,6 @@       {-# 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@@ -172,39 +149,39 @@ -- >>> 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+completeKeys :: String -> Guide -> [String]+completeKeys !prefix guide = +  let !dict = guideDictionary guide+      goDict !dictIx !acc =+        case Dict.follow prefix 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+            let !nc = start nextDictIx "" guide+                !nacc = goNext nc acc+            in goDict nextDictIx nacc+      goNext !comp !acc = 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+          in goNext nc nacc+  -- please re-run comparison benchmarks if you want to modify this function+  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 =+completeLexicon completerSelector guide =+  let goDict guide' !firstChar =         let prefix = chr $ fromIntegral firstChar-        in case Dict.followChar firstChar 0 dict' of+        in case Dict.followChar firstChar 0 (guideDictionary guide') of           Nothing -> []           Just !nextDictIx ->-            let !nc = start nextDictIx "" dict' guide'+            let !nc = start nextDictIx "" guide'             in goNext [] prefix nc        goNext acc prefix comp = case next comp of@@ -215,33 +192,33 @@           in goNext nacc prefix nc    -- FIXME: optimise it even further-  in concatMap  (goDict dict guide) [(1 :: CharType) .. 127]+  in concatMap  (goDict guide) [(1 :: CharType) .. 127] {-# INLINE completeLexicon #-}  -- | Traverses the entire DAWG, returns only words in no particular order.-keys :: Dictionary -> Guide -> [String]-keys dict guide =+keys :: Guide -> [String]+keys guide =   let selectWord prefix comp = prefix : keyToString comp-  in completeLexicon selectWord dict guide+  in completeLexicon selectWord 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 =+values :: Guide -> [ValueType]+values guide =   let selectValue _prefix = value-  in completeLexicon selectValue dict guide+  in completeLexicon selectValue 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 =+toList :: Guide -> [(String, ValueType)]+toList guide =   let selectPair prefix comp =         let !k = prefix : keyToString comp             !v = value comp         in (k, v)-  in completeLexicon selectPair dict guide+  in completeLexicon selectPair guide  -- ** Helpers @@ -280,6 +257,7 @@                          }              in findTerminal nextIx nc +-- | Helper which appends label to the end of the key vector and resizes the vector. appendKeyLabel :: CharType -> Int -> Vector UCharType -> Vector UCharType appendKeyLabel !label !ksize !key = runST do   v <- Vector.unsafeThaw key

@@ -5,7 +5,6 @@ License: BSD-3-Clause Stability: experimental -}-{-# LANGUAGE CPP #-} module Data.DAWG.Internal.DAWGBuilder where  import Control.Monad (forM_, when, unless)@@ -35,10 +34,6 @@ 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'.@@ -171,16 +166,6 @@                 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@@ -218,11 +203,6 @@       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'.@@ -235,24 +215,13 @@     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@@ -372,11 +341,6 @@       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 @@ -386,10 +350,6 @@           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@@ -399,13 +359,6 @@                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@@ -422,19 +375,9 @@                   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@@ -448,22 +391,12 @@               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)@@ -494,9 +427,6 @@             dawgBuilderHashTable db <~~ fromIntegral hashId $ fromIntegral ix    V.iforM_ (dawgBuilderBasePool db) go-#ifdef trace-  traceIO $ "expandHashTable done"-#endif {-# INLINE expandHashTable #-}  -- | Finds suitable transition index.@@ -511,9 +441,6 @@        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@@ -536,30 +463,11 @@       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)+            True -> 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 #-} @@ -571,26 +479,10 @@   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)+  let goUnit !tix 0 = 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@@ -604,15 +496,6 @@         !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')@@ -632,9 +515,6 @@   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'@@ -654,9 +534,6 @@       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@@ -713,9 +590,6 @@ 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)

@@ -5,30 +5,26 @@ License: BSD-3-Clause Stability: experimental -}-{-# LANGUAGE CPP #-} module Data.DAWG.Internal.Dictionary where  import Control.DeepSeq (NFData)-import Control.Monad (forM_)+import Control.Monad (forM_, when) import Data.Binary+import Data.Binary.Get (getWord32le)+import Data.Binary.Put (putWord32le) 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 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.@@ -38,8 +34,30 @@ data Dictionary = Dictionary   { dictionaryUnits :: UV.Vector DictionaryUnit -- ^ Array of dictionary units.   , dictionarySize :: SizeType -- ^ Size of the dictionary.-  } deriving (Generic, Binary, NFData)+  } deriving (Generic, Eq, Show, NFData) +instance Binary Dictionary where+  get = do+    dictionarySize' <- getWord32le+    when (dictionarySize' < 256 || dictionarySize' `mod` 256 /= 0) do+      error $ "Invalid size: " <> show dictionarySize'+    dictionaryUnitsList <- getMany (get @DictionaryUnit)+      $ fromIntegral @BaseType @Int dictionarySize'+    let dictionarySize = fromIntegral @BaseType @SizeType dictionarySize'+        dictionaryUnits = UV.fromList dictionaryUnitsList+    pure Dictionary{..}+  put Dictionary{..} = do+    putWord32le $ fromIntegral @SizeType @BaseType dictionarySize+    mapM_ (put @DictionaryUnit) (UV.toList dictionaryUnits)++-- | Empty dictionary that does not contain any elements.+empty :: Dictionary+empty = Dictionary+  { dictionaryUnits = UV.empty+  , dictionarySize = 0+  }+{-# INLINE empty #-}+ -- | Root dictionary index. Equivalent to @0@. root :: BaseType root = 0@@ -98,7 +116,7 @@ lookup !k d =   case follow k root d of     Nothing -> Nothing-    Just ix -> DictionaryUnit.value <$> (dictionaryUnits d UV.!? fromIntegral ix)+    Just ix -> Just $! value ix d {-# INLINE lookup #-}  -- | Similarlty to 'lookup', it performs lookup of the word prefix@@ -112,7 +130,7 @@ lookupPrefixLength !k !l d =   case followPrefixLength k l root d of     Nothing -> Nothing-    Just !ix -> DictionaryUnit.value <$> (dictionaryUnits d UV.!? fromIntegral ix)+    Just !ix -> Just $! value ix d {-# INLINE lookupPrefixLength #-}  -- | Follows the character by dictionary index of the previous character.@@ -124,17 +142,7 @@       !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 #-} @@ -157,9 +165,6 @@     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@@ -175,3 +180,14 @@   forM_ [0 .. (dictionarySize d) - 1] \ix -> do     putStrLn $ concat       [show ix, "\t", show $ dictionaryUnits d UV.! fromIntegral ix]++-- ** Utilities++-- | Read exact amount of items from lazy bytestring by given helper.+getMany :: forall a. Binary a => Get a -> Int -> Get [a]+getMany getter n = go [] n+  where+    go xs 0 = return $! reverse xs+    go xs i = do+      x <- getter+      x `seq` go (x:xs) (i-1)

@@ -5,7 +5,6 @@ License: BSD-3-Clause Stability: experimental -}-{-# LANGUAGE CPP #-} module Data.DAWG.Internal.DictionaryBuilder where  import Control.Monad (forM_, when)@@ -33,10 +32,6 @@ 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'.@@ -103,70 +98,31 @@   !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+    then 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.@@ -198,10 +154,6 @@    !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 #-}@@ -212,11 +164,6 @@   :: 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@@ -224,19 +171,12 @@     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@@ -268,13 +208,6 @@                     | 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@@ -300,30 +233,17 @@        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@@ -341,15 +261,6 @@                 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@@ -376,13 +287,6 @@ 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@@ -392,14 +296,6 @@             | 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@@ -438,14 +334,6 @@ 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 @@ -481,14 +369,6 @@         !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@@ -526,14 +406,6 @@       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 @@ -542,14 +414,8 @@         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 @@ -568,19 +434,12 @@   => 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 #-}@@ -590,9 +449,6 @@   :: 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@@ -606,18 +462,11 @@         | 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

@@ -9,6 +9,8 @@ module Data.DAWG.Internal.DictionaryUnit where  import Data.Binary+import Data.Binary.Get (getWord32le)+import Data.Binary.Put (putWord32le) import Data.Bits import Data.Vector.Unboxed.Mutable (Unbox) @@ -23,7 +25,11 @@ -- | 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)+  deriving newtype (Eq, Ord, Num, Bits, Integral, Real, Enum)++instance Binary DictionaryUnit where+  get = DictionaryUnit <$> getWord32le+  put = putWord32le . base  instance Show DictionaryUnit where   show u = concat

@@ -10,17 +10,20 @@ import Control.DeepSeq (NFData) import Control.Monad (forM_) import Data.Binary+import Data.Binary.Get (getWord32le)+import Data.Binary.Put (putWord32le) 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.Dictionary (Dictionary, getMany) import Data.DAWG.Internal.GuideUnit (GuideUnit)  import qualified Data.Binary as Binary import qualified Data.Vector.Unboxed as Vector +import qualified Data.DAWG.Internal.Dictionary as Dict import qualified Data.DAWG.Internal.GuideUnit as GuideUnit  -- ** Guide@@ -32,14 +35,29 @@ -- * 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.+  { guideDictionary :: Dictionary -- ^ 'Data.DAWG.Internal.Dictionary.Dictionary' associated with this Guide.   , guideSize :: SizeType -- ^ Size of array. Stored separately.-  } deriving (Generic, Binary, NFData)+  , guideUnits :: Vector GuideUnit -- ^ Array of 'Data.DAWG.Internal.GuideUnit.GuideUnit'. Index is equal to 'Data.DAWG.Internal.Dictionary.Dictionary' index.+  } deriving (Generic, Eq, Show, NFData) +instance Binary Guide where+  get = do+    guideDictionary <- get @Dictionary+    guideSize' <- getWord32le+    guideUnitsList <- getMany (get @GuideUnit) $ fromIntegral @BaseType @Int guideSize'+    let guideSize = fromIntegral @BaseType @SizeType guideSize'+        guideUnits = Vector.fromList guideUnitsList+    pure Guide{..}+  put Guide{..} = do+    put guideDictionary+    putWord32le $ fromIntegral @SizeType @BaseType guideSize+    mapM_ (put @GuideUnit) (Vector.toList guideUnits)+ -- | Constructs an empty guide. empty :: Guide empty = Guide-  { guideUnits = Vector.empty+  { guideDictionary = Dict.empty+  , guideUnits = Vector.empty   , guideSize = 0   } {-# INLINE empty #-}

@@ -5,7 +5,6 @@ License: BSD-3-Clause Stability: experimental -}-{-# LANGUAGE CPP #-} module Data.DAWG.Internal.GuideBuilder where  import Control.Monad (when)@@ -28,11 +27,6 @@ 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'.@@ -48,7 +42,7 @@  -- | Build 'Data.DAWG.Internal.Guide.Guide' -- from 'Data.DAWG.Internal.DAWG.DAWG' and 'Data.DAWG.Internal.Dictionary.Dictionary'.--- Returns 'False' if build failed.+-- Returns 'Nothing' if build fails. build :: HasCallStack => PrimMonad m => DAWG -> Dictionary -> m (Maybe Guide) build dawg dict = do   gref@GRef{..} <- new dawg dict@@ -76,7 +70,8 @@ freeze gb = do   funits <- UV.freeze $ guideBuilderUnits gb     let !guideUnits = (UV.fromList . UV.toList) funits-  let !guideSize = fromIntegral $ UV.length guideUnits+      !guideSize = fromIntegral $ UV.length guideUnits+      !guideDictionary = guideBuilderDictionary gb   pure Guide{..} {-# INLINE freeze #-} @@ -107,17 +102,9 @@ {-# INLINE resizeUnitsAndFlags #-}  -- | Build guide recursively from dawg index and dictionary index.--- Returns 'Nothing' if fails.+-- Returns 'False' 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@@ -128,13 +115,6 @@           !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 @@ -149,21 +129,9 @@                 | 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

@@ -31,7 +31,7 @@        , UCharType -- sibling        )   }-  deriving newtype (Show, Eq, Ord, Binary, NFData)+  deriving newtype (Show, Eq, Ord, 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))@@ -39,6 +39,15 @@ deriving newtype instance V.MVector UV.MVector GuideUnit deriving newtype instance VG.Vector UV.Vector GuideUnit deriving newtype instance Unbox GuideUnit++instance Binary GuideUnit where+  get = do+    c <- getWord8+    s <- getWord8+    pure $! GuideUnit (c, s)+  put (GuideUnit (c, s)) = do+    putWord8 c+    putWord8 s  -- | Empty unit. Equivalent to @0@. empty :: GuideUnit

@@ -0,0 +1,361 @@+{-|+Module: Data.DAWG.Internal.RankedCompleter+Description: Exports ranked completer as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.RankedCompleter where++import Control.Monad (forM, forM_)+import Control.Monad.ST (runST)+import Data.Bits ((.^.))+import Data.Char (chr, ord)+import Data.Set (Set)+import Data.Vector (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.RankedCompleterCandidate+import Data.DAWG.Internal.RankedCompleterNode+import Data.DAWG.Internal.RankedGuide++import qualified Data.DAWG.Internal.Dictionary as Dict+import qualified Data.DAWG.Internal.DictionaryUnit as DU+import qualified Data.DAWG.Internal.RankedGuide as G+import qualified Data.DAWG.Internal.RankedCompleterCandidate as Candidate+import qualified Data.DAWG.Internal.RankedCompleterNode as Node++import qualified Data.Set as Set+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector as V+import qualified Data.Vector.Generic.Mutable as VM++-- ** Priority Queue++-- | Priority queue.+data PQ a = PQ+  { pqSet :: !(Set a) -- ^ Underneath the priority queue it is just a 'Data.Set.Set'.+  , pqTop :: !a -- ^ Top value of a queue. Holds a "minimal" value of a set. When set is empty, it holds an empty value as well.+  }++-- | Checks whether priority queue is nullable or not.+nullPQ :: PQ a -> Bool+nullPQ = Set.null . pqSet+{-# INLINE nullPQ #-}++-- | Initialises an empty priority queue.+emptyPQ :: Monoid a => PQ a+emptyPQ = PQ+  { pqSet = Set.empty+  , pqTop = mempty+  }++-- | Gets a top element from the priority queue. /O(1)/.+queueTop :: PQ a -> a+queueTop = pqTop+{-# INLINE queueTop #-}++-- | Removes and discards a minimal element from the priority queue.+queuePop :: Monoid a => PQ a -> PQ a+queuePop !prev =+  let !nset = Set.deleteMin (pqSet prev)+  in if Set.null nset+     then emptyPQ+     else PQ { pqSet = nset, pqTop = Set.findMin nset }+{-# INLINE queuePop #-}++-- | Pushes an element to the queue.+queuePush :: (Ord a) => a -> PQ a -> PQ a+queuePush a prev = if nullPQ prev+  then PQ { pqSet = Set.singleton a, pqTop = a }+  else +    let ptop = pqTop prev+        ntop = if a < ptop then a else ptop+    in PQ { pqSet = Set.insert a $ pqSet prev, pqTop = ntop }        ++-- ** Ranked Completer++-- | Use 'RankedCompleter' to perform completion requests ranking results by values stored in the dictionary. As 'Data.DAWG.Internal.Completer.Completer', it accumulates data during traversing dictionary via ranked guide. Resulted completion could be accessed via 'keyToString' helper. Value is stored in 'rankedCompleterValue'.+data RankedCompleter = RankedCompleter+  { rankedCompleterGuide :: !RankedGuide+  , rankedCompleterKey :: !(Vector UCharType)+  , rankedCompleterPrefixLength :: !BaseType+  , rankedCompleterValue :: !ValueType+  , rankedCompleterNodes :: !(Vector RankedCompleterNode)+  , rankedCompleterNodeQueue :: !(Vector BaseType)+  , rankedCompleterCandidateQueue :: !(PQ RankedCompleterCandidate)+  }++-- | Helper to access a dictionary from 'RankedCompleter'.+rankedCompleterDictionary :: RankedCompleter -> Dictionary+rankedCompleterDictionary = guideDictionary . rankedGuide . rankedCompleterGuide++-- | Retrieves a completion result from 'RankedCompleter' as 'String'.+keyToString :: RankedCompleter -> String+keyToString = fmap (chr . fromIntegral) . safeInit . V.toList . rankedCompleterKey+  where+    safeInit [] = []+    safeInit xs = init xs+    {-# INLINE safeInit #-}+{-# INLINE keyToString #-}++-- | Starts completion process for 'RankedCompleter' with a 'Dictionary' index and word prefix. For basic usage pass @0@ (dictionary 'Data.DAWG.Internal.Dictionary.root' index) as index.+-- Fpr more complex scenarios different 'Dictionary' indexes could be used here too.+start :: HasCallStack => BaseType -> String -> RankedGuide -> RankedCompleter+start !ix !prefix !guide =+    let !gsize = guideSize $ rankedGuide guide+        prefix' = V.map (fromIntegral @_ @UCharType . ord) $ V.fromList prefix+  +        !nc = RankedCompleter+          { rankedCompleterGuide = guide+          , rankedCompleterKey = prefix'+          , rankedCompleterPrefixLength = fromIntegral $ V.length prefix'+          , rankedCompleterValue = -1+          , rankedCompleterNodes = V.empty+          , rankedCompleterNodeQueue = V.empty+          , rankedCompleterCandidateQueue = emptyPQ+          }+    in if gsize /= 0+      then enqueueNode 0 $ snd $ createNode ix 0 (fromIntegral $ ord 'X') nc+      else nc+  +-- | Retrieves next completion. If present, 'RankedCompleter' will be returned. 'Nothing', otherwise.+next :: HasCallStack => RankedCompleter -> Maybe RankedCompleter+next rc =+  let findSiblingNode !i !c+        | i >= fromIntegral (V.length $ rankedCompleterNodeQueue c) = c+        | otherwise =+          let !nodeIx = rankedCompleterNodeQueue c V.! i+              (hasFoundSibling, nc, nextNodeIx) = if rankedCompleterValue c == -1+                then (True, c, nodeIx) -- skipping looking up sibling for -1+                else findSibling nodeIx c+          in if not hasFoundSibling+             then findSiblingNode (succ i) nc+             else let (nextNodeIx', nc') = findTerminal nextNodeIx nc+                      nc'' = enqueueCandidate nextNodeIx' nc'+                  in findSiblingNode (succ i) nc''+      checkCandidate !c =+        let !nc = findSiblingNode 0 c+        in if nullPQ (rankedCompleterCandidateQueue nc)+           then Nothing+           else Just nc { rankedCompleterNodeQueue = V.empty }++      resizeKey !c =+        let !newSize = fromIntegral $ rankedCompleterPrefixLength c+            !oldSize = V.length $ rankedCompleterKey c+            grow !v = do+              mv <- V.unsafeThaw v+              nv <- VM.grow mv (newSize - oldSize)+              forM_ [ oldSize .. pred newSize ] do+                \i -> VM.unsafeWrite nv i 0+              V.unsafeFreeze nv++            slice !v = V.slice 0 newSize v++            !newKey = case compare oldSize newSize of+              EQ -> rankedCompleterKey c+              LT -> runST $ grow $ rankedCompleterKey c+              GT -> slice $ rankedCompleterKey c+        in c { rankedCompleterKey = newKey }++      enqueueNodes :: BaseType -> RankedCompleter -> (BaseType, RankedCompleter)+      enqueueNodes 0 !c = (0, c)+      enqueueNodes !nodeIx !c =+        let !node = rankedCompleterNodes c V.! fromIntegral nodeIx+            !label' = Node.nodeLabel node+            !newKey = pushBack label' $ rankedCompleterKey c+            !nc = c { rankedCompleterKey = newKey }+            !nc' = enqueueNode nodeIx nc+            !nextNodeIx = Node.prevNodeIx node+        in enqueueNodes nextNodeIx nc'++      postProcessKey !c =+        let reverse' !v = do+              let startIx = 0 + (fromIntegral $ rankedCompleterPrefixLength c)+                  endIx = pred $ V.length $ rankedCompleterKey c+                  indexes = [ startIx .. endIx ]+              values <- forM indexes \i -> do+                VM.unsafeRead v i+              forM_ (zip indexes (reverse values)) \(ix, value') -> do+                VM.unsafeWrite v ix value'+        in pushBack 0 $ V.modify reverse' $ rankedCompleterKey c+      +      processCandidate !c =+        let !candidate = queueTop (rankedCompleterCandidateQueue c)+            !nodeIx' = candidateNodeIx candidate+            !nc = enqueueNode nodeIx' c+            !nodeIx'' = Node.prevNodeIx (rankedCompleterNodes nc V.! fromIntegral nodeIx')+            (!_, !nc') = enqueueNodes nodeIx'' $ resizeKey nc+        in nc'+           { rankedCompleterKey = postProcessKey nc'+           , rankedCompleterValue = candidateValue candidate+           , rankedCompleterCandidateQueue = queuePop (rankedCompleterCandidateQueue nc')+           }+  in case checkCandidate rc of+    Nothing -> Nothing+    Just rcc -> Just $! processCandidate rcc++-- | Retrieves a value associated+-- with the last visited index by 'RankedCompleter' from the 'Dictionary'.+value :: RankedCompleter -> ValueType+value = rankedCompleterValue+{-# INLINE value #-}++-- | Creates a new node and stores it inside 'RankedCompleter'. Returns node identifier and new state of 'RankedCompleter'.+createNode+  :: BaseType -> BaseType -> UCharType -> RankedCompleter -> (BaseType, RankedCompleter)+createNode !dictIx !prevNodeIx' !label !c = +  let !dict = rankedCompleterDictionary c+      maybeSetTerminal x = if label == 0+        then x+        else Node.setHasTerminal (Dict.hasValue dictIx dict) x+      node = maybeSetTerminal+        $ Node.setLabel label+        $ Node.setPrevNodeIx prevNodeIx'+        $ Node.setDictIx dictIx+        $ Node.empty+      nextNodes = pushBack node (rankedCompleterNodes c)+  in (fromIntegral $ V.length nextNodes - 1, c { rankedCompleterNodes = nextNodes })++-- | Pushes a node to queue.+enqueueNode :: BaseType -> RankedCompleter -> RankedCompleter+enqueueNode !nodeIx !c+  | nodeIsQueued ((rankedCompleterNodes c) V.! fromIntegral nodeIx) = c+  | otherwise =+      let modifyIsQueued !v = do+            let nix' = fromIntegral nodeIx+            node <- VM.unsafeRead v nix'+            VM.unsafeWrite v nix' $ Node.setIsQueued True node+          !nnq = pushBack nodeIx (rankedCompleterNodeQueue c)+          !ns = V.modify modifyIsQueued (rankedCompleterNodes c)+      in c { rankedCompleterNodeQueue = nnq+           , rankedCompleterNodes = ns+           }++-- | Pushes a candidate to the priority queue.+enqueueCandidate :: HasCallStack => BaseType -> RankedCompleter -> RankedCompleter+enqueueCandidate !nodeIx !c =+  let !dictIx = Node.nodeDictIx (rankedCompleterNodes c V.! fromIntegral nodeIx)+      !dictValue = DU.value+        $ Dict.dictionaryUnits (rankedCompleterDictionary c) UV.! fromIntegral dictIx+      !candidate = Candidate.setValue dictValue+        $ Candidate.setNodeIx nodeIx+        $ Candidate.empty+      !nextCQueue = queuePush candidate (rankedCompleterCandidateQueue c)+  in c { rankedCompleterCandidateQueue = nextCQueue }++-- | Finds a sibling for given node index. Returns:+--+-- * Flag indicating whether sibling has found or not.+-- * Updated 'RankedCompleter'.+-- * Next node indentifier.+--+-- If sibling has not found, returns @(False, original completer, original node index)@.+findSibling :: BaseType -> RankedCompleter -> (Bool, RankedCompleter, BaseType)+findSibling !nodeIx !c =+  let !node = (rankedCompleterNodes c) V.! fromIntegral nodeIx+      !prevNodeIx' = Node.prevNodeIx node+      !dictIx = Node.nodeDictIx node+      !siblingLabel = G.sibling dictIx $ rankedCompleterGuide c+      mChangedNodes = if siblingLabel == 0+        then let !prevNode = (rankedCompleterNodes c) V.! fromIntegral prevNodeIx'+             in if not (Node.nodeHasTerminal prevNode)+                then Nothing+                else let modifyHasTerminal !v = do+                           let ix' = fromIntegral prevNodeIx'+                           node' <- VM.unsafeRead v ix'+                           VM.unsafeWrite v ix' $ Node.setHasTerminal False node'+                         !ns = V.modify modifyHasTerminal (rankedCompleterNodes c)+                     in Just ns+        else Just (rankedCompleterNodes c)+  in case mChangedNodes of+    Nothing -> (False, c, nodeIx)+    Just nodes ->+      let !dictPrevIx = Node.nodeDictIx (nodes V.! fromIntegral prevNodeIx')+          !dict = rankedCompleterDictionary c+          !nextDictIx = followWithoutCheck dictPrevIx siblingLabel dict+          nc = c { rankedCompleterNodes = nodes }+          (nextNodeIx, nc') = createNode nextDictIx prevNodeIx' siblingLabel nc++      in (True, nc', nextNodeIx)+          +-- | Recursively finds a terminal node for given node index.+findTerminal :: BaseType -> RankedCompleter -> (BaseType, RankedCompleter)+findTerminal !nodeIx !c+  | Node.nodeLabel (rankedCompleterNodes c V.! fromIntegral nodeIx) == 0 = (nodeIx, c)+  | otherwise =+    let !node = rankedCompleterNodes c V.! fromIntegral nodeIx+        !dictIx = Node.nodeDictIx node+        !childLabel = G.child dictIx $ rankedCompleterGuide c+        !nodes = if childLabel == 0+          then let modifyHasTerminal !v = do+                     let ix' = fromIntegral nodeIx+                     node' <- VM.unsafeRead v ix'+                     VM.unsafeWrite v ix' $ Node.setHasTerminal False node'+               in V.modify modifyHasTerminal (rankedCompleterNodes c)+          else rankedCompleterNodes c+        !dict = rankedCompleterDictionary c+        !nextDictIx = followWithoutCheck dictIx childLabel dict+        nc = c { rankedCompleterNodes = nodes }+        (!nextNodeIx, nc') = createNode nextDictIx nodeIx childLabel nc+    in findTerminal nextNodeIx nc'++-- | Follows label in the dictionary without checking for offsets.+followWithoutCheck :: BaseType -> UCharType -> Dictionary -> BaseType+followWithoutCheck !ix !label !d =+  (ix .^. DU.offset (Dict.dictionaryUnits d UV.! fromIntegral ix)) .^. fromIntegral label++-- | Helper that pushes element to the end of the array.+pushBack :: a -> Vector a -> Vector a+pushBack a as = runST $ snoc as+  where+    n = V.length as+    snoc v = do+      mv <- V.unsafeThaw v+      nv <- VM.grow mv 1+      VM.unsafeWrite nv n a+      V.unsafeFreeze nv+++-- | Retrieve all completion results by given @prefix@+-- from 'Dictionary' via associated 'RankedGuide'. 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 -> RankedGuide -> [(String, ValueType)]+completeKeys  !prefix guide =+  let !dict = rankedGuideDictionary guide+      goDict !dictIx !acc =+        case Dict.follow prefix dictIx dict of+          Nothing -> acc+          Just !nextDictIx ->+            let !nc = start nextDictIx "" guide+                !nacc = goNext nc acc+            in goDict nextDictIx nacc+      goNext !comp !acc = case next comp of+        Nothing -> acc+        Just !nc ->+          let !nextWord = concat [prefix, keyToString nc]+              !nextVal = rankedCompleterValue nc+              !nacc = (nextWord, nextVal) : acc+          in goNext nc nacc+  -- please re-run comparison benchmarks if you want to modify this function+  in goDict Dict.root []+{-# INLINE completeKeys #-}

@@ -0,0 +1,52 @@+{-|+Module: Data.DAWG.Internal.RankedCompleterCandidate+Description: Exports ranked completer node candidate with associated value.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.RankedCompleterCandidate where++import Data.DAWG.Internal.BaseType++-- ** Ranked completer candidate++-- | Candidate to a completion result ranked by value in descending order.+data RankedCompleterCandidate = RankedCompleterCandidate+  { candidateNodeIx :: !BaseType -- ^ Index of a node of a candidate for completion.+  , candidateValue :: !ValueType -- ^ Value associated with a candidate for completion.+  } deriving (Eq)++instance Ord RankedCompleterCandidate where+  lhs `compare` rhs = if candidateValue lhs /= candidateValue rhs+    then candidateValue rhs `compare` candidateValue lhs+    else candidateNodeIx lhs `compare` candidateNodeIx rhs++instance Show RankedCompleterCandidate where+  show RankedCompleterCandidate{..} = concat [ show candidateNodeIx, "\t", show candidateValue]++instance Monoid RankedCompleterCandidate where+  mempty = empty++instance Semigroup RankedCompleterCandidate where+  _a <> b = b++-- | Empty candidate which holds root node index and negative value.+empty :: RankedCompleterCandidate+empty = RankedCompleterCandidate+  { candidateNodeIx = 0+  , candidateValue = -1+  }+{-# INLINE empty #-}++-- | Sets a node index to the given candidate.+setNodeIx :: BaseType -> RankedCompleterCandidate -> RankedCompleterCandidate+setNodeIx !nodeIx !RankedCompleterCandidate{..} =+  RankedCompleterCandidate { candidateNodeIx = nodeIx, .. }+{-# INLINE setNodeIx #-}++-- | Sets a value to the given candidate.+setValue :: ValueType -> RankedCompleterCandidate -> RankedCompleterCandidate+setValue !value !RankedCompleterCandidate{..} =+  RankedCompleterCandidate { candidateValue = value, .. }+{-# INLINE setValue #-}

@@ -0,0 +1,71 @@+{-|+Module: Data.DAWG.Internal.RankedCompleterNode+Description: Exports ranked completer node with its API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.RankedCompleterNode where++import Data.DAWG.Internal.BaseType++import Data.Char (chr)+import Data.List (intercalate)++-- ** Ranked completer node++-- | Ranked completer node.+data RankedCompleterNode = RankedCompleterNode+  { nodeDictIx :: !BaseType -- ^ Dictionary index of a node.+  , prevNodeIx :: !BaseType -- ^ Index of a previous completer node.+  , nodeLabel :: !UCharType -- ^ Character associated with a node.+  , nodeIsQueued :: !Bool -- ^ 'True', if node is being queued.+  , nodeHasTerminal :: !Bool -- ^ 'True', if node is being terminal.+  } deriving (Eq)++instance Show RankedCompleterNode where+  show RankedCompleterNode{..} = intercalate "\t"+    [ show nodeDictIx+    , show prevNodeIx+    , show $ chr $ fromIntegral nodeLabel+    , show nodeIsQueued+    , show nodeHasTerminal+    ]++-- | Empty node.+empty :: RankedCompleterNode+empty = RankedCompleterNode+  { nodeDictIx = 0+  , prevNodeIx = 0+  , nodeLabel = 0+  , nodeIsQueued = False+  , nodeHasTerminal = False+  }+{-# INLINE empty #-}++-- | Sets a dictionary index to the given ranked completer node.+setDictIx :: BaseType -> RankedCompleterNode -> RankedCompleterNode+setDictIx !dictIx !RankedCompleterNode{..} = RankedCompleterNode { nodeDictIx = dictIx, .. }+{-# INLINE setDictIx #-}++-- | Sets a previous node index to the given ranked completer node.+setPrevNodeIx :: BaseType -> RankedCompleterNode -> RankedCompleterNode+setPrevNodeIx !dictIx !RankedCompleterNode{..} =+  RankedCompleterNode { prevNodeIx = dictIx, .. }+{-# INLINE setPrevNodeIx #-}++-- | Sets a label to the given ranked completer node.+setLabel :: UCharType -> RankedCompleterNode -> RankedCompleterNode+setLabel !label !RankedCompleterNode{..} = RankedCompleterNode { nodeLabel = label, .. }+{-# INLINE setLabel #-}++-- | Sets @IS_QUEUED@ flag to the given ranked completer node.+setIsQueued :: Bool -> RankedCompleterNode -> RankedCompleterNode+setIsQueued !isQueued !RankedCompleterNode{..} = RankedCompleterNode { nodeIsQueued = isQueued, .. }+{-# INLINE setIsQueued #-}++-- | Sets @HAS_TERMINAL@ flag to the given ranked completer node.+setHasTerminal :: Bool -> RankedCompleterNode -> RankedCompleterNode+setHasTerminal !hasTerminal !RankedCompleterNode{..} =+  RankedCompleterNode { nodeHasTerminal = hasTerminal, .. }+{-# INLINE setHasTerminal #-}

@@ -0,0 +1,53 @@+{-|+Module: Data.DAWG.Internal.RankedGuide+Description: Exports ranked completer as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.RankedGuide where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import GHC.Generics++import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.Dictionary+import Data.DAWG.Internal.Guide (Guide (..))++import qualified Data.Binary as Binary++import qualified Data.DAWG.Internal.Guide as G++-- ** Ranked Guide+++-- | Another kind of 'Data.DAWG.Internal.Guide.Guide' that provides efficient way to perform completions ranked by values that were stored in the Dictionary.+-- It has the same layout as 'Data.DAWG.Internal.Guide.Guide'.+newtype RankedGuide = RankedGuide { rankedGuide :: Guide }+  deriving newtype (Binary, NFData, Eq, Show)+  deriving stock (Generic)++-- | Gets a child by given ranked guide index.+child :: BaseType -> RankedGuide -> UCharType+child !ix = G.child ix . rankedGuide++-- | Gets a sibling by given ranked guide index.+sibling :: BaseType -> RankedGuide -> UCharType+sibling !ix = G.sibling ix . rankedGuide++-- | ^ 'Data.DAWG.Internal.Dictionary.Dictionary' associated with this ranked guide.+rankedGuideDictionary :: RankedGuide -> Dictionary+rankedGuideDictionary = guideDictionary . rankedGuide++-- | Load ranked guide from a file.+read :: FilePath -> IO RankedGuide+read = Binary.decodeFile++-- | Save ranked guide to a file.+write :: FilePath -> RankedGuide -> IO ()+write = Binary.encodeFile++-- | Dump ranked guide to stdout.+dump :: RankedGuide -> IO ()+dump = G.dump . rankedGuide

@@ -0,0 +1,265 @@+{-|+Module: Data.DAWG.Internal.RankedGuideBuilder+Description: Exports ranked guide builder as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.Internal.RankedGuideBuilder where++import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Bits+import Data.Primitive.MutVar+import Data.Vector.Algorithms.Insertion (sortByBounds)+import GHC.Stack (HasCallStack)++import Data.Primitive.PrimArray.Combinators+import Data.DAWG.Internal.BaseType+import Data.DAWG.Internal.GuideUnit+import Data.DAWG.Internal.Guide (Guide(..))+import Data.DAWG.Internal.DAWG (DAWG)+import Data.DAWG.Internal.Dictionary (Dictionary (..))+import Data.DAWG.Internal.RankedGuide+import Data.DAWG.Internal.RankedGuideLink++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.DictionaryUnit as DictUnit+import qualified Data.DAWG.Internal.GuideUnit as GuideUnit+import qualified Data.DAWG.Internal.RankedGuideLink as Link++-- ** Ranked Guide Builder++-- | A mutable builder of 'Data.DAWG.Internal.RankedGuide.RankedGuide'.+newtype RankedGuideBuilder m =+  RGBRef { getRGBRef :: MutVar (PrimState m) (RankedGuideBuilder_ m) }++-- | Builder of Ranked Guide. Do not acess directly. Use 'RankedGuideBuilder' instead.+data RankedGuideBuilder_ m = RankedGuideBuilder+  { rankedGuideBuilderDawg :: DAWG+  , rankedGuideBuilderDictionary :: Dictionary+  , rankedGuideBuilderUnits :: ObjectPool (PrimState m) GuideUnit+  , rankedGuideBuilderLinks :: ObjectPool (PrimState m) RankedGuideLink+  , rankedGuideBuilderIsFixedTable :: ObjectPool (PrimState m) UCharType+  }++-- | Build 'Data.DAWG.Internal.RankedGuide.RankedGuide'+-- from 'Data.DAWG.Internal.DAWG.DAWG' and 'Data.DAWG.Internal.Dictionary.Dictionary'.+-- | Returns 'Nothing' if build fails.+build :: HasCallStack => PrimMonad m => DAWG -> Dictionary -> m (Maybe RankedGuide)+build dawg dict = do+  rgref@RGBRef{..} <- new dawg dict+  resizeUnitsAndFlags rgref++  rgb <- readMutVar getRGBRef+  if Dawg.size (rankedGuideBuilderDawg rgb) <= 1+    then freeze rgb >>= pure . Just+    else do+      maxValueRef <- newMutVar (-1)+      buildFromIndexes Dawg.root Dict.root maxValueRef rgref >>= \case+        False -> pure Nothing+        True -> readMutVar getRGBRef >>= freeze >>= pure . Just++-- | Same as 'build' but throws an error if build fails.+build' :: HasCallStack => PrimMonad m => DAWG -> Dictionary -> m RankedGuide+build' dawg dict = build dawg dict >>= \case+  Just guide -> pure guide+  Nothing -> error "failed to build guide"+{-# INLINE build' #-}++-- | Generates 'Data.DAWG.Internal.RankedGuide.RankedGuide' out of 'RankedGuideBuilder'.+-- Once this function is called, 'RankedGuideBuilder' must not be used anymore.+freeze :: PrimMonad m => RankedGuideBuilder_ m -> m RankedGuide+freeze rgb = do+  funits <- UV.freeze $ rankedGuideBuilderUnits rgb+  let !guideUnits = (UV.fromList . UV.toList) funits+      !guideSize = fromIntegral $ UV.length guideUnits+      !guideDictionary = rankedGuideBuilderDictionary rgb+      !rankedGuide = Guide{..}+  pure RankedGuide{..}++-- ** Helpers++-- | Initialises a new 'RankedGuideBuilder' from DAWG and Dictionary.+new :: PrimMonad m => DAWG -> Dictionary -> m (RankedGuideBuilder m)+new rankedGuideBuilderDawg rankedGuideBuilderDictionary = do+  rankedGuideBuilderUnits <- V.new 0+  rankedGuideBuilderLinks <- V.new 0+  rankedGuideBuilderIsFixedTable <- V.new 0+  let rg = RankedGuideBuilder{..}+  RGBRef <$> newMutVar rg++-- | 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 => RankedGuideBuilder m -> m ()+resizeUnitsAndFlags RGBRef{..} = do+  rgb <- readMutVar getRGBRef+  let dictSize = fromIntegral $ dictionarySize $ rankedGuideBuilderDictionary rgb+      unitsSize = V.length $ rankedGuideBuilderUnits rgb+      flagsSize = V.length $ rankedGuideBuilderIsFixedTable rgb+  newUnits <- V.grow (rankedGuideBuilderUnits rgb)+    $ if unitsSize < dictSize then dictSize - unitsSize else 0+  newFlags <- V.grow (rankedGuideBuilderIsFixedTable rgb)+    $ if flagsSize < (dictSize `div` 8) then (dictSize `div` 8) - flagsSize else 0+  let !nrgb = rgb+        { rankedGuideBuilderUnits = newUnits, rankedGuideBuilderIsFixedTable = newFlags }+  writeMutVar getRGBRef nrgb++-- | Build ranked guide recursively from dawg index and dictionary index.+-- Returns 'False' if fails.+buildFromIndexes+  :: PrimMonad m+  => BaseType -> BaseType -> MutVar (PrimState m) ValueType -> RankedGuideBuilder m -> m Bool+buildFromIndexes !dawgIx !dictIx !maxValueRef rgref@RGBRef{..} = do+  let sortLinks n rgb = do+        let links = rankedGuideBuilderLinks rgb+            l = V.length links+        sortByBounds compare links n l++      updateMaxValue n valueRef rgb = do+        link <- rankedGuideBuilderLinks rgb !~ fromIntegral n+        writeMutVar valueRef (Link.value link)+        +      resizeLinks n = do+        rgb <- readMutVar getRGBRef+        let links = rankedGuideBuilderLinks rgb+            l = V.length links+        newLinks <- case compare l n of+          LT -> V.grow links (n - l)+          EQ -> pure links+          GT -> pure (V.unsafeSlice 0 n links)+        let !nrgb = rgb { rankedGuideBuilderLinks = newLinks }+        writeMutVar getRGBRef nrgb+  rgb0 <- readMutVar getRGBRef+  isFixed dictIx rgb0 >>= \case+    True -> findMaxValue dictIx maxValueRef rgb0+    False -> do+      setIsFixed dictIx rgb0++      let initialNumLinks = V.length $ rankedGuideBuilderLinks rgb0+      enumerateLinks dawgIx dictIx rgref >>= \case+        False -> pure False+        True -> do+          -- enumerateLinks could resize vectors, thus, reading again+          rgb <- readMutVar getRGBRef+          sortLinks initialNumLinks rgb+          turnLinksToUnits dictIx initialNumLinks rgref >>= \case+            False -> pure False+            True -> do+              updateMaxValue initialNumLinks maxValueRef rgb+              resizeLinks initialNumLinks+              pure True++-- | Finds the maximum value by using fixed units.+findMaxValue+  :: PrimMonad m+  => BaseType -> MutVar (PrimState m) ValueType -> RankedGuideBuilder_ m -> m Bool+findMaxValue !startDictIx !maxValueRef rgb = do+  let follow' !dictIx = do+        childLabel <- GuideUnit.child <$> rankedGuideBuilderUnits rgb !~ fromIntegral dictIx+        if childLabel == 0+          then pure $! Just dictIx+          else case Dict.followChar (fromIntegral childLabel) dictIx (rankedGuideBuilderDictionary rgb) of+            Nothing -> pure Nothing+            Just lastDictIx -> follow' lastDictIx++  follow' startDictIx >>= \case+    Nothing -> pure False+    Just !dictIx -> do+      let itHasValue = Dict.hasValue dictIx (rankedGuideBuilderDictionary rgb)+      when itHasValue $ writeMutVar maxValueRef+        $! Dict.value dictIx (rankedGuideBuilderDictionary rgb)+      pure itHasValue            ++-- | Enumerates links to the next states.+enumerateLinks :: PrimMonad m => BaseType -> BaseType -> RankedGuideBuilder m -> m Bool+enumerateLinks !startDawgIx !dictIx rgref@RGBRef{..} = do+  rgb0 <- readMutVar getRGBRef+  let !startDawgChildIx = Dawg.child startDawgIx (rankedGuideBuilderDawg rgb0)+      go !dawgChildIx+        | dawgChildIx == 0 = pure True+        | otherwise = do+            rgb <- readMutVar getRGBRef+            let !startValue = -1+                !childLabel = Dawg.label dawgChildIx (rankedGuideBuilderDawg rgb)+            maxValueRef <- newMutVar startValue+            mValue <- if childLabel == 0+              then if (not $ Dict.hasValue dictIx $ rankedGuideBuilderDictionary rgb)+                   then pure Nothing+                   else do+                     let !value' = Dict.value dictIx $ rankedGuideBuilderDictionary rgb+                     writeMutVar maxValueRef value'+                     pure $! Just value'+              else case Dict.followChar (fromIntegral childLabel) dictIx (rankedGuideBuilderDictionary rgb) of+                Nothing -> pure Nothing+                Just lastDictIx -> do+                   -- outer recursion loop+                  buildFromIndexes dawgChildIx lastDictIx maxValueRef rgref >>= \case+                    False -> pure Nothing+                    True -> do+                      value' <- readMutVar maxValueRef+                      pure $! Just value'+            case mValue of+              Nothing -> pure False+              Just value' -> do+                pushLinkBack (RankedGuideLink (childLabel, value'))+                rgb1 <- readMutVar getRGBRef+                let nextDawgIx = Dawg.sibling dawgChildIx (rankedGuideBuilderDawg rgb1)+                go nextDawgIx++      pushLinkBack !link = do+        rgb <- readMutVar getRGBRef+        let linksSize = V.length $ rankedGuideBuilderLinks rgb+        newLinks <- V.grow (rankedGuideBuilderLinks rgb) 1+        newLinks !<~~ fromIntegral linksSize $ const link+        let !nrgb = rgb { rankedGuideBuilderLinks = newLinks }+        writeMutVar getRGBRef nrgb++  go startDawgChildIx++-- | Modifies units.+turnLinksToUnits :: PrimMonad m => BaseType -> Int -> RankedGuideBuilder m -> m Bool+turnLinksToUnits !dictIx !linksBegin RGBRef{..} = do+  rgb <- readMutVar getRGBRef+  let !lsize = V.length $ rankedGuideBuilderLinks rgb+      links = rankedGuideBuilderLinks rgb+      units = rankedGuideBuilderUnits rgb+  -- the first child+  !firstLabel <- Link.label <$> links !~ fromIntegral linksBegin+  units !<~~ fromIntegral dictIx $ GuideUnit.setChild firstLabel+  !dictStartChildIx <- followWithoutCheck dictIx firstLabel rgb++  -- other children+  let go !dictChildIx !ix+        | ix >= lsize = pure True+        | otherwise = do+            !siblingLabel <- Link.label <$> links !~ fromIntegral ix+            !dictSiblingIx <- followWithoutCheck dictIx siblingLabel rgb+            units !<~~ fromIntegral dictChildIx $ GuideUnit.setSibling siblingLabel+            go dictSiblingIx (succ ix)+  go dictStartChildIx (succ linksBegin)++-- | Follows a transition without any check.+followWithoutCheck+  :: PrimMonad m => BaseType -> UCharType -> RankedGuideBuilder_ m -> m BaseType+followWithoutCheck !ix !label' rgb = do+  let dictUnits = Dict.dictionaryUnits $ rankedGuideBuilderDictionary rgb+      offset' = DictUnit.offset $ (dictUnits UV.! fromIntegral ix)+  pure ((ix .^. offset') .^. fromIntegral label')++-- | Sets dictionary unit as a fixed by index.+setIsFixed :: PrimMonad m => BaseType -> RankedGuideBuilder_ m -> m ()+setIsFixed !ix rgb = do+  let setIsFixed' !v = v .|. (1 .<<. (fromIntegral ix `mod` 8))+  rankedGuideBuilderIsFixedTable rgb !<~~ (fromIntegral ix `div` 8) $! setIsFixed'+                             +-- | Checks whether given dictionary index is fixed or not.+isFixed :: PrimMonad m => BaseType -> RankedGuideBuilder_ m -> m Bool+isFixed !ix rgb = do+  v <- rankedGuideBuilderIsFixedTable rgb !~ (fromIntegral ix `div` 8)+  let x = v .&. (1 .<<. (fromIntegral ix `mod` 8))+  pure $! x /= 0+

@@ -0,0 +1,64 @@+{-|+Module: Data.DAWG.Internal.RankedGuideLink+Description: Exports ranked guide link as well as its internal API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+{-# LANGUAGE TypeFamilies #-}+module Data.DAWG.Internal.RankedGuideLink where++import Data.Vector.Unboxed.Mutable (Unbox)++import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable  as V+import qualified Data.Vector.Unboxed as UV ++import Data.DAWG.Internal.BaseType++import Data.Char (chr)++-- ** Ranked Guide Link++-- | Link that connects dictionary label with associated value.+newtype RankedGuideLink = RankedGuideLink+  { rankedGuideLink+    :: ( UCharType -- label+       , ValueType -- value+       )+  }+  deriving newtype Eq++-- | Sorting links performed by descending value order.+instance Ord RankedGuideLink where+  lhs `compare` rhs = if value lhs /= value rhs+    then value rhs `compare` value lhs+    else label lhs `compare` label rhs++instance Show RankedGuideLink where+  show (RankedGuideLink (l, v)) = concat ["'", [chr $ fromIntegral l], "'\t", show v]++newtype instance UV.MVector s RankedGuideLink+  = MV_RankedGuideLink (UV.MVector s (UCharType, ValueType))+newtype instance UV.Vector RankedGuideLink+  = V_RankedGuideLink (UV.Vector (UCharType, ValueType))++deriving newtype instance V.MVector UV.MVector RankedGuideLink+deriving newtype instance VG.Vector UV.Vector RankedGuideLink+deriving newtype instance Unbox RankedGuideLink++-- | Sets a label to the link.+setLabel :: UCharType -> RankedGuideLink -> RankedGuideLink+setLabel !l (RankedGuideLink (!_, !v)) = RankedGuideLink (l, v)++-- | Sets a value to the link.+setValue :: ValueType -> RankedGuideLink -> RankedGuideLink+setValue !v (RankedGuideLink (!l, !_)) = RankedGuideLink (l, v)++-- | Gets the label of the link.+label :: RankedGuideLink -> UCharType+label = fst . rankedGuideLink++-- | Gets the value of the link.+value :: RankedGuideLink -> ValueType+value = snd . rankedGuideLink

@@ -0,0 +1,93 @@+{-|+Module: Data.DAWG.RankedCompleter+Description: Exports RankedCompleter API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.RankedCompleter+  ( -- * Completer+    -- $usage+    RankedCompleter (..)+  , start+  , next+  , keyToString+  , value+  , completeKeys+  ) where++import Data.DAWG.Internal.RankedCompleter+++-- $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 'RankedCompleter' 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" 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.+--+--

@@ -0,0 +1,56 @@+{-|+Module: Data.DAWG.RankedGuide+Description: Exports RankedGuide API.+Copyright: (c) Andrey Prokopenko, 2025+License: BSD-3-Clause+Stability: experimental+-}+module Data.DAWG.RankedGuide+  ( -- * RankedGuide+    -- $doc++    -- ** Building+    -- $usage++    RankedGuide (..)+  , build+  , build'++    -- ** Basic operations++  , child+  , sibling+  , rankedGuideDictionary++    -- ** Loading and saving++  , read+  , write+  ) where++import Data.DAWG.Internal.RankedGuideBuilder (build, build')+import Data.DAWG.Internal.RankedGuide+  (RankedGuide (..), child, sibling, rankedGuideDictionary, read, write)++import Prelude hiding (read)++-- $doc+--+-- This module offers RankedGuide.++-- $usage+--+-- RankedGuide 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 "myRankedGuide.dawg" guide+--+-- And later loaded back:+--+-- >>> guide <- read "myRankedGuide.dawg"+--

@@ -15,6 +15,8 @@ import Test.Hspec import Text.Read (readMaybe) +import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as BSL import qualified Data.Vector as Vector  main :: IO ()@@ -32,16 +34,11 @@             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"+      -- it must not fail since the DictionarySpec covers it+      dict <- Dict.build' dawg       mGuide <- G.build dawg dict       isJust mGuide `shouldBe` True-      forM_ mGuide \guide -> G.write "lexicon.gde" guide+      forM_ mGuide \guide -> G.write "lexicon.dic" guide          it "Completes keys from a lexicon" do       let completerResultFile = "completer-result"@@ -52,24 +49,24 @@                 [ " ", 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+          go :: BaseType -> String -> String -> G.Guide -> IO ()+          go _dictIx _fullWord [] _guide = pure ()+          go dictIx fw w g = do+            let d = G.guideDictionary g             case Dict.followPrefixLength w (fromIntegral $ length w) dictIx d of               Nothing -> pure ()               Just nextDictIx -> do-                let !nc = start nextDictIx "" d g+                let !nc = start nextDictIx "" g                 goNext fw nc-                go nextDictIx fw w d g+                go nextDictIx fw w g        writeFile completerResultFile ""-      dict <- Dict.read "lexicon.dic"-      guide <- G.read "lexicon.gde"+      guide <- G.read "lexicon.dic"              contents <- readFile "data/query"       forM_ (lines contents) \l -> do         appendFile completerResultFile $ concat [ l, ":" ]-        go Dict.root l l dict guide+        go Dict.root l l guide         appendFile completerResultFile "\n"        True `shouldBe` True@@ -79,3 +76,10 @@       testResult <- readFile completerResultFile       testExpectation <- readFile "data/completer-answer"       testResult `shouldBe` testExpectation++    it "Ensures binary compatibility with C++" do+      cppContents <- BSL.readFile "data/lexicon.guide.dic"+      let cppGuide = Binary.decode cppContents+      guide <- G.read "lexicon.dic"+      cppGuide `shouldBe` guide+      Binary.encode guide `shouldBe` cppContents

@@ -12,6 +12,8 @@ import Test.Hspec import Text.Read (readMaybe) +import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as BSL import qualified Data.Vector as Vector  main :: IO ()@@ -65,3 +67,10 @@       testResult <- readFile dictResultFile       testExpectation <- readFile "data/dictionary-answer"       testResult `shouldBe` testExpectation++    it "Ensures binary compatibility with C++" do+      cppContents <- BSL.readFile "data/lexicon.dic"+      let cppDict = Binary.decode cppContents+      dict <- Dict.read "lexicon.dic"+      cppDict `shouldBe` dict+      Binary.encode dict `shouldBe` cppContents

@@ -0,0 +1,155 @@+{-# LANGUAGE BlockArguments #-}+module Data.DAWG.RankedCompleterSpec where++import Data.DAWG.Internal.BaseType++import Data.DAWG.RankedCompleter (keyToString, start, next)++import qualified Data.DAWG.RankedCompleter as C+import qualified Data.DAWG.RankedGuide as G+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.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe, isJust)+import Test.Hspec+import Test.QuickCheck (chooseEnum, chooseInt, forAll, property, shuffle, vectorOf, withMaxSuccess)+import Text.Read (readMaybe)++import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Set as Set+import qualified Data.Vector as Vector++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "RankedCompleter" 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+      -- it must not fail since the DictionarySpec covers it+      dict <- Dict.build' dawg+      mGuide <- G.build dawg dict+      isJust mGuide `shouldBe` True+      forM_ mGuide \guide -> G.write "ranked-guide.dic" guide+    +    it "Completes keys from a lexicon" do+      let completerResultFile = "ranked-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 -> G.RankedGuide -> IO ()+          go _dictIx _fullWord [] _guide = pure ()+          go dictIx fw w g = do+            let d = G.rankedGuideDictionary g+            case Dict.followPrefixLength w (fromIntegral $ length w) dictIx d of+              Nothing -> pure ()+              Just nextDictIx -> do+                let !nc = start nextDictIx "" g+                goNext fw nc+                go nextDictIx fw w g++      writeFile completerResultFile ""+      guide <- G.read "ranked-guide.dic"+      +      contents <- readFile "data/query"+      forM_ (lines contents) \l -> do+        appendFile completerResultFile $ concat [ l, ":" ]+        go Dict.root l l guide+        appendFile completerResultFile "\n"++      True `shouldBe` True++    it "Checks results" do+      let completerResultFile = "ranked-completer-result"+      testResult <- readFile completerResultFile+      testExpectation <- readFile "data/ranked-completer-answer"+      testResult `shouldBe` testExpectation+++    it "Completes randomly linked keys and values" do+      let n = 65536+          keyLength = 6++          whenJust x action = case x of+            Nothing -> pure ()+            Just val -> action val++          goNext c valueRef = do+            mPrevValue <- readIORef valueRef+            case next c of+              Nothing -> pure ()+              Just !nc -> do+                let v = C.value nc+                -- putStrLn $ concat [keyToString nc, ": ", show v]++                -- 2. Ranked value should be equal or less than the previous one+                -- (i.e. in descending order)+                whenJust mPrevValue \prevValue -> do+                  v `shouldSatisfy` (<= prevValue)++                writeIORef valueRef (Just v)++          wordGen = vectorOf keyLength $ chooseEnum ('A', 'Z')+          shuffledListN = do+            vals <- vectorOf n $ chooseInt (0, 100)+            keys <- vectorOf n wordGen+            let keys' = Set.toList . Set.fromList $ keys+            vals' <- shuffle vals+            pure $ zip keys' (fromIntegral <$> vals')+          prop_rankedCompleterCompletes = forAll shuffledListN \lexicon -> do+            db <- DAWG.new+            forM_ lexicon \(k, v) -> do+              -- putStrLn $ concat [k, "\t", show v]+              DAWG.insert (Vector.fromList k) (Just v) db+            dawg <- DAWG.freeze db+            dict <- Dict.build' dawg++            -- 1. Dictionary should contain value associated with a key+            forM_ lexicon \(k, v) -> do+              Dict.lookup k dict `shouldBe` Just v++            guide <- G.build' dawg dict+            globalRef <- newIORef (-1)+            forM_ ['A' .. 'Z'] \c -> do+              let firstLabel = fromIntegral $ ord c+              case Dict.followChar firstLabel Dict.root dict of+                Nothing -> pure ()+                Just dictIx -> do+                  prevValueRef <- newIORef Nothing+                  let !nc = start dictIx [c] guide+                  goNext nc prevValueRef+                  mLatestVal <- readIORef prevValueRef+                  globalVal <- readIORef globalRef+                  whenJust mLatestVal \latestVal -> do+                    when (globalVal < latestVal) do+                      writeIORef globalRef latestVal++            -- 3. maximum value should always be picked up during full dictionary traversal+            let maxVal = maximum (snd <$> lexicon)+            globalVal <- readIORef globalRef+            maxVal `shouldBe` globalVal+            +      withMaxSuccess 10 $ property prop_rankedCompleterCompletes++    it "Ensures binary compatibility with C++" do+      cppContents <- BSL.readFile "data/lexicon.ranked.dic"+      let cppGuide = Binary.decode cppContents+      guide <- G.read "ranked-guide.dic"+      cppGuide `shouldBe` guide+      Binary.encode guide `shouldBe` cppContents