pred-trie 0.0.1 → 0.0.2

raw patch · 7 files changed

+287/−105 lines, 7 filesdep +criteriondep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• bench/SimpleVShort.hs +64/−0
• pred-trie.cabal +13/−3
• src/Data/Trie/Pred.hs +0/−99
• src/Data/Trie/Pred/Internal.hs +0/−3
• src/Data/Trie/Pred/Unified.hs +21/−0
• src/Data/Trie/Pred/Unified/Fast.hs +115/−0
• src/Data/Trie/Pred/Unified/Norm.hs +74/−0

@@ -0,0 +1,64 @@+module Main where+++import           Data.Trie.Pred.FastUnified+import qualified Data.Trie.Pred.FastUnified as FU+import           Data.Trie.Pred.NormUnified+import qualified Data.Trie.Pred.NormUnified as NU+import Criterion.Main+import           Data.List.NonEmpty+import qualified Data.List.NonEmpty as NE+++tdFU = FUMore "foo" Nothing $ NE.fromList+         [ FURest ("bar":|["baz","qux"]) 1+         , FUMore "tro" (Just 2) $ NE.fromList+             [ FUMore "zja" (Just 3) $ NE.fromList+                 [ FURest ("hda":|["jes","kuq"]) 4 ]+             , FURest ("end":|["orp","vag"]) 5+             ]+         , FURest ("dic":|["but","gea"]) 6+         ]++tdNU = NUMore "foo" Nothing+         [ NUMore "bar" Nothing+             [ NUMore "baz" Nothing+                 [ NUMore "qux" (Just 1) []+                 ]+             ]+         , NUMore "tro" (Just 2)+             [ NUMore "zja" (Just 3)+                 [ NUMore "hda" Nothing+                     [ NUMore "jes" Nothing+                         [ NUMore "kuq" (Just 4) []+                         ]+                     ]+                 ]+             , NUMore "end" Nothing+                 [ NUMore "orp" Nothing+                     [ NUMore "vag" (Just 5) []+                     ]+                 ]+             ]+         , NUMore "dic" Nothing+             [ NUMore "but" Nothing+                 [ NUMore "gea" (Just 6) []+                 ]+             ]+         ]++++main = defaultMain+  [ bgroup "Fast" [ bench "foobarbaz"       $ whnf (FU.lookup $ "foo":|["bar","baz"]) tdFU+                  , bench "footrozjahdajes" $ whnf (FU.lookup $ "foo":|["tro","zja","hda","jes"]) tdFU+                  , bench "footroendorpvag" $ whnf (FU.lookup $ "foo":|["tro","end","orp","vag"]) tdFU+                  , bench "foodicbutgea"    $ whnf (FU.lookup $ "foo":|["dic","but","gea"]) tdFU+                  ]++  , bgroup "Norm" [ bench "foobarbaz"       $ whnf (NU.lookup $ "foo":|["bar","baz"]) tdNU+                  , bench "footrozjahdajes" $ whnf (NU.lookup $ "foo":|["tro","zja","hda","jes"]) tdNU+                  , bench "footroendorpvag" $ whnf (NU.lookup $ "foo":|["tro","end","orp","vag"]) tdNU+                  , bench "foodicbutgea"    $ whnf (NU.lookup $ "foo":|["dic","but","gea"]) tdNU+                  ]+  ]

@@ -1,5 +1,5 @@ Name:                   pred-trie-Version:                0.0.1+Version:                0.0.2 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -13,8 +13,9 @@   Default-Language:     Haskell2010   HS-Source-Dirs:       src   GHC-Options:          -Wall-  Exposed-Modules:      Data.Trie.Pred-  Other-Modules:        Data.Trie.Pred.Internal+  Exposed-Modules:      Data.Trie.Pred.Unified+                        Data.Trie.Pred.Unified.Fast+                        Data.Trie.Pred.Unified.Norm   Build-Depends:        base >= 4 && < 5                       , semigroups @@ -29,6 +30,15 @@                       , hspec                       , QuickCheck                       , quickcheck-instances++Benchmark simplevshort+    Type:               exitcode-stdio-1.0+    Main-Is:            SimpleVShort.hs+    HS-Source-Dirs:     bench+                      , src+    Build-Depends:      base+                      , criterion+                      , semigroups  Source-Repository head   Type:                 git

@@ -1,99 +0,0 @@-{-# LANGUAGE-  GADTs-  #-}--module Data.Trie.Pred-  ( PredTrie (..)-  , lookup-  , merge-  , areDisjoint-  ) where--import Data.Trie.Pred.Internal--import Prelude hiding (lookup)-import Data.List.NonEmpty hiding (map)-import Data.List.NonEmpty as NE hiding (map)----- | A predicative trie is composed of explicit predicate labels (for equality--- tests of predicates), a type for node labels, and some content type-data PredTrie p t x where-  Rest :: NonEmpty t-       -> x-       -> PredTrie p t x-  More :: t-       -> Maybe x-       -> NonEmpty (PredTrie p t x)-       -> PredTrie p t x-  Pred :: p-       -> (t -> Maybe r)-       -> Maybe (r -> x)-       -> [PredTrie p t (r -> x)]-       -> PredTrie p t x----- | Overwrites when similar, leaves untouched when not-merge :: (Eq t, Eq p) => PredTrie p t x -> PredTrie p t x -> PredTrie p t x-merge xx@(Rest tss@(t:|ts) x) yy@(Rest pss@(p:|ps) y)-  | tss == pss = yy-  | t == p     = let-                   xx' = Rest (NE.fromList ts) x-                   yy' = Rest (NE.fromList ps) y-                 in-                 More p Nothing $-                   if areDisjoint xx' yy'-                     then NE.fromList [xx', yy']-                     else NE.fromList-                            [merge (Rest (NE.fromList ts) x) (Rest (NE.fromList ps) y)]-  | otherwise = xx-merge xx@(More t mx xs) yy@(More p my ys)-  | t == p = More p my $ NE.fromList $ foldr go [] $ (NE.toList xs) ++ (NE.toList ys)-  | otherwise = xx-  where-    go :: (Eq t, Eq p) => PredTrie p t x -> [PredTrie p t x] -> [PredTrie p t x]-    go a [] = [a]-    go a (b:bs) | areDisjoint a b =       a : b : bs-                | otherwise       = (merge a b) : bs-merge xx@(Pred t q mrx xrs) yy@(Pred p w mry yrs)-  | t == p = yy-  | otherwise = xx-merge xx@(Rest (t:|ts) x) yy@(More p my ys)-  | t == p = case ts of-               [] -> More p (Just x) ys-               _  -> More p my $ fmap (merge $ Rest (NE.fromList ts) x) ys-  | otherwise = xx-merge xx@(More t mx xs) yy@(Rest (p:|ps) y)-  | t == p = case ps of-               [] -> More t (Just y) xs-               _  -> More t mx $ fmap (flip merge $ Rest (NE.fromList ps) y) xs-  | otherwise = yy-merge xx yy@(Pred _ _ _ _) = yy -- Predicates are more general-merge xx@(Pred _ _ _ _) yy = xx---areDisjoint :: (Eq t, Eq p) => PredTrie p t x -> PredTrie p t x -> Bool-areDisjoint (Rest (t:|_) _) (Rest (p:|_) _) = t == p-areDisjoint (More t _ _)    (More p _ _)    = t == p-areDisjoint (Pred t _ _ _)  (Pred p _ _ _)  = t == p---lookup :: Eq t => NonEmpty t -> PredTrie p t x -> Maybe x-lookup tss@(t:|ts) (Rest ps x) | tss == ps = Just x-                               | otherwise = Nothing-lookup     (t:|ts) (More t' mx xs) | t == t' =-  case ts of-    [] -> mx-    _  -> getFirst $ NE.toList $ fmap (lookup $ NE.fromList ts) xs-                                   | otherwise = Nothing-lookup     (t:|ts) (Pred _ p mrx xrs) =-  p t >>=-    \r -> case ts of-      [] -> ($ r) <$> mrx-      _  -> ($ r) <$> (getFirst $ map (lookup $ NE.fromList ts) xrs)---getFirst :: [Maybe a] -> Maybe a-getFirst [] = Nothing-getFirst (Nothing:xs) = getFirst xs-getFirst (Just x :xs) = Just x

@@ -1,3 +0,0 @@-module Data.Trie.Pred.Internal-    (-    ) where

@@ -0,0 +1,21 @@+module Data.Trie.Pred.Unified where++import Data.Trie.Pred.Unified.Norm+import qualified Data.Trie.Pred.Unified.Norm as NU+import Data.Monoid+++data RPTrie t x = Rooted (Maybe x) [NUPTrie t x]++instance (Eq t) => Monoid (RPTrie t x) where+  mempty = Rooted Nothing []+  mappend = Data.Trie.Pred.Unified.merge++merge :: (Eq t) => RPTrie t x -> RPTrie t x -> RPTrie t x+merge (Rooted mx xs) (Rooted my ys) =+  Rooted my $ foldr go [] $ xs ++ ys+  where+    go :: (Eq t) => NUPTrie t x -> [NUPTrie t x] -> [NUPTrie t x]+    go a [] = [a]+    go a (b:bs) | NU.areDisjoint a b =          a : b : bs+                | otherwise          = (NU.merge a b) : bs

@@ -0,0 +1,115 @@+{-# LANGUAGE+  GADTs+  #-}++module Data.Trie.Pred.Unified.Fast+  ( FUPTrie (..)+  , lookup+  , merge+  , areDisjoint+  ) where++import Prelude hiding (lookup)+import Data.List.NonEmpty hiding (map)+import Data.List.NonEmpty as NE hiding (map)++++-- | A fast, unified, predicative trie. Singleton, leaf-ending+-- branches have their own data constructor, predicate labels and literals+-- have a unified type.+data FUPTrie t x where+  FURest :: NonEmpty t+         -> x+         -> FUPTrie t x+  FUMore :: t+         -> Maybe x+         -> NonEmpty (FUPTrie t x)+         -> FUPTrie t x+  FUPred :: t+         -> (t -> Maybe r)+         -> Maybe (r -> x)+         -> [FUPTrie t (r -> x)]+         -> FUPTrie t x+++-- | Overwrites when similar, leaves untouched when not+merge :: (Eq t) => FUPTrie t x -> FUPTrie t x -> FUPTrie t x+merge xx@(FURest tss@(t:|ts) x) yy@(FURest pss@(p:|ps) y)+  | tss == pss = yy+  | t == p     = let+                   xx' = FURest (NE.fromList ts) x+                   yy' = FURest (NE.fromList ps) y+                 in+                 FUMore p Nothing $+                   if areDisjoint xx' yy'+                     then NE.fromList [xx', yy']+                     else NE.fromList+                            [merge (FURest (NE.fromList ts) x) (FURest (NE.fromList ps) y)]+  | otherwise = xx+merge xx@(FUMore t mx xs) yy@(FUMore p my ys)+  | t == p = FUMore p my $ NE.fromList $ foldr go [] $ (NE.toList xs) ++ (NE.toList ys)+  | otherwise = xx+  where+    go :: (Eq t) => FUPTrie t x -> [FUPTrie t x] -> [FUPTrie t x]+    go a [] = [a]+    go a (b:bs) | areDisjoint a b =       a : b : bs+                | otherwise       = (merge a b) : bs+merge xx@(FUPred t q mrx xrs) yy@(FUPred p w mry yrs)+  | t == p = yy+  | otherwise = xx+merge xx@(FURest (t:|ts) x) yy@(FUMore p my ys)+  | t == p = case ts of+               [] -> FUMore p (Just x) ys+               _  -> FUMore p my $ fmap (merge $ FURest (NE.fromList ts) x) ys+  | otherwise = xx+merge xx@(FUMore t mx xs) yy@(FURest (p:|ps) y)+  | t == p = case ps of+               [] -> FUMore t (Just y) xs+               _  -> FUMore t mx $ fmap (flip merge $ FURest (NE.fromList ps) y) xs+  | otherwise = yy+merge xx@(FUMore t mx xs) yy@(FUPred p w mrx xrs)+  | t == p = yy -- predicate children are incompatible+  | otherwise = xx+merge xx@(FURest (t:|ts) x) yy@(FUPred p w mry yrs)+  | t == p = yy+  | otherwise = xx+merge xx@(FUPred t q mrx xrs) yy@(FUMore p my ys)+  | t == p = yy+  | otherwise = xx+merge xx@(FUPred t q mrx xrs) yy@(FURest (p:|ps) y)+  | t == p = yy+  | otherwise = xx+++areDisjoint :: (Eq t) => FUPTrie t x -> FUPTrie t x -> Bool+areDisjoint (FURest (t:|_) _) (FURest (p:|_) _) = t == p+areDisjoint (FUMore t _ _)    (FUMore p _ _)    = t == p+areDisjoint (FURest (t:|_) _) (FUMore p _ _)    = t == p+areDisjoint (FUMore t _ _)    (FURest (p:|_) _) = t == p+areDisjoint (FUPred t _ _ _)  (FUPred p _ _ _)  = t == p+areDisjoint (FUPred t _ _ _)  (FUMore p _ _)    = t == p+areDisjoint (FUPred t _ _ _)  (FURest (p:|_) _) = t == p+areDisjoint (FUMore t _ _)    (FUPred p _ _ _)  = t == p+areDisjoint (FURest (t:|_) _) (FUPred p _ _ _)  = t == p+++lookup :: Eq t => NonEmpty t -> FUPTrie t x -> Maybe x+lookup tss@(t:|ts) (FURest ps x) | tss == ps = Just x+                                 | otherwise = Nothing+lookup     (t:|ts) (FUMore t' mx xs) | t == t' =+  case ts of+    [] -> mx+    _  -> getFirst $ NE.toList $ fmap (lookup $ NE.fromList ts) xs+                                   | otherwise = Nothing+lookup     (t:|ts) (FUPred _ p mrx xrs) =+  p t >>=+    \r -> case ts of+      [] -> ($ r) <$> mrx+      _  -> ($ r) <$> (getFirst $ map (lookup $ NE.fromList ts) xrs)+++getFirst :: [Maybe a] -> Maybe a+getFirst [] = Nothing+getFirst (Nothing:xs) = getFirst xs+getFirst (Just x :xs) = Just x

@@ -0,0 +1,74 @@+{-# LANGUAGE+  GADTs+  #-}++module Data.Trie.Pred.Unified.Norm+  ( NUPTrie (..)+  , lookup+  , merge+  , areDisjoint+  ) where++import Prelude hiding (lookup)+import Data.List.NonEmpty hiding (map)+import Data.List.NonEmpty as NE hiding (map)++++data NUPTrie t x where+  NUMore :: t+         -> Maybe x+         -> [NUPTrie t x]+         -> NUPTrie t x+  NUPred :: t+         -> (t -> Maybe r)+         -> Maybe (r -> x)+         -> [NUPTrie t (r -> x)]+         -> NUPTrie t x+++-- | Overwrites when similar, leaves untouched when not+merge :: (Eq t) => NUPTrie t x -> NUPTrie t x -> NUPTrie t x+merge xx@(NUMore t mx xs) yy@(NUMore p my ys)+  | t == p = NUMore p my $ foldr go [] $ xs ++ ys+  | otherwise = xx+  where+    go :: (Eq t) => NUPTrie t x -> [NUPTrie t x] -> [NUPTrie t x]+    go a [] = [a]+    go a (b:bs) | areDisjoint a b =       a : b : bs+                | otherwise       = (merge a b) : bs+merge xx@(NUPred t q mrx xrs) yy@(NUPred p w mry yrs)+  | t == p = yy+  | otherwise = xx+merge xx@(NUMore t mx xs) yy@(NUPred p w mrx xrs)+  | t == p = yy -- predicate children are incompatible+  | otherwise = xx+merge xx@(NUPred t q mrx xrs) yy@(NUMore p my ys)+  | t == p = yy+  | otherwise = xx+++areDisjoint :: (Eq t) => NUPTrie t x -> NUPTrie t x -> Bool+areDisjoint (NUMore t _ _)    (NUMore p _ _)    = t == p+areDisjoint (NUPred t _ _ _)  (NUPred p _ _ _)  = t == p+areDisjoint (NUPred t _ _ _)  (NUMore p _ _)    = t == p+areDisjoint (NUMore t _ _)    (NUPred p _ _ _)  = t == p+++lookup :: Eq t => NonEmpty t -> NUPTrie t x -> Maybe x+lookup (t:|ts) (NUMore t' mx xs)+  | t == t' = case ts of+    [] -> mx+    _  -> getFirst $ map (lookup $ NE.fromList ts) xs+  | otherwise = Nothing+lookup (t:|ts) (NUPred _ p mrx xrs) =+  p t >>=+    \r -> case ts of+      [] -> ($ r) <$> mrx+      _  -> ($ r) <$> (getFirst $ map (lookup $ NE.fromList ts) xrs)+++getFirst :: [Maybe a] -> Maybe a+getFirst [] = Nothing+getFirst (Nothing:xs) = getFirst xs+getFirst (Just x :xs) = Just x