pred-trie 0.5.0 → 0.5.1

raw patch · 6 files changed

+416/−7 lines, 6 filesdep +containersdep +hashtablesdep +pred-setPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, hashtables, pred-set

API changes (from Hackage documentation)

Files

• pred-trie.cabal +6/−1
• src/Data/Trie/Pred/Base/Step.hs +5/−3
• src/Data/Trie/Pred/Interface.hs +4/−3
• src/Data/Trie/Pred/Interface/Types.hs +2/−0
• src/Data/Trie/Pred/Mutable.hs +262/−0
• src/Data/Trie/Pred/Mutable/Morph.hs +137/−0

@@ -1,5 +1,5 @@ Name:                   pred-trie-Version:                0.5.0+Version:                0.5.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -19,11 +19,16 @@                         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

@@ -31,11 +31,11 @@  -- * Single Predicated Step -data PredStep k c s a = forall r. PredStep+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@-    predPred :: !(s -> Maybe 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))@@ -65,7 +65,9 @@                else PredStep i p mx $! delete (NE.fromList ts) xs)       (p t) -singletonPred :: Monoid (c s (r -> a)) => k -> (s -> Maybe r) -> (r -> a) -> PredStep k c s a+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  

@@ -90,7 +90,8 @@  newtype PTBuilderT k v m a = PTBuilderT   { runPTBuilderT :: StateT (RootedPredTrie k v) m a-  } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (RootedPredTrie k v))+  } deriving ( Functor, Applicative, Monad, MonadTrans+             , MonadState (RootedPredTrie k v))  instance ( Monad m          , Eq k@@ -128,7 +129,7 @@             -> childContent             -> PTBuilderT k resultContent m () insert !ts !vl =-  modify' ((singleton ts vl) <>)+  modify' (singleton ts vl <>)   insertHere :: ( Monad m@@ -149,7 +150,7 @@             -> PTBuilderT k resultContent m () prefix !ts cs = do   trie <- lift (execPTBuilderT cs)-  modify' ((extrude ts trie) <>)+  modify' (extrude ts trie <>)   lookup :: ( Eq k

@@ -51,6 +51,7 @@ import qualified Data.HashMap.Lazy as HM import Data.Hashable import Data.Function.Poly+import Data.Typeable  import Data.String (IsString (..)) @@ -92,6 +93,7 @@ -- | Existentially quantified case instance ( Eq k          , 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])

@@ -0,0 +1,262 @@+{-# 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)

@@ -0,0 +1,137 @@+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