diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 diff --git a/pred-trie.cabal b/pred-trie.cabal --- a/pred-trie.cabal +++ b/pred-trie.cabal @@ -1,5 +1,5 @@ Name: pred-trie -Version: 0.4.0 +Version: 0.4.1 Author: Athan Clark Maintainer: Athan Clark 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 diff --git a/src/Data/Trie/Pred.hs b/src/Data/Trie/Pred.hs --- a/src/Data/Trie/Pred.hs +++ b/src/Data/Trie/Pred.hs @@ -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" , +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) diff --git a/src/Data/Trie/Pred/Step.hs b/src/Data/Trie/Pred/Step.hs --- a/src/Data/Trie/Pred/Step.hs +++ b/src/Data/Trie/Pred/Step.hs @@ -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 diff --git a/test/Data/Trie/PredSpec.hs b/test/Data/Trie/PredSpec.hs --- a/test/Data/Trie/PredSpec.hs +++ b/test/Data/Trie/PredSpec.hs @@ -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]