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]))
- ]