pred-trie 0.5.1.2 → 0.6.0

raw patch · 10 files changed

+343/−662 lines, 10 filesdep +pred-triedep +strictdep −composition-extradep −quickcheck-instancesdep ~QuickCheckdep ~basedep ~poly-arityPVP ok

version bump matches the API change (PVP)

Dependencies added: pred-trie, strict

Dependencies removed: composition-extra, quickcheck-instances

Dependency ranges changed: QuickCheck, base, poly-arity, tries

API changes (from Hackage documentation)

Files

• README.md +38/−0
• bench/Bench.hs +0/−69
• bench/Main.hs +69/−0
• pred-trie.cabal +110/−93
• src/Data/Trie/Pred/Base.hs +40/−35
• src/Data/Trie/Pred/Base/Step.hs +66/−45
• src/Data/Trie/Pred/Interface/Types.hs +14/−14
• src/Data/Trie/Pred/Mutable.hs +0/−262
• src/Data/Trie/Pred/Mutable/Morph.hs +0/−137
• test/Data/Trie/PredSpec.hs +6/−7

@@ -0,0 +1,38 @@+pred-trie+=========++A predicative trie library - use predicates instead of literal match to capture+classes of results, instead of enumerating distinguished ones.++## Usage++The predicates are existentially quantified such that a predicate _creates_ an+unknown type, while it's result must have the _necessary arity_, matching the+quantified type, to fulfill the lookup:++```haskell+PredTrie s a+  = PNil+  | forall t. PCons+      { predicate :: s -> Maybe t+      , result    :: t -> a+      }+```++...basically.++I broke the lookup phases into "steps", like the [tries](https://github.com/athanclark/tries)+package, and used the fastest-lookup `HashMapStep` trie implementation for the+literal lookups. For more info, read the code :D++## How to run tests++```bash+stack test+```++## Benchmarking++```bash+stack bench --benchmark-arguments="--output profile.html"+```

@@ -1,69 +0,0 @@-{-# LANGUAGE-    OverloadedStrings-  #-}--module Main where---import Prelude hiding (lookup)-import           Data.Trie.Pred.Base-import           Data.Trie.Pred.Base.Step (PredStep (..), PredSteps (..))-import           Data.Trie.Class-import           Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..))-import qualified Data.HashMap.Lazy as HM-import           Data.List.NonEmpty-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import           Data.Attoparsec.Text-import           Criterion.Main-import           Data.Set.Class as Sets---doubleLit :: RootedPredTrie T.Text Double-doubleLit = RootedPredTrie Nothing $ PredTrie-              (HashMapStep $ unUnion $ foldMap (Union . genStep) [1..100])-              (PredSteps [])-  where-    genStep n = HM.singleton (T.pack $ show n) $-                  HashMapChildren (Just n) Nothing--doubleAtto :: RootedPredTrie T.Text Double-doubleAtto = RootedPredTrie Nothing $ PredTrie mempty $ PredSteps-  [PredStep "d" (eitherToMaybe . parseOnly double) (Just id) mempty]-  where-    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) $-                                                 HashMapChildren (Just n) (Just . go $ n-1))-                                (PredSteps [])--main = defaultMain-  [ bgroup "Lit vs. Pred"-    [ bgroup "Lit"-      [ bench "1" $ whnf (lookup ["1"]) doubleLit-      , bench "2" $ whnf (lookup ["21"]) doubleLit-      , bench "3" $ whnf (lookup ["41"]) doubleLit-      , bench "4" $ whnf (lookup ["61"]) doubleLit-      , bench "4" $ whnf (lookup ["81"]) doubleLit-      ]-    , bgroup "Pred"-      [ bench "1" $ whnf (lookup ["1"]) doubleAtto-      , bench "2" $ whnf (lookup ["21"]) doubleAtto-      , bench "3" $ whnf (lookup ["41"]) doubleAtto-      , 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-    ]-  ]

@@ -0,0 +1,69 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++module Main where+++import Prelude hiding (lookup)+import           Data.Trie.Pred.Base (PredTrie (..), RootedPredTrie (..))+import           Data.Trie.Pred.Base.Step (PredStep (..), Pred (..))+import           Data.Trie.Class (Trie (lookup, insert, delete))+import           Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..))+import qualified Data.HashMap.Strict as HM+import           Data.List.NonEmpty ()+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import           Data.Attoparsec.Text (parseOnly, double)+import           Criterion.Main (defaultMain, whnf, bench, bgroup)+import           Data.Set.Class as Sets+++doubleLit :: RootedPredTrie T.Text Double+doubleLit = RootedPredTrie Nothing $ PredTrie+              (HashMapStep $ unUnion $ foldMap (Union . genStep) [1..100])+              (PredStep HM.empty)+  where+    genStep n = HM.singleton (T.pack $ show n) $+                  HashMapChildren (Just n) Nothing++doubleAtto :: RootedPredTrie T.Text Double+doubleAtto = RootedPredTrie Nothing $ PredTrie mempty $ PredStep $+  HM.singleton "d" $ Pred (eitherToMaybe . parseOnly double) (Just id) mempty+  where+    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) (PredStep HM.empty)+         | otherwise = PredTrie (HashMapStep $ HM.singleton (T.pack $ show n) $+                                                 HashMapChildren (Just n) (Just . go $ n-1))+                                (PredStep HM.empty)++main = defaultMain+  [ bgroup "Lit vs. Pred"+    [ bgroup "Lit"+      [ bench "1" $ whnf (lookup ["1"]) doubleLit+      , bench "2" $ whnf (lookup ["21"]) doubleLit+      , bench "3" $ whnf (lookup ["41"]) doubleLit+      , bench "4" $ whnf (lookup ["61"]) doubleLit+      , bench "4" $ whnf (lookup ["81"]) doubleLit+      ]+    , bgroup "Pred"+      [ bench "1" $ whnf (lookup ["1"]) doubleAtto+      , bench "2" $ whnf (lookup ["21"]) doubleAtto+      , bench "3" $ whnf (lookup ["41"]) doubleAtto+      , 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+    ]+  ]

@@ -1,97 +1,114 @@-Name:                   pred-trie-Version:                0.5.1.2-Author:                 Athan Clark <athan.clark@gmail.com>-Maintainer:             Athan Clark <athan.clark@gmail.com>-License:                BSD3-License-File:           LICENSE-Category:               Data-Synopsis:               Predicative tries--- Description:-Cabal-Version:          >= 1.10-Build-Type:             Simple+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: f26559f76aae89fad9fe87fd25894fb71ded746440ac54961b4e1a5837de40ea -Library-  Default-Language:     Haskell2010-  HS-Source-Dirs:       src-  GHC-Options:          -Wall-  Exposed-Modules:      Data.Trie.Pred-                        Data.Trie.Pred.Base-                        Data.Trie.Pred.Base.Step-                        Data.Trie.Pred.Interface-                        Data.Trie.Pred.Interface.Types-                        Data.Trie.Pred.Mutable-                        Data.Trie.Pred.Mutable.Morph-  Build-Depends:        base >= 4.8 && < 5-                      , composition-extra >= 2.0.0-                      , containers-                      , hashable-                      , hashtables-                      , mtl-                      , poly-arity >= 0.0.7-                      , pred-set-                      , semigroups-                      , tries >= 0.0.4-                      , unordered-containers-                      , QuickCheck >= 2.9.2+name:           pred-trie+version:        0.6.0+synopsis:       Predicative tries+description:    Please see the README on Github at <https://git.localcooking.com/tooling/pred-trie#readme>+category:       Data+author:         Athan Clark+maintainer:     athan.clark@localcooking.com+copyright:      2018 Athan Clark+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10 -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.Base-                        Data.Trie.Pred.Base.Step-                        Data.Trie.Pred.Interface-                        Data.Trie.Pred.Interface.Types-  Build-Depends:        base-                      , attoparsec-                      , composition-extra-                      , deepseq-                      , errors-                      , hashable-                      , mtl-                      , poly-arity-                      , semigroups-                      , text-                      , tries-                      , unordered-containers-                      , tasty-                      , tasty-quickcheck-                      , tasty-hunit-                      , QuickCheck-                      , quickcheck-instances+extra-source-files:+    README.md -Benchmark bench-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  Main-Is:              Bench.hs-  Other-Modules:        Data.Trie.Pred-                        Data.Trie.Pred.Base-                        Data.Trie.Pred.Base.Step-                        Data.Trie.Pred.Interface-                        Data.Trie.Pred.Interface.Types-  HS-Source-Dirs:       bench-                      , src-  Ghc-Options:          -Wall -threaded-  Build-Depends:        base-                      , attoparsec-                      , composition-extra-                      , deepseq-                      , hashable-                      , mtl-                      , poly-arity-                      , semigroups-                      , text-                      , tries-                      , unordered-containers-                      , QuickCheck-                      , sets-                      , criterion+source-repository head+  type: git+  location: git://git.localcooking.com/tooling/pred-trie.git -Source-Repository head-  Type:                 git-  Location:             https://github.com/athanclark/pred-trie.git+library+  exposed-modules:+      Data.Trie.Pred+      Data.Trie.Pred.Base+      Data.Trie.Pred.Base.Step+      Data.Trie.Pred.Interface+      Data.Trie.Pred.Interface.Types+  other-modules:+      Paths_pred_trie+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      QuickCheck >=2.9.2+    , base >=4.8 && <5.0+    , containers+    , deepseq+    , hashable+    , hashtables+    , mtl+    , poly-arity >=0.0.7+    , pred-set+    , semigroups+    , strict+    , tries >=0.0.5+    , unordered-containers+  default-language: Haskell2010++test-suite pred-trie-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.Trie.PredSpec+      Paths_pred_trie+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N+  build-depends:+      QuickCheck >=2.9.2+    , attoparsec+    , base+    , containers+    , deepseq+    , errors+    , hashable+    , hashtables+    , mtl+    , poly-arity >=0.0.7+    , pred-set+    , pred-trie+    , semigroups+    , strict+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , text+    , tries >=0.0.5+    , unordered-containers+  default-language: Haskell2010++benchmark pred-trie-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_pred_trie+  hs-source-dirs:+      bench+  ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N+  build-depends:+      QuickCheck >=2.9.2+    , attoparsec+    , base+    , containers+    , criterion+    , deepseq+    , hashable+    , hashtables+    , mtl+    , poly-arity >=0.0.7+    , pred-set+    , pred-trie+    , semigroups+    , sets+    , strict+    , text+    , tries >=0.0.5+    , unordered-containers+  default-language: Haskell2010

@@ -63,19 +63,20 @@ module Data.Trie.Pred.Base where  import Prelude hiding (lookup)-import Data.Trie.Pred.Base.Step-import Data.Trie.Class+import Data.Trie.Pred.Base.Step (PredStep (..), Pred (..))+import Data.Trie.Class (Trie (..)) 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.Data (Typeable)+import Data.Monoid (First (..), Last (..), (<>)) import Data.Maybe (fromMaybe)-import Data.Hashable-import Test.QuickCheck+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HMS+import Test.QuickCheck (Arbitrary (..))+import Control.DeepSeq (NFData (..))   @@ -83,21 +84,24 @@  data PredTrie k a = PredTrie   { predLits  :: !(HT.HashMapStep PredTrie k a) -- ^ a /literal/ step-  , predPreds :: !(PredSteps k PredTrie k a)      -- ^ a /predicative/ step+  , predPreds :: PredStep k PredTrie k a      -- ^ a /predicative/ step   } deriving (Show, Functor, Typeable) +instance (NFData k, NFData a) => NFData (PredTrie k a) where+  rnf (PredTrie hs ps) = rnf hs `seq` rnf ps+ instance ( Arbitrary k          , Arbitrary a          , Eq k          , Hashable k          ) => Arbitrary (PredTrie k a) where-  arbitrary = flip PredTrie (PredSteps []) <$> arbitrary+  arbitrary = flip PredTrie mempty <$> arbitrary  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 @@ -106,10 +110,10 @@          ) => 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 k a-emptyPT = PredTrie HT.empty (PredSteps [])+emptyPT = PredTrie HT.empty (PredStep HMS.empty)   -- subtrie :: Ord s => NonEmpty s -> PredTrie s a -> PredTrie s a@@ -121,56 +125,56 @@ matchPT :: ( Hashable k            , Eq k            ) => NonEmpty k -> PredTrie k a -> Maybe (NonEmpty k, a, [k])-matchPT (t:|ts) (PredTrie ls (PredSteps ps)) = getFirst $+matchPT (t:|ts) (PredTrie ls (PredStep ps)) = getFirst $   First (goLit ls) <> foldMap (First . goPred) ps   where     goLit (HT.HashMapStep xs) = do       (HT.HashMapChildren mx mxs) <- HM.lookup t xs-      let mFoundHere = (t:|[],, []) <$> mx+      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))+                                pure (NE.cons t pre, y, suff))                    <> First mFoundHere -    goPred (PredStep _ p mx xs) = do+    goPred (Pred p mx xs) = do       r <- p t-      let mFoundHere = do x <- mx <$~> r-                          return (t:|[], x, [])+      let mFoundHere = do x <- ($ r) <$> mx+                          pure (t:|[], x, [])       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))+                                pure (NE.cons t pre, y r, suff))                    <> First mFoundHere   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+matchesPT (t:|ts) (PredTrie ls (PredStep ps)) =+  fromMaybe [] (getFirst (First (goLit ls) <> foldMap (First . goPred) ps))   where     goLit (HT.HashMapStep xs) = do       (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)+                          pure [(t:|[],x,ts)]+          prependAncestry (pre,x,suff) = (NE.cons t pre,x,suff)       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)+              pure (foundHere ++ (prependAncestry <$> rs)) -    goPred (PredStep _ p mx xs) = do+    goPred (Pred 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)+      let mFoundHere = do x <- ($ r) <$> mx+                          pure [(t:|[],x,ts)]+          prependAncestryAndApply (pre,x,suff) = (NE.cons t pre,x r,suff)       if null ts       then mFoundHere       else do foundHere <- mFoundHere               let rs = matchesPT (NE.fromList ts) xs-              return $! foundHere ++ (prependAncestryAndApply <$> rs)+              pure (foundHere ++ (prependAncestryAndApply <$> rs))  -- * Rooted Predicative Trie @@ -187,10 +191,10 @@   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 k@@ -198,7 +202,7 @@          ) => 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 k a@@ -219,7 +223,8 @@               ) => [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 [] $ do x <- mx+                                  pure [([],x,[])]     allowRoot (pre,x,suff) = (NE.toList pre,x,suff)

@@ -5,6 +5,8 @@   , MultiParamTypeClasses   , DeriveFunctor   , DeriveDataTypeable+  , OverloadedLists+  , UndecidableInstances   #-}  {- |@@ -20,82 +22,101 @@ module Data.Trie.Pred.Base.Step where  import Prelude hiding (lookup)-import Data.Trie.Class+import Data.Trie.Class (Trie (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Typeable-import Data.Functor.Syntax-import Data.Monoid+import Data.Data (Typeable)+import Data.Monoid (First (..), (<>))+import Data.Maybe (maybe)+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMS+import Control.DeepSeq (NFData (..))   -- * Single Predicated Step -data PredStep k c s a = forall r. Typeable r => PredStep-  { -- | Unique identifier for the predicate - used for combination-    predTag  :: !k-  , -- | The predicate, existentially quantified in the successful result @r@+data Pred c s a = forall r. Typeable r => Pred+  { -- | The predicate, existentially quantified in the successful result @r@     predPred :: !(s -> Maybe r)   , -- | The result function, capturing the quantified result @r@ and turning     --   it into a top-level variable @a@.     predData :: !(Maybe (r -> a))   , -- | Any sub-trie must have __all__ results preceeded in arity with     --   the result at this step.-    predSub  :: !(c s (r -> a))+    predSub  :: c s (r -> a)   } deriving (Typeable) -instance ( Show s-         , Show k-         ) => Show (PredStep k c s a) where-  show (PredStep t _ _ _) = "PredStep {predTag=" ++ show t ++ ", ...}"+instance Show (Pred c s a) where+  show (Pred _ mx _) = "Pred { predSub = ##, predData = " ++ maybe "Nothing" (\_ -> "Just ##") mx ++ " }" -instance Functor (c s) => Functor (PredStep k c s) where-  fmap f (PredStep i p mx xs) = (PredStep i p $! f <.$> mx) $! f <.$> xs+instance Functor (c s) => Functor (Pred c s) where+  fmap f (Pred p mx xs) = Pred p ((f .) <$> mx) ((f .) <$> xs) +instance (Functor (c s), NFData (c s (s -> Maybe a))) => NFData (Pred c s a) where+  rnf (Pred p mx xs) =+    ( case mx of+        Nothing -> ()+        Just f -> rnf (\x -> case p x of+                               Nothing -> Nothing+                               Just r -> Just (f r)+                          )+      ) `seq` rnf ((\f -> (\x -> case p x of+                              Nothing -> Nothing+                              Just r -> Just (f r)+                             )+                   ) <$> xs)++ -- | Lookup and delete only - can't arbitrarilly construct a predicated trie.-instance Trie NonEmpty s c => Trie NonEmpty s (PredStep k c) where-  lookup (t:|ts) (PredStep _ p mx xs) = do+instance Trie NonEmpty s c => Trie NonEmpty s (Pred c) where+  lookup (t:|ts) (Pred p mx xs) = do     r <- p t-    if null ts then mx <$~> r-               else lookup (NE.fromList ts) xs <$~> r-  delete (t:|ts) xss@(PredStep i p mx xs) =-    maybe xss-      (const $ if null ts-               then PredStep i p Nothing xs-               else PredStep i p mx $! delete (NE.fromList ts) xs)-      (p t)+    fmap ($ r) $+      if null ts+      then mx+      else lookup (NE.fromList ts) xs+  delete (t:|ts) xss@(Pred p mx xs) =+    case p t of+      Nothing -> xss+      Just _+        | null ts -> Pred p Nothing xs+        | otherwise -> Pred p mx (delete (NE.fromList ts) xs) + singletonPred :: ( Monoid (c s (r -> a))                  , Typeable r-                 ) => k -> (s -> Maybe r) -> (r -> a) -> PredStep k c s a-singletonPred i p x = PredStep i p (Just x) mempty+                 ) => (s -> Maybe r) -> (r -> a) -> Pred c s a+singletonPred p x = Pred p (Just x) mempty   -- * Adjacent Predicated Steps  -- | Adjacent steps-newtype PredSteps k c s a = PredSteps-  { unPredSteps :: [PredStep k c s a]+newtype PredStep k c s a = PredStep+  { unPredSteps :: HashMap k (Pred c s a)   } deriving (Show, Functor, Typeable) ++instance (Functor (c s), NFData (c s (s -> Maybe a)), NFData k) => NFData (PredStep k c s a) where+  rnf (PredStep xs) = rnf xs+ -- | Lookup and delete only - can't arbitrarilly construct a predicated trie.-instance Trie NonEmpty s c => Trie NonEmpty s (PredSteps k c) where-  lookup ts (PredSteps ps) = getFirst $! foldMap (First . lookup ts) ps-  delete ts (PredSteps ps) = PredSteps $! fmap (delete ts) ps+instance Trie NonEmpty s c => Trie NonEmpty s (PredStep k c) where+  lookup ts (PredStep ps) = getFirst (foldMap (First . lookup ts) ps)+  delete ts (PredStep ps) = PredStep (fmap (delete ts) ps) -instance ( Eq s-         , Eq k-         ) => Monoid (PredSteps k c s a) where-  mempty  = PredSteps []+instance ( Eq k+         , Hashable k+         ) => Monoid (PredStep k c s a) where+  mempty  = PredStep HMS.empty   mappend = unionPred --- | @Last@-style instance+-- | overwrite on the right unionPred :: ( Eq k-             ) => PredSteps k c s a-               -> PredSteps k c s a-               -> PredSteps k 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))-unionPred x (PredSteps []) = x-unionPred (PredSteps []) y = y+             , Hashable k+             ) => PredStep k c s a+               -> PredStep k c s a+               -> PredStep k c s a+unionPred (PredStep xs) (PredStep ys) = PredStep (xs <> ys)

@@ -11,8 +11,8 @@   , MultiParamTypeClasses   , FunctionalDependencies   , ConstraintKinds-  , BangPatterns   , OverloadedStrings+  , OverloadedLists   #-}  @@ -45,13 +45,13 @@   import Prelude hiding (pred)-import           Data.Trie.Pred.Base-import           Data.Trie.Pred.Base.Step+import           Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..), emptyPT)+import           Data.Trie.Pred.Base.Step (Pred (..), PredStep (..)) import qualified Data.Trie.HashMap as HT import qualified Data.HashMap.Lazy as HM-import Data.Hashable-import Data.Function.Poly-import Data.Typeable+import Data.Hashable (Hashable)+import Data.Function.Poly (ArityTypeListIso)+import Data.Typeable (Typeable)  import Data.String (IsString (..)) @@ -95,8 +95,8 @@          , Hashable k          , Typeable r          ) => Extend (PathChunk k ('Just r)) (RootedPredTrie k (r -> a)) (RootedPredTrie k a) where-  extend (Pred i q) (RootedPredTrie mx xs) = RootedPredTrie Nothing $-    PredTrie mempty (PredSteps [PredStep i q mx xs])+  extend (Pred' i q) (RootedPredTrie mx xs) = RootedPredTrie Nothing $+    PredTrie mempty (PredStep (HM.singleton i (Pred q mx xs)))   -- | @FoldR Extend start chunks ~ result@@@ -132,16 +132,16 @@  -- | Match with a predicate against the url chunk directly. pred :: k -> (k -> Maybe r) -> PathChunk k ('Just r)-pred = Pred+pred = Pred'   -- | Constrained to AttoParsec, Regex-Compat and T.Text data PathChunk k (mx :: Maybe *) where-  Lit  :: { litChunk :: !k-          } -> PathChunk k 'Nothing-  Pred :: { predTag  :: !k-          , predPred :: !(k -> Maybe r)-          } -> PathChunk k ('Just r)+  Lit   :: { litChunk :: !k+           } -> PathChunk k 'Nothing+  Pred' :: { predTag  :: !k+           , predPred :: !(k -> Maybe r)+           } -> PathChunk k ('Just r)  -- | Use raw strings instead of prepending @l@ instance IsString k => IsString (PathChunk k 'Nothing) where

@@ -1,262 +0,0 @@-{-# LANGUAGE-    ExistentialQuantification-  #-}--module Data.Trie.Pred.Mutable where--import Prelude hiding (lookup)-import Data.Monoid-import Data.Maybe (fromMaybe)-import Data.Foldable (foldlM)-import Data.Typeable--import Data.List.NonEmpty hiding (insert)--import           Data.HashTable.ST.Basic (HashTable)-import qualified Data.HashTable.ST.Basic as HT-import           Data.PredSet.Mutable (PredSet, PredKey)-import qualified Data.PredSet.Mutable as HS-import Control.Monad.ST-import Data.Hashable----- * Tail--data PredStep s k r = forall a. Typeable a => PredStep-  { predPred :: {-# UNPACK #-} !(PredKey s k a)-  , predData :: !(Maybe (a -> r))-  , predSub  :: !(HashTableTrie s k (a -> r))-  }--data RawValue s k a = RawValue-  { rawValue    :: !(Maybe a)-  , rawChildren :: !(HashTableTrie s k a)-  }--data HashTableTrie s k a = HashTableTrie-  { rawValues :: {-# UNPACK #-} !(HashTable s k (RawValue s k a))-  , predPreds :: [PredStep s k a]-  }---new :: ST s (HashTableTrie s k a)-new = flip HashTableTrie [] <$> HT.new--insert :: ( Eq k-          , Hashable k-          ) => NonEmpty k-            -> a-            -> HashTableTrie s k a-            -> ST s (HashTableTrie s k a)-insert (k:|ks) x ref@(HashTableTrie raw _) =-  case ks of-    [] -> do-      mx' <- HT.lookup raw k-      case mx' of-        Nothing -> do-          children <- new-          HT.insert raw k $! RawValue (Just x) children-          pure ref-        Just (RawValue _ children) -> do-          HT.insert raw k $! RawValue (Just x) children-          pure ref-    (k':ks') -> do-      mx' <- HT.lookup raw k-      case mx' of-        Nothing -> do-          children <- new-          children' <- insert (k':|ks') x children-          HT.insert raw k $! RawValue Nothing children'-          pure ref-        Just (RawValue mx children) -> do-          children' <- insert (k':|ks') x children-          HT.insert raw k $! RawValue mx children'-          pure ref---lookup :: ( Eq k-          , Hashable k-          , Typeable s-          , Typeable k-          ) => PredSet s k-            -> NonEmpty k-            -> HashTableTrie s k a-            -> ST s (Maybe a)-lookup predSet (k:|ks) (HashTableTrie raw preds) = do-  mx <- HT.lookup raw k-  case mx of-    Just (RawValue mx' children) ->-      case ks of-        []       -> pure mx'-        (k':ks') -> lookup predSet (k':|ks') children-    Nothing ->-      let -- go :: Typeable t => Maybe t -> PredStep s k t -> ST s (Maybe t)-          go solution@(Just _) _                          = pure solution-          go Nothing (PredStep predKey mHandler children) = do-            mx' <- HS.lookup predKey k predSet-            case mx' of-              Nothing -> pure Nothing-              Just x  ->-                case ks of-                  [] ->-                    pure $! ($ x) <$> mHandler-                  (k':ks') -> do-                    mf <- lookup predSet (k':|ks') children-                    pure $! ($ x) <$> mf-      in  foldlM go Nothing preds---match :: ( Eq k-         , Hashable k-         , Typeable s-         , Typeable k-         ) => PredSet s k-           -> NonEmpty k-           -> HashTableTrie s k a-           -> ST s (Maybe (NonEmpty k, a, [k]))-match predSet (k:|ks) (HashTableTrie raw preds) = do-  mLit <- goLit raw-  case mLit of-    Just _  -> pure mLit-    Nothing ->-      let go solution@(Just _) _ = pure solution-          go Nothing pred        = goPred pred-      in  foldlM go Nothing preds-  where-    goLit xs = do-      mx' <- HT.lookup raw k-      case mx' of-        Nothing -> pure Nothing-        Just (RawValue mx children) ->-          let mFoundHere = (\x -> (k:|[], x, ks)) <$> mx-              prependAncestry (pre,x,suff) = (k:|toList pre,x,suff)-          in case ks of-            [] -> pure mFoundHere-            (k':ks') -> do-              mFoundThere <- match predSet (k':|ks') children-              pure $! getFirst $-                   First (prependAncestry <$> mFoundThere)-                <> First mFoundHere--    goPred (PredStep predKey mx children) = do-      mr' <- HS.lookup predKey k predSet-      case mr' of-        Nothing -> pure Nothing-        Just r  ->-          let mFoundHere = (\x -> (k:|[], x r, ks)) <$> mx-              prependAncestryAndApply (pre,f,suff) =-                (k:|toList pre,f r,suff)-          in case ks of-            [] -> pure mFoundHere-            (k':ks') -> do-              mFoundThere <- match predSet (k':|ks') children-              pure $! getFirst $-                   First (prependAncestryAndApply <$> mFoundThere)-                <> First mFoundHere--matches :: ( Eq k-           , Hashable k-           , Typeable s-           , Typeable k-           ) => PredSet s k-             -> NonEmpty k-             -> HashTableTrie s k a-             -> ST s [(NonEmpty k, a, [k])]-matches predSet (k:|ks) (HashTableTrie raw preds) = do-  mLit <- goLit raw-  case mLit of-    Just lit -> pure lit-    Nothing ->-      let go solution@(Just _) _ = pure solution-          go Nothing pred        = goPred pred-      in  fromMaybe [] <$> foldlM go Nothing preds-  where-    goLit xs = do-      mx' <- HT.lookup raw k-      case mx' of-        Nothing -> pure Nothing-        Just (RawValue mx children) ->-          let mFoundHere = (\x -> [(k:|[], x, ks)]) <$> mx-              prependAncestry (pre,x,suff) = (k:|toList pre, x, suff)-          in case ks of-            [] -> pure mFoundHere-            (k':ks') ->-              case mFoundHere of-                Nothing -> pure Nothing-                Just foundHere -> do-                  foundThere <- matches predSet (k':|ks') children-                  pure . Just $! foundHere ++ (prependAncestry <$> foundThere)--    goPred (PredStep predKey mx children) = do-      mr <- HS.lookup predKey k predSet-      case mr of-        Nothing -> pure Nothing-        Just r  ->-          let mFoundHere = (\f -> [(k:|[],f r,ks)]) <$> mx-              prependAncestryAndApply (pre,f,suff) =-                (k:|toList pre,f r,suff)-          in case ks of-            [] -> pure mFoundHere-            (k':ks') ->-              case mFoundHere of-                Nothing -> pure Nothing-                Just foundHere -> do-                  foundThere <- matches predSet (k':|ks') children-                  pure . Just $! foundHere ++ (prependAncestryAndApply <$> foundThere)----- * Rooted--data RootedHashTableTrie s k a = RootedHashTableTrie-  { rootedBase    :: !(Maybe a)-  , rootedSub     :: !(HashTableTrie s k a)-  , rootedPredSet :: {-# UNPACK #-} !(PredSet s k)-  }--newR :: ST s (RootedHashTableTrie s k a)-newR = RootedHashTableTrie Nothing <$> new <*> HS.new--lookupR :: ( Eq k-           , Hashable k-           , Typeable s-           , Typeable k-           , Typeable a-           ) => [k]-             -> RootedHashTableTrie s k a-             -> ST s (Maybe a)-lookupR [] (RootedHashTableTrie mx _ _) = pure mx-lookupR (k:ks) (RootedHashTableTrie _ xs predSet) = lookup predSet (k:|ks) xs--matchR :: ( Eq k-          , Hashable k-          , Typeable s-          , Typeable k-          , Typeable a-          ) => [k]-            -> RootedHashTableTrie s k a-            -> ST s (Maybe ([k],a,[k]))-matchR [] (RootedHashTableTrie mx _ _) =-  pure $! (\x -> ([],x,[])) <$> mx-matchR (k:ks) (RootedHashTableTrie mx xs predSet) = do-  mFoundThere <- match predSet (k:|ks) xs-  pure $! getFirst $-      First ((\(pre,x,suff) -> (toList pre,x,suff)) <$> mFoundThere)-   <> First ((\x -> ([],x,k:ks)) <$> mx)---matchesR :: ( Eq k-            , Hashable k-            , Typeable s-            , Typeable k-            , Typeable a-            ) => [k]-              -> RootedHashTableTrie s k a-              -> ST s [([k],a,[k])]-matchesR [] (RootedHashTableTrie mx _ _) =-  pure $! fromMaybe [] $ (\x -> [([],x,[])]) <$> mx-matchesR (k:ks) (RootedHashTableTrie mx xs predSet) = do-  foundThere <- matches predSet (k:|ks) xs-  pure $! foundHere ++ (allowRoot <$> foundThere)-  where-    foundHere = fromMaybe [] $ (\x -> [([],x,k:ks)]) <$> mx-    allowRoot (pre,x,suff) = (toList pre,x,suff)

@@ -1,137 +0,0 @@-module Data.Trie.Pred.Mutable.Morph where--import Data.Trie.Pred.Mutable as M-import Data.Trie.Pred.Base as B-import Data.Trie.Pred.Base.Step as B--import Data.PredSet.Mutable as HS-import Data.Trie.HashMap as HMT-import           Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HM-import           Data.HashTable.ST.Basic (HashTable)-import qualified Data.HashTable.ST.Basic as HT-import qualified Data.Map.Strict as Map--import Control.Monad.ST-import Data.Foldable (foldlM)-import Data.Typeable-import Data.Dynamic-import Data.Hashable-import Data.Proxy-import Data.STRef---toMutableRooted :: ( Eq k-                   , Hashable k-                   , Ord k-                   , Typeable s-                   , Typeable k-                   , Typeable a-                   ) => RootedPredTrie k a-                     -> ST s (RootedHashTableTrie s k a)-toMutableRooted (RootedPredTrie mx xs) = do-  predSet <- HS.new-  xs' <- toMutable predSet xs-  pure $! RootedHashTableTrie mx xs' predSet--toMutable :: ( Eq k-             , Hashable k-             , Ord k-             , Typeable s-             , Typeable k-             , Typeable a-             ) => PredSet s k-               -> PredTrie k a-               -> ST s (HashTableTrie s k a)-toMutable predSet xs = do-  predRefs <- newSTRef Map.empty-  toHashTableTrie predRefs predSet xs---toHashTableTrie :: ( Eq k-                   , Hashable k-                   , Ord k-                   , Typeable s-                   , Typeable k-                   , Typeable a-                   ) => STRef s (HMap k)-                     -> PredSet s k-                     -> PredTrie k a-                     -> ST s (HashTableTrie s k a)-toHashTableTrie predRefs predSet (PredTrie (HashMapStep raw) (PredSteps preds)) = do-  raw' <- toHashTable =<< traverse (toRawValue predRefs predSet) raw-  preds' <- mapM (toMutablePredStep predRefs predSet) preds-  pure (HashTableTrie raw' preds')--toRawValue :: ( Eq k-              , Hashable k-              , Ord k-              , Typeable s-              , Typeable k-              , Typeable a-              ) => STRef s (HMap k)-                -> PredSet s k-                -> HashMapChildren PredTrie k a-                -> ST s (RawValue s k a)-toRawValue predRefs predSet (HashMapChildren mx mchildren) = do-  children <- case mchildren of-                Nothing -> M.new-                Just xs -> toHashTableTrie predRefs predSet xs-  pure (RawValue mx children)--toHashTable :: ( Eq k-               , Hashable k-               ) => HM.HashMap k a-                 -> ST s (HashTable s k a)-toHashTable xs = do-  fresh <- HT.new-  foldlM (\() (k,v) -> HT.insert fresh k v) () (HM.toList xs)-  pure fresh--toMutablePredStep :: ( Ord k-                     , Eq k-                     , Hashable k-                     , Typeable s-                     , Typeable k-                     , Typeable a-                     ) => STRef s (HMap k)-                       -> PredSet s k-                       -> B.PredStep k PredTrie k a-                       -> ST s (M.PredStep s k a)-toMutablePredStep predRefs predSet (B.PredStep tag pred mx children) = do-  predRefs' <- readSTRef predRefs-  mPredKey <- lookupPredKey tag (pure pred) predRefs'-  predKey  <- case mPredKey of-                Nothing -> do predKey' <- HS.insert pred predSet-                              writeSTRef predRefs (insertPredKey tag predKey' predRefs')-                              pure predKey'-                Just x  -> pure x-  children' <- toHashTableTrie predRefs predSet children-  pure (M.PredStep predKey mx children')----- Wiiiked abuse of the type system--type HMap k = Map.Map k Dynamic--insertPredKey :: ( Ord k'-                 , Typeable s-                 , Typeable k-                 , Typeable a-                 ) => k'-                   -> PredKey s k a-                   -> HMap k'-                   -> HMap k'-insertPredKey k pred = Map.insert k (toDyn pred)--lookupPredKey :: ( Ord k'-                 , Typeable s-                 , Typeable k-                 , Typeable a-                 ) => k'-                   -> ST s (k -> Maybe a)-                   -> HMap k'-                   -> ST s (Maybe (PredKey s k a))-lookupPredKey k pred xs = do-  pred' <- pred-  pure $! fromDynamic =<< Map.lookup k xs

@@ -4,20 +4,19 @@  module Data.Trie.PredSpec where -import Data.Trie.Pred.Base-import Data.Trie.Pred.Base.Step-import Data.Trie.Class+import Data.Trie.Pred.Base (PredTrie (..), emptyPT)+import Data.Trie.Pred.Base.Step (PredStep (..), Pred (..))+import Data.Trie.Class (Trie (lookup, insert, delete)) 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 qualified Data.HashMap.Strict 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+import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck as QC  @@ -46,4 +45,4 @@  doubleTable :: PredTrie T.Text Int doubleTable = PredTrie (HashMapStep HM.empty) $-  PredSteps [PredStep "double" (hush . parseOnly double) (Just $ \d -> 0) emptyPT]+  PredStep (HM.singleton "double" (Pred (hush . parseOnly double) (Just $ \d -> 0) emptyPT))