packages feed

pred-trie 0.2.4 → 0.3.0

raw patch · 10 files changed

+306/−674 lines, 10 filesdep +attoparsecdep +containersdep +pred-triedep −quickcheck-instancesdep −tastydep −tasty-hunitdep ~basedep ~composition-extra

Dependencies added: attoparsec, containers, pred-trie, sets, text, tries

Dependencies removed: quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: base, composition-extra

Files

+ bench/Bench.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++module Main where+++import Prelude hiding (lookup)+import           Data.Trie.Pred+import           Data.Trie.Pred.Step (PredStep (..), PredSteps (..))+import           Data.Trie.Class+import           Data.Trie.Map (MapStep (..))+import qualified Data.Map as Map+import           Data.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+              (MapStep $ unUnion $ foldMap (Union . genStep) [1..100])+              (PredSteps [])+  where genStep n = Map.singleton (T.pack $ show n) (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+++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+      ]+    ]+  ]
− bench/SimpleVShort.hs 
@@ -1,64 +0,0 @@-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-                  ]-  ]
pred-trie.cabal view
@@ -1,5 +1,5 @@ Name:                   pred-trie-Version:                0.2.4+Version:                0.3.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -14,41 +14,52 @@   Default-Language:     Haskell2010   HS-Source-Dirs:       src   GHC-Options:          -Wall-  Exposed-Modules:      Data.Trie.Pred.Unified-                        Data.Trie.Pred.Unified.Tail-                        Data.Trie.Pred.Disjoint-                        Data.Trie.Pred.Disjoint.Tail+  Exposed-Modules:      Data.Trie.Pred+                        Data.Trie.Pred.Step   Build-Depends:        base >= 4.6 && < 5                       , semigroups                       , mtl-                      , composition-extra >= 1.2+                      , containers+                      , composition-extra >= 2.0.0+                      , tries >= 0.0.2                       , QuickCheck -Test-Suite spec+-- Test-Suite spec+--   Type:                 exitcode-stdio-1.0+--   Default-Language:     Haskell2010+--   Hs-Source-Dirs:       src+--                       , test+--   Ghc-Options:          -Wall -threaded+--   Main-Is:              Spec.hs+--   Other-Modules:        Data.Trie.PredSpec+--   Build-Depends:        base+--                       , tasty+--                       , tasty-quickcheck+--                       , tasty-hunit+--                       , QuickCheck+--                       , quickcheck-instances+--                       , semigroups+--                       , mtl+--                       , composition-extra++Benchmark bench   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010-  Hs-Source-Dirs:       src-                      , test-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Build-Depends:        base-                      , tasty-                      , tasty-quickcheck-                      , tasty-hunit-                      , QuickCheck-                      , quickcheck-instances-                      , semigroups-                      , mtl-                      , composition-extra--Benchmark simplevshort-    Type:               exitcode-stdio-1.0-    Main-Is:            SimpleVShort.hs-    HS-Source-Dirs:     bench+  Main-Is:              Bench.hs+  HS-Source-Dirs:       bench                       , src-    Build-Depends:      base+  Ghc-Options:          -Wall -threaded+  Build-Depends:        base+                      , pred-trie+                      , tries+                      , containers                       , criterion                       , semigroups+                      , attoparsec+                      , text+                      , composition-extra+                      , QuickCheck+                      , sets  Source-Repository head   Type:                 git
+ src/Data/Trie/Pred.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE+    ExistentialQuantification+  , FlexibleContexts+  , FlexibleInstances+  , MultiParamTypeClasses+  , DeriveFunctor+  #-}++module Data.Trie.Pred where++import Prelude hiding (lookup)+import Data.Trie.Pred.Step+import Data.Trie.Class+import qualified Data.Trie.Map as MT+import qualified Data.Map as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Data.Functor.Syntax+import Data.Monoid+import Data.Maybe (fromMaybe)++++-- * Predicated Trie++data PredTrie s a = PredTrie+  { predLits  :: MT.MapStep PredTrie s a+  , predPreds :: PredSteps PredTrie s a+  } deriving (Functor)++instance Ord s => Trie NonEmpty s PredTrie where+  lookup ts (PredTrie ls ps) =+    getFirst $ First (lookup ts ls) <> First (lookup ts ps)+  delete ts (PredTrie ls ps) = PredTrie (delete ts ls) (delete ts ps)+  insert ts x (PredTrie ls ps) = PredTrie (insert ts x ls) ps -- can only insert literals++instance Ord s => Monoid (PredTrie s a) where+  mempty = PredTrie mempty mempty+  mappend (PredTrie ls1 ps1) (PredTrie ls2 ps2) =+    PredTrie (ls1 <> ls2) (ps1 <> ps2)++emptyPT :: PredTrie s a+emptyPT = PredTrie MT.empty (PredSteps [])++++-- 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 :: Ord s => NonEmpty s -> PredTrie s a -> Maybe (NonEmpty s, a, [s])+matchPT (t:|ts) (PredTrie ls (PredSteps ps)) = getFirst $+  First (goLit ls) <> foldMap (First . goPred) ps+  where+    goLit (MT.MapStep xs) = do+      (mx,mxs) <- Map.lookup t xs+      let mFoundHere = do x <- mx+                          return (t:|[], x, [])+      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 :: Ord s => NonEmpty s -> PredTrie s a -> [(NonEmpty s, a, [s])]+matchesPT (t:|ts) (PredTrie ls (PredSteps ps)) =+  fromMaybe [] $ getFirst $ First (goLit ls) <> foldMap (First . goPred) ps+  where+    goLit (MT.MapStep xs) = do+      (mx,mxs) <- Map.lookup t xs+      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 Predicated Trie++data RootedPredTrie s a = RootedPredTrie+  { rootedBase :: Maybe a+  , rootedSub  :: PredTrie s a+  } deriving (Functor)++instance Ord s => Trie [] s RootedPredTrie where+  lookup [] (RootedPredTrie mx _) = mx+  lookup ts (RootedPredTrie _ xs) = lookup (NE.fromList ts) xs++  delete [] (RootedPredTrie _ xs) = RootedPredTrie Nothing xs+  delete 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 Ord s => Monoid (RootedPredTrie s a) where+  mempty = emptyRPT+  mappend (RootedPredTrie mx xs) (RootedPredTrie my ys) = RootedPredTrie+    (getLast $ Last mx <> Last my) $ xs <> ys+++emptyRPT :: RootedPredTrie s a+emptyRPT = RootedPredTrie Nothing emptyPT++matchRPT :: Ord s => [s] -> RootedPredTrie s a -> Maybe ([s], a, [s])+matchRPT [] (RootedPredTrie mx _) = do x <- mx+                                       return ([],x,[])+matchRPT ts (RootedPredTrie mx xs) = getFirst $+  First mFoundThere <> First (do x <- mx+                                 return ([],x,[]))+  where mFoundThere = do (pre,x,suff) <- matchPT (NE.fromList ts) xs+                         return (NE.toList pre,x,suff)++matchesRPT :: Ord s => [s] -> RootedPredTrie s a -> [([s], a, [s])]+matchesRPT [] (RootedPredTrie mx _) = fromMaybe [] $ do x <- mx+                                                        return [([],x,[])]+matchesRPT ts (RootedPredTrie mx xs) =+  foundHere ++ fmap allowRoot (matchesPT (NE.fromList ts) xs)+  where foundHere = fromMaybe [] $ do x <- mx+                                      return [([],x,[])]+        allowRoot (pre,x,suff) = (NE.toList pre,x,suff)
− src/Data/Trie/Pred/Disjoint.hs 
@@ -1,64 +0,0 @@-module Data.Trie.Pred.Disjoint-  ( RDPTrie (..)-  , merge-  , lookup-  , lookupWithL-  , lookupNearestParent-  , litSingleton-  , litExtrude-  , module Data.Trie.Pred.Disjoint.Tail-  ) where--import Prelude hiding (lookup)-import Data.Trie.Pred.Disjoint.Tail hiding (lookup, lookupWithL, lookupNearestParent, merge)-import qualified Data.Trie.Pred.Disjoint.Tail as ND-import Data.Monoid-import qualified Data.List.NonEmpty as NE----- | A Rooted, predicate, disjointly indexed trie-data RDPTrie p t x = Rooted (Maybe x) [DPTrie p t x]--instance (Eq p, Eq t) => Monoid (RDPTrie p t x) where-  mempty = Rooted Nothing []-  mappend = Data.Trie.Pred.Disjoint.merge--merge :: (Eq p, Eq t) => RDPTrie p t x -> RDPTrie p t x -> RDPTrie p t x-merge (Rooted mx xs) (Rooted my ys) =-  Rooted my $ foldr go [] $ xs ++ ys-  where-    go :: (Eq p, Eq t) => DPTrie p t x -> [DPTrie p t x] -> [DPTrie p t x]-    go a [] = [a]-    go a (b:bs) | ND.areDisjoint a b =        a : b : bs-                | otherwise          = ND.merge a b : bs--lookup :: (Eq t) => [t] -> RDPTrie p t x -> Maybe x-lookup [] (Rooted mx _) = mx-lookup ts (Rooted _ xs) = firstJust $ map (ND.lookup $ NE.fromList ts) xs--lookupWithL :: (Eq t) => (t -> t) -> [t] -> RDPTrie p t x -> Maybe x-lookupWithL _ [] (Rooted mx _) = mx-lookupWithL f ts (Rooted _ xs) = firstJust $ map (ND.lookupWithL f $ NE.fromList ts) xs--lookupNearestParent :: (Eq t) => [t] -> RDPTrie p t x -> Maybe x-lookupNearestParent [] (Rooted mx _) = mx-lookupNearestParent ts (Rooted mx xs) =-  getFirst $ (First $ firstJust $ map (ND.lookupNearestParent $ NE.fromList ts) xs) <> First mx--firstJust :: [Maybe a] -> Maybe a-firstJust [] = Nothing-firstJust (Nothing:xs) = firstJust xs-firstJust (Just x :xs) = Just x---litSingleton :: [t] -> x -> RDPTrie p t x-litSingleton [] x = Rooted (Just x) []-litSingleton ts x = Rooted Nothing [ND.litSingletonTail (NE.fromList ts) x]---litExtrude :: [t] -> RDPTrie p t x -> RDPTrie p t x-litExtrude [] r = r-litExtrude [t] (Rooted mx xs) = Rooted Nothing [DMore t mx xs]-litExtrude ts (Rooted mx xs) = Rooted Nothing [ND.litExtrudeTail (init ts) $-                                                 DMore (last ts) mx xs-                                              ]
− src/Data/Trie/Pred/Disjoint/Tail.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE-  GADTs-  #-}--module Data.Trie.Pred.Disjoint.Tail-  ( DPTrie (..)-  , lookup-  , lookupWithL-  , lookupNearestParent-  , merge-  , areDisjoint-  , litSingletonTail-  , litExtrudeTail-  , sort-  ) where--import Prelude hiding (lookup)-import Data.List.NonEmpty as NE hiding (map, sort)-import Control.Applicative----data DPTrie p t x where-  DMore :: t-        -> Maybe x-        -> [DPTrie p t x]-        -> DPTrie p t x-  DPred :: p-        -> (t -> Maybe r)-        -> Maybe (r -> x)-        -> [DPTrie p t (r -> x)]-        -> DPTrie p t x----- | Overwrites when similar, leaves untouched when not-merge :: (Eq p, Eq t) => DPTrie p t x -> DPTrie p t x -> DPTrie p t x-merge xx@(DMore t mx xs) yy@(DMore p my ys)-  | t == p = DMore p my $ foldr go [] $ xs ++ ys-  | otherwise = xx-  where-    go :: (Eq p, Eq t) => DPTrie p t x -> [DPTrie p t x] -> [DPTrie p t x]-    go a [] = [a]-    go a (b:bs) | areDisjoint a b =     a : b : bs-                | otherwise       = merge a b : bs-merge xx@(DPred t q mrx xrs) yy@(DPred p w mry yrs)-  | t == p = yy-  | otherwise = xx-merge xx@(DMore t mx xs) yy@(DPred p w mrx xrs) = yy-merge xx@(DPred t q mrx xrs) yy@(DMore p my ys) = yy---areDisjoint :: (Eq p, Eq t) => DPTrie p t x -> DPTrie p t x -> Bool-areDisjoint (DMore t _ _)    (DMore p _ _)    = t == p-areDisjoint (DPred t _ _ _)  (DPred p _ _ _)  = t == p-areDisjoint _ _ = True---lookup :: Eq t => NonEmpty t -> DPTrie p t x -> Maybe x-lookup (t:|ts) (DMore t' mx xs)-  | t == t' = case ts of-    [] -> mx-    _  -> firstJust $ map (lookup $ NE.fromList ts) xs-  | otherwise = Nothing-lookup (t:|ts) (DPred _ p mrx xrs) =-  p t >>=-    \r -> case ts of-      [] -> ($ r) <$> mrx-      _  -> ($ r) <$> firstJust (map (lookup $ NE.fromList ts) xrs)--lookupWithL :: Eq t => (t -> t) -> NonEmpty t -> DPTrie p t x -> Maybe x-lookupWithL f (t:|ts) (DMore t' mx xs)-  | null ts = if f t == t'-              then mx-              else Nothing-  | otherwise = if t == t'-                then firstJust $ map (lookupWithL f $ NE.fromList ts) xs-                else Nothing-lookupWithL f (t:|ts) (DPred _ p mrx xrs) =-  p t >>=-    \r -> case ts of-      [] -> ($ r) <$> mrx-      _  -> ($ r) <$> firstJust (map (lookupWithL f $ NE.fromList ts) xrs)--lookupNearestParent :: Eq t => NonEmpty t -> DPTrie p t x -> Maybe x-lookupNearestParent tss@(t:|ts) trie@(DMore t' mx xs) = case lookup tss trie of-  Nothing -> if t == t'-               then case ts of-                      [] -> mx -- redundant; should have successful lookup-                      _  -> case firstJust $ map (lookupNearestParent $ NE.fromList ts) xs of-                              Nothing -> mx-                              justr   -> justr-               else Nothing-  justr -> justr-lookupNearestParent tss@(t:|ts) trie@(DPred t' p mrx xrs) = case lookup tss trie of-  Nothing -> p t >>=-               \r -> case ts of-                        [] -> ($ r) <$> mrx -- redundant; should have successful lookup-                        _  -> case firstJust $ map (lookupNearestParent $ NE.fromList ts) xrs of-                                Nothing -> ($ r) <$> mrx-                                justr   -> ($ r) <$> justr-  justr -> justr---firstJust :: [Maybe a] -> Maybe a-firstJust [] = Nothing-firstJust (Nothing:xs) = firstJust xs-firstJust (Just x :xs) = Just x---litSingletonTail :: NonEmpty t -> x -> DPTrie p t x-litSingletonTail (t:|[]) x = DMore t (Just x) []-litSingletonTail (t:|ts) x = DMore t Nothing  [litSingletonTail (NE.fromList ts) x]---litExtrudeTail :: [t] -> DPTrie p t x -> DPTrie p t x-litExtrudeTail [] r = r-litExtrudeTail (t:ts) r = DMore t Nothing [litExtrudeTail ts r]---sort :: (Eq p, Eq t) => [DPTrie p t x] -> [DPTrie p t x]-sort = foldr insert []-  where-    insert :: (Eq p, Eq t) => DPTrie p t x -> [DPTrie p t x] -> [DPTrie p t x]-    insert r [] = [r]-    insert x@(DMore t _ _) (y@(DMore p _ _):rs)-      | t == p = x : rs-      | otherwise = x : y : rs-    insert x@(DMore t _ _) (y@(DPred p _ _ _):rs) =-        x : y : rs-    insert x@(DPred t _ _ _) (y@(DPred p _ _ _):rs)-      | t == p = x : rs -- basis-      | otherwise = x : y : rs-    insert x@(DPred t _ _ _) (y@(DMore p _ _):rs) =-        y : insert x rs
+ src/Data/Trie/Pred/Step.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE+    ExistentialQuantification+  , FlexibleContexts+  , FlexibleInstances+  , MultiParamTypeClasses+  , DeriveFunctor+  #-}++module Data.Trie.Pred.Step where++import Prelude hiding (lookup)+import Data.Trie.Class+import qualified Data.Trie.Map as MT+import qualified Data.Map as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Data.Functor.Syntax+import Data.Monoid+import Data.Maybe (fromMaybe)+++-- * Single Predicated Step++data PredStep c s a = forall r. PredStep+  { predTag  :: s -- ^ Unique identifier for the predicate - used for combination+  , predPred :: s -> Maybe r+  , predData :: Maybe (r -> a)+  , predSub  :: c s (r -> a)+  }++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)) => s -> (s -> Maybe r) -> (r -> a) -> PredStep c s a+singletonPred i p x = PredStep i p (Just x) mempty+++-- * Adjacent Predicated Steps++newtype PredSteps c s a = PredSteps+  { unPredSteps :: [PredStep c s a] }+  deriving (Functor)++-- | 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 :: Eq s => PredSteps c s a -> PredSteps c s a -> PredSteps c s a+unionPred (PredSteps (xss@(PredStep i p mx xs):pxs)) (PredSteps (yss@(PredStep j q my ys):pys))+  | i == j = PredSteps $ yss : unPredSteps (unionPred (PredSteps pxs) (PredSteps pys))+  | otherwise = PredSteps $ xss : yss : unPredSteps (unionPred (PredSteps pxs) (PredSteps pys))+unionPred x (PredSteps []) = x+unionPred (PredSteps []) y = y
− src/Data/Trie/Pred/Unified.hs 
@@ -1,112 +0,0 @@-module Data.Trie.Pred.Unified-  ( RUPTrie (..)-  , UPTrie (..)-  , assignLit-  , showTrie-  , merge-  , elem-  , lookup-  , lookupWithL-  , lookupNearestParent-  , lookupThrough-  , litSingleton-  , litExtrude-  ) where--import Prelude hiding (lookup, map, elem)-import           Data.Trie.Pred.Unified.Tail (UPTrie (..), showTail)-import qualified Data.Trie.Pred.Unified.Tail as NU-import qualified Data.List.NonEmpty as NE-import Data.Monoid-import Data.Maybe-import Data.Functor.Syntax--import Test.QuickCheck---data RUPTrie t x = Rooted { root :: Maybe x-                          , children :: [UPTrie t x] }-  deriving (Eq)--instance Functor (RUPTrie t) where-  fmap = map--map :: (a -> b) -> RUPTrie t a -> RUPTrie t b-map f (Rooted mx xs) = Rooted (f <$> mx) $ f <$$> xs--instance Foldable (RUPTrie t) where-  foldMap f (Rooted mx xs) = fromMaybe (foldMap (foldMap f) xs) $ f <$> mx--showTrie :: Show t => RUPTrie t x -> String-showTrie (Rooted mx xs) =-  if isNothing mx-  then "(NoRoot) [" ++ concatMap showTail xs ++ "] "-  else "(Root) [" ++ concatMap showTail xs ++ "] "--instance (Eq t) => Monoid (RUPTrie t x) where-  mempty = Rooted Nothing []-  mappend = Data.Trie.Pred.Unified.merge--merge :: (Eq t) => RUPTrie t x -> RUPTrie t x -> RUPTrie t x-merge (Rooted mx xs) (Rooted my ys) =-  Rooted (getLast $ Last mx <> Last my) $ NU.sort $ foldr go [] $ xs ++ ys-  where-    go :: (Eq t) => UPTrie t x -> [UPTrie t x] -> [UPTrie t x]-    go a [] = [a]-    go a (b:bs) | NU.areDisjoint a b =        a : b : bs-                | otherwise          = NU.merge a b : bs--instance (Show t) => Show (RUPTrie t x) where-  show = showTrie--instance (Arbitrary t, Arbitrary x) => Arbitrary (RUPTrie t x) where-  arbitrary = do-    mx <- arbitrary-    xs <- arbitrary `suchThat` (\x -> length x < 10)-    return $ Rooted mx xs---assignLit :: Eq t => [t] -> Maybe x -> RUPTrie t x -> RUPTrie t x-assignLit [] mx (Rooted _ ys) = Rooted mx ys-assignLit ts mx (Rooted my ys) = Rooted my $-  NU.assignLit (NE.fromList ts) mx <$> ys--elem :: (Eq t) => [t] -> RUPTrie t x -> Bool-elem ts = isJust . lookup ts--lookup :: (Eq t) => [t] -> RUPTrie t x -> Maybe x-lookup [] (Rooted mx _) = mx-lookup ts (Rooted _ xs) = firstJust $ NU.lookup (NE.fromList ts) <$> xs---- | Applies @f@ to the last chunk.-lookupWithL :: (Eq t) => (t -> t) -> [t] -> RUPTrie t x -> Maybe x-lookupWithL _ [] (Rooted mx _) = mx-lookupWithL f ts (Rooted _ xs) = firstJust $ NU.lookupWithL f (NE.fromList ts) <$> xs--lookupNearestParent :: (Eq t) => [t] -> RUPTrie t x -> Maybe x-lookupNearestParent [] (Rooted mx _) = mx-lookupNearestParent ts (Rooted mx xs) =-  firstJust $ (NU.lookupNearestParent (NE.fromList ts) <$> xs) ++ [mx]---- | Append contents up-to lookup path.-lookupThrough :: (Eq t) => [t] -> RUPTrie t x -> [x]-lookupThrough [] (Rooted mx _) = maybeToList mx-lookupThrough ts (Rooted mx xs) =-  maybeToList mx ++ NU.firstNonEmpty (NU.lookupThrough (NE.fromList ts) <$> xs)--litSingleton :: [t] -> x -> RUPTrie t x-litSingleton [] x = Rooted (Just x) []-litSingleton ts x = Rooted Nothing [NU.litSingletonTail (NE.fromList ts) x]---litExtrude :: [t] -> RUPTrie t x -> RUPTrie t x-litExtrude [] r = r-litExtrude [t] (Rooted mx xs) = Rooted Nothing [UMore t mx xs]-litExtrude ts (Rooted mx xs) = Rooted Nothing [NU.litExtrudeTail (init ts) $-                                                 UMore (last ts) mx xs-                                              ]---- * Utilities--firstJust :: [Maybe a] -> Maybe a-firstJust = getFirst . foldMap First
− src/Data/Trie/Pred/Unified/Tail.hs 
@@ -1,261 +0,0 @@-{-# LANGUAGE-    GADTs-  #-}--module Data.Trie.Pred.Unified.Tail-  ( UPTrie (..)-  , suppliment-  , tagUPTrie-  , measureDepthRelative-  , minDepth-  , maxDepth-  , showTail-  , assignLit-  , elem-  , lookup-  , lookupWithL-  , lookupNearestParent-  , lookupThrough-  , firstNonEmpty-  , merge-  , areDisjoint-  , litSingletonTail-  , litExtrudeTail-  , sort-  ) where--import Prelude hiding (lookup, elem, map)-import Data.List.NonEmpty as NE hiding (map, sort, length)-import Data.Semigroup hiding (First (..), Last (..))-import Data.Monoid hiding ((<>))-import Data.Maybe-import Data.Functor.Syntax-import Control.Applicative-import Control.Monad--import Test.QuickCheck----data UPTrie t x where-  UMore :: t-        -> Maybe x-        -> [UPTrie t x]-        -> UPTrie t x-  UPred :: t-        -> (t -> Maybe r)-        -> Maybe (r -> x)-        -> [UPTrie t (r -> x)]-        -> UPTrie t x----- | Given a parser and a chunk, take a trie expecting a result, and--- possibly return a reduced trie without the expectation.-suppliment :: (t -> Maybe r) -> t -> UPTrie t (r -> x) -> Maybe (UPTrie t x)-suppliment p t xrs = (xrs <~$>) <$> p t---- | Acts as a default tag value for the node-tagUPTrie :: UPTrie t x -> t-tagUPTrie (UMore t _ _) = t-tagUPTrie (UPred t _ _ _) = t---- | Measure the depth of a trie, based on the relation of other adjacent depths-measureDepthRelative :: ([Int] -> Int) -> UPTrie t x -> Int-measureDepthRelative f = go 0-  where-    go :: Int -> UPTrie t x -> Int-    go n (UMore _ _ xs) =-      f $ go (n+1) <$> xs-    go n (UPred t p _ xrs) =-      f $ go (n+1) <$> mapMaybe (suppliment p t) xrs--maxDepth :: UPTrie t x -> Int-maxDepth = measureDepthRelative maximum'-  where-    maximum' [] = 1-    maximum' xs = maximum xs--minDepth :: UPTrie t x -> Int-minDepth = measureDepthRelative minimum'-  where-    minimum' [] = 1-    minimum' xs = minimum xs--instance Functor (UPTrie t) where-  fmap = map--map :: (a -> b) -> UPTrie t a -> UPTrie t b-map f (UMore t mx xs) = UMore t (f <$> mx) $ f <$$> xs-map f (UPred t p mrx xrs) = UPred t p (f <.$> mrx) $ f <.$$> xrs--instance Foldable (UPTrie t) where-  foldMap f xs = fromMaybe mempty $ unwrapMonoid $ go $ f <$> xs-    where-      go (UMore _ mx xs') = WrapMonoid mx <> WrapMonoid (foldMap (unwrapMonoid . go) xs')-      go (UPred t p mrx xrs) = WrapMonoid (mrx <*> p t) <> WrapMonoid (mconcat-        (mapMaybe (\z -> (\r -> unwrapMonoid $ go $ z <~$> r) <$> p t) xrs))--instance (Eq t, Eq x) => Eq (UPTrie t x) where-  (UMore s mx xs) == (UMore t my ys) = t == s && mx == my && xs == ys-  (UPred s p mx xs) == (UPred t q my ys) = s == t-                                        && (mx <*> p s) == (my <*> q t)-                                        && (suppliment p s <$> xs) -- same children-                                        == (suppliment q t <$> ys)-  (UMore s mx xs) == (UPred t q my ys) = s == t-                                      && mx == (my <*> q t)-                                      && (Just <$> xs) == (suppliment q t <$> ys)-  (UPred s p mx xs) == (UMore t my ys) = s == t-                                      && (mx <*> p s) == my-                                      && (suppliment p s <$> xs) == (Just <$> ys)--instance Eq t => Semigroup (UPTrie t x) where-  (<>) = merge---- | Overwrites when similar, leaves untouched when not-merge :: (Eq t) => UPTrie t x -> UPTrie t x -> UPTrie t x-merge xx@(UMore t mx xs) (UMore p my ys)-  | t == p = UMore p (getLast $ Last mx <> Last my) $ sort $ xs ++ ys-  | otherwise = xx-merge xx@(UPred t _ _ _) yy@(UPred p _ _ _)-  | t == p = yy -- predicate children are incompatible-  | otherwise = xx-merge xx@(UMore t _ _) yy@(UPred p _ _ _)-  | t == p = yy -- rightward bias-  | otherwise = xx-merge xx@(UPred t _ _ _) yy@(UMore p _ _)-  | t == p = yy -- rightward bias-  | otherwise = xx---- | Can only generate literal examples-instance (Arbitrary t, Arbitrary x) => Arbitrary (UPTrie t x) where-  arbitrary = sized go-    where-      go s = do-        t <- arbitrary-        mx <- arbitrary-        xs <- if s <= 1 then return []-                        else scale (subtract 1) arbitrary `suchThat` (\x -> length x < 10)-        return $ UMore t mx xs--showTail :: (Show t) => UPTrie t x -> String-showTail (UMore t _ xs) = "(UMore " ++ show t ++ ") [" ++ concatMap showTail xs ++ "] "-showTail (UPred t _ _ xs) = "(UPred " ++ show t ++ ") [" ++ concatMap showTail xs ++ "] "---- | Ignores contents-instance (Show t) => Show (UPTrie t x) where-  show = showTail----type Path t = NonEmpty t---- | Assigns a value to literal constructors-assignLit :: (Eq t) => Path t -> Maybe x -> UPTrie t x -> UPTrie t x-assignLit (t:|ts) mx yy@(UMore p my ys)-  | t == p = if null ts-             then UMore p mx ys-             else UMore p my $ fmap (assignLit (NE.fromList ts) mx) ys-  | otherwise = yy-assignLit _ _ yy = yy---areDisjoint :: (Eq t) => UPTrie t x -> UPTrie t x -> Bool-areDisjoint (UMore t _ _)    (UMore p _ _)    = t /= p-areDisjoint (UPred t _ _ _)  (UPred p _ _ _)  = t /= p-areDisjoint (UPred t _ _ _)  (UMore p _ _)    = t /= p-areDisjoint (UMore t _ _)    (UPred p _ _ _)  = t /= p--elem :: Eq t => Path t -> UPTrie t x -> Bool-elem ts = isJust . lookup ts--lookup :: Eq t => Path t -> UPTrie t x -> Maybe x-lookup (t:|ts) (UMore t' mx xs) = do-  guard (t == t')-  if null ts then mx-             else firstJust $ fmap (lookup $ NE.fromList ts) xs-lookup (t:|ts) (UPred _ p mrx xrs) = do-  r <- p t-  if null ts then mrx <~$> r-             else firstJust (fmap (lookup $ NE.fromList ts) xrs) <~$> r---- | Apply a transform @f@ to the final path chunk, when matching a literal--- cell - used for eliminating file extensions in nested-routes.-lookupWithL :: Eq t => (t -> t) -> Path t -> UPTrie t x -> Maybe x-lookupWithL f (t:|ts) (UMore t' mx xs)-  | null ts = do guard (f t == t')-                 mx-  | otherwise = do guard (t == t')-                   firstJust $ fmap (lookupWithL f $ NE.fromList ts) xs-lookupWithL f (t:|ts) (UPred _ p mrx xrs) = do-  r <- p t-  if null ts then mrx <~$> r-             else firstJust (fmap (lookupWithL f $ NE.fromList ts) xrs) <~$> r--lookupNearestParent :: Eq t => Path t -> UPTrie t x -> Maybe x-lookupNearestParent tss@(t:|ts) trie@(UMore t' mx xs) = firstJust-  [ lookup tss trie-  , do guard (t == t')-       firstJust $ fmap (lookupNearestParent $ NE.fromList ts) xs ++ [mx]-  ]-lookupNearestParent tss@(t:|ts) trie@(UPred _ p mrx xrs) = firstJust-  [ lookup tss trie-  , do r <- p t-       firstJust (fmap (lookupNearestParent $ NE.fromList ts) xrs ++ [mrx]) <~$> r-  ]---- | Return all nodes passed during a lookup-lookupThrough :: Eq t => Path t -> UPTrie t x -> [x]-lookupThrough (t:|ts) (UMore t' mx xs) = do-  guard $ t == t'-  maybeToList mx ++ (do guard $ null ts-                        firstNonEmpty $ fmap (lookupThrough $ NE.fromList ts) xs)-lookupThrough (t:|ts) (UPred _ p mrx xrs) =-  let (left,right) = fromMaybe (Nothing,[]) $ do-                r <- p t-                return $ if null ts-                         then ( mrx <~$> r, [])-                         else ( mrx <~$> r-                              , firstNonEmpty (fmap (lookupThrough $ NE.fromList ts) xrs) <~$> r-                              )-  in maybeToList left ++ right--firstNonEmpty :: [[a]] -> [a]-firstNonEmpty [] = []-firstNonEmpty (x:xs) | null x = firstNonEmpty xs-                     | otherwise = x---- | Create a singleton trie out of literal constructors-litSingletonTail :: Path t -> x -> UPTrie t x-litSingletonTail (t:|[]) x = UMore t (Just x) []-litSingletonTail (t:|ts) x = UMore t Nothing  [litSingletonTail (NE.fromList ts) x]---- | Push a trie down with literal constructors-litExtrudeTail :: [t] -> UPTrie t x -> UPTrie t x-litExtrudeTail [] r = r-litExtrudeTail (t:ts) r = UMore t Nothing [litExtrudeTail ts r]----- | also does a non-deterministic merge - make sure your nodes are disjoint & clean-sort :: (Eq t) => [UPTrie t x] -> [UPTrie t x]-sort = foldr insert' []-  where-    insert' :: (Eq t) => UPTrie t x -> [UPTrie t x] -> [UPTrie t x]-    insert' r [] = [r]-    insert' x@(UMore t _ _) (y@(UMore p _ _):rs)-      | t == p = x : rs-      | otherwise = x : y : rs-    insert' x@(UMore t _ _) (y@(UPred p _ _ _):rs)-      | t == p = x : rs-      | otherwise = x : y : rs-    insert' x@(UPred t _ _ _) (y@(UPred p _ _ _):rs)-      | t == p = x : rs-      | otherwise = x : y : rs-    insert' x@(UPred t _ _ _) (y@(UMore p _ _):rs)-      | t == p = insert' x rs -- Puts @UPred@ at the bottom-      | otherwise = y : insert' x rs----- * Utilities--firstJust :: [Maybe a] -> Maybe a-firstJust = getFirst . foldMap First
− test/Spec.hs 
@@ -1,13 +0,0 @@-module Main where--import Data.Trie.Pred.UnifiedSpec--import Test.Tasty---main :: IO ()-main = defaultMain tests--tests :: TestTree-tests = testGroup "Testing..."-  [unifiedSpec]