generic-trie-0.3.2/0000755000000000000000000000000007346545000012262 5ustar0000000000000000generic-trie-0.3.2/CHANGELOG.md0000644000000000000000000000072407346545000014076 0ustar00000000000000000.3.2 ----- * Add a `trieAlter` method, and use it to speed up `alter`, `insert` and `delete`. * Make the `Show` instance user friendly. * Add support for GHC versions up to 9.4. * Fix builds on GHC 7.8, and with old `containers` versions. * Stop pretending to support GHC 7.4 and 7.6. These have not actually worked in some time, and it is hard to test on them. 0.3.1 ----- * Improved strictness * GHC 8.4 compatibility 0.3.0.2 ------- * GHC 8 compatibility generic-trie-0.3.2/LICENSE0000644000000000000000000000276207346545000013276 0ustar0000000000000000Copyright (c) 2014, Eric Mertens All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Eric Mertens nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generic-trie-0.3.2/Setup.hs0000644000000000000000000000005607346545000013717 0ustar0000000000000000import Distribution.Simple main = defaultMain generic-trie-0.3.2/app/0000755000000000000000000000000007346545000013042 5ustar0000000000000000generic-trie-0.3.2/app/Main.hs0000644000000000000000000000006207346545000014260 0ustar0000000000000000module Main where main :: IO () main = putStr "" generic-trie-0.3.2/generic-trie.cabal0000644000000000000000000000436507346545000015633 0ustar0000000000000000name: generic-trie version: 0.3.2 synopsis: A map, where the keys may be complex structured data. description: This type implements maps where the keys are themselves complex structured data. For example, the keys may be the abstract syntax trees for a programming language. The map is implemented as a trie, so common parts of the keys will be shared in the representation. The library provides a generic implementation of the data structure, so values of types that have support for 'Generic' may be automatically used as keys in the map. license: BSD3 license-file: LICENSE author: Eric Mertens maintainer: emertens@gmail.com category: Data build-type: Simple cabal-version: >=1.10 homepage: http://github.com/glguy/tries bug-reports: http://github.com/glguy/tries/issues tested-with: GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.2 || ==8.6.1 || ==8.8.1 || ==8.10.7 || ==9.0.2 || ==9.2.2 || ==9.4.2 extra-source-files: CHANGELOG.md library exposed-modules: Data.GenericTrie, Data.GenericTrie.Internal other-modules: Prelude build-depends: base >= 4.7.0.2 && < 4.18, transformers >= 0.2 && < 0.7, containers >= 0.4.2.1 && < 0.7 GHC-options: -O2 -Wall hs-source-dirs: src default-language: Haskell2010 -- cabal repl seems to choke on the custom prelude if you just -- run it on the library in the usual way. If you instead say -- cabal repl bogus, then it works just fine. executable bogus main-is: Main.hs hs-source-dirs: app default-language: Haskell2010 build-depends: base , generic-trie source-repository head type: git location: git://github.com/glguy/tries.git generic-trie-0.3.2/src/Data/0000755000000000000000000000000007346545000013722 5ustar0000000000000000generic-trie-0.3.2/src/Data/GenericTrie.hs0000644000000000000000000002131207346545000016455 0ustar0000000000000000{-# LANGUAGE Safe #-} {- | This module implements an interface for working with maps. For primitive types, like 'Int', the library automatically selects an efficient implementation (e.g., an "IntMap"). For complex structured types, the library uses an implementation based on tries: this is useful when using large and similar keys where comparing for order may become expensive, and storing the distinct keys would be inefficient. The 'OrdKey' type allows for maps with complex keys, where the keys are compared based on order, rather than using the trie implementation. All methods of 'TrieKey' can be derived automatically using a 'GHC.Generics.Generic' instance. @ data Demo = DemoC1 'Int' | DemoC2 'Int' 'Char' deriving 'GHC.Generics.Generic' instance 'TrieKey' Demo @ -} module Data.GenericTrie ( -- * Trie interface Trie , TrieKey , ShowTrieKey -- ** Construction , empty , singleton , fromList , fromListWith , fromListWith' -- ** Updates , alter , insert , insertWith , insertWith' , delete , at -- ** Queries , member , notMember , null , lookup -- ** Folding , foldWithKey , fold , toList -- ** Traversing , traverseWithKey , traverseMaybeWithKey , mapMaybe , mapMaybeWithKey , filter , filterWithKey -- ** Combining maps , union , unionWith , unionWithKey , intersection , intersectionWith , intersectionWithKey , difference , differenceWith , differenceWithKey -- * Keys using 'Ord' , OrdKey(..) ) where import Data.List (foldl') import Data.Maybe (isNothing, isJust) import Prelude hiding (lookup, null, filter) import Data.GenericTrie.Internal ------------------------------------------------------------------------------ -- Various helpers ------------------------------------------------------------------------------ -- | Construct a trie from a list of key-value pairs fromList :: TrieKey k => [(k,v)] -> Trie k v fromList = foldl' (\acc (k,v) -> insert k v acc) empty -- | Construct a trie from a list of key-value pairs. -- The given function is used to combine values at the -- same key. fromListWith :: TrieKey k => (v -> v -> v) -> [(k,v)] -> Trie k v fromListWith f = foldl' (\acc (k,v) -> insertWith f k v acc) empty -- | Version of 'fromListWith' which is strict in the result of -- the combining function. fromListWith' :: TrieKey k => (v -> v -> v) -> [(k,v)] -> Trie k v fromListWith' f = foldl' (\acc (k,v) -> insertWith' f k v acc) empty -- | Construct an empty trie empty :: TrieKey k => Trie k a empty = trieEmpty {-# INLINE empty #-} -- | Test for an empty trie null :: TrieKey k => Trie k a -> Bool null = trieNull {-# INLINE null #-} -- | Lookup an element from a trie lookup :: TrieKey k => k -> Trie k a -> Maybe a lookup = trieLookup {-# INLINE lookup #-} -- | Lens for the value at a given key at :: (Functor f, TrieKey k) => k -> (Maybe a -> f (Maybe a)) -> Trie k a -> f (Trie k a) at k f m = fmap aux (f mv) where mv = lookup k m aux r = case r of Nothing -> maybe m (const (delete k m)) mv Just v' -> insert k v' m -- | Insert an element into a trie insert :: TrieKey k => k -> a -> Trie k a -> Trie k a insert = trieInsert {-# INLINE insert #-} -- | Delete an element from a trie delete :: TrieKey k => k -> Trie k a -> Trie k a delete = trieDelete {-# INLINE delete #-} -- | Construct a trie holding a single value singleton :: TrieKey k => k -> a -> Trie k a singleton = trieSingleton {-# INLINE singleton #-} -- | Apply a function to the values of a trie and keep the elements -- of the trie that result in a 'Just' value. mapMaybeWithKey :: TrieKey k => (k -> a -> Maybe b) -> Trie k a -> Trie k b mapMaybeWithKey = trieMapMaybeWithKey {-# INLINE mapMaybeWithKey #-} -- | Perform an action for each value in a trie and keep the elements -- of the trie that result in a 'Just' value. traverseMaybeWithKey :: (TrieKey k, Applicative f) => (k -> a -> f (Maybe b)) -> Trie k a -> f (Trie k b) traverseMaybeWithKey = trieTraverseMaybeWithKey {-# INLINE traverseMaybeWithKey #-} -- | Filter the values of a trie with the given predicate. filter :: TrieKey k => (a -> Bool) -> Trie k a -> Trie k a filter p = filterWithKey (const p) -- | Version of 'filter' where the predicate also gets the key. filterWithKey :: TrieKey k => (k -> a -> Bool) -> Trie k a -> Trie k a filterWithKey p = mapMaybeWithKey aux where aux k x | p k x = Just x | otherwise = Nothing -- | Fold a trie with a function of the value fold :: TrieKey k => (a -> r -> r) -> r -> Trie k a -> r fold = trieFoldWithKey . const {-# INLINE fold #-} -- | Fold a trie with a function of both key and value foldWithKey :: TrieKey k => (k -> a -> r -> r) -> r -> Trie k a -> r foldWithKey = trieFoldWithKey {-# INLINE foldWithKey #-} -- | Traverse a trie with a function of both key and value traverseWithKey :: (TrieKey k, Applicative f) => (k -> a -> f b) -> Trie k a -> f (Trie k b) traverseWithKey = trieTraverseWithKey {-# INLINE traverseWithKey #-} mergeWithKey :: TrieKey k => (k -> a -> b -> Maybe c) -> (Trie k a -> Trie k c) -> (Trie k b -> Trie k c) -> Trie k a -> Trie k b -> Trie k c mergeWithKey = trieMergeWithKey {-# INLINE mergeWithKey #-} -- | Alter the value at the given key location. -- The parameter function takes the value stored -- at the given key, if one exists, and should return a value to insert at -- that location, or 'Nothing' to delete from that location. alter :: TrieKey k => k -> (Maybe a -> Maybe a) -> Trie k a -> Trie k a alter = trieAlter {-# INLINE alter #-} -- | Insert a value at the given key. The combining function is used -- when a value is already stored at that key. The new value is the -- first argument to the combining function. insertWith :: TrieKey k => (v -> v -> v) -> k -> v -> Trie k v -> Trie k v insertWith f k v = alter k $ \mb -> case mb of Just v0 -> Just (f v v0) Nothing -> Just v -- | Version of 'insertWith' that is strict in the result of combining -- two elements. insertWith' :: TrieKey k => (v -> v -> v) -> k -> v -> Trie k v -> Trie k v insertWith' f k v = alter k $ \mb -> case mb of Just v0 -> Just $! f v v0 Nothing -> Just v -- | Returns 'True' when the 'Trie' has a value stored at the given key. member :: TrieKey k => k -> Trie k a -> Bool member k t = isJust (lookup k t) -- | Returns 'False' when the 'Trie' has a value stored at the given key. notMember :: TrieKey k => k -> Trie k a -> Bool notMember k t = isNothing (lookup k t) -- | Left-biased union of two tries union :: TrieKey k => Trie k a -> Trie k a -> Trie k a union = mergeWithKey (\_ a _ -> Just a) id id -- | Union of two tries with function used to merge overlapping elements unionWith :: TrieKey k => (a -> a -> a) -> Trie k a -> Trie k a -> Trie k a unionWith f = mergeWithKey (\_ a b -> Just (f a b)) id id -- | Union of two tries with function used to merge overlapping elements along with key unionWithKey :: TrieKey k => (k -> a -> a -> a) -> Trie k a -> Trie k a -> Trie k a unionWithKey f = mergeWithKey (\k a b -> Just (f k a b)) id id -- | Left-biased intersection of two tries intersection :: TrieKey k => Trie k a -> Trie k b -> Trie k a intersection = mergeWithKey (\_ a _ -> Just a) (const empty) (const empty) -- | Intersection of two tries parameterized by a combining function of the -- values at overlapping keys intersectionWith :: TrieKey k => (a -> b -> c) -> Trie k a -> Trie k b -> Trie k c intersectionWith f = mergeWithKey (\_ a b -> Just (f a b)) (const empty) (const empty) -- | Intersection of two tries parameterized by a combining function of the -- key and the values at overlapping keys intersectionWithKey :: TrieKey k => (k -> a -> b -> c) -> Trie k a -> Trie k b -> Trie k c intersectionWithKey f = mergeWithKey (\k a b -> Just (f k a b)) (const empty) (const empty) -- | Remove the keys of the right trie from the left trie difference :: TrieKey k => Trie k a -> Trie k b -> Trie k a difference = mergeWithKey (\_ _ _ -> Nothing) id (const empty) -- | Parameterized 'difference' using a custom merge function. -- Return 'Just' to change the value stored in left trie, or -- 'Nothing' to remove from the left trie. differenceWith :: TrieKey k => (a -> b -> Maybe a) -> Trie k a -> Trie k b -> Trie k a differenceWith f = mergeWithKey (\_ -> f) id (const empty) -- | 'differenceWith' where function also has access to the key differenceWithKey :: TrieKey k => (k -> a -> b -> Maybe a) -> Trie k a -> Trie k b -> Trie k a differenceWithKey f = mergeWithKey f id (const empty) -- | Map a function over a trie filtering out elements where function returns 'Nothing' mapMaybe :: TrieKey k => (a -> Maybe b) -> Trie k a -> Trie k b mapMaybe f = mapMaybeWithKey (\_ -> f) generic-trie-0.3.2/src/Data/GenericTrie/0000755000000000000000000000000007346545000016122 5ustar0000000000000000generic-trie-0.3.2/src/Data/GenericTrie/Internal.hs0000644000000000000000000013620607346545000020242 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -- coerce {-# LANGUAGE CPP #-} -- MProxy on ghc >= 8 {-# LANGUAGE EmptyCase #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif #if MIN_VERSION_base(4,9,0) {-# LANGUAGE DataKinds #-} -- Meta #endif -- | Unstable implementation details module Data.GenericTrie.Internal ( TrieKey(..) , ShowTrieKey(..) , Trie(..) , OrdKey(..) , toList -- * Generic derivation implementation , genericTrieNull , genericTrieMap , genericTrieTraverse , genericTrieShowsPrec , genericInsert , genericLookup , genericDelete , genericAlter , genericMapMaybeWithKey , genericSingleton , genericEmpty , genericFoldWithKey , genericTraverseWithKey , genericTraverseMaybeWithKey , TrieRepDefault , GTrieKey(..) , GTrie(..) ) where import Data.Char (chr, ord) import Data.Coerce (coerce) import Data.IntMap (IntMap) #if MIN_VERSION_base(4,9,0) import Data.Kind (Type) #endif import Data.Map (Map) import Data.Maybe (isNothing) import GHC.Generics import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Prelude #if MIN_VERSION_base(4,8,0) import Data.Void (Void) #endif #if MIN_VERSION_base(4,8,0) import Numeric.Natural #endif -- | Types that may be used as the key of a 'Trie'. -- -- For @data@ declarations, the instance can be automatically derived from -- a 'Generic' instance. class TrieKey k where -- | Type of the representation of tries for this key. #if MIN_VERSION_base(4,9,0) type TrieRep k :: Type -> Type #else type TrieRep k :: * -> * #endif -- | Construct an empty trie trieEmpty :: Trie k a -- | Test for an empty trie trieNull :: Trie k a -> Bool -- | Lookup element from trie trieLookup :: k -> Trie k a -> Maybe a -- | Insert element into trie trieInsert :: k -> a -> Trie k a -> Trie k a -- | Delete element from trie trieDelete :: k -> Trie k a -> Trie k a -- | Insert, modify, or remove an element in a trie trieAlter :: k -> (Maybe a -> Maybe a) -> Trie k a -> Trie k a -- | Construct a trie holding a single value trieSingleton :: k -> a -> Trie k a -- | Apply a function to all values stored in a trie trieMap :: (a -> b) -> Trie k a -> Trie k b -- | Traverse the values stored in a trie trieTraverse :: Applicative f => (a -> f b) -> Trie k a -> f (Trie k b) -- | Apply a function to the values of a 'Trie' and keep the elements -- of the trie that result in a 'Just' value. trieMapMaybeWithKey :: (k -> a -> Maybe b) -> Trie k a -> Trie k b -- | Fold a trie with a function of both key and value. trieFoldWithKey :: (k -> a -> r -> r) -> r -> Trie k a -> r -- | Traverse a trie with a function of both key and value. trieTraverseWithKey :: Applicative f => (k -> a -> f b) -> Trie k a -> f (Trie k b) -- | Traverse a trie with a function of both key and value, and keep the elements -- of the trie that result in a 'Just' value. trieTraverseMaybeWithKey :: Applicative f => (k -> a -> f (Maybe b)) -> Trie k a -> f (Trie k b) trieMergeWithKey :: (k -> a -> b -> Maybe c) -> (Trie k a -> Trie k c) -> (Trie k b -> Trie k c) -> Trie k a -> Trie k b -> Trie k c -- Defaults using 'Generic' type instance TrieRep k = TrieRepDefault k default trieEmpty :: ( TrieRep k ~ TrieRepDefault k) => Trie k a trieEmpty = genericEmpty default trieSingleton :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k) => k -> a -> Trie k a trieSingleton = genericSingleton default trieNull :: ( TrieRep k ~ TrieRepDefault k) => Trie k a -> Bool trieNull = genericTrieNull default trieLookup :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k) => k -> Trie k a -> Maybe a trieLookup = genericLookup default trieInsert :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k) => k -> a -> Trie k a -> Trie k a trieInsert = genericInsert default trieDelete :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k) => k -> Trie k a -> Trie k a trieDelete = genericDelete default trieAlter :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k) => k -> (Maybe a -> Maybe a) -> Trie k a -> Trie k a trieAlter = genericAlter default trieMap :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k) => (a -> b) -> Trie k a -> Trie k b trieMap = genericTrieMap default trieTraverse :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k , Applicative f) => (a -> f b) -> Trie k a -> f (Trie k b) trieTraverse = genericTrieTraverse default trieMapMaybeWithKey :: ( GTrieKey (Rep k) , Generic k, TrieRep k ~ TrieRepDefault k) => (k -> a -> Maybe b) -> Trie k a -> Trie k b trieMapMaybeWithKey = genericMapMaybeWithKey default trieFoldWithKey :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k, Generic k) => (k -> a -> r -> r) -> r -> Trie k a -> r trieFoldWithKey = genericFoldWithKey default trieTraverseWithKey :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k, Generic k, Applicative f) => (k -> a -> f b) -> Trie k a -> f (Trie k b) trieTraverseWithKey = genericTraverseWithKey default trieTraverseMaybeWithKey :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k, Generic k, Applicative f) => (k -> a -> f (Maybe b)) -> Trie k a -> f (Trie k b) trieTraverseMaybeWithKey = genericTraverseMaybeWithKey default trieMergeWithKey :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k, Generic k ) => (k -> a -> b -> Maybe c) -> (Trie k a -> Trie k c) -> (Trie k b -> Trie k c) -> Trie k a -> Trie k b -> Trie k c trieMergeWithKey = genericMergeWithKey -- | A map from keys of type @k@, to values of type @a@. newtype Trie k a = MkTrie (TrieRep k a) -- | Transform a trie to an association list. toList :: TrieKey k => Trie k a -> [(k,a)] toList = trieFoldWithKey (\k v xs -> (k,v) : xs) [] class TrieKey k => ShowTrieKey k where -- | Show a representation of the internal structure of a trie trieShowsPrec :: Show a => Int -> Trie k a -> ShowS default trieShowsPrec :: ( Show a, GTrieKeyShow (Rep k) , TrieRep k ~ TrieRepDefault k) => Int -> Trie k a -> ShowS trieShowsPrec = genericTrieShowsPrec ------------------------------------------------------------------------------ -- Manually derived instances for base types ------------------------------------------------------------------------------ -- | 'Int' tries are implemented with 'IntMap'. instance TrieKey Int where type TrieRep Int = IntMap trieLookup k (MkTrie x) = IntMap.lookup k x trieInsert k v (MkTrie t) = MkTrie (IntMap.insert k v t) trieDelete k (MkTrie t) = MkTrie (IntMap.delete k t) trieAlter k f (MkTrie t) = MkTrie (IntMap.alter f k t) trieEmpty = MkTrie IntMap.empty trieSingleton k v = MkTrie (IntMap.singleton k v) trieNull (MkTrie x) = IntMap.null x trieMap f (MkTrie x) = MkTrie (IntMap.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (IntMap.mapMaybeWithKey f x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,6,4) MkTrie <$> IntMap.traverseMaybeWithKey f x #else MkTrie . IntMap.mapMaybe id <$> IntMap.traverseWithKey f x #endif trieFoldWithKey f z (MkTrie x) = IntMap.foldrWithKey f z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (IntMap.traverseWithKey f x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (IntMap.mergeWithKey f (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} instance ShowTrieKey Int where trieShowsPrec p (MkTrie x) = showsPrec p x {-# INLINABLE trieShowsPrec #-} -- | 'Integer' tries are implemented with 'Map'. instance TrieKey Integer where type TrieRep Integer = Map Integer trieLookup k (MkTrie t) = Map.lookup k t trieInsert k v (MkTrie t) = MkTrie (Map.insert k v t) trieDelete k (MkTrie t) = MkTrie (Map.delete k t) trieAlter k f (MkTrie t) = MkTrie (Map.alter f k t) trieEmpty = MkTrie Map.empty trieSingleton k v = MkTrie (Map.singleton k v) trieNull (MkTrie x) = Map.null x trieMap f (MkTrie x) = MkTrie (Map.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (Map.mapMaybeWithKey f x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,5,8) MkTrie <$> Map.traverseMaybeWithKey f x #else MkTrie . Map.mapMaybe id <$> Map.traverseWithKey f x #endif trieFoldWithKey f z (MkTrie x) = Map.foldrWithKey f z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (Map.traverseWithKey f x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (Map.mergeWithKey f (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} instance ShowTrieKey Integer where trieShowsPrec p (MkTrie x) = showsPrec p x {-# INLINABLE trieShowsPrec #-} #if MIN_VERSION_base(4,8,0) -- | 'Natural' tries are implemented with 'Map'. instance TrieKey Natural where type TrieRep Natural = Map Natural trieLookup k (MkTrie t) = Map.lookup k t trieInsert k v (MkTrie t) = MkTrie (Map.insert k v t) trieDelete k (MkTrie t) = MkTrie (Map.delete k t) trieAlter k f (MkTrie t) = MkTrie (Map.alter f k t) trieEmpty = MkTrie Map.empty trieSingleton k v = MkTrie (Map.singleton k v) trieNull (MkTrie x) = Map.null x trieMap f (MkTrie x) = MkTrie (Map.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (Map.mapMaybeWithKey f x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,5,8) MkTrie <$> Map.traverseMaybeWithKey f x #else MkTrie . Map.mapMaybe id <$> Map.traverseWithKey f x #endif trieFoldWithKey f z (MkTrie x) = Map.foldrWithKey f z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (Map.traverseWithKey f x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (Map.mergeWithKey f (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} instance ShowTrieKey Natural where trieShowsPrec p (MkTrie x) = showsPrec p x {-# INLINABLE trieShowsPrec #-} #endif -- | 'Word' tries are implemented with 'IntMap'. instance TrieKey Word where type TrieRep Word = IntMap trieLookup k (MkTrie t) = IntMap.lookup (fromIntegral k) t trieDelete k (MkTrie t) = MkTrie (IntMap.delete (fromIntegral k) t) trieInsert k v (MkTrie t) = MkTrie (IntMap.insert (fromIntegral k) v t) trieAlter k f (MkTrie t) = MkTrie (IntMap.alter f (fromIntegral k) t) trieEmpty = MkTrie IntMap.empty trieSingleton k v = MkTrie (IntMap.singleton (fromIntegral k) v) trieNull (MkTrie x) = IntMap.null x trieMap f (MkTrie x) = MkTrie (IntMap.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (IntMap.mapMaybeWithKey (f . fromIntegral) x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,6,4) MkTrie <$> IntMap.traverseMaybeWithKey (f . fromIntegral) x #else MkTrie . IntMap.mapMaybe id <$> IntMap.traverseWithKey (f . fromIntegral) x #endif trieFoldWithKey f z (MkTrie x) = IntMap.foldrWithKey (f . fromIntegral) z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (IntMap.traverseWithKey (f . fromIntegral) x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (IntMap.mergeWithKey (f . fromIntegral) (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} instance ShowTrieKey Word where trieShowsPrec p (MkTrie x) = showParen (p > 10) (showString "fromList " . shows [(fromIntegral k :: Word, v) | (k,v) <- IntMap.toList x]) {-# INLINABLE trieShowsPrec #-} -- | 'Char' tries are implemented with 'IntMap'. instance TrieKey Char where type TrieRep Char = IntMap trieLookup k (MkTrie t) = IntMap.lookup (ord k) t trieDelete k (MkTrie t) = MkTrie (IntMap.delete (ord k) t) trieInsert k v (MkTrie t) = MkTrie (IntMap.insert (ord k) v t) trieAlter k f (MkTrie t) = MkTrie (IntMap.alter f (ord k) t) trieEmpty = MkTrie IntMap.empty trieSingleton k v = MkTrie (IntMap.singleton (ord k) v) trieNull (MkTrie x) = IntMap.null x trieMap f (MkTrie x) = MkTrie (IntMap.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (IntMap.mapMaybeWithKey (f . chr) x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,6,4) MkTrie <$> IntMap.traverseMaybeWithKey (f . chr) x #else MkTrie . IntMap.mapMaybe id <$> IntMap.traverseWithKey (f . chr) x #endif trieFoldWithKey f z (MkTrie x) = IntMap.foldrWithKey (f . chr) z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (IntMap.traverseWithKey (f . chr) x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (IntMap.mergeWithKey (f . chr) (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} instance ShowTrieKey Char where trieShowsPrec p (MkTrie x) = showsPrec p x {-# INLINABLE trieShowsPrec #-} -- | Tries indexed by 'OrdKey' will be represented as an ordinary 'Map' -- and the keys will be compared based on the 'Ord' instance for @k@. newtype OrdKey k = OrdKey { getOrdKey :: k } deriving (Read, Show, Eq, Ord) -- | 'OrdKey' tries are implemented with 'Map', this is -- intended for cases where it is better for some reason -- to force the use of a 'Map' than to use the generically -- derived structure. instance Ord k => TrieKey (OrdKey k) where type TrieRep (OrdKey k) = Map k trieLookup (OrdKey k) (MkTrie x) = Map.lookup k x trieInsert (OrdKey k) v (MkTrie x) = MkTrie (Map.insert k v x) trieDelete (OrdKey k) (MkTrie x) = MkTrie (Map.delete k x) trieAlter (OrdKey k) f (MkTrie x) = MkTrie (Map.alter f k x) trieEmpty = MkTrie Map.empty trieSingleton (OrdKey k) v = MkTrie (Map.singleton k v) trieNull (MkTrie x) = Map.null x trieMap f (MkTrie x) = MkTrie (Map.map f x) trieTraverse f (MkTrie x) = fmap MkTrie (traverse f x) trieMapMaybeWithKey f (MkTrie x) = MkTrie (Map.mapMaybeWithKey (f . OrdKey) x) trieTraverseMaybeWithKey f (MkTrie x) = #if MIN_VERSION_containers (0,5,8) MkTrie <$> Map.traverseMaybeWithKey (f . OrdKey) x #else MkTrie . Map.mapMaybe id <$> Map.traverseWithKey (f . OrdKey) x #endif trieFoldWithKey f z (MkTrie x) = Map.foldrWithKey (f . OrdKey) z x trieTraverseWithKey f (MkTrie x) = fmap MkTrie (Map.traverseWithKey (f . OrdKey) x) trieMergeWithKey f g h (MkTrie x) (MkTrie y) = MkTrie (Map.mergeWithKey (f . OrdKey) (coerce g) (coerce h) x y) {-# INLINABLE trieEmpty #-} {-# INLINABLE trieInsert #-} {-# INLINABLE trieLookup #-} {-# INLINABLE trieDelete #-} {-# INLINABLE trieAlter #-} {-# INLINABLE trieSingleton #-} {-# INLINABLE trieFoldWithKey #-} {-# INLINABLE trieTraverse #-} {-# INLINABLE trieTraverseWithKey #-} {-# INLINABLE trieTraverseMaybeWithKey #-} {-# INLINABLE trieNull #-} {-# INLINABLE trieMap #-} {-# INLINABLE trieMergeWithKey #-} {-# INLINABLE trieMapMaybeWithKey #-} instance (Show k, Ord k) => ShowTrieKey (OrdKey k) where trieShowsPrec p (MkTrie x) = showsPrec p x {-# INLINABLE trieShowsPrec #-} ------------------------------------------------------------------------------ -- Automatically derived instances for common types ------------------------------------------------------------------------------ #if MIN_VERSION_base(4,8,0) instance TrieKey Void instance ShowTrieKey Void #endif instance TrieKey () instance ShowTrieKey () instance TrieKey Bool instance ShowTrieKey Bool instance TrieKey Ordering instance ShowTrieKey Ordering instance TrieKey k => TrieKey (Maybe k) instance ShowTrieKey k => ShowTrieKey (Maybe k) instance (TrieKey a, TrieKey b) => TrieKey (Either a b) instance (ShowTrieKey a, ShowTrieKey b) => ShowTrieKey (Either a b) instance (TrieKey a, TrieKey b) => TrieKey (a,b) instance (ShowTrieKey a, ShowTrieKey b) => ShowTrieKey (a,b) instance (TrieKey a, TrieKey b, TrieKey c) => TrieKey (a,b,c) instance (ShowTrieKey a, ShowTrieKey b, ShowTrieKey c) => ShowTrieKey (a,b,c) instance (TrieKey a, TrieKey b, TrieKey c, TrieKey d) => TrieKey (a,b,c,d) instance (ShowTrieKey a, ShowTrieKey b, ShowTrieKey c, ShowTrieKey d) => ShowTrieKey (a,b,c,d) instance (TrieKey a, TrieKey b, TrieKey c, TrieKey d, TrieKey e) => TrieKey (a,b,c,d,e) instance (ShowTrieKey a, ShowTrieKey b, ShowTrieKey c, ShowTrieKey d, ShowTrieKey e) => ShowTrieKey (a,b,c,d,e) instance TrieKey k => TrieKey [k] instance ShowTrieKey k => ShowTrieKey [k] ------------------------------------------------------------------------------ -- Generic 'TrieKey' method implementations ------------------------------------------------------------------------------ -- | Generic implementation of 'lookup'. This is the default implementation. genericLookup :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => k -> Trie k a -> Maybe a genericLookup k t = gtrieLookup (from k) =<< unwrap t {-# INLINABLE genericLookup #-} -- | Generic implementation of 'trieNull'. This is the default implementation. genericTrieNull :: ( TrieRep k ~ TrieRepDefault k ) => Trie k a -> Bool genericTrieNull = isNothing . unwrap {-# INLINABLE genericTrieNull #-} -- | Generic implementation of 'singleton'. This is the default implementation. genericSingleton :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => k -> a -> Trie k a genericSingleton k v = wrap $ Just $! gtrieSingleton (from k) v {-# INLINABLE genericSingleton #-} -- | Generic implementation of 'empty'. This is the default implementation. genericEmpty :: ( TrieRep k ~ TrieRepDefault k ) => Trie k a genericEmpty = MkTrie EmptyTrie {-# INLINABLE genericEmpty #-} -- | Generic implementation of 'insert'. This is the default implementation. genericInsert :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => k -> a -> Trie k a -> Trie k a genericInsert k v m = wrap $ case unwrap m of Nothing -> Just $! gtrieSingleton (from k) v Just t -> Just $! gtrieInsert (from k) v t {-# INLINABLE genericInsert #-} -- | Generic implementation of 'delete'. This is the default implementation. genericDelete :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => k -> Trie k a -> Trie k a genericDelete k m = wrap (gtrieDelete (from k) =<< unwrap m) {-# INLINABLE genericDelete #-} -- | Generic implementation of 'alter'. This is the default implementation. genericAlter :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => k -> (Maybe a -> Maybe a) -> Trie k a -> Trie k a genericAlter k f m = wrap (gtrieAlter (from k) f =<< unwrap m) {-# INLINABLE genericAlter #-} -- | Generic implementation of 'trieMap'. This is the default implementation. genericTrieMap :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k ) => (a -> b) -> Trie k a -> Trie k b genericTrieMap f x = wrap (fmap (gtrieMap f) $! unwrap x) {-# INLINABLE genericTrieMap #-} -- | Generic implementation of 'trieTraverse'. This is the default implementation. genericTrieTraverse :: ( GTrieKey (Rep k) , TrieRep k ~ TrieRepDefault k , Applicative f ) => (a -> f b) -> Trie k a -> f (Trie k b) genericTrieTraverse f x = fmap wrap (traverse (gtrieTraverse f) (unwrap x)) {-# INLINABLE genericTrieTraverse #-} -- | Generic implementation of 'trieShowsPrec'. This is the default implementation. genericTrieShowsPrec :: ( Show a, GTrieKeyShow (Rep k) , TrieRep k ~ TrieRepDefault k ) => Int -> Trie k a -> ShowS genericTrieShowsPrec p m = case unwrap m of Just x -> showsPrec p x Nothing -> showString "()" {-# INLINABLE genericTrieShowsPrec #-} -- | Generic implementation of 'mapMaybe'. This is the default implementation. genericMapMaybeWithKey :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => (k -> a -> Maybe b) -> Trie k a -> Trie k b genericMapMaybeWithKey f x = wrap (gmapMaybeWithKey (f . to) =<< unwrap x) {-# INLINABLE genericMapMaybeWithKey #-} -- | Generic implementation of 'foldWithKey'. This is the default implementation. genericFoldWithKey :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => (k -> a -> r -> r) -> r -> Trie k a -> r genericFoldWithKey f z m = case unwrap m of Nothing -> z Just x -> gfoldWithKey (f . to) z x {-# INLINABLE genericFoldWithKey #-} -- | Generic implementation of 'traverseWithKey'. This is the default implementation. genericTraverseWithKey :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k , Applicative f ) => (k -> a -> f b) -> Trie k a -> f (Trie k b) genericTraverseWithKey f m = fmap wrap (traverse (gtraverseWithKey (f . to)) (unwrap m)) {-# INLINABLE genericTraverseWithKey #-} -- | Generic implementation of 'traverseMaybeWithKey'. This is the default implementation. genericTraverseMaybeWithKey :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k , Applicative f ) => (k -> a -> f (Maybe b)) -> Trie k a -> f (Trie k b) genericTraverseMaybeWithKey f m = fmap (maybe (MkTrie EmptyTrie) wrap) (traverse (gtraverseMaybeWithKey (f . to)) (unwrap m)) {-# INLINABLE genericTraverseMaybeWithKey #-} -- | Generic implementation of 'mergeWithKey'. This is the default implementation. genericMergeWithKey :: ( GTrieKey (Rep k), Generic k , TrieRep k ~ TrieRepDefault k ) => (k -> a -> b -> Maybe c) -> (Trie k a -> Trie k c) -> (Trie k b -> Trie k c) -> Trie k a -> Trie k b -> Trie k c genericMergeWithKey f g h (MkTrie x) (MkTrie y) = case (x,y) of (EmptyTrie, EmptyTrie) -> MkTrie EmptyTrie (NonEmptyTrie{} , EmptyTrie) -> g (MkTrie x) (EmptyTrie, NonEmptyTrie{} ) -> h (MkTrie y) (NonEmptyTrie x', NonEmptyTrie y') -> wrap (gmergeWithKey (f . to) (aux g) (aux h) x' y') where aux k t = unwrap (k (MkTrie (NonEmptyTrie t))) {-# INLINABLE genericMergeWithKey #-} wrap :: TrieRep k ~ TrieRepDefault k1 => Maybe (GTrie (Rep k1) a) -> Trie k a wrap Nothing = MkTrie EmptyTrie wrap (Just t) = MkTrie (NonEmptyTrie t) unwrap :: TrieRep t ~ TrieRepDefault t2 => Trie t t1 -> Maybe (GTrie (Rep t2) t1) unwrap (MkTrie EmptyTrie) = Nothing unwrap (MkTrie (NonEmptyTrie t)) = Just t ------------------------------------------------------------------------------ -- Generic implementation class ------------------------------------------------------------------------------ -- | The default implementation of a 'TrieRep' is 'GTrie' wrapped in -- a 'Maybe'. This wrapping is due to the 'GTrie' being a non-empty -- trie allowing all the of the "emptiness" to be represented at the -- top level for any given generically implemented key. data TrieRepDefault k a = EmptyTrie | NonEmptyTrie !(GTrie (Rep k) a) -- | Mapping of generic representation of keys to trie structures. #if __GLASGOW_HASKELL__ >= 810 type GTrie :: (Type -> Type) -> Type -> Type data family GTrie f a #elif MIN_VERSION_base(4,9,0) data family GTrie (f :: Type -> Type) a #else data family GTrie (f :: * -> *) a #endif newtype instance GTrie (M1 i c f) a = MTrie (GTrie f a) data instance GTrie (f :+: g) a = STrieL !(GTrie f a) | STrieR !(GTrie g a) | STrieB !(GTrie f a) !(GTrie g a) newtype instance GTrie (f :*: g) a = PTrie (GTrie f (GTrie g a)) newtype instance GTrie (K1 i k) a = KTrie (Trie k a) newtype instance GTrie U1 a = UTrie a data instance GTrie V1 a instance GTrieKey f => Functor (GTrie f) where fmap = gtrieMap -- | TrieKey operations on Generic representations used to provide -- the default implementations of tries. class GTrieKey f where gtrieLookup :: f p -> GTrie f a -> Maybe a gtrieInsert :: f p -> a -> GTrie f a -> GTrie f a gtrieSingleton :: f p -> a -> GTrie f a gtrieDelete :: f p -> GTrie f a -> Maybe (GTrie f a) gtrieAlter :: f p -> (Maybe a -> Maybe a) -> GTrie f a -> Maybe (GTrie f a) gtrieMap :: (a -> b) -> GTrie f a -> GTrie f b gtrieTraverse :: Applicative m => (a -> m b) -> GTrie f a -> m (GTrie f b) gmapMaybeWithKey :: (f p -> a -> Maybe b) -> GTrie f a -> Maybe (GTrie f b) gfoldWithKey :: (f p -> a -> r -> r) -> r -> GTrie f a -> r gtraverseWithKey :: Applicative m => (f p -> a -> m b) -> GTrie f a -> m (GTrie f b) gtraverseMaybeWithKey :: Applicative m => (f p -> a -> m (Maybe b)) -> GTrie f a -> m (Maybe (GTrie f b)) gmergeWithKey :: (f p -> a -> b -> Maybe c) -> (GTrie f a -> Maybe (GTrie f c)) -> (GTrie f b -> Maybe (GTrie f c)) -> GTrie f a -> GTrie f b -> Maybe (GTrie f c) -- | The 'GTrieKeyShow' class provides generic implementations -- of 'showsPrec'. This class is separate due to its implementation -- varying for different kinds of metadata. class GTrieKeyShow f where gtrieShowsPrec :: Show a => Int -> GTrie f a -> ShowS ------------------------------------------------------------------------------ -- Generic implementation for metadata ------------------------------------------------------------------------------ -- | Generic metadata is skipped in trie representation and operations. instance GTrieKey f => GTrieKey (M1 i c f) where gtrieLookup (M1 k) (MTrie x) = gtrieLookup k x gtrieInsert (M1 k) v (MTrie t)= MTrie (gtrieInsert k v t) gtrieSingleton (M1 k) v = MTrie (gtrieSingleton k v) gtrieDelete (M1 k) (MTrie x) = fmap MTrie (gtrieDelete k x) gtrieAlter (M1 k) f (MTrie x) = fmap MTrie (gtrieAlter k f x) gtrieMap f (MTrie x) = MTrie (gtrieMap f x) gtrieTraverse f (MTrie x) = fmap MTrie (gtrieTraverse f x) gmapMaybeWithKey f (MTrie x) = fmap MTrie (gmapMaybeWithKey (f . M1) x) gfoldWithKey f z (MTrie x) = gfoldWithKey (f . M1) z x gtraverseWithKey f (MTrie x) = fmap MTrie (gtraverseWithKey (f . M1) x) gtraverseMaybeWithKey f (MTrie x) = fmap coerce (gtraverseMaybeWithKey (f . M1) x) gmergeWithKey f g h (MTrie x) (MTrie y) = fmap MTrie (gmergeWithKey (f . M1) (coerce g) (coerce h) x y) {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieMap #-} {-# INLINE gmapMaybeWithKey #-} {-# INLINE gtrieTraverse #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} #if MIN_VERSION_base(4,9,0) data MProxy (c :: Meta) (f :: Type -> Type) a = MProxy #else data MProxy (c :: *) (f :: * -> *) a = MProxy #endif instance GTrieKeyShow f => GTrieKeyShow (M1 D d f) where gtrieShowsPrec p (MTrie x) = showsPrec p x instance (Constructor c, GTrieKeyShow f) => GTrieKeyShow (M1 C c f) where gtrieShowsPrec p (MTrie x) = showParen (p > 10) $ showString "Con " . shows (conName (MProxy :: MProxy c f ())) . showString " " . showsPrec 11 x instance GTrieKeyShow f => GTrieKeyShow (M1 S s f) where gtrieShowsPrec p (MTrie x) = showsPrec p x ------------------------------------------------------------------------------ -- Generic implementation for fields ------------------------------------------------------------------------------ checkNull :: TrieKey k => Trie k a -> Maybe (Trie k a) checkNull x | trieNull x = Nothing | otherwise = Just x -- | Generic fields are represented by tries of the field type. instance TrieKey k => GTrieKey (K1 i k) where gtrieLookup (K1 k) (KTrie x) = trieLookup k x gtrieInsert (K1 k) v (KTrie t) = KTrie (trieInsert k v t) gtrieSingleton (K1 k) v = KTrie (trieSingleton k v) gtrieDelete (K1 k) (KTrie t) = fmap KTrie (checkNull (trieDelete k t)) gtrieAlter (K1 k) f (KTrie t) = fmap KTrie (checkNull (trieAlter k f t)) gtrieMap f (KTrie x) = KTrie (trieMap f x) gtrieTraverse f (KTrie x) = fmap KTrie (trieTraverse f x) gmapMaybeWithKey f (KTrie x) = fmap KTrie (checkNull (trieMapMaybeWithKey (f . K1) x)) gfoldWithKey f z (KTrie x) = trieFoldWithKey (f . K1) z x gtraverseWithKey f (KTrie x) = fmap KTrie (trieTraverseWithKey (f . K1) x) gtraverseMaybeWithKey f (KTrie x) = fmap (fmap KTrie . checkNull) (trieTraverseMaybeWithKey (f . K1) x) gmergeWithKey f g h (KTrie x) (KTrie y) = fmap KTrie (checkNull (trieMergeWithKey (f . K1) g' h' x y)) where g' t = case g (KTrie t) of Just (KTrie t') -> t' Nothing -> trieEmpty h' t = case h (KTrie t) of Just (KTrie t') -> t' Nothing -> trieEmpty {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieMap #-} {-# INLINE gtrieTraverse #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} {-# INLINE gmergeWithKey #-} {-# INLINE gmapMaybeWithKey #-} instance ShowTrieKey k => GTrieKeyShow (K1 i k) where gtrieShowsPrec p (KTrie x) = trieShowsPrec p x ------------------------------------------------------------------------------ -- Generic implementation for products ------------------------------------------------------------------------------ -- | Generic products are represented by tries of tries. instance (GTrieKey f, GTrieKey g) => GTrieKey (f :*: g) where gtrieLookup (i :*: j) (PTrie x) = gtrieLookup j =<< gtrieLookup i x gtrieInsert (i :*: j) v (PTrie t) = case gtrieAlter i f t of -- The "impossible" error is unfortunate. We *could* add another function -- -- ginsertChange :: f i -> (Maybe a -> a) -> GTrie i a -> GTrie i a -- -- and use that, but that would only push the "impossible" errors to the -- implementations using `Map` and `IntMap`, which doesn't seem to help. Nothing -> error "gtrieInsert: insertion produced an empty trie" Just t' -> PTrie t' where -- f :: Maybe (GTrie g a) -> Maybe (GTrie g a) f Nothing = Just $! gtrieSingleton j v f (Just u) = Just $! gtrieInsert j v u gtrieDelete (i :*: j) (PTrie t) = fmap PTrie (gtrieAlter i f t) where -- f :: Maybe (GTrie g a) -> Maybe (GTrie g a) f Nothing = Nothing f (Just u) = gtrieDelete j u gtrieAlter (i :*: j) f (PTrie t) = fmap PTrie (gtrieAlter i g t) where -- g :: Maybe (GTrie g a) -> Maybe (GTrie g a) g Nothing = case f Nothing of Nothing -> Nothing Just v -> Just $! gtrieSingleton j v g (Just u) = gtrieAlter j f u gtrieSingleton (i :*: j) v = PTrie (gtrieSingleton i (gtrieSingleton j v)) gtrieMap f (PTrie x) = PTrie (gtrieMap (gtrieMap f) x) gtrieTraverse f (PTrie x) = fmap PTrie (gtrieTraverse (gtrieTraverse f) x) gmapMaybeWithKey f (PTrie x) = fmap PTrie (gmapMaybeWithKey (\i -> gmapMaybeWithKey (\j -> f (i:*:j))) x) gfoldWithKey f z (PTrie x) = gfoldWithKey (\i m r -> gfoldWithKey (\j -> f (i:*:j)) r m) z x gtraverseWithKey f (PTrie x) = fmap PTrie (gtraverseWithKey (\i -> gtraverseWithKey (\j -> f (i :*: j))) x) gtraverseMaybeWithKey f (PTrie x) = fmap (fmap PTrie) (gtraverseMaybeWithKey (\i -> gtraverseMaybeWithKey (\j -> f (i :*: j))) x) gmergeWithKey f g h (PTrie x) (PTrie y) = fmap PTrie $! gmergeWithKey (\i -> gmergeWithKey (\j -> f (i:*:j)) (g' i) (h' i)) (coerce g) (coerce h) x y where g' i t = do PTrie t' <- g (PTrie (gtrieSingleton i t)) gtrieLookup i t' h' i t = do PTrie t' <- h (PTrie (gtrieSingleton i t)) gtrieLookup i t' {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieMap #-} {-# INLINE gtrieTraverse #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} {-# INLINE gmergeWithKey #-} {-# INLINE gmapMaybeWithKey #-} instance (GTrieKeyShow f, GTrieKeyShow g) => GTrieKeyShow (f :*: g) where gtrieShowsPrec p (PTrie x) = showsPrec p x ------------------------------------------------------------------------------ -- Generic implementation for sums ------------------------------------------------------------------------------ -- | Generic sums are represented by up to a pair of sub-tries. instance (GTrieKey f, GTrieKey g) => GTrieKey (f :+: g) where gtrieLookup (L1 k) (STrieL x) = gtrieLookup k x gtrieLookup (L1 k) (STrieB x _) = gtrieLookup k x gtrieLookup (R1 k) (STrieR y) = gtrieLookup k y gtrieLookup (R1 k) (STrieB _ y) = gtrieLookup k y gtrieLookup _ _ = Nothing gtrieInsert (L1 k) v (STrieL x) = STrieL (gtrieInsert k v x) gtrieInsert (L1 k) v (STrieR y) = STrieB (gtrieSingleton k v) y gtrieInsert (L1 k) v (STrieB x y) = STrieB (gtrieInsert k v x) y gtrieInsert (R1 k) v (STrieL x) = STrieB x (gtrieSingleton k v) gtrieInsert (R1 k) v (STrieR y) = STrieR (gtrieInsert k v y) gtrieInsert (R1 k) v (STrieB x y) = STrieB x (gtrieInsert k v y) gtrieSingleton (L1 k) v = STrieL (gtrieSingleton k v) gtrieSingleton (R1 k) v = STrieR (gtrieSingleton k v) gtrieDelete (L1 k) (STrieL x) = fmap STrieL $! gtrieDelete k x gtrieDelete (L1 _) (STrieR y) = Just $! STrieR y gtrieDelete (L1 k) (STrieB x y) = case gtrieDelete k x of Nothing -> Just $! STrieR y Just x' -> Just $! STrieB x' y gtrieDelete (R1 _) (STrieL x) = Just $! STrieL x gtrieDelete (R1 k) (STrieR y) = fmap STrieR $! gtrieDelete k y gtrieDelete (R1 k) (STrieB x y) = case gtrieDelete k y of Nothing -> Just $! STrieL x Just y' -> Just $! STrieB x y' gtrieAlter (L1 k) f (STrieL x) = do x' <- gtrieAlter k f x Just $! STrieL x' gtrieAlter (L1 k) f t@(STrieR y) = case f Nothing of Nothing -> Just t Just v -> Just $! STrieB (gtrieSingleton k v) y gtrieAlter (L1 k) f (STrieB x y) = case gtrieAlter k f x of Just x' -> Just $! STrieB x' y Nothing -> Just $! STrieR y gtrieAlter (R1 k) f (STrieR y) = do y' <- gtrieAlter k f y Just $! STrieR y' gtrieAlter (R1 k) f t@(STrieL x) = case f Nothing of Nothing -> Just t Just v -> Just $! STrieB x (gtrieSingleton k v) gtrieAlter (R1 k) f (STrieB x y) = case gtrieAlter k f y of Just y' -> Just $! STrieB x y' Nothing -> Just $! STrieL x gtrieMap f (STrieB x y) = STrieB (gtrieMap f x) (gtrieMap f y) gtrieMap f (STrieL x) = STrieL (gtrieMap f x) gtrieMap f (STrieR y) = STrieR (gtrieMap f y) gtrieTraverse f (STrieB x y) = liftA2 STrieB (gtrieTraverse f x) (gtrieTraverse f y) gtrieTraverse f (STrieL x) = fmap STrieL (gtrieTraverse f x) gtrieTraverse f (STrieR y) = fmap STrieR (gtrieTraverse f y) gmapMaybeWithKey f (STrieL x) = fmap STrieL $! gmapMaybeWithKey (f . L1) x gmapMaybeWithKey f (STrieR y) = fmap STrieR $! gmapMaybeWithKey (f . R1) y gmapMaybeWithKey f (STrieB x y) = case (gmapMaybeWithKey (f . L1) x, gmapMaybeWithKey (f . R1) y) of (Nothing, Nothing) -> Nothing (Just x', Nothing) -> Just $! STrieL x' (Nothing, Just y') -> Just $! STrieR y' (Just x', Just y') -> Just $! STrieB x' y' gtraverseMaybeWithKey f (STrieL x) = fmap STrieL <$> gtraverseMaybeWithKey (f . L1) x gtraverseMaybeWithKey f (STrieR y) = fmap STrieR <$> gtraverseMaybeWithKey (f . R1) y gtraverseMaybeWithKey f (STrieB x y) = liftA2 finish (gtraverseMaybeWithKey (f . L1) x) (gtraverseMaybeWithKey (f . R1) y) where finish Nothing Nothing = Nothing finish (Just x') Nothing = Just $! STrieL x' finish Nothing (Just y') = Just $! STrieR y' finish (Just x') (Just y') = Just $! STrieB x' y' gfoldWithKey f z (STrieL x) = gfoldWithKey (f . L1) z x gfoldWithKey f z (STrieR y) = gfoldWithKey (f . R1) z y gfoldWithKey f z (STrieB x y) = gfoldWithKey (f . L1) (gfoldWithKey (f . R1) z y) x gtraverseWithKey f (STrieL x) = fmap STrieL (gtraverseWithKey (f . L1) x) gtraverseWithKey f (STrieR y) = fmap STrieR (gtraverseWithKey (f . R1) y) gtraverseWithKey f (STrieB x y) = liftA2 STrieB (gtraverseWithKey (f . L1) x) (gtraverseWithKey (f . R1) y) gmergeWithKey f g h x0 y0 = case (split x0, split y0) of ((xl,xr),(yl,yr)) -> build (mergel xl yl) (merger xr yr) where split (STrieL x) = (Just x, Nothing) split (STrieR y) = (Nothing, Just y) split (STrieB x y) = (Just x, Just y) build (Just x) (Just y) = Just (STrieB x y) build (Just x) Nothing = Just (STrieL x) build Nothing (Just y) = Just (STrieR y) build Nothing Nothing = Nothing mergel Nothing Nothing = Nothing mergel (Just x) Nothing = gl x mergel Nothing (Just y) = hl y mergel (Just x) (Just y) = gmergeWithKey (f . L1) gl hl x y merger Nothing Nothing = Nothing merger (Just x) Nothing = gr x merger Nothing (Just y) = hr y merger (Just x) (Just y) = gmergeWithKey (f . R1) gr hr x y gl t = do STrieL t' <- g (STrieL t) return t' gr t = do STrieR t' <- g (STrieR t) return t' hl t = do STrieL t' <- h (STrieL t) return t' hr t = do STrieR t' <- h (STrieR t) return t' {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieTraverse #-} {-# INLINE gtrieMap #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} {-# INLINE gmergeWithKey #-} {-# INLINE gmapMaybeWithKey #-} instance (GTrieKeyShow f, GTrieKeyShow g) => GTrieKeyShow (f :+: g) where gtrieShowsPrec p (STrieB x y) = showParen (p > 10) $ showString "STrieB " . showsPrec 11 x . showString " " . showsPrec 11 y gtrieShowsPrec p (STrieL x) = showParen (p > 10) $ showString "STrieL " . showsPrec 11 x gtrieShowsPrec p (STrieR y) = showParen (p > 10) $ showString "STrieR " . showsPrec 11 y ------------------------------------------------------------------------------ -- Generic implementation for units ------------------------------------------------------------------------------ -- | Tries of constructors without fields are represented by a single value. instance GTrieKey U1 where gtrieLookup _ (UTrie x) = Just x gtrieInsert _ v _ = UTrie v gtrieDelete _ _ = Nothing gtrieAlter _ f (UTrie x) = case f (Just x) of Nothing -> Nothing Just x' -> Just $! UTrie x' gtrieSingleton _ = UTrie gtrieMap f (UTrie x) = UTrie (f x) gtrieTraverse f (UTrie x) = fmap UTrie (f x) gmapMaybeWithKey f (UTrie x) = fmap UTrie $! f U1 x gtraverseMaybeWithKey f (UTrie x) = fmap (fmap UTrie) $! f U1 x gfoldWithKey f z (UTrie x) = f U1 x z gtraverseWithKey f (UTrie x) = fmap UTrie (f U1 x) gmergeWithKey f _ _ (UTrie x) (UTrie y) = fmap UTrie $! f U1 x y {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieTraverse #-} {-# INLINE gtrieMap #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} {-# INLINE gmergeWithKey #-} {-# INLINE gmapMaybeWithKey #-} instance GTrieKeyShow U1 where gtrieShowsPrec p (UTrie x) = showsPrec p x ------------------------------------------------------------------------------ -- Generic implementation for empty types ------------------------------------------------------------------------------ -- | Tries of types without constructors are represented by an empty type. instance GTrieKey V1 where -- Why is this represented by an empty type? One might expect it would -- be represented by a unit type, as there is exactly one total function -- from any empty type to any other type. First, remember that -- TrieRepDefault offers an EmptyTrie constructor. So a TrieMap Void x -- will be represented by that. Next, note that while the generic Rep -- types can be put together in arbitrary ways, derived Generic instances (which -- are the only ones that matter) are always structured as sums of products, -- and only use V1 at the outermost level. That is, V1 will only appear in a -- generic representation if it is the only thing there (aside from M1 -- wrappers). In particular, the only GTrie types that contain V1 are ones -- for empty types, which are adequately represented by EmptyTrie. Indeed, -- if we offered an inhabited GTrie for a Void type, we'd run into trouble, -- because then we'd falsely claim that the TrieMap from Void isn't null! gtrieLookup _ t = case t of gtrieInsert _ _ t = case t of gtrieDelete _ t = case t of gtrieAlter _ _ t = case t of gtrieSingleton k _ = case k of gtrieMap _ t = case t of gtrieTraverse _ t = case t of gmapMaybeWithKey _ t = case t of gfoldWithKey _ _ t = case t of gtraverseWithKey _ t = case t of gtraverseMaybeWithKey _ t = case t of gmergeWithKey _ _ _ t _ = case t of {-# INLINE gtrieLookup #-} {-# INLINE gtrieInsert #-} {-# INLINE gtrieDelete #-} {-# INLINE gtrieAlter #-} {-# INLINE gtrieSingleton #-} {-# INLINE gtrieMap #-} {-# INLINE gtrieTraverse #-} {-# INLINE gfoldWithKey #-} {-# INLINE gtraverseWithKey #-} {-# INLINE gtraverseMaybeWithKey #-} {-# INLINE gmergeWithKey #-} {-# INLINE gmapMaybeWithKey #-} instance GTrieKeyShow V1 where gtrieShowsPrec _ _ = showString "()" ------------------------------------------------------------------------------ -- Various instances for Trie ------------------------------------------------------------------------------ instance (TrieKey k, Show k, Show a) => Show (Trie k a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) instance (Show a, GTrieKeyShow f) => Show (GTrie f a) where showsPrec = gtrieShowsPrec instance TrieKey k => Functor (Trie k) where fmap = trieMap instance TrieKey k => Foldable.Foldable (Trie k) where foldMap = Traversable.foldMapDefault foldr f = trieFoldWithKey (\_ -> f) #if MIN_VERSION_base(4,8,0) null = trieNull #endif instance TrieKey k => Traversable (Trie k) where traverse = trieTraverse generic-trie-0.3.2/src/0000755000000000000000000000000007346545000013051 5ustar0000000000000000generic-trie-0.3.2/src/Prelude.hs0000644000000000000000000000146107346545000015007 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -- | This hideous module lets us avoid dealing with the fact that -- various functions haven't always been exported from the standard -- Prelude. module Prelude ( module Prel #if !MIN_VERSION_base(4,18,0) , Applicative (..) #endif #if !MIN_VERSION_base(4,10,0) , liftA2 #endif #if !MIN_VERSION_base(4,8,0) , Foldable (foldMap) , Traversable (traverse) , Word , (<$>) #endif ) where import "base" Prelude as Prel #if !MIN_VERSION_base(4,18,0) import Control.Applicative (Applicative (..)) #endif #if !MIN_VERSION_base(4,10,0) import Control.Applicative (liftA2) #endif #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) import Data.Word (Word) import Control.Applicative ((<$>)) #endif