diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Changelog for `lfudacaching` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 0.1.0.0 - 2026-03-06 + +Pure Haskell implementation of cache data structures with three eviction policies: +LFUDA (Least Frequently Used with Dynamic Aging), GDSF (Greedy Dual-Size Frequency), +and LFU (Least Frequently Used). + +- Immutable API: `insert`, `insertView`, `lookup`, `peek`, `contains`, `remove`, `purge` +- `Functor`, `Foldable`, `Traversable` instances for `LfudaCache` +- Test suite (29 tests), benchmarks, and demo program diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,191 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to the Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by the Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding any notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2026 philippedev101 + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,147 @@ +# lfudacaching + +A pure Haskell implementation of cache data structures with multiple eviction policies: + +- **LFUDA** (Least Frequently Used with Dynamic Aging) - Prevents cache pollution by aging out stale entries +- **GDSF** (Greedy Dual-Size Frequency) - Factors in entry size alongside frequency +- **LFU** (Least Frequently Used) - Classic frequency-based eviction without aging + +Based on the Go implementation from [lfuda-go](https://github.com/bparli/lfuda-go). + +## Installation + +Add `lfudacaching` to your `package.yaml` dependencies: + +```yaml +dependencies: + - lfudacaching +``` + +Or in your `.cabal` file: + +```cabal +build-depends: lfudacaching +``` + +## Usage + +Note: `Data.LfudaCache` exports its own `lookup`, so you need to hide it from `Prelude`. + +```haskell +import Data.LfudaCache +import Prelude hiding (lookup) + +main :: IO () +main = do + -- Create a cache with capacity 100 using LFUDA policy + let cache = newLFUDA 100 + + -- Insert key-value pairs + let cache1 = insert "alice" 42 cache + let cache2 = insert "bob" 99 cache1 + + -- Lookup updates frequency (affects eviction priority) + case lookup "alice" cache2 of + Just (val, cache2') -> do + putStrLn $ "Found alice: " ++ show val + -- Use cache2' going forward (frequency of "alice" was bumped) + print (size cache2') + Nothing -> putStrLn "Not found" + + -- Peek reads without updating frequency + case peek "bob" cache2 of + Just val -> putStrLn $ "Peeked bob: " ++ show val + Nothing -> putStrLn "Not found" + + -- Check membership without frequency update + print $ contains "alice" cache2 -- True + + -- Remove an entry + let cache3 = remove "alice" cache2 + + -- Cache info + print $ size cache3 -- 1 + print $ keys cache3 -- ["bob"] +``` + +A demo program is included — run it with `stack exec lfuda-demo`. + +## API Overview + +### Construction + +| Function | Description | +|------------|--------------------------------------| +| `newLFUDA` | Create cache with LFUDA policy | +| `newGDSF` | Create cache with GDSF policy | +| `newLFU` | Create cache with LFU policy | +| `newCache` | Create cache with specified policy | + +### Operations + +| Function | Description | +|--------------|------------------------------------------------| +| `insert` | Insert a key-value pair | +| `insertView` | Insert, returning the evicted entry if any | +| `lookup` | Get value and update frequency | +| `peek` | Get value without updating frequency | +| `contains` | Check if key exists (no frequency update) | +| `remove` | Remove an entry | +| `purge` | Clear all entries | + +### Cache Information + +| Function | Description | +|----------|--------------------------------------------------| +| `keys` | Get all keys ordered by priority (highest first) | +| `size` | Current number of entries | +| `age` | Current cache age | + +### Typeclass Instances + +`LfudaCache k` is an instance of `Functor`, `Foldable`, and `Traversable`, allowing you to map, fold, and traverse over cached values. + +## Eviction Policies + +### LFUDA +Priority = frequency + cache age. When an entry is evicted, the cache age is set to the evicted entry's frequency. This prevents long-lived but infrequently accessed entries from dominating the cache. + +### GDSF +Priority = frequency + cache age * entry size. Similar to LFUDA but factors in entry size, giving larger entries higher eviction resistance. Currently all entries use a fixed size of 1, so GDSF behaves similarly to LFUDA. + +### LFU +Priority = frequency. Simple frequency counting with no aging. The cache age never changes. Entries that were popular in the past stay cached even if they are no longer accessed. + +## Important Behavioral Notes + +### Priorities are sticky + +Entry priorities are stored in the underlying priority queue and are **only recalculated on `lookup`**, not when the cache age changes. This means: + +- After an eviction raises the cache age, existing entries keep their old (lower) priorities. +- A freshly inserted entry gets `priority = 1 + current_age`, which can be *higher* than an old entry whose priority was computed when the age was lower. +- To "refresh" an entry's priority to account for the current age, you must `lookup` it. + +This is standard LFUDA behavior and means that entries which haven't been accessed recently will naturally drift toward eviction as the cache ages. + +### Re-inserting a key resets its frequency + +Calling `insert` on an existing key replaces the value **and resets its frequency to 1**. If you've built up a high frequency through many `lookup` calls, re-inserting the same key throws that away. Use `lookup` to access entries without resetting frequency, or check with `contains`/`peek` before inserting. + +### Eviction happens during insert + +When the cache is full, `insert` evicts the lowest-priority entry **before returning**. If you insert a key you intend to immediately remove, the eviction still happens. This can remove entries you intended to keep. + +### Purge does not reset age + +`purge` clears all entries and resets the size to 0, but the cache age is preserved. Entries inserted after a purge will have their priority calculated using the pre-purge age. + +## Building + +```bash +stack build # Build library +stack test # Run tests (29 tests) +stack bench # Run benchmarks +stack exec lfuda-demo # Run demo program +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,98 @@ +module Main (main) where + +import Data.LfudaCache +import Data.Foldable (foldl') +import Prelude hiding (lookup) + + +main :: IO () +main = do + putStrLn "=== LFUDA Cache Demo ===" + putStrLn "" + + -- Create a small cache to demonstrate eviction behavior + let cache :: LfudaCache String Int + cache = newLFUDA 3 + putStrLn $ "Created LFUDA cache with capacity 3" + putStrLn "" + + -- Insert some entries + let c1 = insert "alice" (100 :: Int) cache + let c2 = insert "bob" 200 c1 + let c3 = insert "carol" 300 c2 + putStrLn $ "Inserted alice=100, bob=200, carol=300" + putStrLn $ "Size: " ++ show (size c3) + putStrLn $ "Keys: " ++ show (keys c3) + putStrLn "" + + -- Lookup bumps frequency + putStrLn "Looking up 'alice' 3 times (bumps frequency)..." + let c4 = foldl' (\c _ -> case lookup "alice" c of + Just (_, c') -> c' + Nothing -> c + ) c3 [1..3 :: Int] + + -- Insert a 4th entry - should evict lowest frequency entry + -- Use insertView to see what was evicted + let (evicted, c5) = insertView "dave" 400 c4 + putStrLn $ "Inserted dave=400, eviction occurred: " ++ show (evicted /= Nothing) + case evicted of + Just (k, v) -> putStrLn $ "Evicted: " ++ show k ++ "=" ++ show v + Nothing -> pure () + putStrLn $ "Keys after eviction: " ++ show (keys c5) + putStrLn $ "alice still in cache: " ++ show (contains "alice" c5) + putStrLn "" + + -- Demonstrate peek vs lookup + putStrLn "--- Peek vs Lookup ---" + case peek "alice" c5 of + Just v -> putStrLn $ "peek alice = " ++ show v ++ " (no frequency update)" + Nothing -> putStrLn "alice not found" + + case lookup "alice" c5 of + Just (v, _) -> putStrLn $ "lookup alice = " ++ show v ++ " (frequency updated)" + Nothing -> putStrLn "alice not found" + putStrLn "" + + -- Demonstrate insertView + putStrLn "--- InsertView ---" + let (evictedEntry, c6) = insertView "eve" 500 c5 + case evictedEntry of + Just (k, v) -> putStrLn $ "Evicted: " ++ show k ++ "=" ++ show v + Nothing -> putStrLn "No eviction" + putStrLn $ "Keys: " ++ show (keys c6) + putStrLn "" + + -- Compare policies + putStrLn "=== Policy Comparison ===" + putStrLn "" + comparePolicies + +comparePolicies :: IO () +comparePolicies = do + let capacity :: Int + capacity = 3 + items :: [(String, Int)] + items = [("a", 1), ("b", 2), ("c", 3), ("d", 4), ("e", 5)] + + -- For each policy, insert items and show what survives + let policies :: [(CachePolicy, String)] + policies = [(LFUDA, "LFUDA"), (GDSF, "GDSF"), (LFU, "LFU")] + + mapM_ (\(policy, name) -> do + let cache0 :: LfudaCache String Int + cache0 = newCache capacity policy + -- Insert first 3 + cache1 = foldl' (\c (k, v) -> insert k v c) cache0 (take 3 items) + -- Bump frequency of "a" + let cache2 = foldl' (\c _ -> case lookup "a" c of + Just (_, c') -> c' + Nothing -> c + ) cache1 [1..2 :: Int] + -- Insert remaining 2 + let cache3 = foldl' (\c (k, v) -> insert k v c) cache2 (drop 3 items) + + putStrLn $ name ++ ":" + putStrLn $ " Surviving keys: " ++ show (keys cache3) + putStrLn $ " Age: " ++ show (age cache3) + ) policies diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,78 @@ +module Main (main) where + +import Test.Tasty.Bench +import Data.LfudaCache +import Data.Foldable (foldl') +import Prelude hiding (lookup) + + +main :: IO () +main = defaultMain + [ bgroup "insert" + [ bench "LFUDA/1000" $ nf (insertN LFUDA 1000) 10000 + , bench "GDSF/1000" $ nf (insertN GDSF 1000) 10000 + , bench "LFU/1000" $ nf (insertN LFU 1000) 10000 + ] + , bgroup "lookup" + [ bench "LFUDA/hit" $ nf (lookupHit LFUDA 1000) 5000 + , bench "GDSF/hit" $ nf (lookupHit GDSF 1000) 5000 + , bench "LFU/hit" $ nf (lookupHit LFU 1000) 5000 + , bench "LFUDA/miss" $ nf (lookupMiss LFUDA 1000) 5000 + , bench "LFU/miss" $ nf (lookupMiss LFU 1000) 5000 + ] + , bgroup "mixed" + [ bench "LFUDA/1000" $ nf (mixedWorkload LFUDA 1000) 10000 + , bench "GDSF/1000" $ nf (mixedWorkload GDSF 1000) 10000 + , bench "LFU/1000" $ nf (mixedWorkload LFU 1000) 10000 + ] + , bgroup "contains" + [ bench "LFUDA/1000" $ nf (containsWorkload LFUDA 1000) 5000 + , bench "LFU/1000" $ nf (containsWorkload LFU 1000) 5000 + ] + ] + +-- | Insert n items into a cache of given capacity +insertN :: CachePolicy -> Int -> Int -> LfudaCache Int Int +insertN policy capacity n = + foldl' (\c i -> insert i i c) (newCache capacity policy) [0..n-1] + +-- | Lookup items that are in the cache (hits) +lookupHit :: CachePolicy -> Int -> Int -> LfudaCache Int Int +lookupHit policy capacity n = + let cache0 = foldl' (\c i -> insert i i c) (newCache capacity policy) [0..capacity-1] + in foldl' (\c i -> + case lookup (i `mod` capacity) c of + Just (_, c') -> c' + Nothing -> c + ) cache0 [0..n-1] + +-- | Lookup items that are not in the cache (misses) +lookupMiss :: CachePolicy -> Int -> Int -> LfudaCache Int Int +lookupMiss policy capacity n = + let cache0 = foldl' (\c i -> insert i i c) (newCache capacity policy) [0..capacity-1] + in foldl' (\c i -> + case lookup (capacity + i) c of + Just (_, c') -> c' + Nothing -> c + ) cache0 [0..n-1] + +-- | Mixed insert/lookup workload +mixedWorkload :: CachePolicy -> Int -> Int -> LfudaCache Int Int +mixedWorkload policy capacity n = + foldl' (\c i -> + if even i + then insert (i `mod` (capacity * 2)) i c + else case lookup (i `mod` (capacity * 2)) c of + Just (_, c') -> c' + Nothing -> c + ) (newCache capacity policy) [0..n-1] + +-- | Contains check workload (no frequency update) +containsWorkload :: CachePolicy -> Int -> Int -> Int +containsWorkload policy capacity n = + let cache0 = foldl' (\c i -> insert i i c) (newCache capacity policy) [0..capacity-1] + in foldl' (\acc i -> + if contains (i `mod` (capacity * 2)) cache0 + then acc + 1 + else acc + ) (0 :: Int) [0..n-1] diff --git a/lfudacaching.cabal b/lfudacaching.cabal new file mode 100644 --- /dev/null +++ b/lfudacaching.cabal @@ -0,0 +1,148 @@ +cabal-version: 3.0 +name: lfudacaching +version: 0.1.0.0 +synopsis: Pure LFUDA, GDSF, and LFU cache implementations +description: + Pure, immutable cache with three eviction policies: + . + * __LFUDA__ — Least Frequently Used with Dynamic Aging + * __GDSF__ — Greedy Dual-Size Frequency + * __LFU__ — Least Frequently Used + . + All operations are /O(log n)/ in the number of cached entries, backed by a + hash-priority search queue. + +category: Data +homepage: https://github.com/philippedev101/lfudacache#readme +bug-reports: https://github.com/philippedev101/lfudacache/issues +author: philippedev101 +maintainer: philippedev101@gmail.com +copyright: 2026 +license: Apache-2.0 +license-file: LICENSE +build-type: Simple + +extra-source-files: + README.md + +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/philippedev101/lfudacache + +-- Shared language, extensions, and base dependency +common lang + default-language: GHC2021 + default-extensions: + BangPatterns + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + DisambiguateRecordFields + DuplicateRecordFields + FunctionalDependencies + GADTs + KindSignatures + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + PartialTypeSignatures + PolyKinds + RecordWildCards + RoleAnnotations + UnboxedSums + UnboxedTuples + UnliftedDatatypes + UnliftedNewtypes + ViewPatterns + build-depends: + base >= 4.18 && < 5 + +-- Strict warnings for development components (not the library) +common dev-warnings + ghc-options: + -Weverything + + -- Unavoidable noise + -Wno-missing-import-lists + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + -Wno-safe + -Wno-unsafe + + -- Promoted to errors + -Werror=deprecations + -Werror=identities + -Werror=incomplete-patterns + -Werror=incomplete-record-updates + -Werror=missing-fields + -Werror=missing-methods + -Werror=ambiguous-fields + -Werror=missing-export-lists + -Werror=missing-local-signatures + -Werror=monomorphism-restriction + -Werror=type-defaults + -Werror=orphans + -Werror=name-shadowing + -Werror=missing-kind-signatures + -Werror=missing-deriving-strategies + -Werror=unticked-promoted-constructors + -Werror=missing-role-annotations + + -- foldl' import is redundant on GHC 9.10+ but required on 9.6/9.8 + -Wno-unused-imports + + -- Cross-module specialisation: unfixable + -Wno-all-missed-specialisations + -Wno-missed-specialisations + +library + import: lang + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: + Data.LfudaCache + build-depends: + deepseq >= 1.4 && < 1.7 + , hashable >= 1.4 && < 1.6 + , psqueues >= 0.2.8 && < 0.3 + , ghc-prim >= 0.10 && < 0.14 + +executable lfuda-demo + import: lang, dev-warnings + hs-source-dirs: app + main-is: Main.hs + build-depends: + lfudacaching + +test-suite lfuda-test + import: lang, dev-warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Data.LfudaCache + build-depends: + lfudacaching + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + +benchmark lfuda-bench + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -O2 -rtsopts + build-depends: + lfudacaching + , tasty-bench >= 0.4 && < 0.5 diff --git a/src/Data/LfudaCache.hs b/src/Data/LfudaCache.hs new file mode 100644 --- /dev/null +++ b/src/Data/LfudaCache.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE StrictData #-} +{-| +Module : Data.LfudaCache +Description : Pure LFUDA, GDSF, and LFU cache implementations +Copyright : (c) 2026 philippedev101 +License : Apache-2.0 +Maintainer : philippedev101@gmail.com +Stability : experimental + +Pure, immutable cache with three eviction policies: __LFUDA__, __GDSF__, and __LFU__. + +== Eviction policies + +* __LFUDA__ (Least Frequently Used with Dynamic Aging) — combines access + frequency with a global /age/ counter that advances on every eviction. + New entries start with @frequency + age@ as their priority, which prevents + long-lived but rarely accessed items from permanently occupying the cache + (a common weakness of plain LFU). + +* __GDSF__ (Greedy Dual-Size Frequency) — extends LFUDA by factoring in + entry size: @frequency + age × size@. Useful when cached values have + varying costs. + +* __LFU__ (Least Frequently Used) — evicts the entry with the lowest access + frequency. No aging is applied, so frequently accessed items are never + evicted regardless of how long ago they were last accessed. + +== Quick start + +@ +import Data.LfudaCache +import Prelude hiding ('lookup') + +example :: (Maybe String, LfudaCache String String) +example = + let cache = 'newLFUDA' 100 + cache' = 'insert' \"hello\" \"world\" cache + in case 'lookup' \"hello\" cache' of + Just (val, cache'') -> (Just val, cache'') + Nothing -> (Nothing, cache') +@ + +== Complexity + +All operations are /O(log n)/ in the number of cached entries, backed by a +hash-priority search queue ('Data.HashPSQ.HashPSQ'). + +== Lookup vs Peek + +'lookup' increments the entry's access frequency (affecting future eviction +priority). 'peek' returns the value without any side effect on frequency — +useful for monitoring or read-only inspection. +-} +module Data.LfudaCache + ( -- * Cache type + LfudaCache + , CachePolicy(..) + , Age + + -- * Construction + , newLFUDA + , newGDSF + , newLFU + , newCache + + -- * Insertion + , insert + , insertView + + -- * Lookup + , lookup + , peek + , contains + + -- * Deletion + , remove + , purge + + -- * Size and metadata + , keys + , size + , age + ) where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.Maybe (isNothing) +import GHC.Generics (Generic) +import GHC.Types (Type) +import Prelude hiding (lookup) +import qualified Data.HashPSQ as HashPSQ + + +-- | Eviction policy. See the module documentation for a description of each. +type CachePolicy :: Type +data CachePolicy + = LFUDA -- ^ Least Frequently Used with Dynamic Aging. + -- Priority = @frequency + age@. + | GDSF -- ^ Greedy Dual-Size Frequency. + -- Priority = @frequency + age × size@. + | LFU -- ^ Plain Least Frequently Used (no aging). + -- Priority = @frequency@. + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Access count for a cache entry. Incremented on every 'lookup' hit. +type Frequency :: Type +type Frequency = Int64 + +-- | Cache age counter. Under LFUDA\/GDSF this advances on every eviction, +-- ensuring that newly inserted entries are not immediately evicted just +-- because older entries accumulated high frequency counts. +type Age :: Type +type Age = Int64 + +-- | Internal priority value computed from 'Frequency', 'Size', and 'Age' +-- according to the active 'CachePolicy'. The entry with the /lowest/ +-- priority is evicted first. +type Priority :: Type +type Priority = Int64 + +-- | Logical size of a cache entry (used by the 'GDSF' policy). +-- Currently fixed at @1@ for every entry. +type Size :: Type +type Size = Int64 + +-- | Internal result of an eviction attempt (not exported). +type EvictionResult :: Type -> Type -> Type +type role EvictionResult representational representational +data EvictionResult k v = + EvictionResult + { evicted :: !Bool -- ^ Whether an eviction occurred + , evictedKey :: !(Maybe k) -- ^ The key that was evicted (if any) + , evictedValue :: !(Maybe v) -- ^ The value that was evicted (if any) + } deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +-- | An immutable, bounded cache parameterised by key type @k@ and value +-- type @v@. The eviction strategy is determined by the 'CachePolicy' chosen +-- at construction time. +-- +-- The cache supports 'Functor', 'Foldable', and 'Traversable' over values, +-- as well as 'Eq', 'Show', and 'NFData'. +type LfudaCache :: Type -> Type -> Type +type role LfudaCache representational representational +data LfudaCache k v = LfudaCache + { lfudaCapacity :: {-# UNPACK #-} !Int -- ^ The maximum number of elements in the cache + , lfudaSize :: {-# UNPACK #-} !Int -- ^ The current number of elements in the cache + , lfudaAge :: {-# UNPACK #-} !Age -- ^ The current age of the cache + , lfudaPolicy :: !CachePolicy -- ^ The cache eviction policy to use + , lfudaQueue :: !(HashPSQ.HashPSQ k Priority (Frequency, Size, v)) -- ^ Underlying priority queue + } deriving stock (Generic) + +instance (Show k, Show v) => Show (LfudaCache k v) where + show c = "LfudaCache { capacity=" ++ show (lfudaCapacity c) ++ + ", size=" ++ show (lfudaSize c) ++ + ", age=" ++ show (lfudaAge c) ++ + ", policy=" ++ show (lfudaPolicy c) ++ + ", entries=" ++ show (lfudaSize c) ++ " }" + +instance (Eq k, Eq v, Hashable k, Ord k) => Eq (LfudaCache k v) where + c1 == c2 = lfudaCapacity c1 == lfudaCapacity c2 && + lfudaSize c1 == lfudaSize c2 && + lfudaAge c1 == lfudaAge c2 && + lfudaPolicy c1 == lfudaPolicy c2 && + lfudaQueue c1 == lfudaQueue c2 + +instance (NFData k, NFData v) => NFData (LfudaCache k v) + +-- Manual implementation of Functor +instance (Hashable k, Ord k) => Functor (LfudaCache k) where + {-# INLINABLE fmap #-} + fmap f (LfudaCache cap sizeVal ageVal policy queue) = + LfudaCache cap sizeVal ageVal policy (mapQueue f queue) + where + mapQueue :: forall v v'. (v -> v') -> HashPSQ.HashPSQ k Priority (Frequency, Size, v) -> HashPSQ.HashPSQ k Priority (Frequency, Size, v') + mapQueue g = HashPSQ.fromList . map mapEntry . HashPSQ.toList + where + mapEntry :: (k, Priority, (Frequency, Size, v)) -> (k, Priority, (Frequency, Size, v')) + mapEntry (k, p, (freq, s, v)) = (k, p, (freq, s, g v)) + +-- Manual implementation of Foldable +instance (Hashable k, Ord k) => Foldable (LfudaCache k) where + {-# INLINABLE foldr #-} + foldr f z = foldr (\(_, _, (_, _, v)) acc -> f v acc) z . HashPSQ.toList . lfudaQueue + +-- Manual implementation of Traversable +instance (Hashable k, Ord k) => Traversable (LfudaCache k) where + {-# INLINABLE traverse #-} + traverse f (LfudaCache cap sizeVal ageVal policy queue) = + LfudaCache cap sizeVal ageVal policy <$> traverseQueue f queue + where + traverseQueue :: forall f v v'. Applicative f => + (v -> f v') -> + HashPSQ.HashPSQ k Priority (Frequency, Size, v) -> + f (HashPSQ.HashPSQ k Priority (Frequency, Size, v')) + traverseQueue g = fmap HashPSQ.fromList . traverse transformEntry . HashPSQ.toList + where + transformEntry :: (k, Priority, (Frequency, Size, v)) -> f (k, Priority, (Frequency, Size, v')) + transformEntry (k, p, (freq, s, v)) = (\v' -> (k, p, (freq, s, v'))) <$> g v + +-- | Create a new empty cache with the given maximum capacity and eviction +-- policy. Calls 'error' if @capacity < 1@. +-- +-- >>> size (newCache 100 LFUDA) +-- 0 +{-# INLINABLE newCache #-} +newCache :: Int -> CachePolicy -> LfudaCache k v +newCache capacity policy + | capacity < 1 = error "LfudaCache.new: capacity < 1" + | otherwise = LfudaCache capacity 0 0 policy HashPSQ.empty + +-- | @'newLFUDA' cap@ — shorthand for @'newCache' cap 'LFUDA'@. +{-# INLINABLE newLFUDA #-} +newLFUDA :: Int -> LfudaCache k v +newLFUDA capacity = newCache capacity LFUDA + +-- | @'newGDSF' cap@ — shorthand for @'newCache' cap 'GDSF'@. +{-# INLINABLE newGDSF #-} +newGDSF :: Int -> LfudaCache k v +newGDSF capacity = newCache capacity GDSF + +-- | @'newLFU' cap@ — shorthand for @'newCache' cap 'LFU'@. +{-# INLINABLE newLFU #-} +newLFU :: Int -> LfudaCache k v +newLFU capacity = newCache capacity LFU + +-- | Compute the eviction priority for an entry under the given policy. +-- Lower priority ⇒ evicted first. +{-# INLINE calculatePriority #-} +calculatePriority :: CachePolicy -> Frequency -> Size -> Age -> Priority +calculatePriority LFUDA freq _ ageValue = freq + ageValue +calculatePriority GDSF freq sizeValue ageValue = freq + ageValue * sizeValue +calculatePriority LFU freq _ _ = freq + +-- | Common logic for insert operations +{-# INLINABLE prepareInsert #-} +prepareInsert :: (Hashable k, Ord k) => k -> v -> LfudaCache k v + -> (Bool, LfudaCache k v) +prepareInsert key val c = + let initialFreq :: Frequency + initialFreq = 1 + entrySize :: Size + entrySize = 1 -- Default size (could be parameterized in future) + priority = calculatePriority (lfudaPolicy c) initialFreq entrySize (lfudaAge c) + (mbOldVal, queue') = HashPSQ.insertView key priority (initialFreq, entrySize, val) (lfudaQueue c) + sizeIncrease = isNothing mbOldVal + in (sizeIncrease, c { lfudaSize = if sizeIncrease + then lfudaSize c + 1 + else lfudaSize c + , lfudaQueue = queue' + }) + +-- | Restore 'LfudaCache' invariants by evicting elements if cache exceeds capacity +-- Returns (eviction result, updated cache) +{-# INLINABLE trim #-} +trim :: (Hashable k, Ord k) => LfudaCache k v -> (EvictionResult k v, LfudaCache k v) +trim c + | lfudaSize c <= lfudaCapacity c = + (EvictionResult False Nothing Nothing, c) + | otherwise = + case HashPSQ.findMin (lfudaQueue c) of + Nothing -> + (EvictionResult False Nothing Nothing, c) -- Should not happen in practice + Just (k, _, (freq, _, v)) -> + let newAge = case lfudaPolicy c of + LFU -> lfudaAge c -- No aging for LFU + _ -> freq -- Set age to frequency + c' = c { lfudaSize = lfudaSize c - 1 + , lfudaAge = newAge + , lfudaQueue = HashPSQ.deleteMin (lfudaQueue c) + } + in (EvictionResult True (Just k) (Just v), c') + +-- | Insert a key–value pair. If the key already exists its value is +-- replaced and its frequency is reset to @1@. When the cache is at +-- capacity the lowest-priority entry is evicted first. +-- +-- Use 'insertView' if you need to know /which/ entry was evicted. +-- +-- /O(log n)/ +-- +-- >>> let c = insert "a" 1 (newLFUDA 2) +-- >>> size c +-- 1 +{-# INLINABLE insert #-} +insert :: (Hashable k, Ord k) => k -> v -> LfudaCache k v -> LfudaCache k v +insert key val c = + let (_, c') = prepareInsert key val c + (_, c'') = trim c' + in c'' + +-- | Like 'insert', but also returns the evicted entry (if any) as +-- @'Just' (key, value)@, or 'Nothing' when no eviction was necessary. +-- +-- /O(log n)/ +-- +-- >>> let (ev1, c) = insertView "a" 1 (newLFUDA 1) +-- >>> ev1 +-- Nothing +-- >>> let (ev2, _) = insertView "b" 2 c +-- >>> ev2 +-- Just ("a",1) +{-# INLINABLE insertView #-} +insertView :: (Hashable k, Ord k) => k -> v -> LfudaCache k v -> (Maybe (k, v), LfudaCache k v) +insertView key val c = + let (_, c') = prepareInsert key val c + (evictionResult, c'') = trim c' + in case (evictedKey evictionResult, evictedValue evictionResult) of + (Just k, Just v) -> (Just (k, v), c'') + _ -> (Nothing, c'') + +-- | Look up a key, returning its value and an updated cache with the +-- entry's frequency incremented. Returns 'Nothing' on a cache miss. +-- +-- Use 'peek' if you do not want the frequency bump. +-- +-- /O(log n)/ +-- +-- >>> let c = insert "a" 1 (newLFUDA 2) +-- >>> fmap fst (lookup "a" c) +-- Just 1 +-- >>> lookup "z" c +-- Nothing +{-# INLINABLE lookup #-} +lookup :: (Hashable k, Ord k) => k -> LfudaCache k v -> Maybe (v, LfudaCache k v) +lookup k c = + case HashPSQ.lookup k (lfudaQueue c) of + Nothing -> Nothing + Just (_, (freq, entrySize, v)) -> + let newFreq = freq + 1 + newPriority = calculatePriority (lfudaPolicy c) newFreq entrySize (lfudaAge c) + c' = c { lfudaQueue = HashPSQ.insert k newPriority (newFreq, entrySize, v) (lfudaQueue c) } + in Just (v, c') + +-- | Test whether a key is present in the cache. Does /not/ affect +-- the entry's frequency. +-- +-- /O(log n)/ +-- +-- >>> let c = insert "a" 1 (newLFUDA 2) +-- >>> contains "a" c +-- True +-- >>> contains "z" c +-- False +{-# INLINABLE contains #-} +contains :: (Hashable k, Ord k) => k -> LfudaCache k v -> Bool +contains k = HashPSQ.member k . lfudaQueue + +-- | Retrieve a value without incrementing its access frequency. +-- Useful for read-only inspection, monitoring, or debugging. +-- +-- /O(log n)/ +-- +-- >>> let c = insert "a" 1 (newLFUDA 2) +-- >>> peek "a" c +-- Just 1 +-- >>> peek "z" c +-- Nothing +{-# INLINABLE peek #-} +peek :: (Hashable k, Ord k) => k -> LfudaCache k v -> Maybe v +peek k c = (\(_, (_, _, v)) -> v) <$> HashPSQ.lookup k (lfudaQueue c) + +-- | Remove a key from the cache. Returns the cache unchanged if the key +-- is not present. +-- +-- /O(log n)/ +-- +-- >>> let c = insert "a" 1 (newLFUDA 2) +-- >>> size (remove "a" c) +-- 0 +-- >>> size (remove "z" c) +-- 1 +{-# INLINABLE remove #-} +remove :: (Hashable k, Ord k) => k -> LfudaCache k v -> LfudaCache k v +remove k c = + case HashPSQ.lookup k (lfudaQueue c) of + Nothing -> c + Just _ -> c { lfudaSize = lfudaSize c - 1 + , lfudaQueue = HashPSQ.delete k (lfudaQueue c) + } + +-- | Remove all entries from the cache, resetting 'size' to @0@. +-- The capacity and policy are preserved. +-- +-- /O(1)/ +-- +-- >>> size (purge (insert "a" 1 (newLFUDA 2))) +-- 0 +{-# INLINABLE purge #-} +purge :: LfudaCache k v -> LfudaCache k v +purge c = c { lfudaSize = 0 + , lfudaQueue = HashPSQ.empty + } + +-- | The current age of the cache. Under 'LFUDA' and 'GDSF' the age +-- advances each time an entry is evicted; under 'LFU' it stays at @0@. +-- +-- /O(1)/ +{-# INLINABLE age #-} +age :: LfudaCache k v -> Age +age = lfudaAge + +-- | All keys currently in the cache, ordered from highest to lowest +-- eviction priority (i.e. the entry most likely to survive eviction +-- comes first). +-- +-- /O(n log n)/ +{-# INLINABLE keys #-} +keys :: (Hashable k, Ord k) => LfudaCache k v -> [k] +keys = map (\(k, _, _) -> k) . reverse . HashPSQ.toList . lfudaQueue + +-- | The number of entries currently stored in the cache. +-- +-- /O(1)/ +{-# INLINABLE size #-} +size :: LfudaCache k v -> Int +size = lfudaSize diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Test.Data.LfudaCache (tests) +import Test.Tasty +import Prelude + + +main :: IO () +main = defaultMain tests diff --git a/test/Test/Data/LfudaCache.hs b/test/Test/Data/LfudaCache.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/LfudaCache.hs @@ -0,0 +1,979 @@ +module Test.Data.LfudaCache + ( tests + ) where + +import Test.Tasty +import Test.Tasty.HUnit +import Control.Monad +import Data.Maybe (isNothing) +import Data.LfudaCache +import Data.Foldable (foldl') +import Prelude hiding (lookup) +import Data.Kind + + +tests :: TestTree +tests = testGroup "LFUDA Cache Tests" + [ testCase "Basic LFUDA Operations" testLFUDA + , testCase "GDSF Test" testGDSF + , testCase "Insert Eviction Via InsertView" testInsertEviction + , testCase "Contains Doesn't Update Frequency" testLFUDAContains + , testCase "Peek Doesn't Update Frequency" testLFUDAPeek + , testCase "Remove Operation" testLFUDARemove + , testCase "Age Tracking" testLFUDAAge + , testCase "Size Tracking" testLFUDASize + , testCase "LFU Basic Operations" testLFU + , testCase "LFU No Dynamic Aging" testLFUNoAging + , testCase "LFU Frequency-Based Eviction" testLFUFrequencyEviction + , testCase "LFU InsertView" testLFUInsertView + , testCase "GDSF Size-Weighted Eviction" testGDSFSizeEviction + , testCase "GDSF Dynamic Aging" testGDSFAging + , testCase "GDSF Frequency And Size" testGDSFFrequencyAndSize + , testCase "Edge: Re-insert Resets Frequency" testReinsertResetsFrequency + , testCase "Edge: Capacity 1 Corner Cases" testCapacity1 + , testCase "Edge: Size Consistency" testSizeConsistency + , testCase "Edge: Purge Preserves Age" testPurgePreservesAge + , testCase "Edge: Operations After Purge" testOpsAfterPurge + , testCase "Edge: InsertView Self-Replace" testInsertViewSelfReplace + , testCase "Edge: InsertView Evicts Correct Entry" testInsertViewEvictsCorrect + , testCase "Edge: Remove Nonexistent" testRemoveNonexistent + , testCase "Edge: Equal Frequency Eviction" testEqualFrequencyEviction + , testCase "Edge: LFUDA Age Accumulation" testAgeAccumulation + , testCase "Edge: Lookup After Insert Same Key" testLookupAfterReinsert + , testCase "Edge: Rapid Insert-Remove Cycles" testInsertRemoveCycles + , testBenchmark "LFUDA Benchmark" benchmarkLFUDA + , testBenchmark "LFUDA Random Benchmark" benchmarkLFUDARand + ] + +testLFUDA :: Assertion +testLFUDA = do + -- Create cache with proper policy + let initialCache :: LfudaCache Int Int + initialCache = newCache 666 LFUDA + + -- Track number of evictions using insertView + let insertAndTrackEvictions :: (LfudaCache Int Int, Int) -> Int -> (LfudaCache Int Int, Int) + insertAndTrackEvictions (cache, count) i = + let (evictedEntry, cache') = insertView i i cache + newCount = case evictedEntry of + Just _ -> count + 1 + Nothing -> count + in (cache', newCount) + + let finalCacheAndCount = foldl' insertAndTrackEvictions (initialCache, 0) [100..999 :: Int] + finalCache = fst finalCacheAndCount + evictionCount = snd finalCacheAndCount + + let len = size finalCache + assertEqual "Cache length should match" 666 len + + let keys2 = keys finalCache + assertEqual "Keys length should match cache length" len (length keys2) + + -- Check eviction count + assertEqual "Eviction count should match" (234 :: Int) evictionCount + + -- Check values that should be in cache + forM_ keys2 $ \k -> do + let result = lookup k finalCache + case result of + Just (v, _) -> assertEqual "Value should match key" k v + Nothing -> assertFailure $ "Key " ++ show k ++ " should be in cache" + + -- These should be misses (keys 100-333, since we inserted 900 items in a cache of size 666) + forM_ [100..333 :: Int] $ \i -> do + let result = lookup i finalCache + assertBool ("Key " ++ show i ++ " should not be in cache") (isNothing result) + + -- Set a new value and check it + let cacheWithNewVal = insert (256 :: Int) (256 :: Int) finalCache + + let result = lookup (256 :: Int) cacheWithNewVal + case result of + Just (v, _) -> assertEqual "Value for key 256 should be 256" (256 :: Int) v + Nothing -> assertFailure "Key 256 should be in cache" + + -- Check most frequently used key after updating key 256 + let updatedCache = case result of + Just (_, c') -> c' + Nothing -> cacheWithNewVal + + let keysAfterUpdate = keys updatedCache + assertBool "Keys should be present after update" (not (null keysAfterUpdate)) + + -- Purge and verify empty + let purgedCache = purge updatedCache + let lenAfterPurge = size purgedCache + assertEqual "Cache should be empty after purge" 0 lenAfterPurge + + let resultAfterPurge = lookup (200 :: Int) purgedCache + assertBool "Cache should contain nothing after purge" (isNothing resultAfterPurge) + +testGDSF :: Assertion +testGDSF = do + let initialCache :: LfudaCache Int Int + initialCache = newGDSF 666 + + -- Insert elements with power of 2 values + let cacheWith10to19 = foldl' (\cache i -> + insert i (2 ^ i) cache + ) initialCache [10..19 :: Int] + + -- Insert more elements with same key/value + let finalCache = foldl' (\cache i -> + insert i i cache + ) cacheWith10to19 [100..999 :: Int] + + let len = size finalCache + assertEqual "Cache length should match" 666 len + + let keys2 = keys finalCache + assertEqual "Keys length should match cache length" len (length keys2) + + -- Check values that should be in cache + forM_ keys2 $ \k -> do + let result = lookup k finalCache + assertBool "Get should return a result" (not (isNothing result)) + case result of + Just (v, _) -> + if k >= 10 && k <= 19 + then assertEqual "Value should be 2^key for keys 10-19" (2 ^ k) v + else assertEqual "Value should match key for other keys" k v + Nothing -> assertFailure $ "Key " ++ show k ++ " should be in cache" + + -- Set a new value and check it + let cacheWithNewVal = insert (256 :: Int) (256 :: Int) finalCache + + let result = lookup (256 :: Int) cacheWithNewVal + case result of + Just (v, _) -> assertEqual "Value for key 256 should be 256" (256 :: Int) v + Nothing -> assertFailure "Key 256 should be in cache" + + -- Check most frequently used key after updating key 256 + let updatedCache = case result of + Just (_, c') -> c' + Nothing -> cacheWithNewVal + + let keysAfterUpdate = keys updatedCache + -- Key 256 should have higher frequency due to the get operation above + assertBool "Keys should be present after update" (not (null keysAfterUpdate)) + +testInsertEviction :: Assertion +testInsertEviction = do + let cache :: LfudaCache Int Int + cache = newCache 1 LFUDA + + -- First insert should not evict + let (evicted1, _) = insertView (1 :: Int) (1 :: Int) cache + assertEqual "Should not have evicted" Nothing evicted1 + + -- Second insert (different key) should evict + let c1 = insert (1 :: Int) (1 :: Int) cache + let (evicted2, _) = insertView (2 :: Int) (2 :: Int) c1 + assertBool "Should have evicted" (evicted2 /= Nothing) + +testLFUDAContains :: Assertion +testLFUDAContains = do + let initialCache :: LfudaCache Int Int + initialCache = newCache 2 LFUDA + + let cache1 = insert (1 :: Int) (1 :: Int) initialCache + let cache2 = insert (2 :: Int) (2 :: Int) cache1 + + -- Bump hits for key 1 + let finalCache1 = foldl' (\c _ -> + case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) cache2 [1..10 :: Int] + + let keys1 = keys finalCache1 + case keys1 of + (k:_) -> assertEqual "Key 1 should be most frequently used" (1 :: Int) k + [] -> assertFailure "Keys list should not be empty" + + -- Contains should not bump hits for key 2 + let finalCache2 = foldl' (\c _ -> c) finalCache1 (replicate 20 (contains (2 :: Int) finalCache1)) + + let keys2 = keys finalCache2 + case keys2 of + (k:_) -> assertEqual "Key 1 should still be most frequently used" (1 :: Int) k + [] -> assertFailure "Keys list should not be empty" + +testLFUDAPeek :: Assertion +testLFUDAPeek = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 2 + + let cache1 = insert (1 :: Int) (1 :: Int) initialCache + let cache2 = insert (2 :: Int) (2 :: Int) cache1 + + -- Peek should not update frequency + let result1 = peek (1 :: Int) cache2 + assertEqual "Value for key 1 should be 1" (Just 1) result1 + + -- Increase frequency of key 2 + let cache2' = case lookup (2 :: Int) cache2 of + Just (_, c) -> c + Nothing -> cache2 + + -- Adding key 3 should evict key 1 (lowest frequency) + let cache3 = insert (3 :: Int) (3 :: Int) cache2' + + -- Key 1 should be evicted + let containsKey1 = contains (1 :: Int) cache3 + assertBool "Key 1 should have been evicted" (not containsKey1) + +testLFUDARemove :: Assertion +testLFUDARemove = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 2 + + let cache1 = insert (1 :: Int) (1 :: Int) initialCache + let cache2 = insert (2 :: Int) (2 :: Int) cache1 + + let result1 = lookup (1 :: Int) cache2 + case result1 of + Just (v, _) -> assertEqual "Value for key 1 should be 1" (1 :: Int) v + Nothing -> assertFailure "Key 1 should be in cache" + + -- Remove key 1 + assertBool "Key 1 should be in cache before removal" (contains (1 :: Int) cache2) + let cache2' = remove (1 :: Int) cache2 + + let result1' = lookup (1 :: Int) cache2' + assertBool "Key 1 should not be in cache after removal" (isNothing result1') + + let len = size cache2' + assertEqual "Cache length should be 1 after removal" 1 len + +testLFUDAAge :: Assertion +testLFUDAAge = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 1 + + -- Set key 1 with initial frequency 1 + let cache1 = insert (1 :: Int) (1 :: Int) initialCache + + -- Bump hits on key 1 to frequency 2 + let cache1' = case lookup (1 :: Int) cache1 of + Just (_, c) -> c + Nothing -> cache1 + + -- Set key 2 - but key 2 will be immediately evicted because + -- it has lower priority (1) than key 1 (2) + let cache2 = insert (2 :: Int) (2 :: Int) cache1' + + -- The age should now be 1 (the frequency of the evicted key 2) + let age1 = age cache2 + assertEqual "Cache age should be 1" 1 age1 + +testLFUDASize :: Assertion +testLFUDASize = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 10 + + -- Insert elements + let finalCache = foldl' (\cache i -> + insert i i cache + ) initialCache [10..29 :: Int] + + -- Check size + let s = size finalCache + assertEqual "Cache size should be 10" 10 s + + -- Purge and check size again + let purgedCache = purge finalCache + let s' = size purgedCache + assertEqual "Cache size should be 0 after purge" 0 s' + +-- Edge Case Tests + +-- Re-inserting a key resets its frequency to 1, making it vulnerable to eviction +testReinsertResetsFrequency :: Assertion +testReinsertResetsFrequency = do + let cache :: LfudaCache Int Int + cache = newLFUDA 2 + + -- Insert keys 1 and 2 + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = insert (2 :: Int) (20 :: Int) c1 + + -- Lookup key 1 many times to build up its frequency + let c3 = foldl' (\c _ -> case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) c2 [1..10 :: Int] + + -- Key 1 now has high frequency. Re-insert it with new value - resets freq to 1! + let c4 = insert (1 :: Int) (100 :: Int) c3 + + -- Verify the value was updated + assertEqual "Value should be updated to 100" (Just 100) (peek (1 :: Int) c4) + + -- Now insert key 3. Key 1 has freq 1 again, key 2 also has freq 1. + -- One of them gets evicted. + let c5 = insert (3 :: Int) (30 :: Int) c4 + assertEqual "Size should be 2" 2 (size c5) + +-- Capacity 1 cache: every new distinct key causes eviction +testCapacity1 :: Assertion +testCapacity1 = do + let cache :: LfudaCache Int Int + cache = newLFUDA 1 + + -- First insert: no eviction + let (ev1, _) = insertView (1 :: Int) (10 :: Int) cache + let c1 = insert (1 :: Int) (10 :: Int) cache + assertEqual "First insert should not evict" Nothing ev1 + assertEqual "Size should be 1" 1 (size c1) + + -- Same key: replaces value, no eviction (size stays 1) + let (ev2, c2) = insertView (1 :: Int) (20 :: Int) c1 + assertEqual "Re-insert same key should not evict" Nothing ev2 + assertEqual "Size should still be 1" 1 (size c2) + assertEqual "Value should be updated" (Just 20) (peek (1 :: Int) c2) + + -- Different key: must evict + let (ev3, c3) = insertView (2 :: Int) (30 :: Int) c2 + assertBool "Different key should evict" (ev3 /= Nothing) + assertEqual "Size should still be 1" 1 (size c3) + assertBool "Key 1 should be gone" (not (contains (1 :: Int) c3)) + assertEqual "Key 2 should be present" (Just 30) (peek (2 :: Int) c3) + + -- Lookup on evicted key + let result = lookup (1 :: Int) c3 + assertBool "Lookup evicted key should return Nothing" (isNothing result) + +-- Size must always match the actual number of entries in the queue +testSizeConsistency :: Assertion +testSizeConsistency = do + let cache :: LfudaCache Int Int + cache = newLFUDA 3 + + -- Empty cache + assertEqual "Empty cache size" 0 (size cache) + + -- Insert 3 + let c1 = insert (1 :: Int) (10 :: Int) cache + assertEqual "After 1 insert" 1 (size c1) + let c2 = insert (2 :: Int) (20 :: Int) c1 + let c3 = insert (3 :: Int) (30 :: Int) c2 + assertEqual "After 3 inserts" 3 (size c3) + + -- Remove 1 + let c4 = remove (1 :: Int) c3 + assertEqual "After remove" 2 (size c4) + assertEqual "Keys count matches size" (size c4) (length (keys c4)) + + -- Re-insert key 1 (no eviction, room available) + let (ev, c5) = insertView (1 :: Int) (100 :: Int) c4 + assertEqual "Should not evict (room available)" Nothing ev + assertEqual "After re-insert" 3 (size c5) + + -- Re-insert existing key 2 (replace, no size change) + let c6 = insert (2 :: Int) (200 :: Int) c5 + assertEqual "After replace" 3 (size c6) + assertEqual "Keys count matches size" (size c6) (length (keys c6)) + + -- Insert 4th key to force eviction + let (ev2, c7) = insertView (4 :: Int) (40 :: Int) c6 + assertBool "Should evict" (ev2 /= Nothing) + assertEqual "After eviction" 3 (size c7) + assertEqual "Keys count matches size" (size c7) (length (keys c7)) + + -- Purge + let c8 = purge c7 + assertEqual "After purge" 0 (size c8) + assertEqual "Keys empty after purge" 0 (length (keys c8)) + + -- Insert after purge + let c9 = insert (5 :: Int) (50 :: Int) c8 + assertEqual "After insert post-purge" 1 (size c9) + +-- Purge clears entries but does NOT reset age +testPurgePreservesAge :: Assertion +testPurgePreservesAge = do + let cache :: LfudaCache Int Int + cache = newLFUDA 1 + + let c1 = insert (1 :: Int) (10 :: Int) cache + -- Bump frequency to 3 + let c2 = foldl' (\c _ -> case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) c1 [1..2 :: Int] + + -- Evict key 1 by inserting key 2 + let c3 = insert (2 :: Int) (20 :: Int) c2 + let ageBeforePurge = age c3 + assertBool "Age should be > 0 after eviction" (ageBeforePurge > 0) + + -- Purge + let c4 = purge c3 + assertEqual "Age should survive purge" ageBeforePurge (age c4) + assertEqual "Size should be 0" 0 (size c4) + +-- Cache should work normally after purge +testOpsAfterPurge :: Assertion +testOpsAfterPurge = do + let cache :: LfudaCache Int Int + cache = newLFUDA 2 + + -- Fill cache, then purge + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = insert (2 :: Int) (20 :: Int) c1 + let c3 = purge c2 + + -- All operations should work on purged cache + assertBool "Contains on purged cache" (not (contains (1 :: Int) c3)) + assertEqual "Peek on purged cache" Nothing (peek (1 :: Int) c3) + assertBool "Lookup on purged cache" (isNothing (lookup (1 :: Int) c3)) + assertEqual "Keys on purged cache" [] (keys c3) + + -- Insert should work + let (ev1, c4) = insertView (3 :: Int) (30 :: Int) c3 + assertEqual "Should not evict (empty after purge)" Nothing ev1 + assertEqual "Value accessible" (Just 30) (peek (3 :: Int) c4) + let (ev2, c5) = insertView (4 :: Int) (40 :: Int) c4 + assertEqual "Should not evict (still room)" Nothing ev2 + assertEqual "Size should be 2" 2 (size c5) + + -- Eviction should work after purge + let (ev3, c6) = insertView (5 :: Int) (50 :: Int) c5 + assertBool "Should evict now (full)" (ev3 /= Nothing) + assertEqual "Size still 2" 2 (size c6) + +-- insertView on an existing key should NOT report eviction +testInsertViewSelfReplace :: Assertion +testInsertViewSelfReplace = do + let cache :: LfudaCache Int Int + cache = newLFUDA 2 + + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = insert (2 :: Int) (20 :: Int) c1 + + -- insertView same key: no eviction, just replacement + let (evicted, c3) = insertView (1 :: Int) (100 :: Int) c2 + assertEqual "Should not report eviction for self-replace" Nothing evicted + assertEqual "Value should be updated" (Just 100) (peek (1 :: Int) c3) + assertEqual "Size should be unchanged" 2 (size c3) + + -- insertView on capacity-1 cache, same key + let cache1 :: LfudaCache Int Int + cache1 = newLFUDA 1 + let c4 = insert (1 :: Int) (10 :: Int) cache1 + let (evicted2, c5) = insertView (1 :: Int) (100 :: Int) c4 + assertEqual "No eviction for self-replace on cap-1" Nothing evicted2 + assertEqual "Size should be 1" 1 (size c5) + +-- insertView reports the correct evicted entry +testInsertViewEvictsCorrect :: Assertion +testInsertViewEvictsCorrect = do + let cache :: LfudaCache Int Int + cache = newLFUDA 1 + + let c1 = insert (1 :: Int) (10 :: Int) cache + + -- Insert key 2, should evict key 1 and report it + let (evicted, c2) = insertView (2 :: Int) (20 :: Int) c1 + assertEqual "Should report key 1 evicted" (Just (1 :: Int, 10 :: Int)) evicted + assertEqual "Size should be 1" 1 (size c2) + + -- Bump key 2 frequency, then insert key 3 + let c3 = case lookup (2 :: Int) c2 of + Just (_, c) -> c + Nothing -> c2 + let (evicted2, _) = insertView (3 :: Int) (30 :: Int) c3 + -- Key 3 has freq 1, key 2 has freq 2, so key 3 gets evicted + assertEqual "Should report key 3 evicted (lower freq)" (Just (3 :: Int, 30 :: Int)) evicted2 + +-- Remove on empty cache and nonexistent keys +testRemoveNonexistent :: Assertion +testRemoveNonexistent = do + let cache :: LfudaCache Int Int + cache = newLFUDA 5 + + -- Remove from empty cache + let c1 = remove (1 :: Int) cache + assertEqual "Size should still be 0" 0 (size c1) + + -- Insert then remove nonexistent + let c2 = insert (1 :: Int) (10 :: Int) c1 + assertBool "Key 999 should not be in cache" (not (contains (999 :: Int) c2)) + let c3 = remove (999 :: Int) c2 + assertEqual "Size should still be 1" 1 (size c3) + + -- Remove then remove same key again + assertBool "Key 1 should be in cache" (contains (1 :: Int) c3) + let c4 = remove (1 :: Int) c3 + assertBool "Key 1 should be gone after removal" (not (contains (1 :: Int) c4)) + let c5 = remove (1 :: Int) c4 + assertEqual "Size should be 0" 0 (size c5) + +-- When all entries have the same frequency, eviction should still work +testEqualFrequencyEviction :: Assertion +testEqualFrequencyEviction = do + let cache :: LfudaCache Int Int + cache = newLFUDA 3 + + -- Insert 3 entries, all with frequency 1 + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = insert (2 :: Int) (20 :: Int) c1 + let c3 = insert (3 :: Int) (30 :: Int) c2 + + -- Insert 4th, must evict one (all have same freq) + let (ev, c4) = insertView (4 :: Int) (40 :: Int) c3 + assertBool "Must evict something" (ev /= Nothing) + assertEqual "Size must be 3" 3 (size c4) + assertEqual "Keys count must be 3" 3 (length (keys c4)) + + -- All remaining keys should be accessible + let remainingKeys = keys c4 + forM_ remainingKeys $ \k -> + assertBool ("Key " ++ show k ++ " should be accessible") (contains k c4) + +-- LFUDA age should grow over multiple eviction cycles +testAgeAccumulation :: Assertion +testAgeAccumulation = do + let cache :: LfudaCache Int Int + cache = newLFUDA 1 + + assertEqual "Initial age" 0 (age cache) + + -- Round 1: insert key 1, bump freq to 3, evict with key 2 + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = foldl' (\c _ -> case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) c1 [1..2 :: Int] + -- key 1 has freq 3 + let c3 = insert (2 :: Int) (20 :: Int) c2 + -- key 2 (freq 1) was evicted, age should be 1 + let age1 = age c3 + assertEqual "Age after first eviction cycle" 1 age1 + + -- Round 2: bump key 1 freq more, evict again + let c4 = foldl' (\c _ -> case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) c3 [1..3 :: Int] + -- key 1 now has freq 6 + let c5 = insert (3 :: Int) (30 :: Int) c4 + -- key 3 (freq 1) evicted, but its priority was 1 + age1 = 2 + -- age should be set to the evicted entry's frequency (1), NOT the priority + let age2 = age c5 + assertEqual "Age after second eviction cycle" 1 age2 + + -- Round 3: create a scenario where an entry with freq > 1 gets evicted. + -- Use a size-2 cache for this. + let cache2 :: LfudaCache Int Int + cache2 = newLFUDA 2 + + let d1 = insert (10 :: Int) (100 :: Int) cache2 + let d2 = insert (20 :: Int) (200 :: Int) d1 + -- Bump key 20 freq to 3 + let d3 = foldl' (\c _ -> case lookup (20 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) d2 [1..2 :: Int] + -- key 10 has freq 1, key 20 has freq 3 + -- Insert key 30: evicts key 10 (freq 1), age becomes 1 + let d4 = insert (30 :: Int) (300 :: Int) d3 + assertEqual "Age after evicting freq-1 entry" 1 (age d4) + + -- Now bump key 30 freq to 4 + let d5 = foldl' (\c _ -> case lookup (30 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) d4 [1..3 :: Int] + -- key 20 has freq 3, stale priority = 3 (set when age was 0, never recalculated) + -- key 30 has freq 4, priority = 4 + 1 = 5 (recalculated on each lookup) + -- Insert key 40: priority = 1 + age(1) = 2 + -- Eviction order by priority: key 40 (2) < key 20 (3) < key 30 (5) + -- key 40 gets evicted immediately (lowest priority), age = freq(40) = 1 + let d6 = insert (40 :: Int) (400 :: Int) d5 + assertEqual "Age stays 1 (key 40 evicted, not key 20)" 1 (age d6) + + -- To actually evict a high-freq entry, we need to lookup key 20 first + -- to refresh its priority with the current age + let d7 = case lookup (20 :: Int) d6 of + Just (_, c') -> c' -- key 20 freq becomes 4, priority = 4 + 1 = 5 + Nothing -> d6 + -- key 20 now has freq 4, priority 5. key 30 has freq 4, priority 5. + -- Insert key 50: priority = 1 + 1 = 2. Still lowest, key 50 evicted. + let d8 = insert (50 :: Int) (500 :: Int) d7 + assertEqual "Age still 1 (new entry evicted again)" 1 (age d8) + +-- After re-inserting a key, lookup should return the new value +-- but with reset frequency (making it vulnerable to eviction) +testLookupAfterReinsert :: Assertion +testLookupAfterReinsert = do + let cache :: LfudaCache Int Int + cache = newLFUDA 2 + + let c1 = insert (1 :: Int) (10 :: Int) cache + let c2 = insert (2 :: Int) (20 :: Int) c1 + + -- Bump key 1 frequency high + let c3 = foldl' (\c _ -> case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) c2 [1..5 :: Int] + + -- Re-insert key 1 with new value (resets freq to 1!) + let c4 = insert (1 :: Int) (999 :: Int) c3 + + -- Lookup should return new value + case lookup (1 :: Int) c4 of + Just (v, _) -> assertEqual "Should get new value" (999 :: Int) v + Nothing -> assertFailure "Key 1 should be in cache" + + -- But now key 1 has low freq again. + -- Bump key 2 freq so key 1 becomes eviction target + let c5 = case lookup (2 :: Int) c4 of + Just (_, c') -> c' + Nothing -> c4 + + -- Insert key 3: should evict key 1 (lowest freq after re-insert) + let c6 = insert (3 :: Int) (30 :: Int) c5 + assertBool "Key 1 should be evicted (freq was reset)" (not (contains (1 :: Int) c6)) + assertBool "Key 2 should survive" (contains (2 :: Int) c6) + +-- Rapid insert-remove cycles should keep size correct +testInsertRemoveCycles :: Assertion +testInsertRemoveCycles = do + let cache :: LfudaCache Int Int + cache = newLFUDA 5 + + -- Insert and remove 100 keys rapidly + let finalCache = foldl' (\c i -> + let c1 = insert i i c + c2 = remove i c1 + in c2 + ) cache [1..100 :: Int] + + assertEqual "Size should be 0 after insert-remove cycles" 0 (size finalCache) + assertEqual "Keys should be empty" [] (keys finalCache) + + -- Insert-remove with some surviving (use capacity 10 to avoid eviction interference) + let cache10 :: LfudaCache Int Int + cache10 = newLFUDA 10 + let finalCache2 = foldl' (\c i -> + let c1 = insert i i c + in if even i + then remove i c1 + else c1 + ) cache10 [1..10 :: Int] + + assertEqual "Size should be 5 (odd keys survive)" 5 (size finalCache2) + forM_ [1, 3, 5, 7, 9 :: Int] $ \i -> + assertBool ("Key " ++ show i ++ " should be present") (contains i finalCache2) + forM_ [2, 4, 6, 8, 10 :: Int] $ \i -> + assertBool ("Key " ++ show i ++ " should be absent") (not (contains i finalCache2)) + + -- Verify that with tight capacity, eviction CAN steal surviving entries + -- Capacity 5, insert keys 1-10, keep odd, remove even. + -- At i=10, cache has [1,3,5,7,9] (full), inserting 10 evicts an odd key first! + let finalCache3 = foldl' (\c i -> + let c1 = insert i i c + in if even i + then remove i c1 + else c1 + ) cache [1..10 :: Int] + + assertEqual "Size should be 4 (one odd key was evicted by insert 10)" 4 (size finalCache3) + +-- LFU Tests + +testLFU :: Assertion +testLFU = do + let initialCache :: LfudaCache Int Int + initialCache = newLFU 5 + + -- Insert 5 elements + let cache1 = foldl' (\c i -> insert i (i * 10) c) initialCache [1..5 :: Int] + assertEqual "Cache size should be 5" 5 (size cache1) + + -- All 5 elements should be present + forM_ [1..5 :: Int] $ \i -> do + let result = peek i cache1 + assertEqual ("Value for key " ++ show i) (Just (i * 10)) result + + -- Insert 6th element, should evict one + let (evicted6, cache2) = insertView (6 :: Int) (60 :: Int) cache1 + assertBool "Should have evicted" (evicted6 /= Nothing) + assertEqual "Cache size should still be 5" 5 (size cache2) + + -- Key 6 should be present + let result6 = peek (6 :: Int) cache2 + assertEqual "Key 6 should be present" (Just 60) result6 + +testLFUNoAging :: Assertion +testLFUNoAging = do + let initialCache :: LfudaCache Int Int + initialCache = newLFU 1 + + -- Insert key 1, then bump its frequency + let cache1 = insert (1 :: Int) (10 :: Int) initialCache + let cache1' = case lookup (1 :: Int) cache1 of + Just (_, c) -> c + Nothing -> cache1 + + -- Age should be 0 before any eviction + assertEqual "Age should be 0 initially" 0 (age cache1') + + -- Insert key 2, which evicts key 2 (lower priority) since key 1 has freq 2 + let cache2 = insert (2 :: Int) (20 :: Int) cache1' + + -- Age should STILL be 0 for LFU (no dynamic aging) + assertEqual "Age should remain 0 for LFU" 0 (age cache2) + + -- Key 1 should survive (higher frequency) + assertBool "Key 1 should still be in cache" (contains (1 :: Int) cache2) + +testLFUFrequencyEviction :: Assertion +testLFUFrequencyEviction = do + let initialCache :: LfudaCache Int Int + initialCache = newLFU 3 + + -- Insert 3 elements + let cache1 = insert (1 :: Int) (10 :: Int) initialCache + let cache2 = insert (2 :: Int) (20 :: Int) cache1 + let cache3 = insert (3 :: Int) (30 :: Int) cache2 + + -- Bump frequency of key 1 (3 extra lookups -> freq 4) + let cache3' = foldl' (\c _ -> + case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) cache3 [1..3 :: Int] + + -- Bump frequency of key 3 (1 extra lookup -> freq 2) + let cache3'' = case lookup (3 :: Int) cache3' of + Just (_, c) -> c + Nothing -> cache3' + + -- Key 2 still has freq 1 (lowest), so inserting key 4 should evict key 2 + let cache4 = insert (4 :: Int) (40 :: Int) cache3'' + + -- Key 2 should be gone (lowest frequency) + assertBool "Key 2 should be evicted" (not (contains (2 :: Int) cache4)) + + -- Keys 1 and 3 should still be present + assertBool "Key 1 should survive" (contains (1 :: Int) cache4) + assertBool "Key 3 should survive" (contains (3 :: Int) cache4) + + -- Key 4 should be present + assertBool "Key 4 should be present" (contains (4 :: Int) cache4) + +testLFUInsertView :: Assertion +testLFUInsertView = do + let cache :: LfudaCache Int Int + cache = newLFU 2 + + -- First insert returns Nothing (no eviction) + let (evicted1, cache1) = insertView (1 :: Int) (10 :: Int) cache + assertEqual "No eviction on first insert" Nothing evicted1 + + -- Second insert returns Nothing (still room) + let (evicted2, cache2) = insertView (2 :: Int) (20 :: Int) cache1 + assertEqual "No eviction on second insert" Nothing evicted2 + + -- Third insert should evict the lowest frequency entry + let (evicted3, cache3) = insertView (3 :: Int) (30 :: Int) cache2 + assertBool "Should have evicted something" (evicted3 /= Nothing) + assertEqual "Cache size should be 2" 2 (size cache3) + +-- GDSF Tests + +testGDSFSizeEviction :: Assertion +testGDSFSizeEviction = do + -- GDSF priority = frequency + age * size + -- All new entries have frequency 1 and size 1, so initially priority = 1 + 0*1 = 1 + -- After eviction, age increases, making new entries have higher priority + let initialCache :: LfudaCache Int Int + initialCache = newGDSF 2 + + let cache1 = insert (1 :: Int) (10 :: Int) initialCache + let cache2 = insert (2 :: Int) (20 :: Int) cache1 + + -- Bump key 1 frequency to 2 + let cache2' = case lookup (1 :: Int) cache2 of + Just (_, c) -> c + Nothing -> cache2 + + -- Insert key 3, should evict key 2 (freq 1 < key 1's freq 2) + let cache3 = insert (3 :: Int) (30 :: Int) cache2' + assertBool "Key 2 should be evicted" (not (contains (2 :: Int) cache3)) + assertBool "Key 1 should survive" (contains (1 :: Int) cache3) + +testGDSFAging :: Assertion +testGDSFAging = do + let initialCache :: LfudaCache Int Int + initialCache = newGDSF 1 + + -- Insert key 1, bump frequency to 3 + let cache1 = insert (1 :: Int) (10 :: Int) initialCache + let cache1' = foldl' (\c _ -> + case lookup (1 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) cache1 [1..2 :: Int] + + assertEqual "Age should be 0 before eviction" 0 (age cache1') + + -- Insert key 2, it will be evicted (freq 1 < key 1's freq 3) + let cache2 = insert (2 :: Int) (20 :: Int) cache1' + + -- Age should now be 1 (frequency of the evicted key) + assertEqual "Age should be 1 after eviction" 1 (age cache2) + assertBool "Key 1 should survive" (contains (1 :: Int) cache2) + +testGDSFFrequencyAndSize :: Assertion +testGDSFFrequencyAndSize = do + -- Test that GDSF uses both frequency and age*size in priority + let initialCache :: LfudaCache Int Int + initialCache = newGDSF 3 + + -- Insert 3 entries + let cache1 = insert (1 :: Int) (10 :: Int) initialCache + let cache2 = insert (2 :: Int) (20 :: Int) cache1 + let cache3 = insert (3 :: Int) (30 :: Int) cache2 + + -- Bump key 2's frequency to 3 + let cache3' = foldl' (\c _ -> + case lookup (2 :: Int) c of + Just (_, c') -> c' + Nothing -> c + ) cache3 [1..2 :: Int] + + -- Bump key 3's frequency to 2 + let cache3'' = case lookup (3 :: Int) cache3' of + Just (_, c) -> c + Nothing -> cache3' + + -- Key 1 has freq 1, Key 2 has freq 3, Key 3 has freq 2 + -- Insert key 4, should evict key 1 (lowest frequency) + let cache4 = insert (4 :: Int) (40 :: Int) cache3'' + assertBool "Key 1 should be evicted (lowest freq)" (not (contains (1 :: Int) cache4)) + assertBool "Key 2 should survive" (contains (2 :: Int) cache4) + assertBool "Key 3 should survive" (contains (3 :: Int) cache4) + assertBool "Key 4 should be present" (contains (4 :: Int) cache4) + + -- Verify age was updated after eviction + let ageAfter = age cache4 + assertBool "Age should have increased" (ageAfter > 0) + +-- Pure implementation of random number generation for testing +type SimpleRandom :: Type +data SimpleRandom :: Type where + SimpleRandom :: Int -> SimpleRandom + +nextRandom :: SimpleRandom -> (Int, SimpleRandom) +nextRandom (SimpleRandom seed) = + let newSeed = (seed * 1103515245 + 12345) `mod` 2147483647 + value = newSeed `mod` 32768 + in (value, SimpleRandom newSeed) + +rangeRandom :: Int -> Int -> SimpleRandom -> (Int, SimpleRandom) +rangeRandom low high rand = + let (val, rand') = nextRandom rand + scaled = low + (val `mod` (high - low + 1)) + in (scaled, rand') + +generateTrace :: Int -> SimpleRandom -> ([Int], SimpleRandom) +generateTrace n rand = + go n rand [] + where + go :: Int -> SimpleRandom -> [Int] -> ([Int], SimpleRandom) + go 0 r acc = (reverse acc, r) + go i r acc = + let evenOdd = i `mod` 2 == 0 + (val, r') = if evenOdd + then rangeRandom 0 16383 r + else rangeRandom 0 32767 r + in go (i-1) r' (val:acc) + +-- Benchmark tests (simplified versions for HUnit) +testBenchmark :: String -> Assertion -> TestTree +testBenchmark name benchmark = testCase name benchmark + +benchmarkLFUDA :: Assertion +benchmarkLFUDA = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 1000 -- Smaller cache size to ensure evictions + + -- Generate deterministic random trace + let traceSeed = SimpleRandom 42 + (trace, _) = generateTrace 2000 traceSeed + + -- Split the trace: first half for setting, second half for getting + let setTrace = take 1000 trace + queryTrace = drop 1000 trace + + -- Set operations + let cacheAfterSet = foldl' (\cache i -> + insert i i cache + ) initialCache setTrace + + -- Get operations and count hits/misses + let hitsAndMisses = foldl' (\(h, m) i -> + case lookup i cacheAfterSet of + Just _ -> (h + 1, m) + Nothing -> (h, m + 1) + ) (0 :: Int, 0 :: Int) queryTrace + hits = fst hitsAndMisses + misses = snd hitsAndMisses + + -- With our cache size of 1000 and different query items, + -- we should have both hits and misses + assertBool "Should have some hits" (hits > (0 :: Int)) + assertBool "Should have some misses" (misses > (0 :: Int)) + +benchmarkLFUDARand :: Assertion +benchmarkLFUDARand = do + let initialCache :: LfudaCache Int Int + initialCache = newLFUDA 1000 -- Smaller cache size to ensure evictions + + -- Generate deterministic random trace + let traceSeed = SimpleRandom 24 + (trace, _) = generateTrace 2000 traceSeed + + -- Process the trace in a pure way + let processItem :: (LfudaCache Int Int, Int, Int) -> (Int, Int) -> (LfudaCache Int Int, Int, Int) + processItem (cache, h, m) (idx, val) = + -- Set on even indices + let cache' = if even idx + then insert val val cache + else cache + + -- Check get result + getResult = lookup val cache' + h' = case getResult of { Just _ -> h + 1; Nothing -> h } + m' = case getResult of { Just _ -> m; Nothing -> m + 1 } + + -- Extra hits/misses for idx mod 7 = 0 + extras = + if idx `mod` 7 == 0 + then foldl' (\(eh, em) _ -> + if contains val cache' + then (eh + 1, em) + else (eh, em + 1) + ) (0 :: Int, 0 :: Int) [1..19 :: Int] + else (0, 0) + + -- Update cache if we got a hit + cache'' = case getResult of + Just (_, c) -> c + Nothing -> cache' + + in (cache'', h' + fst extras, m' + snd extras) + + let fullResult = foldl' processItem (initialCache, 0 :: Int, 0 :: Int) (zip [0 :: Int ..] trace) + + -- Check results + case fullResult of + (_, hits, misses) -> do + assertBool "Should have some hits" (hits > (0 :: Int)) + assertBool "Should have some misses" (misses > (0 :: Int))