pred-trie 0.4.1 → 0.5.0

raw patch · 9 files changed

+688/−327 lines, 9 filesdep +poly-arityPVP ok

version bump matches the API change (PVP)

Dependencies added: poly-arity

API changes (from Hackage documentation)

Files

• bench/Bench.hs +2/−2
• pred-trie.cabal +18/−7
• src/Data/Trie/Pred.hs +4/−225
• src/Data/Trie/Pred/Base.hs +225/−0
• src/Data/Trie/Pred/Base/Step.hs +99/−0
• src/Data/Trie/Pred/Interface.hs +174/−0
• src/Data/Trie/Pred/Interface/Types.hs +164/−0
• src/Data/Trie/Pred/Step.hs +0/−91
• test/Data/Trie/PredSpec.hs +2/−2

@@ -6,8 +6,8 @@   import Prelude hiding (lookup)-import           Data.Trie.Pred-import           Data.Trie.Pred.Step (PredStep (..), PredSteps (..))+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

@@ -1,5 +1,5 @@ Name:                   pred-trie-Version:                0.4.1+Version:                0.5.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -15,13 +15,16 @@   HS-Source-Dirs:       src   GHC-Options:          -Wall   Exposed-Modules:      Data.Trie.Pred-                        Data.Trie.Pred.Step+                        Data.Trie.Pred.Base+                        Data.Trie.Pred.Base.Step+                        Data.Trie.Pred.Interface+                        Data.Trie.Pred.Interface.Types   Build-Depends:        base >= 4.8 && < 5                       , composition-extra >= 2.0.0                       , hashable                       , mtl+                      , poly-arity >= 0.0.7                       , semigroups-                      , text                       , tries >= 0.0.4                       , unordered-containers                       , QuickCheck@@ -35,7 +38,10 @@   Main-Is:              Spec.hs   Other-Modules:        Data.Trie.PredSpec                         Data.Trie.Pred-                        Data.Trie.Pred.Step+                        Data.Trie.Pred.Base+                        Data.Trie.Pred.Base.Step+                        Data.Trie.Pred.Interface+                        Data.Trie.Pred.Interface.Types   Build-Depends:        base                       , attoparsec                       , composition-extra@@ -43,6 +49,7 @@                       , errors                       , hashable                       , mtl+                      , poly-arity                       , semigroups                       , text                       , tries@@ -58,20 +65,24 @@   Default-Language:     Haskell2010   Main-Is:              Bench.hs   Other-Modules:        Data.Trie.Pred-                        Data.Trie.Pred.Step+                        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-                      , attoparsec-                      , text                       , QuickCheck                       , sets                       , criterion

@@ -1,226 +1,5 @@-{-# LANGUAGE-    ExistentialQuantification-  , FlexibleContexts-  , FlexibleInstances-  , MultiParamTypeClasses-  , DeriveFunctor-  , DeriveGeneric-  , DeriveDataTypeable-  , TupleSections-  , BangPatterns-  #-}--{- |-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 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:--> forall a. p -> Maybe 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" <https://en.wikipedia.org/wiki/Rose_tree rose-tree>,-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)->       }--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--import Prelude hiding (lookup)-import Data.Trie.Pred.Step-import Data.Trie.Class-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 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 k-         , Arbitrary a-         , Eq k-         , Hashable k-         ) => Arbitrary (PredTrie k a) where-  arbitrary = (flip PredTrie $ PredSteps []) <$> 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)-  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 k-         , Eq k-         ) => Monoid (PredTrie k a) where-  mempty = PredTrie mempty mempty-  mappend (PredTrie ls1 ps1) (PredTrie ls2 ps2) =-    (PredTrie $! ls1 <> ls2) $! ps1 <> ps2--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 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-      (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--    goPred (PredStep _ p mx xs) = do-      r <- p t-      let mFoundHere = do x <- mx <$~> r-                          return (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))-                   <> 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-  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)-      if null ts-      then mFoundHere-      else do foundHere <- mFoundHere-              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-      else do foundHere <- mFoundHere-              let rs = matchesPT (NE.fromList ts) xs-              return $! foundHere ++ (prependAncestryAndApply <$> rs)---- * Rooted Predicative Trie--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 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--  insert [] x (RootedPredTrie _ xs)  = RootedPredTrie (Just x) xs-  insert ts x (RootedPredTrie mx xs) = RootedPredTrie mx $! insert (NE.fromList ts) x xs---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---emptyRPT :: RootedPredTrie k a-emptyRPT = RootedPredTrie Nothing emptyPT--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)-  where-    mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs-                     pure (NE.toList pre,x,suff)+module Data.Trie.Pred+  ( module Data.Trie.Pred.Interface+  ) where -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)-  where-    foundHere = fromMaybe [] $! (\x -> [([],x,[])]) <$> mx-    allowRoot (pre,x,suff) = (NE.toList pre,x,suff)+import Data.Trie.Pred.Interface

@@ -0,0 +1,225 @@+{-# LANGUAGE+    ExistentialQuantification+  , FlexibleContexts+  , FlexibleInstances+  , MultiParamTypeClasses+  , DeriveFunctor+  , DeriveDataTypeable+  , TupleSections+  #-}++{- |+Module      : Data.Trie.Pred.Base+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 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:++> forall a. p -> Maybe 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" <https://en.wikipedia.org/wiki/Rose_tree rose-tree>,+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)+>       }++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 internally, but serves to help see the+representation. If you want to build tries+and perform lookups casually, please see the "Data.Trie.Pred.Interface" module.+-}++module Data.Trie.Pred.Base where++import Prelude hiding (lookup)+import Data.Trie.Pred.Base.Step+import Data.Trie.Class+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 k a = PredTrie+  { predLits  :: !(HT.HashMapStep PredTrie k a) -- ^ a /literal/ step+  , predPreds :: !(PredSteps k PredTrie k a)      -- ^ a /predicative/ step+  } deriving (Show, Functor, Typeable)++instance ( Arbitrary k+         , Arbitrary a+         , Eq k+         , Hashable k+         ) => Arbitrary (PredTrie k a) where+  arbitrary = flip PredTrie (PredSteps []) <$> 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)+  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 k+         , Eq k+         ) => Monoid (PredTrie k a) where+  mempty = PredTrie mempty mempty+  mappend (PredTrie ls1 ps1) (PredTrie ls2 ps2) =+    (PredTrie $! ls1 <> ls2) $! ps1 <> ps2++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 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+      (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++    goPred (PredStep _ p mx xs) = do+      r <- p t+      let mFoundHere = do x <- mx <$~> r+                          return (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))+                   <> 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+  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)+      if null ts+      then mFoundHere+      else do foundHere <- mFoundHere+              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+      else do foundHere <- mFoundHere+              let rs = matchesPT (NE.fromList ts) xs+              return $! foundHere ++ (prependAncestryAndApply <$> rs)++-- * Rooted Predicative Trie++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 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++  insert [] x (RootedPredTrie _ xs)  = RootedPredTrie (Just x) xs+  insert ts x (RootedPredTrie mx xs) = RootedPredTrie mx $! insert (NE.fromList ts) x xs+++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+++emptyRPT :: RootedPredTrie k a+emptyRPT = RootedPredTrie Nothing emptyPT++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)+  where+    mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs+                     pure (NE.toList pre,x,suff)++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)+  where+    foundHere = fromMaybe [] $! (\x -> [([],x,[])]) <$> mx+    allowRoot (pre,x,suff) = (NE.toList pre,x,suff)

@@ -0,0 +1,99 @@+{-# LANGUAGE+    ExistentialQuantification+  , FlexibleContexts+  , FlexibleInstances+  , MultiParamTypeClasses+  , DeriveFunctor+  , DeriveDataTypeable+  #-}++{- |+Module      : Data.Trie.Pred.Base.Step+Copyright   : (c) 2015 Athan Clark++License     : BSD-3+Maintainer  : athan.clark@gmail.com+Stability   : experimental+Portability : GHC+-}++module Data.Trie.Pred.Base.Step where++import Prelude hiding (lookup)+import Data.Trie.Class+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Data.Typeable+import Data.Functor.Syntax+import Data.Monoid+++-- * Single Predicated Step++data PredStep k c s a = forall 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) +  , -- | 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))+  } deriving (Typeable)++instance ( Show s+         , Show k+         ) => Show (PredStep k c s a) where+  show (PredStep t _ _ _) = "PredStep {predTag=" ++ show t ++ ", ...}"++instance Functor (c s) => Functor (PredStep k c s) where+  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 k c) where+  lookup (t:|ts) (PredStep _ 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)++singletonPred :: Monoid (c s (r -> a)) => k -> (s -> Maybe r) -> (r -> a) -> PredStep k c s a+singletonPred i p x = PredStep i p (Just x) mempty+++-- * Adjacent Predicated Steps++-- | Adjacent steps+newtype PredSteps k c s a = PredSteps+  { unPredSteps :: [PredStep k c s a]+  } deriving (Show, Functor, Typeable)++-- | 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 ( Eq s+         , Eq k+         ) => Monoid (PredSteps k c s a) where+  mempty  = PredSteps []+  mappend = unionPred++-- | @Last@-style instance+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

@@ -0,0 +1,174 @@+{-# LANGUAGE+    GeneralizedNewtypeDeriving+  , MultiParamTypeClasses+  , DeriveFunctor+  , BangPatterns+  , FlexibleContexts+  , TypeFamilies+  #-}++{- |+Module      : Data.Trie.Pred.Interface+Copyright   : (c) 2015 Athan Clark++License     : BSD-style+Maintainer  : athan.clark@gmail.com+Stability   : experimental+Portability : GHC++This module defines a "builder" monad, which aides in the process of building+a trie. It's a monad transformer, so you can use it alongside whichever+context you're already working in.++> myBuilder :: ( Eq k+>              , Hashable k+>              , MonadIO m+>              ) => PTBuilder String Int m ()+> myBuilder = do+>   insertHere 0+>   insert ("some" ./ "path" ./ nil) 1+>   insert ("some" ./ pred "pred-chunk" upperPred ./ nil) 2+>   prefix ("some") $ do+>     insert ("thing" ./ nil) 3+>     insert ("else" ./ nil) 4+>     data <- liftIO (doSomething)+>     insert ("another" ./ "thing" ./ nil) data+>   where+>     uppderPred :: String -> Maybe String+>     uppderPred s | all isUpperCase s = Just s+>                  | otherwise         = Nothing+>++Then we can get our trie to perform lookups by executing the monad:++> main :: IO ()+> main = do+>   trie <- execPTBuilderT myBuilder+>   print (lookup ["foo", "bar", "baz"] trie)++-}++module Data.Trie.Pred.Interface+  ( -- * Construction+    -- ** Builder Monad+    PTBuilderT (..)+  , execPTBuilderT+  , -- ** Combinators+    insert+  , insertHere+  , prefix+  , -- ** Specifying Paths+    only+  , pred+  , (./)+  , nil+  , -- * Query+    lookup+  , match+  , matches+  , -- * Delete+    delete+  , -- * Types+    RootedPredTrie+  , PathChunks+  , PathChunk+  ) where++import Prelude hiding (lookup, pred)+import Data.Trie.Pred.Base+import Data.Trie.Pred.Interface.Types+import Data.Function.Poly+import qualified Data.Trie.Class as TC++import Data.Hashable+import Data.Monoid+import Control.Monad.State+import Control.Monad.Writer+++-- * Building Tries++newtype PTBuilderT k v m a = PTBuilderT+  { runPTBuilderT :: StateT (RootedPredTrie k v) m a+  } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (RootedPredTrie k v))++instance ( Monad m+         , Eq k+         , Hashable k+         ) => MonadWriter (RootedPredTrie k v) (PTBuilderT k v m) where+  tell x = modify' (x <>)+  listen x = do+    x' <- x+    w <- get+    return (x', w)+  pass x = do+    (x', f) <- x+    modify' f+    return x'+++execPTBuilderT :: ( Monad m+                  , Eq k+                  , Hashable k+                  ) => PTBuilderT k v m a -> m (RootedPredTrie k v)+execPTBuilderT = flip execStateT mempty . runPTBuilderT+++-- * Combinators++insert :: ( Monad m+          , Eq k+          , Hashable k+          , Singleton (PathChunks k xs)+              childContent+              (RootedPredTrie k resultContent)+          , cleanxs ~ CatMaybes xs+          , ArityTypeListIso childContent cleanxs resultContent+          ) => PathChunks k xs+            -> childContent+            -> PTBuilderT k resultContent m ()+insert !ts !vl =+  modify' ((singleton ts vl) <>)+++insertHere :: ( Monad m+              , Eq k+              , Hashable k+              ) => v+                -> PTBuilderT k v m ()+insertHere = insert nil+++prefix :: ( Monad m+          , Eq k+          , Hashable k+          , cleanxs ~ CatMaybes xs+          , ExtrudeSoundly k cleanxs xs childContent resultContent+          ) => PathChunks k xs+            -> PTBuilderT k childContent  m ()+            -> PTBuilderT k resultContent m ()+prefix !ts cs = do+  trie <- lift (execPTBuilderT cs)+  modify' ((extrude ts trie) <>)+++lookup :: ( Eq k+          , Hashable k+          ) => [k] -> RootedPredTrie k a -> Maybe a+lookup = TC.lookup++delete :: ( Eq k+          , Hashable k+          ) => [k] -> RootedPredTrie k a -> RootedPredTrie k a+delete = TC.delete++match :: ( Hashable k+         , Eq k+         ) => [k] -> RootedPredTrie k a -> Maybe ([k], a, [k])+match = matchRPT+++matches :: ( Hashable k+           , Eq k+           ) => [k] -> RootedPredTrie k a -> [([k], a, [k])]+matches = matchesRPT

@@ -0,0 +1,164 @@+{-# LANGUAGE+    GADTs+  , TypeOperators+  , TypeFamilies+  , KindSignatures+  , DataKinds+  , RankNTypes+  , FlexibleInstances+  , FlexibleContexts+  , UndecidableInstances+  , MultiParamTypeClasses+  , FunctionalDependencies+  , ConstraintKinds+  , BangPatterns+  , OverloadedStrings+  #-}+++{- |+Module      : Data.Trie.Pred.Interface.Types+Copyright   : (c) 2015 Athan Clark++License     : BSD-style+Maintainer  : athan.clark@gmail.com+Stability   : experimental+Portability : GHC+-}++module Data.Trie.Pred.Interface.Types+  ( -- * Heterogenous Construction+    Singleton (..)+  , Extend (..)+  , Extrude (..)+  , ExtrudeSoundly+  , CatMaybes+  , -- * Path Construction+    only+  , pred+  , (./)+  , nil+  , -- * Path Types+    PathChunk+  , PathChunks+  ) where+++import Prelude hiding (pred)+import           Data.Trie.Pred.Base+import           Data.Trie.Pred.Base.Step+import qualified Data.Trie.HashMap as HT+import qualified Data.HashMap.Lazy as HM+import Data.Hashable+import Data.Function.Poly++import Data.String (IsString (..))+++-- * Classes++-- | Convenience type-level function for removing 'Nothing's from a type list.+type family CatMaybes (xs :: [Maybe *]) :: [*] where+  CatMaybes '[]               = '[]+  CatMaybes ('Nothing  ': xs) =      CatMaybes xs+  CatMaybes (('Just x) ': xs) = x ': CatMaybes xs++-- | Creates a string of nodes - a trie with a width of 1.+class Singleton chunks a trie | chunks a -> trie where+  singleton :: chunks -> a -> trie++-- Basis+instance Singleton (PathChunks k '[]) a (RootedPredTrie k a) where+  singleton Nil r = RootedPredTrie (Just r) emptyPT++-- Successor+instance ( Singleton (PathChunks k xs) new trie0+         , Extend (PathChunk k x) trie0 trie1+         ) => Singleton (PathChunks k (x ': xs)) new trie1 where+  singleton (Cons u us) r = extend u $! singleton us r+++-- | Turn a list of tries (@Rooted@) into a node with those children+class Extend eitherUrlChunk child result | eitherUrlChunk child -> result where+  extend :: eitherUrlChunk -> child -> result++-- | Literal case+instance ( Eq k+         , Hashable k+         ) => Extend (PathChunk k 'Nothing) (RootedPredTrie k a) (RootedPredTrie k a) where+  extend (Lit t) (RootedPredTrie mx xs) = RootedPredTrie Nothing $+    PredTrie (HT.HashMapStep $! HM.singleton t (HT.HashMapChildren mx $ Just xs)) mempty++-- | Existentially quantified case+instance ( Eq k+         , Hashable k+         ) => 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])+++-- | @FoldR Extend start chunks ~ result@+class Extrude chunks start result | chunks start -> result where+  extrude :: chunks -> start -> result++-- Basis+instance Extrude (PathChunks k '[]) (RootedPredTrie k a) (RootedPredTrie k a) where+  extrude Nil r = r++-- Successor+instance ( Extrude (PathChunks k xs) trie0 trie1+         , Extend  (PathChunk k x)   trie1 trie2+         ) => Extrude (PathChunks k (x ': xs)) trie0 trie2 where+  extrude (Cons u us) r = extend u $! extrude us r+++-- | A simple proof showing that the list version and function version are+--   interchangable.+type ExtrudeSoundly k cleanxs xs c r =+  ( cleanxs ~ CatMaybes xs+  , ArityTypeListIso c cleanxs r+  , Extrude (PathChunks k xs)+      (RootedPredTrie k c)+      (RootedPredTrie k r)+  )++-- * Query Types++-- | Match a literal key+only :: k -> PathChunk k 'Nothing+only = Lit++-- | Match with a predicate against the url chunk directly.+pred :: k -> (k -> Maybe r) -> PathChunk k ('Just r)+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)++-- | Use raw strings instead of prepending @l@+instance IsString k => IsString (PathChunk k 'Nothing) where+  fromString = Lit . fromString++-- | Container when defining route paths+data PathChunks k (xs :: [Maybe *]) where+  Cons :: PathChunk k mx+       -> PathChunks k xs+       -> PathChunks k (mx ': xs)+  Nil  :: PathChunks k '[]+++-- | The cons-cell for building a query path.+(./) :: PathChunk k mx -> PathChunks k xs -> PathChunks k (mx ': xs)+(./) = Cons++infixr 9 ./++-- | The basis, equivalent to @[]@+nil :: PathChunks k '[]+nil = Nil

@@ -1,91 +0,0 @@-{-# LANGUAGE-    ExistentialQuantification-  , FlexibleContexts-  , 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 Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE-import qualified Data.Text          as T--import Data.Typeable-import Data.Functor.Syntax-import Data.Monoid----- * Single Predicated Step--data PredStep c s a = forall r. PredStep-  { 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---- | Lookup and delete only - can't arbitrarilly construct a predicated trie.-instance Trie NonEmpty s c => Trie NonEmpty s (PredStep c) where-  lookup (t:|ts) (PredStep _ 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)--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----- * Adjacent Predicated Steps---- | Adjacent steps-newtype PredSteps c s a = PredSteps-  { unPredSteps :: [PredStep c s a]-  } 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--instance Eq s => Monoid (PredSteps c s a) where-  mempty  = PredSteps []-  mappend = unionPred---- | @Last@-style instance-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))-unionPred x (PredSteps []) = x-unionPred (PredSteps []) y = y

@@ -4,8 +4,8 @@  module Data.Trie.PredSpec where -import Data.Trie.Pred-import Data.Trie.Pred.Step+import Data.Trie.Pred.Base+import Data.Trie.Pred.Base.Step import Data.Trie.Class import Data.Trie.HashMap (HashMapStep (..)) import Data.List.NonEmpty (NonEmpty (..))