pattern-trie (empty) → 0.1.0
raw patch · 11 files changed
+1670/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changedbinary-added
Dependencies added: QuickCheck, base, bytestring, bytestring-trie, containers, criterion, deepseq, doctest, hashable, mtl, pattern-trie, tasty, tasty-quickcheck, text, unordered-containers
Files
- CHANGELOG.md +4/−0
- LICENSE +373/−0
- Setup.hs +2/−0
- bench/Main.hs +151/−0
- docs-extra/backtrack.png binary
- docs-extra/backtrack.tex +38/−0
- doctests.hs +3/−0
- pattern-trie.cabal +93/−0
- src/Data/Trie/Pattern.hs +680/−0
- test/Main.hs +11/−0
- test/Test/Data/Trie/Pattern.hs +315/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+## 0.1.0++Initial release.+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -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+
+ docs-extra/backtrack.png view
binary file changed (absent → 7621 bytes)
+ docs-extra/backtrack.tex view
@@ -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}+
+ doctests.hs view
@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["src"]
+ pattern-trie.cabal view
@@ -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 <roman@pkaboo.org>+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+
+ src/Data/Trie/Pattern.hs view
@@ -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.+--+-- <<docs-extra/backtrack.png>>+--+-- 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+
+ test/Main.hs view
@@ -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
+ test/Test/Data/Trie/Pattern.hs view
@@ -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+