From c97b39f9a99e20f7a631cf3bb383cac88ac21d1f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 9 Mar 2016 13:15:23 +0000 Subject: [PATCH] Rearrange hs directory into an actual Haskell project --- hs/.gitignore | 1 + hs/LICENSE | 165 +++++++++++++++++ hs/Setup.hs | 3 + hs/src/Syndicate/Dataspace/Trie/ESOP2016.hs | 79 ++++++++ .../Syndicate/Dataspace/Trie/ESOP2016v2.hs} | 55 +----- hs/src/Syndicate/Dataspace/Trie/ESOP2016v3.hs | 84 +++++++++ hs/src/Syndicate/Dataspace/Trie/Prefix.hs | 88 +++++++++ hs/syndicate.cabal | 37 ++++ hs/test/Main.hs | 27 +++ .../Dataspace/Trie/Tests/ESOP2016.hs | 55 ++++++ .../Dataspace/Trie/Tests/ESOP2016v2.hs | 55 ++++++ .../Dataspace/Trie/Tests/ESOP2016v3.hs | 95 ++++++++++ .../Syndicate/Dataspace/Trie/Tests/Prefix.hs} | 110 ++---------- hs/treetrie1.hs | 130 -------------- hs/treetrie3.hs | 170 ------------------ 15 files changed, 710 insertions(+), 444 deletions(-) create mode 100644 hs/.gitignore create mode 100644 hs/LICENSE create mode 100755 hs/Setup.hs create mode 100644 hs/src/Syndicate/Dataspace/Trie/ESOP2016.hs rename hs/{treetrie2.hs => src/Syndicate/Dataspace/Trie/ESOP2016v2.hs} (50%) create mode 100644 hs/src/Syndicate/Dataspace/Trie/ESOP2016v3.hs create mode 100644 hs/src/Syndicate/Dataspace/Trie/Prefix.hs create mode 100644 hs/syndicate.cabal create mode 100644 hs/test/Main.hs create mode 100644 hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016.hs create mode 100644 hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v2.hs create mode 100644 hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v3.hs rename hs/{treetrie4.hs => test/Syndicate/Dataspace/Trie/Tests/Prefix.hs} (71%) delete mode 100644 hs/treetrie1.hs delete mode 100644 hs/treetrie3.hs diff --git a/hs/.gitignore b/hs/.gitignore new file mode 100644 index 0000000..849ddff --- /dev/null +++ b/hs/.gitignore @@ -0,0 +1 @@ +dist/ diff --git a/hs/LICENSE b/hs/LICENSE new file mode 100644 index 0000000..31afd6d --- /dev/null +++ b/hs/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/hs/Setup.hs b/hs/Setup.hs new file mode 100755 index 0000000..cd7dc32 --- /dev/null +++ b/hs/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/hs/src/Syndicate/Dataspace/Trie/ESOP2016.hs b/hs/src/Syndicate/Dataspace/Trie/ESOP2016.hs new file mode 100644 index 0000000..f2ecffb --- /dev/null +++ b/hs/src/Syndicate/Dataspace/Trie/ESOP2016.hs @@ -0,0 +1,79 @@ +module Syndicate.Dataspace.Trie.ESOP2016 where +-- ESOP 2016 implementation of dataspace tries. +-- Includes bug fixes wrt the paper. + +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +data Sigma = Open + | Close + | Wild + | Ch Char + deriving (Eq, Ord, Show) + +data Trie a = Ok a + | Tl (Trie a) + | Br (Map.Map Sigma (Trie a)) + deriving (Eq, Show) + +empty = Br Map.empty + +null (Br h) = Map.null h +null _ = False + +tl r = if null r then empty else Tl r + +untl (Tl r) = r +untl _ = empty + +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route (x : s) (Br h) f = if Map.null h + then f + else route s (get h x) f +route (Close : s) (Tl r) f = route s r f +route (Open : s) (Tl r) f = route s (tl (tl r)) f +route (x : s) (Tl r) f = route s (tl r) f + +get h x = case Map.lookup x h of + Just r -> r + Nothing -> case x of + Open -> tl (get h Wild) + Close -> untl (get h Wild) + Wild -> empty + x -> get h Wild + +combine r1 r2 f leftEmpty rightEmpty = g r1 r2 + where g (Tl r1) (Tl r2) = tl (g r1 r2) + g (Tl r1) r2 = g (expand r1) r2 + g r1 (Tl r2) = g r1 (expand r2) + g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = dedup $ leftEmpty r2 + g r1 r2 | null r2 = dedup $ rightEmpty r1 + g (Br h1) (Br h2) = dedup $ Br (foldKeys g h1 h2) + +foldKeys g h1 h2 = Set.foldr f Map.empty keys + where f x acc = Map.insert x (g (get h1 x) (get h2 x)) acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +expand r = Br (Map.fromList [(Wild, tl r), (Close, r)]) + +dedup (Br h) = Br (Map.filterWithKey (distinct h) h) + +distinct h Wild r = not (null r) +distinct h Open (Tl r) = r /= get h Wild +distinct h Open r = not (null r) +distinct h Close r = r /= untl (get h Wild) +distinct h x r = r /= get h Wild + +--------------------------------------------------------------------------- + +union r1 r2 = combine r1 r2 unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs diff --git a/hs/treetrie2.hs b/hs/src/Syndicate/Dataspace/Trie/ESOP2016v2.hs similarity index 50% rename from hs/treetrie2.hs rename to hs/src/Syndicate/Dataspace/Trie/ESOP2016v2.hs index a6309c1..9c84081 100644 --- a/hs/treetrie2.hs +++ b/hs/src/Syndicate/Dataspace/Trie/ESOP2016v2.hs @@ -1,10 +1,10 @@ -module TreeTrie where +module Syndicate.Dataspace.Trie.ESOP2016v2 where +-- Close to the ESOP 2016 implementation of dataspace tries, but takes +-- a step toward efficiency by using collapse/update instead of dedup/distinct. --- import Debug.Trace import Prelude hiding (null, seq) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Test.HUnit data Sigma = Open | Close @@ -96,52 +96,3 @@ unionCombine r1 r2 | null r1 = r2 unionCombine r1 r2 | null r2 = r1 unions rs = foldr union empty rs - ---------------------------------------------------------------------------- - -ok vs = Ok (Set.fromList vs) -seq x r = if null r then r else Br (Map.singleton x r) - -seqCh '<' = Open -seqCh '>' = Close -seqCh '*' = Wild -seqCh x = Ch x - -seqs s r = foldr (\ x r -> seq (seqCh x) r) r s - -main = runTestTT $ - test [ - "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), - "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), - (Ch 'b', ok [2])]) ~=? - union (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), - (Ch 'b', ok [2])]) ~=? - unions [seqs "a" (ok [1]), - seqs "b" (ok [2]), - seqs "a" (ok [2])], - "union idem" ~: (seqs "abc" (ok [1])) ~=? - union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "union wild" ~: - Br (Map.fromList [(Open,Br (Map.fromList [(Wild,Tl (ok [1])), - (Ch 'a',Br (Map.fromList [(Close,ok [1,2]), - (Wild,Tl (ok [1]))]))])), - (Wild,ok [1])]) - ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), - "route union wild1" ~: Set.fromList [1,2] ~=? - route [Open, Ch 'a', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild2" ~: Set.fromList [1] ~=? - route [Open, Ch 'b', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild3" ~: Set.fromList [1] ~=? - route [Open, Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild4" ~: Set.fromList [1] ~=? - route [Open, Ch 'a', Ch 'a', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty - ] diff --git a/hs/src/Syndicate/Dataspace/Trie/ESOP2016v3.hs b/hs/src/Syndicate/Dataspace/Trie/ESOP2016v3.hs new file mode 100644 index 0000000..4d05dff --- /dev/null +++ b/hs/src/Syndicate/Dataspace/Trie/ESOP2016v3.hs @@ -0,0 +1,84 @@ +module Syndicate.Dataspace.Trie.ESOP2016v3 where +-- Explicitly separate Open/Close/Wild from other edges in Br nodes. +-- This gives an elegant presentation. + +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +data Trie a = Mt + | Ok a + | Tl (Trie a) + | Br (Trie a, Trie a, Trie a, Map.Map Char (Trie a)) -- Open, Close, Wild, rest + deriving (Eq, Show) + +empty = Mt + +null Mt = True +null _ = False + +tl r = if null r then empty else Tl r + +untl (Tl r) = r +untl _ = empty + +route _ Mt f = f +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route ('<' : s) (Br (r, _, _, _)) f = route s r f +route ('>' : s) (Br (_, r, _, _)) f = route s r f +route (x : s) (Br (_, _, w, h)) f = route s (Map.findWithDefault w x h) f +route ('<' : s) (Tl r) f = route s (tl (tl r)) f +route ('>' : s) (Tl r) f = route s r f +route (x : s) (Tl r) f = route s (tl r) f + +get w h x = Map.findWithDefault w x h + +combine f leftEmpty rightEmpty r1 r2 = g r1 r2 + where g (Tl r1) (Tl r2) = tl (g r1 r2) + g (Tl r1) r2 = g (expand r1) r2 + g r1 (Tl r2) = g r1 (expand r2) + g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = collapse $ leftEmpty r2 + g r1 r2 | null r2 = collapse $ rightEmpty r1 + g r1 r2 = collapse $ foldKeys g r1 r2 + +foldKeys g (Br (o1, c1, w1, h1)) (Br (o2, c2, w2, h2)) = + Br (g o1 o2, g c1 c2, w, Set.foldr f Map.empty keys) + where w = g w1 w2 + f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +expand r = Br (Mt, r, tl r, Map.empty) + +collapse (Br (Mt, k, Tl k', h)) | Map.null h && k == k' = tl k +collapse (Br (Mt, Mt, Tl k, h)) | Map.null h = tl k +collapse (Br (Mt, Mt, Mt, h)) | Map.null h = empty +collapse r = r + +update x k w h = if k == w then Map.delete x h else Map.insert x k h + +--------------------------------------------------------------------------- + +union :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +union = combine unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +intersection :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +intersection = combine intersectionCombine (const empty) (const empty) +intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +intersectionCombine r1 r2 | null r1 = empty +intersectionCombine r1 r2 | null r2 = empty + +difference :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +difference = combine differenceCombine (const empty) id +differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in + if Set.null xs then empty else (Ok xs) +differenceCombine r1 r2 | null r1 = empty +differenceCombine r1 r2 | null r2 = r1 diff --git a/hs/src/Syndicate/Dataspace/Trie/Prefix.hs b/hs/src/Syndicate/Dataspace/Trie/Prefix.hs new file mode 100644 index 0000000..a2f424d --- /dev/null +++ b/hs/src/Syndicate/Dataspace/Trie/Prefix.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleInstances #-} +module Syndicate.Dataspace.Trie.Prefix where +-- Alternate representation, where Open has an explicit *arity* +-- attached to it, and matching close-parens are implicitly tracked. +-- Where ESOP2016-style implementations have "", this style has +-- "<3xyz". + +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +data Trie a = Mt + | Ok a + | Br (Map.Map Integer (Trie a), Trie a, Map.Map Char (Trie a)) -- Opens, Wild, rest + deriving (Eq, Show) + +empty = Mt + +null Mt = True +null _ = False + +makeTail _ r | null r = r +makeTail 0 r = r +makeTail n r = Br (Map.empty, makeTail (n - 1) r, Map.empty) + +stripTail _ r | null r = Just r +stripTail 0 r = Just r +stripTail n (Br (os, r, h)) | Map.null os && Map.null h = stripTail (n - 1) r +stripTail _ _ = Nothing + +route _ Mt f = f +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route ('<' : nc : s) (Br (os, w, _)) f = + let n = (read (nc : []) :: Integer) in + case Map.lookup n os of + Just r -> route s r f + Nothing -> route s (makeTail n w) f +route (x : s) (Br (_, w, h)) f = route s (Map.findWithDefault w x h) f + +get w h x = Map.findWithDefault w x h + +combine f leftEmpty rightEmpty r1 r2 = g r1 r2 + where g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = collapse $ leftEmpty r2 + g r1 r2 | null r2 = collapse $ rightEmpty r1 + g r1 r2 = collapse $ foldKeys g r1 r2 + +foldKeys g (Br (os1, w1, h1)) (Br (os2, w2, h2)) = + Br (Set.foldr fo Map.empty sizes, w, Set.foldr f Map.empty keys) + where sizes = Set.union (Map.keysSet os1) (Map.keysSet os2) + w = g w1 w2 + fo size acc = let o1 = Map.findWithDefault (makeTail size w1) size os1 in + let o2 = Map.findWithDefault (makeTail size w2) size os2 in + let o = g o1 o2 in + if stripTail size o == Just w then acc else Map.insert size o acc + f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +collapse (Br (os, Mt, h)) | Map.null os && Map.null h = empty +collapse r = r + +update x k w h = if k == w then Map.delete x h else Map.insert x k h + +--------------------------------------------------------------------------- + +union :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +union = combine unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +intersection :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +intersection = combine intersectionCombine (const empty) (const empty) +intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +intersectionCombine r1 r2 | null r1 = empty +intersectionCombine r1 r2 | null r2 = empty + +difference :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) +difference = combine differenceCombine (const empty) id +differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in + if Set.null xs then empty else (Ok xs) +differenceCombine r1 r2 | null r1 = empty +differenceCombine r1 r2 | null r2 = r1 diff --git a/hs/syndicate.cabal b/hs/syndicate.cabal new file mode 100644 index 0000000..9924e7c --- /dev/null +++ b/hs/syndicate.cabal @@ -0,0 +1,37 @@ +name: syndicate +version: 0.1.0.0 +synopsis: An Actor-based language with multicast, managed shared state, and grouping. +copyright: Copyright © 2016 Tony Garnock-Jones +homepage: http://syndicate-lang.org/ +license: LGPL-3 +license-file: LICENSE +author: Tony Garnock-Jones +maintainer: tonyg@leastfixedpoint.com +category: Concurrency +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Syndicate.Dataspace.Trie.ESOP2016 + , Syndicate.Dataspace.Trie.ESOP2016v2 + , Syndicate.Dataspace.Trie.ESOP2016v3 + , Syndicate.Dataspace.Trie.Prefix + build-depends: base + , containers + hs-source-dirs: src + default-language: Haskell2010 + +test-suite syndicate-dataspace-testsuite + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base + , containers + , QuickCheck + , HUnit + , Cabal + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , syndicate + hs-source-dirs: test + default-language: Haskell2010 diff --git a/hs/test/Main.hs b/hs/test/Main.hs new file mode 100644 index 0000000..d1b47ca --- /dev/null +++ b/hs/test/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleInstances #-} +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +import Syndicate.Dataspace.Trie.Tests.ESOP2016 as ESOP2016 +import Syndicate.Dataspace.Trie.Tests.ESOP2016v2 as ESOP2016v2 +import Syndicate.Dataspace.Trie.Tests.ESOP2016v3 as ESOP2016v3 +import Syndicate.Dataspace.Trie.Tests.Prefix as Prefix + +testOpts = (mempty :: TestOptions) + { topt_maximum_generated_tests = Just 1000 + , topt_maximum_unsuitable_generated_tests = Just 10000 + } +runnerOpts = (mempty :: RunnerOptions) { ropt_test_options = Just testOpts } +runTests tests = defaultMainWithOpts tests runnerOpts + +main = runTests + [ testGroup "ESOP2016" $ hUnitTestToTests ESOP2016.hUnitSuite + , testGroup "ESOP2016v2" $ hUnitTestToTests ESOP2016v2.hUnitSuite + , testGroup "ESOP2016v3" $ hUnitTestToTests ESOP2016v3.hUnitSuite + , testGroup "Prefix" [ testGroup "HUnit tests" $ hUnitTestToTests Prefix.hUnitSuite + , testGroup "QuickCheck tests" Prefix.quickCheckSuite + ] + ] diff --git a/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016.hs b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016.hs new file mode 100644 index 0000000..e472788 --- /dev/null +++ b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016.hs @@ -0,0 +1,55 @@ +module Syndicate.Dataspace.Trie.Tests.ESOP2016 where + +import Prelude hiding (null, seq) +import Syndicate.Dataspace.Trie.ESOP2016 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +ok vs = Ok (Set.fromList vs) +seq x r = if null r then r else Br (Map.singleton x r) + +seqCh '<' = Open +seqCh '>' = Close +seqCh '*' = Wild +seqCh x = Ch x + +seqs s r = foldr (\ x r -> seq (seqCh x) r) r s + +hUnitSuite = test + [ "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), + "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), + (Ch 'b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), + (Ch 'b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + -- This is noisier than it needs to be. + Br (Map.fromList [(Open,Br (Map.fromList [(Close, ok [1]), + (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))])), + (Ch 'a',Br (Map.fromList [(Close, ok [1,2]), + (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))]))]))])), + (Wild, ok [1])]) + ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route [Open, Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route [Open, Ch 'b', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route [Open, Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route [Open, Ch 'a', Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty + ] diff --git a/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v2.hs b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v2.hs new file mode 100644 index 0000000..a5e2779 --- /dev/null +++ b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v2.hs @@ -0,0 +1,55 @@ +module Syndicate.Dataspace.Trie.Tests.ESOP2016v2 where +-- Close to the ESOP 2016 implementation of dataspace tries, but takes +-- a step toward efficiency by using collapse/update instead of dedup/distinct. + +import Prelude hiding (null, seq) +import Syndicate.Dataspace.Trie.ESOP2016v2 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +ok vs = Ok (Set.fromList vs) +seq x r = if null r then r else Br (Map.singleton x r) + +seqCh '<' = Open +seqCh '>' = Close +seqCh '*' = Wild +seqCh x = Ch x + +seqs s r = foldr (\ x r -> seq (seqCh x) r) r s + +hUnitSuite = test + [ "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), + "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), + (Ch 'b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), + (Ch 'b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Map.fromList [(Open,Br (Map.fromList [(Wild,Tl (ok [1])), + (Ch 'a',Br (Map.fromList [(Close,ok [1,2]), + (Wild,Tl (ok [1]))]))])), + (Wild,ok [1])]) + ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route [Open, Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route [Open, Ch 'b', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route [Open, Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route [Open, Ch 'a', Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty + ] diff --git a/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v3.hs b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v3.hs new file mode 100644 index 0000000..e3b763e --- /dev/null +++ b/hs/test/Syndicate/Dataspace/Trie/Tests/ESOP2016v3.hs @@ -0,0 +1,95 @@ +module Syndicate.Dataspace.Trie.Tests.ESOP2016v3 where +-- Explicitly separate Open/Close/Wild from other edges in Br nodes. +-- This gives an elegant presentation. + +import Prelude hiding (null, seq) +import Syndicate.Dataspace.Trie.ESOP2016v3 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +ok vs = Ok (Set.fromList vs) + +seq _ r | null r = r +seq '<' r = Br (r, Mt, Mt, Map.empty) +seq '>' r = Br (Mt, r, Mt, Map.empty) +seq '*' r = Br (tl r, untl r, r, Map.empty) +seq x r = Br (Mt, Mt, Mt, Map.singleton x r) + +seqs s r = foldr seq r s + +hUnitSuite = test + [ "seqs simple" ~: + Br (Br (Mt, ok [1], Mt, Map.empty), Mt, Mt, Map.empty) ~=? seqs "<>" (ok [1]), + "union simple1" ~: + Br (Mt, Mt, Mt, + Map.fromList [('a', ok [1]), + ('b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: + Br (Mt, Mt, Mt, + Map.fromList [('a', ok [1,2]), + ('b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: + (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Br (Mt, + ok [1], + Tl (ok [1]), + Map.fromList [('a', Br (Mt, + ok [1,2], + Tl (ok [1]), + Map.empty))]), + Mt, + ok [1], + Map.empty) ~=? + union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route "<>" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "intersection simple1" ~: + seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), + "intersection simple2" ~: + empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "intersection idem" ~: + (seqs "abc" (ok [1])) ~=? + intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "difference simple1" ~: + seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), + "difference simple1a" ~: + seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), + "difference simple2" ~: + empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), + "difference wild" ~: + Br (Tl (ok [1]), + Mt, + ok [1], + Map.fromList [('a', Mt)]) ~=? + difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), + "union after difference" ~: + seqs "*" (ok [1]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), + "union after difference 2" ~: + Br (Tl (ok [1]), + Mt, + ok [1], + Map.fromList [('a', ok [2])]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])) + ] diff --git a/hs/treetrie4.hs b/hs/test/Syndicate/Dataspace/Trie/Tests/Prefix.hs similarity index 71% rename from hs/treetrie4.hs rename to hs/test/Syndicate/Dataspace/Trie/Tests/Prefix.hs index 13619ba..21c46e7 100644 --- a/hs/treetrie4.hs +++ b/hs/test/Syndicate/Dataspace/Trie/Tests/Prefix.hs @@ -1,93 +1,22 @@ {-# LANGUAGE FlexibleInstances #-} -module TreeTrie where +module Syndicate.Dataspace.Trie.Tests.Prefix where +-- Alternate representation, where Open has an explicit *arity* +-- attached to it, and matching close-parens are implicitly tracked. +-- Where ESOP2016-style implementations have "", this style has +-- "<3xyz". --- import Debug.Trace -import Prelude hiding (null, seq) +import Prelude hiding (null) +import Syndicate.Dataspace.Trie.Prefix import qualified Data.Map.Strict as Map import qualified Data.Set as Set + import Test.HUnit - import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 import Control.Monad -data Trie a = Mt - | Ok a - | Br (Map.Map Integer (Trie a), Trie a, Map.Map Char (Trie a)) -- Opens, Wild, rest - deriving (Eq, Show) - -empty = Mt - -null Mt = True -null _ = False - -makeTail _ r | null r = r -makeTail 0 r = r -makeTail n r = Br (Map.empty, makeTail (n - 1) r, Map.empty) - -stripTail _ r | null r = Just r -stripTail 0 r = Just r -stripTail n (Br (os, r, h)) | Map.null os && Map.null h = stripTail (n - 1) r -stripTail _ _ = Nothing - -route _ Mt f = f -route [] (Ok v) f = v -route [] _ f = f -route (_ : _) (Ok v) f = f -route ('<' : nc : s) (Br (os, w, _)) f = - let n = (read (nc : []) :: Integer) in - case Map.lookup n os of - Just r -> route s r f - Nothing -> route s (makeTail n w) f -route (x : s) (Br (_, w, h)) f = route s (Map.findWithDefault w x h) f - -get w h x = Map.findWithDefault w x h - -combine f leftEmpty rightEmpty r1 r2 = g r1 r2 - where g (Ok v) r2 = f (Ok v) r2 - g r1 (Ok v) = f r1 (Ok v) - g r1 r2 | null r1 = collapse $ leftEmpty r2 - g r1 r2 | null r2 = collapse $ rightEmpty r1 - g r1 r2 = collapse $ foldKeys g r1 r2 - -foldKeys g (Br (os1, w1, h1)) (Br (os2, w2, h2)) = - Br (Set.foldr fo Map.empty sizes, w, Set.foldr f Map.empty keys) - where sizes = Set.union (Map.keysSet os1) (Map.keysSet os2) - w = g w1 w2 - fo size acc = let o1 = Map.findWithDefault (makeTail size w1) size os1 in - let o2 = Map.findWithDefault (makeTail size w2) size os2 in - let o = g o1 o2 in - if stripTail size o == Just w then acc else Map.insert size o acc - f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc - keys = Set.union (Map.keysSet h1) (Map.keysSet h2) - -collapse (Br (os, Mt, h)) | Map.null os && Map.null h = empty -collapse r = r - -update x k w h = if k == w then Map.delete x h else Map.insert x k h - ---------------------------------------------------------------------------- - -union :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) -union = combine unionCombine id id -unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) -unionCombine r1 r2 | null r1 = r2 -unionCombine r1 r2 | null r2 = r1 - -unions rs = foldr union empty rs - -intersection = combine intersectionCombine (const empty) (const empty) -intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) -intersectionCombine r1 r2 | null r1 = empty -intersectionCombine r1 r2 | null r2 = empty - -difference = combine differenceCombine (const empty) id -differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in - if Set.null xs then empty else (Ok xs) -differenceCombine r1 r2 | null r1 = empty -differenceCombine r1 r2 | null r2 = r1 - ---------------------------------------------------------------------------- - ok vs = Ok (Set.fromList vs) seqs _ r | null r = r @@ -96,8 +25,8 @@ seqs ('<' : n : s) r = Br (Map.singleton (read (n : []) :: Integer) (seqs s r), seqs ('*' : s) r = Br (Map.empty, seqs s r, Map.empty) seqs (x : s) r = Br (Map.empty, Mt, Map.singleton x (seqs s r)) -simpleTestCases = test [ - "seqs simple" ~: +hUnitSuite = test + [ "seqs simple" ~: Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]), "union simple1" ~: Br (Map.empty, Mt, @@ -198,7 +127,7 @@ simpleTestCases = test [ (intersection (union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1]))) (union (seqs "*" (ok [4])) (seqs "<1b" (ok [2])))) - ] + ] --------------------------------------------------------------------------- @@ -275,10 +204,7 @@ unionBasics = combineBasics union (||) intersectionBasics = combineBasics intersection (&&) differenceBasics = combineBasics difference (\ x y -> x && not y) -qCheck name t = do putStrLn name - quickCheckWith stdArgs { maxSuccess = 500 } t - -main = do runTestTT simpleTestCases - qCheck "differenceBasics" differenceBasics - qCheck "intersectionBasics" intersectionBasics - qCheck "unionBasics" unionBasics +quickCheckSuite = [ testProperty "differenceBasics" differenceBasics + , testProperty "intersectionBasics" intersectionBasics + , testProperty "unionBasics" unionBasics + ] diff --git a/hs/treetrie1.hs b/hs/treetrie1.hs deleted file mode 100644 index ae1adbd..0000000 --- a/hs/treetrie1.hs +++ /dev/null @@ -1,130 +0,0 @@ -module TreeTrie where - --- import Debug.Trace -import Prelude hiding (null, seq) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Test.HUnit - -data Sigma = Open - | Close - | Wild - | Ch Char - deriving (Eq, Ord, Show) - -data Trie a = Ok a - | Tl (Trie a) - | Br (Map.Map Sigma (Trie a)) - deriving (Eq, Show) - -empty = Br Map.empty - -null (Br h) = Map.null h -null _ = False - -tl r = if null r then empty else Tl r - -untl (Tl r) = r -untl _ = empty - -route [] (Ok v) f = v -route [] _ f = f -route (_ : _) (Ok v) f = f -route (x : s) (Br h) f = if Map.null h - then f - else route s (get h x) f -route (Close : s) (Tl r) f = route s r f -route (Open : s) (Tl r) f = route s (tl (tl r)) f -route (x : s) (Tl r) f = route s (tl r) f - -get h x = case Map.lookup x h of - Just r -> r - Nothing -> case x of - Open -> tl (get h Wild) - Close -> untl (get h Wild) - Wild -> empty - x -> get h Wild - -combine r1 r2 f leftEmpty rightEmpty = g r1 r2 - where g (Tl r1) (Tl r2) = tl (g r1 r2) - g (Tl r1) r2 = g (expand r1) r2 - g r1 (Tl r2) = g r1 (expand r2) - g (Ok v) r2 = f (Ok v) r2 - g r1 (Ok v) = f r1 (Ok v) - g r1 r2 | null r1 = dedup $ leftEmpty r2 - g r1 r2 | null r2 = dedup $ rightEmpty r1 - g (Br h1) (Br h2) = dedup $ Br (foldKeys g h1 h2) - -foldKeys g h1 h2 = Set.foldr f Map.empty keys - where f x acc = Map.insert x (g (get h1 x) (get h2 x)) acc - keys = Set.union (Map.keysSet h1) (Map.keysSet h2) - -expand r = Br (Map.fromList [(Wild, tl r), (Close, r)]) - -dedup (Br h) = Br (Map.filterWithKey (distinct h) h) - -distinct h Wild r = not (null r) -distinct h Open (Tl r) = r /= get h Wild -distinct h Open r = not (null r) -distinct h Close r = r /= untl (get h Wild) -distinct h x r = r /= get h Wild - ---------------------------------------------------------------------------- - -union r1 r2 = combine r1 r2 unionCombine id id -unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) -unionCombine r1 r2 | null r1 = r2 -unionCombine r1 r2 | null r2 = r1 - -unions rs = foldr union empty rs - ---------------------------------------------------------------------------- - -ok vs = Ok (Set.fromList vs) -seq x r = if null r then r else Br (Map.singleton x r) - -seqCh '<' = Open -seqCh '>' = Close -seqCh '*' = Wild -seqCh x = Ch x - -seqs s r = foldr (\ x r -> seq (seqCh x) r) r s - -main = runTestTT $ - test [ - "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), - "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), - (Ch 'b', ok [2])]) ~=? - union (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), - (Ch 'b', ok [2])]) ~=? - unions [seqs "a" (ok [1]), - seqs "b" (ok [2]), - seqs "a" (ok [2])], - "union idem" ~: (seqs "abc" (ok [1])) ~=? - union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "union wild" ~: - -- This is noisier than it needs to be. - Br (Map.fromList [(Open,Br (Map.fromList [(Close, ok [1]), - (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))])), - (Ch 'a',Br (Map.fromList [(Close, ok [1,2]), - (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))]))]))])), - (Wild, ok [1])]) - ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), - "route union wild1" ~: Set.fromList [1,2] ~=? - route [Open, Ch 'a', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild2" ~: Set.fromList [1] ~=? - route [Open, Ch 'b', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild3" ~: Set.fromList [1] ~=? - route [Open, Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild4" ~: Set.fromList [1] ~=? - route [Open, Ch 'a', Ch 'a', Close] (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty - ] diff --git a/hs/treetrie3.hs b/hs/treetrie3.hs deleted file mode 100644 index 49a9161..0000000 --- a/hs/treetrie3.hs +++ /dev/null @@ -1,170 +0,0 @@ -module TreeTrie where - --- import Debug.Trace -import Prelude hiding (null, seq) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Test.HUnit - -data Trie a = Mt - | Ok a - | Tl (Trie a) - | Br (Trie a, Trie a, Trie a, Map.Map Char (Trie a)) -- Open, Close, Wild, rest - deriving (Eq, Show) - -empty = Mt - -null Mt = True -null _ = False - -tl r = if null r then empty else Tl r - -untl (Tl r) = r -untl _ = empty - -route _ Mt f = f -route [] (Ok v) f = v -route [] _ f = f -route (_ : _) (Ok v) f = f -route ('<' : s) (Br (r, _, _, _)) f = route s r f -route ('>' : s) (Br (_, r, _, _)) f = route s r f -route (x : s) (Br (_, _, w, h)) f = route s (Map.findWithDefault w x h) f -route ('<' : s) (Tl r) f = route s (tl (tl r)) f -route ('>' : s) (Tl r) f = route s r f -route (x : s) (Tl r) f = route s (tl r) f - -get w h x = Map.findWithDefault w x h - -combine f leftEmpty rightEmpty r1 r2 = g r1 r2 - where g (Tl r1) (Tl r2) = tl (g r1 r2) - g (Tl r1) r2 = g (expand r1) r2 - g r1 (Tl r2) = g r1 (expand r2) - g (Ok v) r2 = f (Ok v) r2 - g r1 (Ok v) = f r1 (Ok v) - g r1 r2 | null r1 = collapse $ leftEmpty r2 - g r1 r2 | null r2 = collapse $ rightEmpty r1 - g r1 r2 = collapse $ foldKeys g r1 r2 - -foldKeys g (Br (o1, c1, w1, h1)) (Br (o2, c2, w2, h2)) = - Br (g o1 o2, g c1 c2, w, Set.foldr f Map.empty keys) - where w = g w1 w2 - f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc - keys = Set.union (Map.keysSet h1) (Map.keysSet h2) - -expand r = Br (Mt, r, tl r, Map.empty) - -collapse (Br (Mt, k, Tl k', h)) | Map.null h && k == k' = tl k -collapse (Br (Mt, Mt, Tl k, h)) | Map.null h = tl k -collapse (Br (Mt, Mt, Mt, h)) | Map.null h = empty -collapse r = r - -update x k w h = if k == w then Map.delete x h else Map.insert x k h - ---------------------------------------------------------------------------- - -union = combine unionCombine id id -unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) -unionCombine r1 r2 | null r1 = r2 -unionCombine r1 r2 | null r2 = r1 - -unions rs = foldr union empty rs - -intersection = combine intersectionCombine (const empty) (const empty) -intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) -intersectionCombine r1 r2 | null r1 = empty -intersectionCombine r1 r2 | null r2 = empty - -difference = combine differenceCombine (const empty) id -differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in - if Set.null xs then empty else (Ok xs) -differenceCombine r1 r2 | null r1 = empty -differenceCombine r1 r2 | null r2 = r1 - ---------------------------------------------------------------------------- - -ok vs = Ok (Set.fromList vs) - -seq _ r | null r = r -seq '<' r = Br (r, Mt, Mt, Map.empty) -seq '>' r = Br (Mt, r, Mt, Map.empty) -seq '*' r = Br (tl r, untl r, r, Map.empty) -seq x r = Br (Mt, Mt, Mt, Map.singleton x r) - -seqs s r = foldr seq r s - -main = runTestTT $ - test [ - "seqs simple" ~: - Br (Br (Mt, ok [1], Mt, Map.empty), Mt, Mt, Map.empty) ~=? seqs "<>" (ok [1]), - "union simple1" ~: - Br (Mt, Mt, Mt, - Map.fromList [('a', ok [1]), - ('b', ok [2])]) ~=? - union (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "union simple2" ~: - Br (Mt, Mt, Mt, - Map.fromList [('a', ok [1,2]), - ('b', ok [2])]) ~=? - unions [seqs "a" (ok [1]), - seqs "b" (ok [2]), - seqs "a" (ok [2])], - "union idem" ~: - (seqs "abc" (ok [1])) ~=? - union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "union wild" ~: - Br (Br (Mt, - ok [1], - Tl (ok [1]), - Map.fromList [('a', Br (Mt, - ok [1,2], - Tl (ok [1]), - Map.empty))]), - Mt, - ok [1], - Map.empty) ~=? - union (seqs "*" (ok [1])) (seqs "" (ok [2])), - "route union wild1" ~: Set.fromList [1,2] ~=? - route "" (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild2" ~: Set.fromList [1] ~=? - route "" (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild3" ~: Set.fromList [1] ~=? - route "<>" (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "route union wild4" ~: Set.fromList [1] ~=? - route "" (union - (seqs "*" (ok [1])) - (seqs "" (ok [2]))) Set.empty, - "intersection simple1" ~: - seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), - "intersection simple2" ~: - empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "intersection idem" ~: - (seqs "abc" (ok [1])) ~=? - intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "difference simple1" ~: - seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), - "difference simple1a" ~: - seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), - "difference simple2" ~: - empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), - "difference wild" ~: - Br (Tl (ok [1]), - Mt, - ok [1], - Map.fromList [('a', Mt)]) ~=? - difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), - "union after difference" ~: - seqs "*" (ok [1]) ~=? - union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), - "union after difference 2" ~: - Br (Tl (ok [1]), - Mt, - ok [1], - Map.fromList [('a', ok [2])]) ~=? - union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])) - ]