diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 diff --git a/pred-trie.cabal b/pred-trie.cabal --- a/pred-trie.cabal +++ b/pred-trie.cabal @@ -1,5 +1,5 @@ Name: pred-trie -Version: 0.4.1 +Version: 0.5.0 Author: Athan Clark Maintainer: Athan Clark 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 diff --git a/src/Data/Trie/Pred.hs b/src/Data/Trie/Pred.hs --- a/src/Data/Trie/Pred.hs +++ b/src/Data/Trie/Pred.hs @@ -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" , -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 diff --git a/src/Data/Trie/Pred/Base.hs b/src/Data/Trie/Pred/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Pred/Base.hs @@ -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" , +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) diff --git a/src/Data/Trie/Pred/Base/Step.hs b/src/Data/Trie/Pred/Base/Step.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Pred/Base/Step.hs @@ -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 diff --git a/src/Data/Trie/Pred/Interface.hs b/src/Data/Trie/Pred/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Pred/Interface.hs @@ -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 diff --git a/src/Data/Trie/Pred/Interface/Types.hs b/src/Data/Trie/Pred/Interface/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Pred/Interface/Types.hs @@ -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 diff --git a/src/Data/Trie/Pred/Step.hs b/src/Data/Trie/Pred/Step.hs deleted file mode 100644 --- a/src/Data/Trie/Pred/Step.hs +++ /dev/null @@ -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 diff --git a/test/Data/Trie/PredSpec.hs b/test/Data/Trie/PredSpec.hs --- a/test/Data/Trie/PredSpec.hs +++ b/test/Data/Trie/PredSpec.hs @@ -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 (..))