diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 0.1.0 + +Initial release. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. 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/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.DeepSeq +import Criterion.Main +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Hashable +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Trie.Pattern + +import qualified Data.Sequence as Seq +#if __GLASGOW_HASKELL__ < 804 +import qualified Data.Trie as BST +#endif + +main :: IO () +main = defaultMain + [ bgroup "pattern-trie (ByteString)" + [ env (genStaticPTrie staticBKeys) $ + bench "match (static)" . ptrieBMatch + , env (genPTrie captureBKeys) $ + bench "match (capture)" . ptrieBMatch + ] + , bgroup "pattern-trie (Text)" + [ env (genStaticPTrie staticTKeys) $ + bench "match (static)" . ptrieTMatch + , env (genPTrie captureTKeys) $ + bench "match (capture)" . ptrieTMatch + ] +#if __GLASGOW_HASKELL__ < 804 + , bgroup "bytestring-trie" + [ env (genBSTrie staticBKeys) $ + bench "lookup" . bstrieLookup + ] +#endif + ] + +------------------------------------------------------------------------------ +-- pattern-trie + +-- Generators + +genStaticPTrie :: (Eq s, Hashable s) => [Str s] -> IO (Trie s Int) +genStaticPTrie keys = genPTrie (map mkPat keys) + where + mkPat = Seq.fromList . map EqStr + +genPTrie :: (Eq s, Hashable s) => [Pattern s] -> IO (Trie s Int) +genPTrie pats = return $! build pats + where + build = fromAssocList . (`zip` [1..]) + +-- Benchmarks + +ptrieBMatch :: Trie ByteString Int -> Benchmarkable +ptrieBMatch t = nf run bchunks + where + run :: Str ByteString -> Maybe (Int, Seq (Capture ByteString)) + run s = match s t + +ptrieTMatch :: Trie Text Int -> Benchmarkable +ptrieTMatch t = nf run tchunks + where + run :: Str Text -> Maybe (Int, Seq (Capture Text)) + run s = match s t + +------------------------------------------------------------------------------ +-- bytestring-trie + +#if __GLASGOW_HASKELL__ < 804 + +-- Generators + +newtype BSTrie a = BSTrie (BST.Trie a) + +instance NFData (BSTrie a) where + rnf t = t `seq` () + +genBSTrie :: [[ByteString]] -> IO (BSTrie Int) +genBSTrie keys = return $! build keys + where + build = BSTrie . BST.fromList . (`zip` [1..]) . map mconcat + +-- Benchmarks + +bstrieLookup :: BSTrie Int -> Benchmarkable +bstrieLookup (BSTrie t) = nf run (mconcat bchunks) + where + run :: ByteString -> Maybe Int + run s = BST.lookup s t + +#endif + +------------------------------------------------------------------------------ +-- Test keys + +staticBKeys :: [[ByteString]] +staticBKeys = genKeys bchunks + +staticTKeys :: [[Text]] +staticTKeys = genKeys tchunks + +captureBKeys :: [Pattern ByteString] +captureBKeys = captureKeys bchunks + +captureTKeys :: [Pattern Text] +captureTKeys = captureKeys tchunks + +captureKeys :: [s] -> [Pattern s] +captureKeys chunks = map Seq.fromList (genKeys matchers) + where + -- Replace the last chunk with a "capture", so it can appear at every + -- position of a generated key. + matchers = map EqStr (init chunks) ++ [AnyStr] + +-- Given a list of length n, generate n! lists (i.e. keys), each of length n, +-- whereby the i'th item in the input list appears at positions 1..i. E.g. the +-- 1st item only appears as the 1st chunk of a path, the 2nd item can appear as +-- the 1st and 2nd chunk of a path, ..., the nth item can appear at any position +-- of a path (and in particular, it is the last chunk of every path). +-- +-- For example: +-- @ +-- genKeys [1..3] +-- [[1,2,3],[1,3,3],[2,2,3],[2,3,3],[3,2,3],[3,3,3]] +-- @ +genKeys :: [a] -> [[a]] +genKeys l = mapM next [0..(length l - 1)] + where + next i = drop i l + +-- (Static) ByteString chunks from which the keys of the tries are built up. +bchunks :: [ByteString] +bchunks = + [ "abcde" + , "bcdef" + , "cdefg" + , "defgh" + , "efghi" + , "fghij" + ] + +tchunks :: [Text] +tchunks = map decodeUtf8 bchunks + diff --git a/docs-extra/backtrack.png b/docs-extra/backtrack.png new file mode 100644 Binary files /dev/null and b/docs-extra/backtrack.png differ diff --git a/docs-extra/backtrack.tex b/docs-extra/backtrack.tex new file mode 100644 --- /dev/null +++ b/docs-extra/backtrack.tex @@ -0,0 +1,38 @@ +\documentclass[convert={size=250}]{standalone} + +\usepackage{tikz} +\usepackage{tikz-qtree} + +\begin{document} + +\begin{tikzpicture}[sibling distance=20pt, level distance=30pt] + \Tree [.\node[blue](/){$\circ$}; + \edge[->] node[auto=right] {a}; + [.\node[blue](/a){$\circ$}; + \edge[->] node[auto=right] {a}; + [.\node(/a/a){$\circ$}; + \edge node[auto=right] {a}; + [.\node[red](/a/a/a){$\bullet$}; ] + ] + \edge[->] node[auto=left] {*}; + [.\node(/a/*){$\circ$}; + \edge node[auto=right] {a}; + [.\node[red](/a/*/a){$\bullet$}; ] ] ] + \edge[->] node[auto=left] {*}; + [.\node[blue](/*){$\circ$}; + \edge[->] node[auto=right] {a}; + [.\node(/*/a){$\circ$}; + \edge node[auto=right] {a}; + [.\node[red](/*/a/a){$\bullet$}; ] ] + \edge[->] node[auto=left] {*}; + [.$\circ$ + \edge[->] node[auto=right] {b}; + [.\node[green]{$\bullet$}; ] ] ] ] + + \draw[semithick,->,dotted] (/a/a) to[bend right] ([yshift=-10pt]/a); + \draw[semithick,->,dotted] (/a/*) to[bend right] ([yshift=-10pt]/); + \draw[semithick,->,dotted] (/*/a) to[bend right] ([yshift=-10pt]/*); +\end{tikzpicture} + +\end{document} + diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,3 @@ +import Test.DocTest + +main = doctest ["src"] diff --git a/pattern-trie.cabal b/pattern-trie.cabal new file mode 100644 --- /dev/null +++ b/pattern-trie.cabal @@ -0,0 +1,93 @@ +name: pattern-trie +version: 0.1.0 +category: Data +synopsis: Pattern tries +description: + Simple pattern tries for structured keys, where lookups + can capture (parts of) the input strings. + +author: Roman S. Borschel +maintainer: Roman S. Borschel +copyright: 2018 Roman S. Borschel +license: MPL-2.0 +license-file: LICENSE + +cabal-version: 1.18 +build-type: Simple +extra-source-files: CHANGELOG.md, docs-extra/*.tex +extra-doc-files: docs-extra/*.png + +source-repository head + type: git + location: https://gitlab.com/romanb/pattern-trie + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: + Data.Trie.Pattern + default-extensions: + NoImplicitPrelude + ghc-options: + -Wall + -fwarn-tabs + -- -ddump-simpl + -- -dsuppress-all + -- -dno-suppress-type-signatures + -- -dno-suppress-idinfo + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.10 && < 1.0 + , containers >= 0.5.7 && < 0.6 + , deepseq >= 1.4.3 && < 1.5 + , hashable >= 1.2 && < 1.3 + , text >= 1.0 && < 2.0 + , unordered-containers >= 0.2 && < 0.3 + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: + -Wall + -fwarn-tabs + -threaded + other-modules: Test.Data.Trie.Pattern + build-depends: + base + , bytestring + , containers + , mtl + , pattern-trie + , QuickCheck >= 2.10 + , tasty >= 0.11 + , tasty-quickcheck >= 0.9 + , unordered-containers + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: + base + , doctest >= 0.16 + +benchmark bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: + base + , bytestring + , criterion + , containers + , deepseq + , hashable + , pattern-trie + , text + + if impl(ghc < 8.4) + build-depends: bytestring-trie + diff --git a/src/Data/Trie/Pattern.hs b/src/Data/Trie/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Pattern.hs @@ -0,0 +1,680 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE + BangPatterns + , DeriveGeneric + , DeriveAnyClass + , DerivingStrategies + , GeneralizedNewtypeDeriving + , TupleSections +#-} + +-- | A variant of a (radix) trie with the following characteristics: +-- +-- * Keys are simple 'Pattern's composed of 'Matcher's and hence a single key +-- can match multiple input 'Str'ings. +-- * Looking up a 'match' for a 'Str'ing can 'Capture' parts of the string. +-- * Both patterns and input strings are understood as being composed of +-- (indivisible) chunks of strings of a generic type @s@ (typically +-- instantiated to either 'Text' or 'ByteString'). More precisely, every +-- chunk of an input 'Str'ing is tested against a 'Matcher' of a 'Pattern' +-- in sequence. As a result, pattern tries usually end up less compact than +-- more general tries, since sharing of prefixes as well as all operations +-- are limited to the granularity of these chunks. +-- +-- These characteristics hint at the primary intended use-case, whereby +-- keys have a \"natural\" decomposition into chunks and the same +-- chunks are heavily shared by different keys, e.g. as in directory trees. +-- A pattern trie allows to associate values with simple patterns, whereby a +-- single value can essentially be looked up by all strings matching a pattern, +-- thereby capturing parts of it. +-- +-- __Strictness:__ +-- A 'Trie' is strict in the spine as well as the values (WHNF). +-- +-- __Ordering:__ The order of keys and thus elements is unspecified. +-- No particular order may be assumed by folds and traversals, whose +-- combining operations should hence be commutative. +-- +-- __Example:__ +-- +-- >>> :set -XOverloadedStrings +-- +-- >>> import Data.ByteString (ByteString) +-- +-- >>> let p1 = mempty |> EqStr "home" |> EqStr "alice" |> EqStr "tmp" +-- >>> let p2 = mempty |> EqStr "home" |> AnyStr |> EqStr "music" +-- >>> let p3 = mempty |> EqStr "data" |> EqStr "bob" |> EqStr "books" +-- >>> let p4 = mempty |> EqStr "data" |> AnyStr |> EqStr "books" +-- >>> let p5 = mempty |> EqStr "data" |> AnyStr |> EqStr "books" |> EqStr "sicp" +-- +-- >>> let trie = fromAssocList $ [p1,p2,p3,p4,p5] `zip` [1..] :: Trie ByteString Int +-- +-- >>> match ["home","alice","tmp"] trie +-- Just (1,fromList []) +-- +-- >>> match ["home","bob","tmp"] trie +-- Nothing +-- +-- >>> match ["home","alice","music"] trie +-- Just (2,fromList [Capture {captured = "alice"}]) +-- +-- >>> match ["home","bob","music"] trie +-- Just (2,fromList [Capture {captured = "bob"}]) +-- +-- >>> match ["data","bob","books"] trie +-- Just (3,fromList []) +-- +-- >>> match ["data","alice","books"] trie +-- Just (4,fromList [Capture {captured = "alice"}]) +-- +-- >>> match ["data","alice","books","sicp"] trie +-- Just (5,fromList [Capture {captured = "alice"}]) +-- +-- >>> match ["data","bob","books","sicp"] trie +-- Just (5,fromList [Capture {captured = "bob"}]) +-- +-- >>> matchPrefix ["data","alice","books","wonderland"] trie +-- Just (4,fromList [Capture {captured = "alice"}],["wonderland"]) +-- +-- >>> matchPrefix ["data","bob","books","wonderland"] trie +-- Just (4,fromList [Capture {captured = "bob"}],["wonderland"]) +-- +-- >>> let (t,c,s) = matchPrefixTrie ["data","bob","books","wonderland"] trie +-- >>> (value t, c, s) +-- (Just 4,fromList [Capture {captured = "bob"}],["wonderland"]) +-- +module Data.Trie.Pattern + ( Trie, value + + -- * Patterns + -- $definitions + , Pattern, Str, Matcher (..), Capture (..) + + -- ** Testing Patterns + , overlapping + , MatchOrd (..), MatchPrefixOrd (..) + , matchOrd, matchPrefixOrd + , apply + , applyCapture + , unapplyCapture + , applyMatch + , applyMatches + , applyMatchPrefix + , applyMatchesPrefix + + -- * List conversion + , fromAssocList + , toAssocList + + -- * Modifications + , insert + , adjust + , delete + + -- * 'Pattern' lookup + -- $lookupBigO + , lookup + , lookupPrefix + , lookupPrefixTrie + + -- * 'Str'ing matching + -- $matchingBigO + , match + , matchPrefix + , matchPrefixTrie + + -- * Special folds and traversals + , traverseWithKey + , foldMapWithKey + , foldrWithKey + + -- * Re-exports + , (|>) + ) where + +import GHC.Generics (Generic) + +import Control.Applicative +import Control.DeepSeq (NFData) +import Control.Monad ((<$!>)) +import Data.ByteString (ByteString) +import Data.Coerce (coerce) +import Data.Foldable +import Data.Hashable +import Data.List (foldl') +import Data.HashMap.Strict (HashMap) +import Data.Maybe (fromMaybe, isJust) +import Data.Semigroup +import Data.Sequence (Seq (..), (|>)) +import Data.Text (Text) +import Prelude hiding (lookup) + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Sequence as Seq +import qualified Data.Traversable as Traversable + +-- | An unordered map from 'Pattern's of strings of type @s@ to values +-- of type @a@. +data Trie s a = Trie + { strtries :: !(HashMap s (Trie s a)) + , vartrie :: !(Maybe (Trie s a)) + , value :: !(Maybe a) + -- ^ The value at the root of the trie, i.e. + -- + -- @ + -- value t == 'lookup' mempty t + -- @ + } deriving stock (Eq, Show, Read, Generic) + deriving anyclass NFData + +instance Traversable (Trie s) where + traverse f = traverseWithKey (const f) + +instance Functor (Trie s) where + fmap = Traversable.fmapDefault + +instance Foldable (Trie s) where + foldMap = Traversable.foldMapDefault + + null (Trie a Nothing Nothing) = HashMap.null a + null _ = False + {-# INLINE null #-} + +-- | /Note (left preference)/: If two tries have a value attached to +-- the same 'Pattern' (i.e. to the same key), then @t1 <> t2@ preserves +-- the value of @t1@. +instance (Eq s, Hashable s) => Semigroup (Trie s a) where + a <> b = Trie (HashMap.unionWith (<>) (strtries a) (strtries b)) + (vartrie a <> vartrie b) + (value a <|> value b) + + stimes = stimesIdempotent + +-- | /Note/: @mappend = (<>)@. +instance (Eq s, Hashable s) => Monoid (Trie s a) where + mempty = Trie mempty Nothing Nothing + mappend = (<>) + +----------------------------------------------------------------------------- +-- Patterns + +-- $definitions +-- __Definition (/Prefix Match/):__ A 'Str'ing is a /prefix match/ for a +-- 'Pattern', iff all 'Matcher's in the pattern succeed when applied on +-- the chunks of the input string in sequence. A /proper prefix match/ +-- is a prefix match that is not a (full) match. +-- +-- A prefix match is witnessed by 'applyMatchesPrefix'. +-- +-- __Definition (/(Full) Match/):__ A 'Str'ing is a /(full) match/ for a +-- 'Pattern', iff it is a prefix match and there are no unmatched +-- remaining chunks of the input (i.e. the string and the pattern have +-- the same length). +-- +-- A (full) match is witnessed by 'applyMatches'. +-- +-- __Definition (/Overlapping Patterns/):__ +-- Two patterns are /overlapping/, iff they are not equal and +-- there exists an input 'Str'ing that is a (full) match for both patterns. +-- +-- Overlapping patterns are witnessed by 'overlapping'. + +-- | A pattern is a sequence of 'Matcher's and serves as a key in a pattern +-- trie. +-- +-- If two patterns are overlapping for an input string, the preference for +-- a 'match' is given by the partial order @EqStr > AnyStr@ on the competing +-- matchers, i.e. towards the more specific pattern. This partial order is +-- witnessed and subsumed by the total order 'MatchOrd'. +-- +-- The preference for a prefix match is reversed, i.e. for an input string where +-- only a proper prefix is a match for overlapping patterns, the preference +-- is given by the partial order @AnyStr > EqStr@, i.e. towards the more general +-- pattern. This partial order is witnessed and subsumed by the total order +-- 'PrefixMatchOrd'. +type Pattern s = Seq (Matcher s) + +-- | A (chunked) input string to 'match' on a 'Pattern' in a trie. +-- +-- /Note:/ Input strings can be infinite. Since the tries are always finite, +-- an infinite input string is only consumed until either a match has been +-- found or the applicable paths in the trie have been exhaustively searched. +type Str s = [s] + +-- | A captured chunk of an input 'Str'ing. +newtype Capture s = Capture { captured :: s } + deriving stock (Eq, Ord, Show, Read, Generic) + deriving anyclass NFData + +-- | A 'Matcher' is applied on a single chunk of an input 'Str'ing +-- while looking for a 'match' and either /succeeds/ or /fails/. If it succeeds, +-- it may 'Capture' the chunk. +data Matcher s + -- | Match and capture an arbitrary chunk of an input string. + = AnyStr + -- | Match a chunk of an input string exactly, capturing nothing. + | EqStr !s + deriving stock (Eq, Show, Read, Generic) + deriving anyclass NFData + +-- | A total order for matchers that subsumes the partial order for +-- the preference between overlapping patterns on a 'matchPrefix'. +-- +-- >>> MatchPrefixOrd AnyStr > MatchPrefixOrd (EqStr "a") +-- True +-- +-- >>> let p1 = mempty |> EqStr "a" |> EqStr "b" +-- >>> let p2 = mempty |> AnyStr |> EqStr "b" +-- >>> matchPrefixOrd p1 < matchPrefixOrd p2 +-- True +newtype MatchPrefixOrd s = MatchPrefixOrd (Matcher s) + deriving Eq + +matchPrefixOrd :: Pattern s -> Seq (MatchPrefixOrd s) +matchPrefixOrd = coerce + +-- | A total order for matchers that subsumes the partial order for +-- the preference between overlapping patterns on a 'match'. +-- +-- >>> MatchOrd AnyStr < MatchOrd (EqStr "a") +-- True +-- +-- >>> let p1 = mempty |> EqStr "a" |> EqStr "b" +-- >>> let p2 = mempty |> AnyStr |> EqStr "b" +-- >>> matchOrd p1 > matchOrd p2 +-- True +newtype MatchOrd s = MatchOrd (Matcher s) + deriving Eq + +matchOrd :: Pattern s -> Seq (MatchOrd s) +matchOrd = coerce + +instance Ord s => Ord (MatchOrd s) where + compare (MatchOrd m1) (MatchOrd m2) = + compare (MatchPrefixOrd m2) (MatchPrefixOrd m1) + +instance Ord s => Ord (MatchPrefixOrd s) where + compare (MatchPrefixOrd m1) (MatchPrefixOrd m2) = + case (m1, m2) of + (AnyStr , EqStr _) -> GT + (EqStr _, AnyStr) -> LT + (AnyStr , AnyStr) -> EQ + (EqStr s1, EqStr s2) -> compare s1 s2 + +-- | Check whether two patterns are overlapping, i.e. whether there +-- exists a 'Str'ing that is a (full) match for both patterns. +-- +-- >>> let p1 = mempty |> EqStr "a" |> AnyStr +-- >>> let p2 = mempty |> AnyStr |> EqStr "b" +-- >>> let p3 = mempty |> EqStr "a" |> EqStr "c" +-- >>> overlapping p1 p1 +-- False +-- >>> overlapping p1 p2 +-- True +-- >>> overlapping p1 p3 +-- True +-- >>> overlapping p2 p3 +-- False +overlapping :: Eq s => Pattern s -> Pattern s -> Bool +overlapping p1 p2 = Seq.length p1 == Seq.length p2 && go True p1 p2 + where + go eq Empty Empty = not eq + go _ Empty _ = False + go _ _ Empty = False + go _ (EqStr _ :<| p1') (AnyStr :<| p2') = go False p1' p2' + go _ (AnyStr :<| p1') (EqStr _ :<| p2') = go False p1' p2' + go eq (AnyStr :<| p1') (AnyStr :<| p2') = go eq p1' p2' + go eq (EqStr s :<| p1') (EqStr s' :<| p2') = + if s /= s' + then False + else go eq p1' p2' + +-- | Apply a string to a pattern, returning the unmatched +-- suffix of the pattern together with the captured chunks and the +-- remaining (unmatched) suffix of the input string. +-- +-- >>> let p = mempty |> EqStr "a" |> AnyStr |> EqStr "c" +-- >>> let s = ["a", "b", "d"] +-- >>> apply s p +-- (fromList [EqStr "c"],fromList [Capture {captured = "b"}],["d"]) +apply :: Eq s => Str s -> Pattern s -> (Pattern s, Seq (Capture s), Str s) +apply = go Seq.empty + where + go !cs ss Empty = (Empty, cs, ss) + go !cs [] p = (p , cs, []) + go !cs str@(s:s') pat@(m :<| p') = case m of + AnyStr -> go (cs |> Capture s) s' p' + EqStr ss -> if s == ss + then go cs s' p' + else (pat, cs, str) + +-- | Apply a string to a pattern, returning the captures. +-- +-- >>> let p = mempty |> EqStr "a" |> AnyStr |> EqStr "c" +-- >>> let s = ["a", "b", "d"] +-- >>> applyCapture s p +-- fromList [Capture {captured = "b"}] +applyCapture :: Eq s => Str s -> Pattern s -> Seq (Capture s) +applyCapture s p = case apply s p of + (_, c, _) -> c +{-# INLINE applyCapture #-} + +-- | (Re)Construct the longest input 'Str'ing matching a prefix of a pattern, +-- using the given captures to satisfy matchers. As long as there are enough +-- captures to satisfy all matchers in the pattern, the resulting string will +-- always be a (full) match for the pattern. +-- +-- Furthermore, if an input string @s@ is a (full) match for a pattern @p@, then +-- +-- @ +-- unapplyCapture p (applyCapture s p) == s +-- @ +-- +-- >>> let p = mempty |> EqStr "a" |> AnyStr |> EqStr "c" +-- >>> let s = ["a", "b", "c"] +-- >>> unapplyCapture p (applyCapture s p) +-- ["a","b","c"] +unapplyCapture :: Pattern s -> Seq (Capture s) -> Str s +unapplyCapture = go [] + where + go !str Empty _ = str + go !str (_ :|> AnyStr ) Empty = str + go !str (p :|> EqStr s) cs = go (s : str) p cs + go !str (p :|> AnyStr ) (cs :|> c) = go (captured c : str) p cs + +-- | Apply a string to a pattern, returning the captures iff +-- the string is a (full) match for the pattern. +-- +-- >>> let p = mempty |> EqStr "a" |> AnyStr |> EqStr "c" +-- >>> applyMatch ["a", "b", "c", "d"] p +-- Nothing +-- >>> applyMatch ["a", "b", "c"] p +-- Just (fromList [Capture {captured = "b"}]) +applyMatch :: Eq s => Str s -> Pattern s -> Maybe (Seq (Capture s)) +applyMatch s p = case apply s p of + (Empty, cs, []) -> Just cs + _ -> Nothing + +-- | Apply a string to a pattern, returning 'True' iff the string +-- is a (full) match for the pattern. +applyMatches :: Eq s => Str s -> Pattern s -> Bool +applyMatches s = isJust . applyMatch s + +-- | Apply a string to a pattern, returning the captures iff +-- the string is a prefix match for the pattern. +-- +-- >>> let p = mempty |> EqStr "a" |> AnyStr |> EqStr "c" +-- >>> applyMatchPrefix ["a", "b", "c", "d"] p +-- Just (fromList [Capture {captured = "b"}]) +applyMatchPrefix :: Eq s => Str s -> Pattern s -> Maybe (Seq (Capture s)) +applyMatchPrefix s p = case apply s p of + (Empty, cs, _) -> Just cs + _ -> Nothing + +-- | Apply a string to a pattern, returning 'True' iff the string +-- is a prefix match for the pattern. +applyMatchesPrefix:: Eq s => Str s -> Pattern s -> Bool +applyMatchesPrefix s = isJust . applyMatchPrefix s + +----------------------------------------------------------------------------- +-- List conversion + +-- | Create a pattern trie from a list of patterns and associated values. +-- +-- \(\mathcal{O}(n \cdot k)\), where \(n\) is the length of the list and +-- \(k\) is the length of the longest pattern in the list. +fromAssocList :: (Eq s, Hashable s) => [(Pattern s, a)] -> Trie s a +fromAssocList = foldl' add mempty + where + add t (p, a) = insert p a t +{-# INLINE fromAssocList #-} + +-- | Create a list of patterns and associated values from a pattern trie. +-- +-- \(\mathcal{O}(n \cdot k)\), where \(n\) is the number of values in the trie +-- and \(k\) is the length of the longest pattern in the trie. +toAssocList :: (Eq s, Hashable s) => Trie s a -> [(Pattern s, a)] +toAssocList t = foldrWithKey (\p a l -> (p, a) : l) [] t +{-# INLINE toAssocList #-} + +----------------------------------------------------------------------------- +-- Updates + +-- | Insert the value for the given pattern into the trie. +-- +-- \(\Theta(k)\), where \(k\) is the length of the pattern. +insert :: (Eq s, Hashable s) => Pattern s -> a -> Trie s a -> Trie s a +insert p !a = go p + where + go Empty = modVal (const (Just a)) + go (AnyStr :<| p') = modVar ((Just $!) . go p' . fromMaybe mempty) + go (EqStr s :<| p') = modStr $ \m -> + let t' = HashMap.lookupDefault mempty s m + in HashMap.insert s (go p' t') m +{-# SPECIALISE insert :: BPattern -> a -> BTrie a -> BTrie a #-} +{-# SPECIALISE insert :: TPattern -> a -> TTrie a -> TTrie a #-} + +-- | Update the value of the given pattern in the trie, if it exists. +-- +-- \(\mathcal{O}(k)\), where \(k\) is the length of the pattern. +adjust :: (Eq s, Hashable s) => Pattern s -> (a -> a) -> Trie s a -> Trie s a +adjust p f = go p + where + go Empty = modVal (f <$!>) + go (AnyStr :<| p') = modVar (go p' <$!>) + go (EqStr s :<| p') = modStr (HashMap.adjust (go p') s) +{-# SPECIALISE adjust :: BPattern -> (a -> a) -> BTrie a -> BTrie a #-} +{-# SPECIALISE adjust :: TPattern -> (a -> a) -> TTrie a -> TTrie a #-} + +-- | Remove the value for the given pattern from the trie, if it exists. +-- +-- \(\mathcal{O}(k)\), where \(k\) is the length of the pattern. +delete :: (Eq s, Hashable s) => Pattern s -> Trie s a -> Trie s a +delete p = go p + where + go Empty = modVal (const Nothing) + go (AnyStr :<| p') = modVar (maybe Nothing (go' p')) + go (EqStr s :<| p') = modStr (HashMap.update (go' p') s) + + go' p' t = case go p' t of + t' | null t' -> Nothing + t' -> Just t' +{-# SPECIALISE delete :: BPattern -> BTrie a -> BTrie a #-} +{-# SPECIALISE delete :: TPattern -> TTrie a -> TTrie a #-} + +----------------------------------------------------------------------------- +-- Lookups + +-- $lookupBigO +-- ===Time Complexity (successful lookups) +-- \(\Theta(k)\), where \(k\) is the length of the pattern. + +type LookupNextR r s a = Trie s a -> Pattern s -> r -> r + +lookupIter :: (Eq s, Hashable s) => LookupNextR r s a -> r -> Pattern s -> Trie s a -> r +lookupIter nextR = go + where + go r p t = + let !r' = nextR t p r + in case p of + Empty -> r' + AnyStr :<| p' -> maybe r' (go r' p') (vartrie t) + EqStr s :<| p' -> maybe r' (go r' p') (HashMap.lookup s (strtries t)) +{-# INLINE lookupIter #-} + +-- | Lookup the trie rooted at the longest prefix of a pattern, returning it +-- together with the remaining suffix of the pattern. +lookupPrefixTrie :: (Eq s, Hashable s) => Pattern s -> Trie s a -> (Trie s a, Pattern s) +lookupPrefixTrie p t = lookupIter nextR (t, Empty) p t + where + nextR t' p' = const (t', p') +{-# SPECIALISE lookupPrefixTrie :: BPattern -> BTrie a -> (BTrie a, BPattern) #-} +{-# SPECIALISE lookupPrefixTrie :: TPattern -> TTrie a -> (TTrie a, TPattern) #-} + +-- | Lookup the value for the longest matching prefix of a pattern, +-- returning it together with the remaining suffix of the pattern. +-- If there is no value in the trie for any prefix of the given pattern, +-- the result is 'Nothing'. +lookupPrefix :: (Eq s, Hashable s) => Pattern s -> Trie s a -> Maybe (a, Pattern s) +lookupPrefix p t = lookupIter nextR Nothing p t + where + nextR t' p' r = ((,p') <$!> value t') <|> r +{-# SPECIALISE lookupPrefix :: BPattern -> BTrie a -> Maybe (a, BPattern) #-} +{-# SPECIALISE lookupPrefix :: TPattern -> TTrie a -> Maybe (a, TPattern) #-} + +-- | Lookup the value of a pattern. +-- If there is no value in the trie for the given pattern, the result is +-- 'Nothing'. +lookup :: (Eq s, Hashable s) => Pattern s -> Trie s a -> Maybe a +lookup p t = case lookupPrefixTrie p t of + (t', Empty) -> value t' + _ -> Nothing +{-# INLINE lookup #-} + +----------------------------------------------------------------------------- +-- Matching + +-- $matchingBigO +-- ===Time Complexity (successful matches) +-- In what follows \(k\) is always the length of the input string (i.e. the +-- number of chunks). +-- +-- __/Best case/__: \(\Theta(k)\), when the input string matches the most +-- specific pattern in the trie (i.e. with the least captures) from all those +-- that have a matching prefix for the string. +-- +-- __/Worst case/__: \(\mathcal{O}(2^k)\), when there are \(2^{k-1}\) distinct +-- patterns of length at least \(k\) in the trie, all of which have a prefix of +-- length \(k-1\) that is a prefix match for the input string, but none except +-- for the most general of them are an actual (full) match. This is a +-- pathological case that comes about from backtracking to more general patterns +-- and is illustrated in an example with \(k=3\) for the input string +-- @["a","a","b"]@ below. +-- +-- <> +-- +-- Nodes with values are filled, choice points are blue, dead ends are red and +-- dashed lines indicate backtracking. The above trie contains the keys +-- (patterns) +-- +-- * @mempty |> EqStr "a" |> EqStr "a" |> EqStr "a"@ +-- * @mempty |> EqStr "a" |> AnyStr |> EqStr "a"@ +-- * @mempty |> AnyStr |> EqStr "a" |> EqStr "a"@ +-- * @mempty |> AnyStr |> AnyStr |> EqStr "b"@ +-- +-- with some arbitrary values. The paths are explored left-to-right in a +-- depth-first search. The number of steps for a match in the worst case is more +-- accurately approximated by +-- \[ \underbrace{2^k - 1}_{\text{downwards searching}} + \underbrace{2^{k-1} - 1}_{\text{upwards backtracking}} \] +-- Dropping the asymptotically insignificant constants and lower terms yields the +-- bound. For realistic values of \(k\), however, the difference matters. + +-- | A choice point for backtracking to alternative branches. +data Choice s a = Choice !(Seq (Capture s)) (Str s) !(Trie s a) + +type MatchNextR r s a = Trie s a -> Seq (Capture s) -> Str s -> r -> r + +matchIter :: (Eq s, Hashable s) => MatchNextR r s a -> r -> Str s -> Trie s a -> r +matchIter nextR = go Seq.empty [] + where + go !cs !cps r str t = + let !r' = nextR t cs str r + in case str of + [] -> if isJust (value t) then r' else backtrack r' cps + (s:s') -> case HashMap.lookup s (strtries t) of + Just t' -> case vartrie t of + Nothing -> go cs cps r' s' t' + Just t'' -> + -- Add a new choice point + let cps' = Choice (cs |> Capture s) s' t'' : cps + in go cs cps' r' s' t' + Nothing -> case vartrie t of + Just t' -> go (cs |> Capture s) cps r' s' t' + Nothing -> backtrack r' cps + + -- Continue at the last choice point, if any + backtrack r [] = r + backtrack r (Choice cs' ss' t' : cps') = go cs' cps' r ss' t' +{-# INLINE matchIter #-} + +-- | Lookup the trie rooted at the longest matching prefix of the input string, +-- returning it together with any captured parts and the remaining (unmatched) +-- suffix of the input string. +-- +-- In particular, if the input string is a (full) match for a pattern, the +-- returned trie is the subtrie that is rooted at the associated 'value'. +matchPrefixTrie :: (Eq s, Hashable s) => Str s -> Trie s a -> (Trie s a, Seq (Capture s), Str s) +matchPrefixTrie s t = matchIter nextR (t, Seq.empty, []) s t + where + nextR t' cs' s' = const (t', cs', s') +{-# SPECIALISE matchPrefixTrie :: BStr -> BTrie a -> (BTrie a, Seq BCapture, BStr) #-} +{-# SPECIALISE matchPrefixTrie :: TStr -> TTrie a -> (TTrie a, Seq TCapture, TStr) #-} + +-- | Lookup the value for the longest matching prefix of the input string, +-- returning it together with any captured parts and the remaining +-- (unmatched) suffix of the input string. If no prefix of the input +-- string matches any pattern in the trie, the result is 'Nothing'. +matchPrefix :: (Eq s, Hashable s) => Str s -> Trie s a -> Maybe (a, Seq (Capture s), Str s) +matchPrefix s t = matchIter nextR Nothing s t + where + nextR t' cs s' r = ((,cs,s') <$!> value t') <|> r +{-# SPECIALISE matchPrefix :: BStr -> BTrie a -> Maybe (a, Seq BCapture, BStr) #-} +{-# SPECIALISE matchPrefix :: TStr -> TTrie a -> Maybe (a, Seq TCapture, TStr) #-} + +-- | Lookup the value for an input string by matching it against the patterns of +-- a trie. The value of the matching pattern, if any, is returned together with +-- any captured parts of the input string. If the input string does not match +-- any pattern in the trie, the result is 'Nothing'. +-- +match :: (Eq s, Hashable s) => Str s -> Trie s a -> Maybe (a, Seq (Capture s)) +match s t = case matchPrefixTrie s t of + (t', cs, []) -> (,cs) <$!> value t' + _ -> Nothing +{-# INLINE match #-} + +----------------------------------------------------------------------------- +-- Folds and traversals with keys (patterns) + +traverseWithKey :: Applicative f => (Pattern s -> a -> f b) -> Trie s a -> f (Trie s b) +traverseWithKey f t = go mempty t + where + go !p (Trie vals vars v) = + let f1 = HashMap.traverseWithKey (\k -> go (p |> EqStr k)) vals + f2 = traverse (go (p |> AnyStr)) vars + f3 = traverse (f p) v + in Trie <$> f1 <*> f2 <*> f3 + +foldMapWithKey :: Monoid m => (Pattern s -> a -> m) -> Trie s a -> m +foldMapWithKey f = getConst . traverseWithKey (\p -> Const . f p) + +foldrWithKey :: (Pattern s -> a -> b -> b) -> b -> Trie s a -> b +foldrWithKey f b t = appEndo (foldMapWithKey (\p -> Endo . f p) t) b + +----------------------------------------------------------------------------- +-- Utilities + +modStr :: (HashMap s (Trie s a) -> HashMap s (Trie s a)) -> Trie s a -> Trie s a +modStr f t = t { strtries = f (strtries t) } +{-# INLINE modStr #-} + +modVar :: (Maybe (Trie s a) -> Maybe (Trie s a)) -> Trie s a -> Trie s a +modVar f t = t { vartrie = f (vartrie t) } +{-# INLINE modVar #-} + +modVal :: (Maybe a -> Maybe a) -> Trie s a -> Trie s a +modVal f t = t { value = f (value t) } +{-# INLINE modVal #-} + +type BTrie a = Trie ByteString a +type BStr = Str ByteString +type BCapture = Capture ByteString +type BPattern = Pattern ByteString + +type TTrie a = Trie Text a +type TStr = Str Text +type TCapture = Capture Text +type TPattern = Pattern Text + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +module Main where + +import Test.Data.Trie.Pattern +import Test.Tasty + +main :: IO () +main = defaultMain tests diff --git a/test/Test/Data/Trie/Pattern.hs b/test/Test/Data/Trie/Pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Trie/Pattern.hs @@ -0,0 +1,315 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Test.Data.Trie.Pattern (tests) where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Functor.Identity +import Data.Functor.Compose +import Data.List (inits) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif +import Data.Sequence (Seq (..)) +import Data.Trie.Pattern +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Sequence as Seq +import qualified Data.Trie.Pattern as Trie + +tests :: TestTree +tests = testGroup "Data.Trie.Pattern" + [ testGroup "Semigroup" + [ testProperty "Left preference" checkSemigroupLeftPref + , testProperty "Associativity" checkSemigroupAssoc + ] + , testGroup "Monoid" + [ testProperty "Identity" checkMonoidId + ] + , testGroup "Functor" + [ testProperty "Identity" checkFunctorId + , testProperty "Composition" checkFunctorComp + ] + , testGroup "Traversable" + [ testProperty "Identity" checkTraversableId + , testProperty "Composition" checkTraversableComp + ] + , testProperty "capture" checkCapture + , testProperty "overlapping" checkOverlapping + , testProperty "match" checkMatch + , testProperty "match (overlapping)" checkMatchOverlapping + , testProperty "match (partial overlap)" checkMatchPartialOverlap + , testProperty "lookup" checkLookup + , testProperty "insert" checkInsert + , testProperty "from/to list" checkListConversion + , testProperty "delete" checkDelete + , testProperty "adjust" checkAdjust + , testProperty "null" checkNull + , testProperty "value" checkValue + , testProperty "lookupPrefix" checkLookupPrefix + , testProperty "matchPrefix" checkMatchPrefix + ] + +------------------------------------------------------------------------------- +-- Basic properties + +checkNull :: Property +checkNull = once (null (mempty :: Trie ByteString Int)) + .&&. (forAll genTrie (not . null)) + +checkValue :: Property +checkValue = forAll genTrie $ \t -> + Trie.value t == Trie.lookup Empty t + +checkListConversion :: Property +checkListConversion = forAll genTrie $ \t -> + Trie.fromAssocList (Trie.toAssocList t) == t + +checkCapture :: Property +checkCapture = forAll genPatternMatch $ \(p, s) -> + Trie.unapplyCapture p (Trie.applyCapture s p) == s + +checkOverlapping :: Property +checkOverlapping = forAll genTwinPatterns $ \(p1, p2) -> + -- Irreflexive + not (Trie.overlapping p1 p1) + .&&. + -- Symmetric + (Trie.overlapping p1 p2 ==> Trie.overlapping p2 p1) + +------------------------------------------------------------------------------- +-- Properties of lookups and matching + +checkMatch :: Property +checkMatch = forAll genPatterns check + where + check patterns = + let t = Trie.fromAssocList patterns + in conjoin . flip map patterns $ \(p, a) -> + forAll (genStr p) $ \s -> + let c = Trie.applyCapture s p + in Trie.match s t == Just (a, c) + +checkMatchOverlapping :: Property +checkMatchOverlapping = forAll genPatternMatch $ \(p, s) -> + let -- Overlaps with 'p' w.r.t 's' + p' = Seq.fromList (map Trie.EqStr s) + t = Trie.fromAssocList [(p, 1), (p', 2)] :: Trie ByteString Int + c = Trie.applyCapture s p + in + (Trie.match s t == Just (2, Seq.empty)) + .&&. + (Trie.matchPrefix s t == Just (2, Seq.empty, [])) + .&&. + (p /= p' ==> Trie.overlapping p p') + .&&. + (p /= p' ==> Trie.matchOrd p' > Trie.matchOrd p) + .&&. + (p /= p' ==> Trie.matchPrefix (s ++ ["x"]) t == Just (1, c, ["x"]) + && Trie.matchPrefixOrd p > Trie.matchPrefixOrd p') + +-- Partially overlapping patterns (i.e. those with an overlapping +-- proper prefix) are not ambiguous but require backtracking via +-- choice points, since the more specific path is explored first. +checkMatchPartialOverlap :: Property +checkMatchPartialOverlap = forAll genPatternMatch $ \(p, s) -> + let -- A match for ../a/c requires backtracking to the choice point + -- before ../a, since the /a/.. branches are explored first. + pm = p |> AnyStr |> EqStr "c" -- matches + p' = p |> EqStr "a" |> EqStr "b" -- no match but explored first + p'' = p |> EqStr "a" |> AnyStr |> AnyStr -- no match but explored first + s' = s ++ ["a","c"] + t = Trie.fromAssocList [(p', 1), (pm, 2), (p'', 3)] :: Trie ByteString Int + c = Trie.applyCapture s' pm + in + Trie.match s' t == Just (2, c) + +checkLookup :: Property +checkLookup = forAll genPatterns check + where + check patterns = + let t = Trie.fromAssocList patterns + in conjoin . flip map patterns $ \(p, a) -> + Trie.lookup p t == Just a + +-- Generate a trie containing values for all prefixes of an +-- arbitrary pattern. Then iteratively remove the patterns +-- from the trie, starting with the longest prefix, each time +-- verifying that 'lookupPrefix' yields the right value and +-- remaining suffix. +checkLookupPrefix :: Property +checkLookupPrefix = forAll (genPattern Nothing) $ \p -> + let + patterns = toList (Seq.inits p) `zip` [(1::Int)..] + trie = Trie.fromAssocList patterns + check (px, a) ~(t, props) = + let + p' = Seq.drop (Seq.length px) p + ok = Trie.lookupPrefix p t == Just (a, p') + in + (Trie.delete px t, ok : props) + in + conjoin (snd (foldr check (trie, []) patterns)) + +-- Generate a trie containing values for all prefixes of an +-- arbitrary pattern. Then iteratively remove the patterns +-- from the trie, starting with the longest prefix, each time +-- verifying that 'matchPrefix' applied to an input string +-- matching the entire pattern yields the right value, captured +-- chunks and remaining suffix. +checkMatchPrefix :: Property +checkMatchPrefix = forAll genPatternMatch $ \(p, s) -> + let + patterns = toList (Seq.inits p) `zip` [(1::Int)..] + trie = Trie.fromAssocList patterns + inputs = patterns `zip` inits s + check ((px, a), sx) ~(t, props) = + let + s' = drop (length sx) s + cs = Trie.applyCapture sx px + ok = Trie.matchPrefix s t == Just (a, cs, s') + in + (Trie.delete px t, ok : props) + in + conjoin (snd (foldr check (trie, []) inputs)) + +------------------------------------------------------------------------------- +-- Properties of modifications + +checkInsert :: Property +checkInsert = forAll genTrie $ \t -> + forAll (genPattern Nothing) $ \p -> + let t' = Trie.insert p 42 t + in Trie.lookup p t' == Just 42 + +-- For an arbitrary trie, iteratively delete every pattern, checking +-- the presence and absence of the pattern before and after each +-- deletion, respectively, as well as that the final trie is empty. +checkDelete :: Property +checkDelete = forAll genTrie $ \t -> + let (t', props) = Trie.foldrWithKey reduce (t, []) t + in null t' .&&. conjoin props + where + reduce p a (t, props) = + let before = Trie.lookup p t == Just a + t' = Trie.delete p t + after = Trie.lookup p t' == Nothing + in (t', before : after : props) + +checkAdjust :: Property +checkAdjust = forAll genTrie $ \t -> + let (p, a) = head (Trie.toAssocList t) + t' = Trie.adjust p (+ 1) t + in Trie.lookup p t' == Just (a + 1) && + Trie.delete p t == Trie.delete p t' + +------------------------------------------------------------------------------- +-- Semigroup and monoid properties of tries + +checkSemigroupLeftPref :: Property +checkSemigroupLeftPref = forAll genTrie $ \t -> + forAll (genPattern Nothing) $ \p -> + let t' = Trie.insert p 1 t + t'' = Trie.insert p 2 t + in (t' <> t'') == t' + +checkSemigroupAssoc :: Property +checkSemigroupAssoc = forAll (replicateM 3 genTrie) $ \[t1,t2,t3] -> + (t1 <> t2) <> t3 == t1 <> (t2 <> t3) + +checkMonoidId :: Property +checkMonoidId = forAll genTrie $ \t -> + t <> mempty == t && mempty <> t == t + +------------------------------------------------------------------------------- +-- Functor laws for tries + +checkFunctorId :: Property +checkFunctorId = forAll genTrie $ \t -> + fmap id t == id t + +checkFunctorComp :: Property +checkFunctorComp = forAll genTrie $ \t -> + fmap (f . g) t == (fmap f . fmap g) t + where + f, g :: Int -> Int + f x = x + 1 + g x = x * 2 + +------------------------------------------------------------------------------- +-- Traversable laws for tries + +checkTraversableId :: Property +checkTraversableId = forAll genTrie $ \t -> + traverse Identity t == Identity t + +checkTraversableComp :: Property +checkTraversableComp = forAll genTrie $ \t -> + traverse (Compose . fmap g . f) t + == + (Compose . fmap (traverse g) . traverse f) t + where + f, g :: Int -> Maybe Int + f x = Just (x + 1) + g x = Just (x * 2) + +------------------------------------------------------------------------------- +-- Generators + +genByteString :: Gen ByteString +genByteString = C8.pack <$> listOf1 arbitraryASCIIChar + +-- Generate an input string matching a given pattern. +genStr :: Pattern ByteString -> Gen (Str ByteString) +genStr p = mapM gen (toList p) + where + gen Trie.AnyStr = genByteString + gen (Trie.EqStr s) = pure s + +genPattern :: Maybe ByteString -> Gen (Pattern ByteString) +genPattern prefix = do + n <- choose (1, 10) + s <- vectorOf n genMatcher + return $ Seq.fromList (maybe s ((:s) . Trie.EqStr) prefix) + +-- | Generate two (possibly overlapping) patterns of the same length. +genTwinPatterns :: Gen (Pattern ByteString, Pattern ByteString) +genTwinPatterns = do + p1 <- genPattern Nothing + p2 <- Seq.fromList <$> vectorOf (Seq.length p1) genMatcher + return (p1, p2) + +-- Generate an arbitrary pattern together with a matching +-- input string. +genPatternMatch :: Gen (Pattern ByteString, Str ByteString) +genPatternMatch = do + p <- genPattern Nothing + s <- genStr p + return (p, s) + +genMatcher :: Gen (Matcher ByteString) +genMatcher = oneof [str, var] + where + str = Trie.EqStr <$> genByteString + var = pure Trie.AnyStr + +-- Generate 1-100 non-overlapping patterns +genPatterns :: Gen [(Pattern ByteString, Int)] +genPatterns = do + n <- choose (1, 100) + r <- mapM (genPattern . Just . C8.pack . show) [1..n] + return $ r `zip` [1..n] + +genTrie :: Gen (Trie ByteString Int) +genTrie = Trie.fromAssocList <$> genPatterns +