packages feed

pred-trie 0.2.0 → 0.2.1

raw patch · 5 files changed

+265/−108 lines, 5 filesdep +composition-extradep +mtldep +tastydep −hspecsetup-changed

Dependencies added: composition-extra, mtl, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: hspec

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
pred-trie.cabal view
@@ -1,5 +1,5 @@ Name:                   pred-trie-Version:                0.2.0+Version:                0.2.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -20,6 +20,9 @@                         Data.Trie.Pred.Disjoint.Tail   Build-Depends:        base >= 4.6 && < 5                       , semigroups+                      , mtl+                      , composition-extra >= 1.2+                      , QuickCheck  Test-Suite spec   Type:                 exitcode-stdio-1.0@@ -29,9 +32,14 @@   Ghc-Options:          -Wall   Main-Is:              Spec.hs   Build-Depends:        base-                      , hspec+                      , tasty+                      , tasty-quickcheck+                      , tasty-hunit                       , QuickCheck                       , quickcheck-instances+                      , semigroups+                      , mtl+                      , composition-extra  Benchmark simplevshort     Type:               exitcode-stdio-1.0
src/Data/Trie/Pred/Unified.hs view
@@ -3,42 +3,49 @@   , assignLit   , showTrie   , merge+  , elem   , lookup   , lookupWithL   , lookupNearestParent+  , lookupThrough   , litSingleton   , litExtrude-  , module Data.Trie.Pred.Unified.Tail   ) where -import Prelude hiding (lookup)-import Data.Trie.Pred.Unified.Tail hiding (lookup, lookupWithL, lookupNearestParent, merge, assignLit)+import Prelude hiding (lookup, map, elem)+import           Data.Trie.Pred.Unified.Tail (UPTrie (..), showTail) import qualified Data.Trie.Pred.Unified.Tail as NU-import Data.Monoid-import Data.Maybe (fromMaybe) 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) = case mx of-  Nothing -> "(NoRoot) [" ++ concatMap showTail xs ++ "] "-  Just x  -> "(Root) [" ++ concatMap showTail xs ++ "] "+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 -instance (Show t) => Show (RUPTrie t x) where-  show = showTrie--assignLit :: Eq t => [t] -> Maybe x -> RUPTrie t x -> RUPTrie t x-assignLit [] mx (Rooted my ys) = Rooted mx ys-assignLit ts mx (Rooted my ys) = Rooted my $-  map (NU.assignLit (NE.fromList ts) mx) ys- 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@@ -48,23 +55,43 @@     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 $ map (NU.lookup $ NE.fromList ts) xs+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 $ map (NU.lookupWithL f $ NE.fromList ts) xs+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) =-  getFirst $ (First $ firstJust $ map (NU.lookupNearestParent $ NE.fromList ts) xs) <> First mx+  firstJust $ (NU.lookupNearestParent (NE.fromList ts) <$> xs) ++ [mx] -firstJust :: [Maybe a] -> Maybe a-firstJust [] = Nothing-firstJust (Nothing:xs) = firstJust xs-firstJust (Just x :xs) = Just x+-- | Append contents up-to lookup path.+lookupThrough :: (Eq t, Monoid x) => [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) []@@ -77,3 +104,8 @@ 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 view
@@ -1,14 +1,22 @@ {-# LANGUAGE-  GADTs+    GADTs   #-}  module Data.Trie.Pred.Unified.Tail   ( UPTrie (..)+  , suppliment+  , tagUPTrie+  , measureDepthRelative+  , minDepth+  , maxDepth   , showTail   , assignLit+  , elem   , lookup   , lookupWithL   , lookupNearestParent+  , lookupThrough+  , firstNonEmpty   , merge   , areDisjoint   , litSingletonTail@@ -16,12 +24,19 @@   , sort   ) where -import Prelude hiding (lookup)-import Data.List.NonEmpty as NE hiding (map, sort)+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@@ -33,100 +48,186 @@         -> [UPTrie t (r -> x)]         -> UPTrie t x -showTail :: (Show t) => UPTrie t x -> String-showTail (UMore t mx xs) = "(UMore " ++ show t ++ ") [" ++ concatMap showTail xs ++ "] "-showTail (UPred t p mx xs) = "(UPred " ++ show t ++ ") [" ++ concatMap showTail xs ++ "] " --- | Ignores contents-instance (Show t) => Show (UPTrie t x) where-  show = showTail+-- | 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 --- | Assigns a value to literal constructors-assignLit :: (Eq t) => NonEmpty t -> Maybe x -> UPTrie t x -> UPTrie t x-assignLit (t:|ts) mx yy@(UMore p my ys)-  | t == p = case ts of-               [] -> UMore p mx ys-               _  -> UMore p my $ map (assignLit (NE.fromList ts) mx) ys-  | otherwise = yy-assignLit _ _ yy@(UPred _ _ _ _) = yy+-- | 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) yy@(UMore p my ys)-  | t == p = UMore p my $ sort $ xs ++ ys+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 q mrx xrs) yy@(UPred p w mry yrs)+merge xx@(UPred t _ _ _) yy@(UPred p _ _ _)   | t == p = yy -- predicate children are incompatible   | otherwise = xx-merge xx@(UMore t mx xs) yy@(UPred p w mrx xrs)+merge xx@(UMore t _ _) yy@(UPred p _ _ _)   | t == p = yy -- rightward bias   | otherwise = xx-merge xx@(UPred t q mrx xrs) yy@(UMore p my ys)+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 => NonEmpty t -> UPTrie t x -> Maybe x-lookup (t:|ts) (UMore t' mx xs)-  | t == t' = case ts of-    [] -> mx-    _  -> firstJust $ map (lookup $ NE.fromList ts) xs-  | otherwise = Nothing-lookup (t:|ts) (UPred _ p mrx xrs) =-  p t >>=-    \r -> case ts of-      [] -> ($ r) <$> mrx-      _  -> ($ r) <$> firstJust (map (lookup $ NE.fromList ts) xrs)+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 -lookupWithL :: Eq t => (t -> t) -> NonEmpty t -> UPTrie t x -> Maybe x+-- | 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 = 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) (UPred _ 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 -> UPTrie t x -> Maybe x-lookupNearestParent tss@(t:|ts) trie@(UMore 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@(UPred 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+  | 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)+  | null ts = maybeToList $ do guard (t == t')+                               mx+  | otherwise = maybeToList mx+             ++ (do guard (t == t')+                    firstNonEmpty $ lookupThrough (NE.fromList ts) <$> xs)+lookupThrough (t:|ts) (UPred _ p mrx xrs) =+  let (l,r) = 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 l ++ r -firstJust :: [Maybe a] -> Maybe a-firstJust [] = Nothing-firstJust (Nothing:xs) = firstJust xs-firstJust (Just x :xs) = Just x+firstNonEmpty :: [[a]] -> [a]+firstNonEmpty [] = []+firstNonEmpty (x:xs) | null x = firstNonEmpty xs+                     | otherwise = x  -- | Create a singleton trie out of literal constructors-litSingletonTail :: NonEmpty t -> x -> UPTrie t x+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] @@ -136,21 +237,27 @@ litExtrudeTail (t:ts) r = UMore t Nothing [litExtrudeTail ts r]  --- also does a non-deterministic merge - make sure your nodes are disjoint & clean+-- | 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 []+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)+    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)+    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 -- basis+    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-      | otherwise = y : insert x 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 view
@@ -1,1 +1,13 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import Data.Trie.Pred.UnifiedSpec++import Test.Tasty+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Testing..."+  [unifiedSpec]