pred-trie 0.3.0 → 0.4.0
raw patch · 7 files changed
+225/−80 lines, 7 filesdep +deepseqdep +hashabledep +quickcheck-instancesdep −containersdep −pred-triedep ~basedep ~composition-extradep ~triessetup-changed
Dependencies added: deepseq, hashable, quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck, unordered-containers
Dependencies removed: containers, pred-trie
Dependency ranges changed: base, composition-extra, tries
Files
- Setup.hs +2/−0
- bench/Bench.hs +18/−4
- pred-trie.cabal +39/−28
- src/Data/Trie/Pred.hs +96/−35
- src/Data/Trie/Pred/Step.hs +27/−13
- test/Data/Trie/PredSpec.hs +30/−0
- test/Spec.hs +13/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
bench/Bench.hs view
@@ -9,8 +9,8 @@ import Data.Trie.Pred import Data.Trie.Pred.Step (PredStep (..), PredSteps (..)) import Data.Trie.Class-import Data.Trie.Map (MapStep (..))-import qualified Data.Map as Map+import Data.Trie.HashMap (HashMapStep (..))+import qualified Data.HashMap.Lazy as HM import Data.List.NonEmpty import qualified Data.List.NonEmpty as NE import qualified Data.Text as T@@ -21,9 +21,10 @@ doubleLit :: RootedPredTrie T.Text Double doubleLit = RootedPredTrie Nothing $ PredTrie- (MapStep $ unUnion $ foldMap (Union . genStep) [1..100])+ (HashMapStep $ unUnion $ foldMap (Union . genStep) [1..100]) (PredSteps [])- where genStep n = Map.singleton (T.pack $ show n) (Just n, Nothing)+ where+ genStep n = HM.singleton (T.pack $ show n) (Just n, Nothing) doubleAtto :: RootedPredTrie T.Text Double doubleAtto = RootedPredTrie Nothing $ PredTrie mempty $ PredSteps@@ -32,6 +33,12 @@ eitherToMaybe (Left _) = Nothing eitherToMaybe (Right a) = Just a +deepLit :: RootedPredTrie T.Text Double+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)))+ (PredSteps []) main = defaultMain [ bgroup "Lit vs. Pred"@@ -49,5 +56,12 @@ , bench "4" $ whnf (lookup ["61"]) doubleAtto , bench "4" $ whnf (lookup ["81"]) doubleAtto ]+ ]+ , bgroup "Lit Deep"+ [ bench "10" $ whnf (lookup ["10"]) deepLit+ , bench "9" $ whnf (lookup ["10","9"]) deepLit+ , bench "8" $ whnf (lookup ["10","9","8"]) deepLit+ , bench "7" $ whnf (lookup ["10","9","8","7"]) deepLit+ , bench "6" $ whnf (lookup ["10","9","8","7","6"]) deepLit ] ]
pred-trie.cabal view
@@ -1,5 +1,5 @@ Name: pred-trie-Version: 0.3.0+Version: 0.4.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -16,50 +16,61 @@ GHC-Options: -Wall Exposed-Modules: Data.Trie.Pred Data.Trie.Pred.Step- Build-Depends: base >= 4.6 && < 5- , semigroups- , mtl- , containers+ Build-Depends: base >= 4.8 && < 5 , composition-extra >= 2.0.0- , tries >= 0.0.2+ , hashable+ , mtl+ , semigroups+ , tries >= 0.0.3+ , unordered-containers , QuickCheck --- Test-Suite spec--- Type: exitcode-stdio-1.0--- Default-Language: Haskell2010--- Hs-Source-Dirs: src--- , test--- Ghc-Options: -Wall -threaded--- Main-Is: Spec.hs--- Other-Modules: Data.Trie.PredSpec--- Build-Depends: base--- , tasty--- , tasty-quickcheck--- , tasty-hunit--- , QuickCheck--- , quickcheck-instances--- , semigroups--- , mtl--- , composition-extra+Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -Wall -threaded+ Main-Is: Spec.hs+ Other-Modules: Data.Trie.PredSpec+ Data.Trie.Pred+ Data.Trie.Pred.Step+ Build-Depends: base+ , composition-extra+ , deepseq+ , hashable+ , mtl+ , semigroups+ , tries+ , unordered-containers+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , QuickCheck+ , quickcheck-instances Benchmark bench Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Main-Is: Bench.hs+ Other-Modules: Data.Trie.Pred+ Data.Trie.Pred.Step HS-Source-Dirs: bench , src Ghc-Options: -Wall -threaded Build-Depends: base- , pred-trie- , tries- , containers- , criterion+ , composition-extra+ , deepseq+ , hashable+ , mtl , semigroups+ , tries+ , unordered-containers , attoparsec , text- , composition-extra , QuickCheck , sets+ , criterion Source-Repository head Type: git
src/Data/Trie/Pred.hs view
@@ -4,44 +4,93 @@ , FlexibleInstances , MultiParamTypeClasses , DeriveFunctor+ , DeriveGeneric+ , DeriveDataTypeable+ , TupleSections #-} +{- |+Module : Data.Trie.Pred+Copyright : (c) 2015 Athan Clark++License : BSD-3+Maintainer : athan.clark@gmail.com+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.++As a botched example, you could imagine a "step" of the trie structure as something+like this:++> PredTrie s a+> = PNil+> | forall t. PCons+> { predicate :: s -> Maybe t+> , result :: t -> a+> }++This isn't how it's actually represented, of course - this doesn't acocunt for+/literal/ matches (i.e. enumerated results).+-}+ module Data.Trie.Pred where import Prelude hiding (lookup) import Data.Trie.Pred.Step import Data.Trie.Class-import qualified Data.Trie.Map as MT-import qualified Data.Map as Map+import qualified Data.Trie.HashMap as HT+import qualified Data.HashMap.Lazy as HM import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import Data.Typeable import Data.Functor.Syntax import Data.Monoid import Data.Maybe (fromMaybe)+import Data.Hashable+import Test.QuickCheck -- * Predicated Trie data PredTrie s a = PredTrie- { predLits :: MT.MapStep PredTrie s a- , predPreds :: PredSteps PredTrie s a- } deriving (Functor)+ { predLits :: HT.HashMapStep PredTrie s a -- ^ a /literal/ step+ , predPreds :: PredSteps PredTrie s a -- ^ a /predicative/ step+ } deriving (Functor, Typeable) -instance Ord s => Trie NonEmpty s PredTrie where+-- | Dummy instance for quickcheck+instance Show (PredTrie s a) where+ show _ = "PredTrie {..}"++instance ( Arbitrary s+ , Arbitrary a+ , Eq s+ , Hashable s+ ) => Arbitrary (PredTrie s a) where+ arbitrary = (flip PredTrie $ PredSteps []) <$> arbitrary++instance ( Hashable s+ , Eq s+ ) => Trie NonEmpty s PredTrie where lookup ts (PredTrie ls 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 (insert ts x ls) ps -- can only insert literals+ insert ts x (PredTrie ls ps) = PredTrie (HT.insert ts x ls) ps -- can only insert literals -instance Ord s => Monoid (PredTrie s a) where+instance ( Hashable s+ , Eq s+ ) => Monoid (PredTrie s a) where mempty = PredTrie mempty mempty mappend (PredTrie ls1 ps1) (PredTrie ls2 ps2) = PredTrie (ls1 <> ls2) (ps1 <> ps2) emptyPT :: PredTrie s a-emptyPT = PredTrie MT.empty (PredSteps [])+emptyPT = PredTrie HT.empty (PredSteps []) @@ -51,12 +100,14 @@ -- | Find the nearest parent node of the requested query, while returning -- the split of the string that was matched, and what wasn't.-matchPT :: Ord s => NonEmpty s -> PredTrie s a -> Maybe (NonEmpty s, a, [s])+matchPT :: ( Hashable s+ , Eq s+ ) => NonEmpty s -> PredTrie s a -> Maybe (NonEmpty s, a, [s]) matchPT (t:|ts) (PredTrie ls (PredSteps ps)) = getFirst $ First (goLit ls) <> foldMap (First . goPred) ps where- goLit (MT.MapStep xs) = do- (mx,mxs) <- Map.lookup t xs+ goLit (HT.HashMapStep xs) = do+ (mx,mxs) <- HM.lookup t xs let mFoundHere = do x <- mx return (t:|[], x, []) if null ts then mFoundHere@@ -74,12 +125,14 @@ <> First mFoundHere -matchesPT :: Ord s => NonEmpty s -> PredTrie s a -> [(NonEmpty s, a, [s])]+matchesPT :: ( Hashable s+ , Eq s+ ) => NonEmpty s -> PredTrie s a -> [(NonEmpty s, a, [s])] matchesPT (t:|ts) (PredTrie ls (PredSteps ps)) = fromMaybe [] $ getFirst $ First (goLit ls) <> foldMap (First . goPred) ps where- goLit (MT.MapStep xs) = do- (mx,mxs) <- Map.lookup t xs+ goLit (HT.HashMapStep xs) = do+ (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)@@ -101,21 +154,27 @@ -- * Rooted Predicated Trie data RootedPredTrie s a = RootedPredTrie- { rootedBase :: Maybe a- , rootedSub :: PredTrie s a- } deriving (Functor)+ { rootedBase :: Maybe a -- ^ The "root" node - the path at @[]@+ , rootedSub :: PredTrie s a -- ^ The actual predicative trie+ } deriving (Functor, Typeable) -instance Ord s => Trie [] s RootedPredTrie where++instance ( Hashable s+ , Eq s+ ) => Trie [] s RootedPredTrie where lookup [] (RootedPredTrie mx _) = mx lookup ts (RootedPredTrie _ xs) = lookup (NE.fromList ts) xs - delete [] (RootedPredTrie _ xs) = RootedPredTrie Nothing xs+ delete [] (RootedPredTrie _ xs) = RootedPredTrie Nothing xs delete ts (RootedPredTrie mx xs) = RootedPredTrie mx $ delete (NE.fromList ts) xs - insert [] x (RootedPredTrie _ xs) = RootedPredTrie (Just x) xs+ insert [] x (RootedPredTrie _ xs) = RootedPredTrie (Just x) xs insert ts x (RootedPredTrie mx xs) = RootedPredTrie mx $ insert (NE.fromList ts) x xs -instance Ord s => Monoid (RootedPredTrie s a) where++instance ( Hashable s+ , Eq s+ ) => Monoid (RootedPredTrie s a) where mempty = emptyRPT mappend (RootedPredTrie mx xs) (RootedPredTrie my ys) = RootedPredTrie (getLast $ Last mx <> Last my) $ xs <> ys@@ -124,20 +183,22 @@ emptyRPT :: RootedPredTrie s a emptyRPT = RootedPredTrie Nothing emptyPT -matchRPT :: Ord s => [s] -> RootedPredTrie s a -> Maybe ([s], a, [s])-matchRPT [] (RootedPredTrie mx _) = do x <- mx- return ([],x,[])+matchRPT :: ( Hashable s+ , Eq s+ ) => [s] -> RootedPredTrie s a -> Maybe ([s], a, [s])+matchRPT [] (RootedPredTrie mx _) = ([],,[]) <$> mx matchRPT ts (RootedPredTrie mx xs) = getFirst $- First mFoundThere <> First (do x <- mx- return ([],x,[]))- where mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs- return (NE.toList pre,x,suff)+ First mFoundThere <> First (([],,[]) <$> mx)+ where+ mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs+ pure (NE.toList pre,x,suff) -matchesRPT :: Ord s => [s] -> RootedPredTrie s a -> [([s], a, [s])]-matchesRPT [] (RootedPredTrie mx _) = fromMaybe [] $ do x <- mx- return [([],x,[])]+matchesRPT :: ( Hashable s+ , Eq s+ ) => [s] -> RootedPredTrie s a -> [([s], a, [s])]+matchesRPT [] (RootedPredTrie mx _) = fromMaybe [] $ (\x -> [([],x,[])]) <$> mx matchesRPT ts (RootedPredTrie mx xs) = foundHere ++ fmap allowRoot (matchesPT (NE.fromList ts) xs)- where foundHere = fromMaybe [] $ do x <- mx- return [([],x,[])]- allowRoot (pre,x,suff) = (NE.toList pre,x,suff)+ where+ foundHere = fromMaybe [] $ (\x -> [([],x,[])]) <$> mx+ allowRoot (pre,x,suff) = (NE.toList pre,x,suff)
src/Data/Trie/Pred/Step.hs view
@@ -4,30 +4,43 @@ , FlexibleInstances , MultiParamTypeClasses , DeriveFunctor+ , DeriveGeneric+ , DeriveDataTypeable+ , BangPatterns #-} +{- |+Module : Data.Trie.Pred+Copyright : (c) 2015 Athan Clark++License : BSD-3+Maintainer : athan.clark@gmail.com+Stability : experimental+Portability : GHC+-}+ module Data.Trie.Pred.Step where import Prelude hiding (lookup) import Data.Trie.Class-import qualified Data.Trie.Map as MT-import qualified Data.Map as Map import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import Data.Typeable import Data.Functor.Syntax import Data.Monoid-import Data.Maybe (fromMaybe) -- * 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- , predData :: Maybe (r -> a)- , predSub :: c s (r -> a)- }+ { 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.+ } deriving (Typeable) instance Functor (c s) => Functor (PredStep c s) where fmap f (PredStep i p mx xs) = PredStep i p (f <.$> mx) $ f <.$> xs@@ -51,9 +64,10 @@ -- * Adjacent Predicated Steps +-- | Adjacent steps newtype PredSteps c s a = PredSteps- { unPredSteps :: [PredStep c s a] }- deriving (Functor)+ { unPredSteps :: [PredStep c s a]+ } deriving (Functor, Typeable) -- | Lookup and delete only - can't arbitrarilly construct a predicated trie. instance Trie NonEmpty s c => Trie NonEmpty s (PredSteps c) where@@ -61,13 +75,13 @@ delete ts (PredSteps ps) = PredSteps $ fmap (delete ts) ps instance Eq s => Monoid (PredSteps c s a) where- mempty = PredSteps []+ mempty = PredSteps [] mappend = unionPred -- | @Last@-style instance unionPred :: Eq s => PredSteps c s a -> PredSteps c s a -> PredSteps c s a-unionPred (PredSteps (xss@(PredStep i p mx xs):pxs)) (PredSteps (yss@(PredStep j q my ys):pys))- | i == j = PredSteps $ yss : unPredSteps (unionPred (PredSteps pxs) (PredSteps pys))+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)) unionPred x (PredSteps []) = x unionPred (PredSteps []) y = y
+ test/Data/Trie/PredSpec.hs view
@@ -0,0 +1,30 @@+module Data.Trie.PredSpec where++import Data.Trie.Pred+import Data.Trie.Class+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Prelude hiding (lookup)+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck as QC+++instance Arbitrary a => Arbitrary (NonEmpty a) where+ arbitrary = (:|) <$> arbitrary <*> arbitrary++predSpec :: TestTree+predSpec = testGroup "Data.Trie.Pred"+ [ testGroup "literals"+ [ QC.testProperty "lookup after insert should exist" lookupInsertExists+ , QC.testProperty "lookup after delete should not exist" lookupDeleteNotExists+ ]+ ]+++lookupInsertExists :: NonEmpty Int -> Int -> PredTrie Int Int -> Bool+lookupInsertExists ks v xs = Just v == lookup ks (insert ks v xs)++lookupDeleteNotExists :: NonEmpty Int -> PredTrie Int Int -> Bool+lookupDeleteNotExists ks xs = Nothing == lookup ks (delete ks xs)
+ test/Spec.hs view
@@ -0,0 +1,13 @@+module Main where++import Data.Trie.PredSpec++import Test.Tasty+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Testing..."+ [predSpec]