pred-trie 0.4.0 → 0.4.1
raw patch · 5 files changed
+149/−96 lines, 5 filesdep +errorsdep ~tries
Dependencies added: errors
Dependency ranges changed: tries
Files
- bench/Bench.hs +5/−3
- pred-trie.cabal +6/−2
- src/Data/Trie/Pred.hs +98/−76
- src/Data/Trie/Pred/Step.hs +19/−15
- test/Data/Trie/PredSpec.hs +21/−0
bench/Bench.hs view
@@ -9,7 +9,7 @@ import Data.Trie.Pred import Data.Trie.Pred.Step (PredStep (..), PredSteps (..)) import Data.Trie.Class-import Data.Trie.HashMap (HashMapStep (..))+import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..)) import qualified Data.HashMap.Lazy as HM import Data.List.NonEmpty import qualified Data.List.NonEmpty as NE@@ -24,7 +24,8 @@ (HashMapStep $ unUnion $ foldMap (Union . genStep) [1..100]) (PredSteps []) where- genStep n = HM.singleton (T.pack $ show n) (Just n, Nothing)+ genStep n = HM.singleton (T.pack $ show n) $+ HashMapChildren (Just n) Nothing doubleAtto :: RootedPredTrie T.Text Double doubleAtto = RootedPredTrie Nothing $ PredTrie mempty $ PredSteps@@ -37,7 +38,8 @@ deepLit = RootedPredTrie Nothing $ go 10 where go n | n == 0 = PredTrie (HashMapStep HM.empty) (PredSteps [])- | otherwise = PredTrie (HashMapStep $ HM.singleton (T.pack $ show n) (Just n, Just $ go (n-1)))+ | otherwise = PredTrie (HashMapStep $ HM.singleton (T.pack $ show n) $+ HashMapChildren (Just n) (Just . go $ n-1)) (PredSteps []) main = defaultMain
pred-trie.cabal view
@@ -1,5 +1,5 @@ Name: pred-trie-Version: 0.4.0+Version: 0.4.1 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -21,7 +21,8 @@ , hashable , mtl , semigroups- , tries >= 0.0.3+ , text+ , tries >= 0.0.4 , unordered-containers , QuickCheck @@ -36,11 +37,14 @@ Data.Trie.Pred Data.Trie.Pred.Step Build-Depends: base+ , attoparsec , composition-extra , deepseq+ , errors , hashable , mtl , semigroups+ , text , tries , unordered-containers , tasty
src/Data/Trie/Pred.hs view
@@ -7,6 +7,7 @@ , DeriveGeneric , DeriveDataTypeable , TupleSections+ , BangPatterns #-} {- |@@ -18,23 +19,46 @@ Stability : experimental Portability : GHC -A "predicative" trie is a lookup table where you can embed arbitrary predicates-as a method to satisfy a node as "found" - this is done with existential quantification.-To embed our predicates, we need to build the trie's data constructors manually,-to unify the existential data with the the result function.+A "predicative" trie is a lookup table where you can use /predicates/+as a method to match a query path, where success is also enriched with /any/+auxiliary data. This library allows you to match a path-chunk (if you consider+a query to the different levels of the tree as a /list/) with a Boolean predicate,+augmented with existentially quantified data. This lets us use parsers, regular+expressions, and other functions that can be turned into the form of: -As a botched example, you could imagine a "step" of the trie structure as something-like this:+> forall a. p -> Maybe a -> PredTrie s a-> = PNil-> | forall t. PCons-> { predicate :: s -> Maybe t-> , result :: t -> a+However, because the communicated data is existentially quantified, we __cannot__+revisit a definition - we cannot @update@ a predicative node, or change any of+its children. The current version of this library forces you to use 'PredTrie'+and 'RootedPredTrie' directly (i.e. the data constructors) to build your trie+manually.++This isn't the actual code, but it's a general idea for how you could build a+trie. We build a "tagged" <https://en.wikipedia.org/wiki/Rose_tree rose-tree>,+where each node has either a literal name (and is a singleton of the @k@ type in our+lookup path) or a predicate to consider the current node or its children as the target.+You could imagine a "step" of the trie structure as something like this:++> data PredTrie k a+> = Nil+> | Lit+> { litTag :: k+> , litResult :: Maybe a+> , litChildren :: Maybe (PredTrie k a) > }+> | forall t. Pred+> { predMatch :: k -> Maybe t+> , predResult :: Maybe (t -> a)+> , predChildren :: Maybe (PredTrie k a)+> } -This isn't how it's actually represented, of course - this doesn't acocunt for-/literal/ matches (i.e. enumerated results).+Notice how in the @Pred@ constructor, we first /create/ the @t@ data in @predMatch@,+then /consume/ it in @predResult@. We make a tree out of steps by recursing over the+steps.++This isn't how it's actually represented, unfortunately. There will be a+monadic interface in the next version. -} module Data.Trie.Pred where@@ -58,59 +82,54 @@ -- * Predicated Trie -data PredTrie s a = PredTrie- { predLits :: HT.HashMapStep PredTrie s a -- ^ a /literal/ step- , predPreds :: PredSteps PredTrie s a -- ^ a /predicative/ step- } deriving (Functor, Typeable)---- | Dummy instance for quickcheck-instance Show (PredTrie s a) where- show _ = "PredTrie {..}"+data PredTrie k a = PredTrie+ { predLits :: !(HT.HashMapStep PredTrie k a) -- ^ a /literal/ step+ , predPreds :: !(PredSteps PredTrie k a) -- ^ a /predicative/ step+ } deriving (Show, Functor, Typeable) -instance ( Arbitrary s+instance ( Arbitrary k , Arbitrary a- , Eq s- , Hashable s- ) => Arbitrary (PredTrie s a) where+ , Eq k+ , Hashable k+ ) => Arbitrary (PredTrie k a) where arbitrary = (flip PredTrie $ PredSteps []) <$> arbitrary -instance ( Hashable s- , Eq s- ) => Trie NonEmpty s PredTrie where+instance ( Hashable k+ , Eq k+ ) => Trie NonEmpty k PredTrie where lookup ts (PredTrie ls ps) =- getFirst $ First (lookup ts ls) <> First (lookup ts ps)+ getFirst $ (First $! lookup ts ls) <> First (lookup ts ps) delete ts (PredTrie ls ps) = PredTrie (delete ts ls) (delete ts ps) insert ts x (PredTrie ls ps) = PredTrie (HT.insert ts x ls) ps -- can only insert literals -instance ( Hashable s- , Eq s- ) => Monoid (PredTrie s a) where+instance ( Hashable k+ , Eq k+ ) => Monoid (PredTrie k a) where mempty = PredTrie mempty mempty mappend (PredTrie ls1 ps1) (PredTrie ls2 ps2) =- PredTrie (ls1 <> ls2) (ps1 <> ps2)+ (PredTrie $! ls1 <> ls2) $! ps1 <> ps2 -emptyPT :: PredTrie s a+emptyPT :: PredTrie k a emptyPT = PredTrie HT.empty (PredSteps []) - -- subtrie :: Ord s => NonEmpty s -> PredTrie s a -> PredTrie s a -- subtrie (t:|ts) (PredTrie (MapTrie (MapStep ls)) ps) -- | null ts = getFirst $ First (lookup ts ls) -- | Find the nearest parent node of the requested query, while returning -- the split of the string that was matched, and what wasn't.-matchPT :: ( Hashable s- , Eq s- ) => NonEmpty s -> PredTrie s a -> Maybe (NonEmpty s, a, [s])+matchPT :: ( Hashable k+ , Eq k+ ) => NonEmpty k -> PredTrie k a -> Maybe (NonEmpty k, a, [k]) matchPT (t:|ts) (PredTrie ls (PredSteps ps)) = getFirst $ First (goLit ls) <> foldMap (First . goPred) ps where goLit (HT.HashMapStep xs) = do- (mx,mxs) <- HM.lookup t xs- let mFoundHere = do x <- mx- return (t:|[], x, [])- if null ts then mFoundHere+ (HT.HashMapChildren mx mxs) <- HM.lookup t xs+ let mFoundHere = (t:|[],, []) <$> mx+ if null ts+ then mFoundHere else getFirst $ First (do (pre,y,suff) <- matchPT (NE.fromList ts) =<< mxs return (t:|NE.toList pre, y, suff)) <> First mFoundHere@@ -119,73 +138,76 @@ r <- p t let mFoundHere = do x <- mx <$~> r return (t:|[], x, [])- if null ts then mFoundHere+ if null ts+ then mFoundHere else getFirst $ First (do (pre,y,suff) <- matchPT (NE.fromList ts) xs return (t:|NE.toList pre, y r, suff)) <> First mFoundHere -matchesPT :: ( Hashable s- , Eq s- ) => NonEmpty s -> PredTrie s a -> [(NonEmpty s, a, [s])]+matchesPT :: ( Hashable k+ , Eq k+ ) => NonEmpty k -> PredTrie k a -> [(NonEmpty k, a, [k])] matchesPT (t:|ts) (PredTrie ls (PredSteps ps)) = fromMaybe [] $ getFirst $ First (goLit ls) <> foldMap (First . goPred) ps where goLit (HT.HashMapStep xs) = do- (mx,mxs) <- HM.lookup t xs+ (HT.HashMapChildren mx mxs) <- HM.lookup t xs let mFoundHere = do x <- mx return [(t:|[],x,ts)] prependAncestry (pre,x,suff) = (t:| NE.toList pre,x,suff)- if null ts then mFoundHere+ if null ts+ then mFoundHere else do foundHere <- mFoundHere- let rs = fromMaybe [] $ matchesPT (NE.fromList ts) <$> mxs- return $ foundHere ++ (prependAncestry <$> rs)+ let rs = fromMaybe [] $! matchesPT (NE.fromList ts) <$> mxs+ return $! foundHere ++ (prependAncestry <$> rs) goPred (PredStep _ p mx xs) = do r <- p t let mFoundHere = do x <- mx <$~> r return [(t:|[],x,ts)] prependAncestryAndApply (pre,x,suff) = (t:| NE.toList pre,x r,suff)- if null ts then mFoundHere+ if null ts+ then mFoundHere else do foundHere <- mFoundHere let rs = matchesPT (NE.fromList ts) xs- return $ foundHere ++ (prependAncestryAndApply <$> rs)+ return $! foundHere ++ (prependAncestryAndApply <$> rs) --- * Rooted Predicated Trie+-- * Rooted Predicative Trie -data RootedPredTrie s a = RootedPredTrie- { rootedBase :: Maybe a -- ^ The "root" node - the path at @[]@- , rootedSub :: PredTrie s a -- ^ The actual predicative trie- } deriving (Functor, Typeable)+data RootedPredTrie k a = RootedPredTrie+ { rootedBase :: !(Maybe a) -- ^ The "root" node - the path at @[]@+ , rootedSub :: !(PredTrie k a) -- ^ The actual predicative trie+ } deriving (Show, Functor, Typeable) -instance ( Hashable s- , Eq s- ) => Trie [] s RootedPredTrie where+instance ( Hashable k+ , Eq k+ ) => Trie [] k RootedPredTrie where lookup [] (RootedPredTrie mx _) = mx lookup ts (RootedPredTrie _ xs) = lookup (NE.fromList ts) xs delete [] (RootedPredTrie _ xs) = RootedPredTrie Nothing xs- delete ts (RootedPredTrie mx xs) = RootedPredTrie mx $ delete (NE.fromList ts) xs+ delete ts (RootedPredTrie mx xs) = RootedPredTrie mx $! delete (NE.fromList ts) xs insert [] x (RootedPredTrie _ xs) = RootedPredTrie (Just x) xs- insert ts x (RootedPredTrie mx xs) = RootedPredTrie mx $ insert (NE.fromList ts) x xs+ insert ts x (RootedPredTrie mx xs) = RootedPredTrie mx $! insert (NE.fromList ts) x xs -instance ( Hashable s- , Eq s- ) => Monoid (RootedPredTrie s a) where+instance ( Hashable k+ , Eq k+ ) => Monoid (RootedPredTrie k a) where mempty = emptyRPT mappend (RootedPredTrie mx xs) (RootedPredTrie my ys) = RootedPredTrie- (getLast $ Last mx <> Last my) $ xs <> ys+ (getLast $! Last mx <> Last my) $! xs <> ys -emptyRPT :: RootedPredTrie s a+emptyRPT :: RootedPredTrie k a emptyRPT = RootedPredTrie Nothing emptyPT -matchRPT :: ( Hashable s- , Eq s- ) => [s] -> RootedPredTrie s a -> Maybe ([s], a, [s])+matchRPT :: ( Hashable k+ , Eq k+ ) => [k] -> RootedPredTrie k a -> Maybe ([k], a, [k]) matchRPT [] (RootedPredTrie mx _) = ([],,[]) <$> mx matchRPT ts (RootedPredTrie mx xs) = getFirst $ First mFoundThere <> First (([],,[]) <$> mx)@@ -193,12 +215,12 @@ mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs pure (NE.toList pre,x,suff) -matchesRPT :: ( Hashable s- , Eq s- ) => [s] -> RootedPredTrie s a -> [([s], a, [s])]-matchesRPT [] (RootedPredTrie mx _) = fromMaybe [] $ (\x -> [([],x,[])]) <$> mx+matchesRPT :: ( Hashable k+ , Eq k+ ) => [k] -> RootedPredTrie k a -> [([k], a, [k])]+matchesRPT [] (RootedPredTrie mx _) = fromMaybe [] $ (\x -> [([],x,[])]) <$> mx matchesRPT ts (RootedPredTrie mx xs) =- foundHere ++ fmap allowRoot (matchesPT (NE.fromList ts) xs)+ (foundHere ++) $! fmap allowRoot (matchesPT (NE.fromList ts) xs) where- foundHere = fromMaybe [] $ (\x -> [([],x,[])]) <$> mx+ foundHere = fromMaybe [] $! (\x -> [([],x,[])]) <$> mx allowRoot (pre,x,suff) = (NE.toList pre,x,suff)
src/Data/Trie/Pred/Step.hs view
@@ -25,6 +25,7 @@ import Data.Trie.Class import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T import Data.Typeable import Data.Functor.Syntax@@ -34,16 +35,19 @@ -- * Single Predicated Step data PredStep c s a = forall r. PredStep- { predTag :: !s -- ^ Unique identifier for the predicate - used for combination- , predPred :: s -> Maybe r -- ^ The predicate, existentially quantified in the successful result @r@- , predData :: Maybe (r -> a) -- ^ The result function, capturing the quantified result @r@ and turning- -- it into a top-level variable @a@.- , predSub :: c s (r -> a) -- ^ Any sub-trie must have __all__ results preceeded in arity with- -- the result at this step.+ { predTag :: {-# UNPACK #-} !T.Text -- ^ Unique identifier for the predicate - used for combination+ , predPred :: !(s -> Maybe r) -- ^ The predicate, existentially quantified in the successful result @r@+ , predData :: !(Maybe (r -> a)) -- ^ The result function, capturing the quantified result @r@ and turning+ -- it into a top-level variable @a@.+ , predSub :: !(c s (r -> a)) -- ^ Any sub-trie must have __all__ results preceeded in arity with+ -- the result at this step. } deriving (Typeable) +instance Show s => Show (PredStep c s a) where+ show (PredStep t _ _ _) = "PredStep {predTag=" ++ show t ++ ", ...}"+ instance Functor (c s) => Functor (PredStep c s) where- fmap f (PredStep i p mx xs) = PredStep i p (f <.$> mx) $ f <.$> xs+ fmap f (PredStep i p mx xs) = (PredStep i p $! f <.$> mx) $! f <.$> xs -- | Lookup and delete only - can't arbitrarilly construct a predicated trie. instance Trie NonEmpty s c => Trie NonEmpty s (PredStep c) where@@ -55,10 +59,10 @@ maybe xss (const $ if null ts then PredStep i p Nothing xs- else PredStep i p mx $ delete (NE.fromList ts) xs)+ else PredStep i p mx $! delete (NE.fromList ts) xs) (p t) -singletonPred :: Monoid (c s (r -> a)) => s -> (s -> Maybe r) -> (r -> a) -> PredStep c s a+singletonPred :: Monoid (c s (r -> a)) => T.Text -> (s -> Maybe r) -> (r -> a) -> PredStep c s a singletonPred i p x = PredStep i p (Just x) mempty @@ -67,21 +71,21 @@ -- | Adjacent steps newtype PredSteps c s a = PredSteps { unPredSteps :: [PredStep c s a]- } deriving (Functor, Typeable)+ } deriving (Show, Functor, Typeable) -- | Lookup and delete only - can't arbitrarilly construct a predicated trie. instance Trie NonEmpty s c => Trie NonEmpty s (PredSteps c) where- lookup ts (PredSteps ps) = getFirst $ foldMap (First . lookup ts) ps- delete ts (PredSteps ps) = PredSteps $ fmap (delete ts) ps+ lookup ts (PredSteps ps) = getFirst $! foldMap (First . lookup ts) ps+ delete ts (PredSteps ps) = PredSteps $! fmap (delete ts) ps instance Eq s => Monoid (PredSteps c s a) where mempty = PredSteps [] mappend = unionPred -- | @Last@-style instance-unionPred :: Eq s => PredSteps c s a -> PredSteps c s a -> PredSteps c s a+unionPred :: PredSteps c s a -> PredSteps c s a -> PredSteps c s a unionPred (PredSteps (xss@(PredStep i _ _ _):pxs)) (PredSteps (yss@(PredStep j _ _ _):pys))- | i == j = PredSteps $ yss : unPredSteps (unionPred (PredSteps pxs) (PredSteps pys))- | otherwise = PredSteps $ xss : yss : unPredSteps (unionPred (PredSteps pxs) (PredSteps pys))+ | i == j = PredSteps $ yss : (unPredSteps $! unionPred (PredSteps pxs) (PredSteps pys))+ | otherwise = PredSteps $ xss : yss : (unPredSteps $! unionPred (PredSteps pxs) (PredSteps pys)) unionPred x (PredSteps []) = x unionPred (PredSteps []) y = y
test/Data/Trie/PredSpec.hs view
@@ -1,10 +1,20 @@+{-# LANGUAGE+ OverloadedStrings+ #-}+ module Data.Trie.PredSpec where import Data.Trie.Pred+import Data.Trie.Pred.Step import Data.Trie.Class+import Data.Trie.HashMap (HashMapStep (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import qualified Data.HashMap.Lazy as HM+import Data.Attoparsec.Text (parseOnly, double)+import qualified Data.Text as T+import Control.Error (hush) import Prelude hiding (lookup) import Test.QuickCheck import Test.Tasty@@ -20,6 +30,9 @@ [ QC.testProperty "lookup after insert should exist" lookupInsertExists , QC.testProperty "lookup after delete should not exist" lookupDeleteNotExists ]+ , testGroup "predicates"+ [ QC.testProperty "any double is parsed by a double" lookupDouble+ ] ] @@ -28,3 +41,11 @@ lookupDeleteNotExists :: NonEmpty Int -> PredTrie Int Int -> Bool lookupDeleteNotExists ks xs = Nothing == lookup ks (delete ks xs)++lookupDouble :: Double -> Bool+lookupDouble d = Just 0 == lookup ((T.pack $ show d) :| []) doubleTable+++doubleTable :: PredTrie T.Text Int+doubleTable = PredTrie (HashMapStep HM.empty) $+ PredSteps [PredStep "double" (hush . parseOnly double) (Just $ \d -> 0) emptyPT]