@@ -0,0 +1,133 @@
1+{-# LANGUAGE QuantifiedConstraints #-}
2+module OpenAPI.Checker.TracePrefixTree
3+ ( TracePrefixTree
4+ , empty
5+ , singleton
6+ , fromList
7+ , null
8+ , foldWith
9+ , toList
10+ , filter
11+ ) where
12+
13+import qualified GHC.Exts as T
14+import Data.Foldable hiding (null, toList)
15+import Data.Kind
16+import qualified Data.Map as M
17+import Data.Monoid
18+import qualified Data.Set as S
19+import qualified Data.TypeRepMap as T
20+import OpenAPI.Checker.Trace
21+import Prelude hiding (null, filter)
22+import Type.Reflection
23+import Data.Type.Equality
24+
25+-- | A list of @AnItem r f@, but optimized into a prefix tree.
26+data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree
27+ { rootItems :: !(ASet (f r))
28+ , snocItems :: !(T.TypeRepMap (AStep f r))
29+ }
30+
31+deriving instance Eq (TracePrefixTree f a)
32+
33+-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
34+-- the components are ordered by the @SomeTypeRep@ of the @a@.
35+compareTRM
36+ :: (forall a. Typeable a => Ord (f a))
37+ => T.TypeRepMap f -> T.TypeRepMap f -> Ordering
38+compareTRM s1 s2
39+ = foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
40+ where
41+ (m1, m2) = (toMap s1, toMap s2)
42+ mKeys = S.toAscList $ M.keysSet m1 `S.union` M.keysSet m2
43+ compareMaybe _ Nothing Nothing = EQ
44+ compareMaybe _ Nothing (Just _) = LT
45+ compareMaybe _ (Just _) Nothing = GT
46+ compareMaybe cmp (Just x) (Just y) = cmp x y
47+ compareW
48+ :: (forall a. Typeable a => Ord (f a))
49+ => T.WrapTypeable f -> T.WrapTypeable f -> Ordering
50+ compareW (T.WrapTypeable (x :: f a)) (T.WrapTypeable (y :: f b))
51+ | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
52+ | otherwise = EQ -- unreachable
53+ toMap s = M.fromList
54+ [(someTypeRep x, w) | w@(T.WrapTypeable x) <- T.toList s]
55+
56+instance Ord (TracePrefixTree f a) where
57+ compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2)
58+ = compare r1 r2 <> compareTRM s1 s2
59+
60+data ASet (a :: Type) where
61+ AnEmptySet :: ASet a
62+ ASet :: Ord a => S.Set a -> ASet a
63+
64+instance Semigroup (ASet a) where
65+ AnEmptySet <> s = s
66+ s <> AnEmptySet = s
67+ ASet s1 <> ASet s2 = ASet $ S.union s1 s2
68+
69+deriving instance Eq (ASet a)
70+deriving instance Ord (ASet a)
71+
72+-- type traceprefixset = traceprefixtree proxy
73+
74+instance Monoid (ASet a) where
75+ mempty = AnEmptySet
76+
77+data AStep (f :: k -> Type) (r :: k) (a :: k) where
78+ AStep
79+ :: Steppable r a => !(M.Map (Step r a) (TracePrefixTree f a)) -> AStep f r a
80+
81+deriving instance Eq (AStep f r a)
82+deriving instance Ord (AStep f r a)
83+
84+singleton :: AnItem f r -> TracePrefixTree f r
85+singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) T.empty
86+ where
87+ go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r
88+ go Root !t = t
89+ go (Snoc xs x) !t = go xs $ TracePrefixTree AnEmptySet $ T.one
90+ $ AStep $ M.singleton x t
91+
92+instance Semigroup (TracePrefixTree f r) where
93+ TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =
94+ TracePrefixTree (r1 <> r2) (T.unionWith joinSteps s1 s2)
95+ where joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
96+
97+instance Monoid (TracePrefixTree f r) where
98+ mempty = TracePrefixTree mempty T.empty
99+
100+empty :: TracePrefixTree f r
101+empty = mempty
102+
103+fromList :: [AnItem f r] -> TracePrefixTree f r
104+fromList = foldMap singleton
105+
106+null :: TracePrefixTree f r -> Bool
107+null (TracePrefixTree AnEmptySet s) = T.size s == 0
108+null _ = False
109+
110+foldWith
111+ :: forall f m r. Monoid m
112+ => (forall a. Ord (f a) => Trace r a -> f a -> m) -> TracePrefixTree f r -> m
113+foldWith k = goTPT Root
114+ where
115+ goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m
116+ goTPT xs t = goASet xs (rootItems t) <> goTRM xs (snocItems t)
117+ goASet :: forall a. Trace r a -> ASet (f a) -> m
118+ goASet _ AnEmptySet = mempty
119+ goASet xs (ASet rs) = foldMap (k xs) rs
120+ goTRM :: forall a. Trace r a -> T.TypeRepMap (AStep f a) -> m
121+ goTRM xs s = foldMap (\(T.WrapTypeable f) -> goAStep xs f) $ T.toList s
122+ goAStep :: forall a b. Trace r a -> AStep f a b -> m
123+ goAStep xs (AStep m)
124+ = M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
125+
126+toList :: TracePrefixTree f r -> [AnItem f r]
127+toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f:)) t) []
128+
129+-- | Select a subtree by prefix
130+filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a
131+filter Root t = t
132+filter (Snoc xs x) t = foldMap (\(AStep m) -> fold $ M.lookup x m)
133+ $ T.lookup $ snocItems $ filter xs t