representable-tries (empty) → 0.1
raw patch · 5 files changed
+439/−0 lines, 5 filesdep +adjunctionsdep +arraydep +basesetup-changed
Dependencies added: adjunctions, array, base, comonad, comonad-transformers, containers, contravariant, distributive, keys, mtl, representable-functors, semigroupoids, semigroups, transformers
Files
- Control/Monad/Reader/Trie.hs +218/−0
- Data/Semigroupoid/Trie.hs +142/−0
- LICENSE +30/−0
- Setup.lhs +7/−0
- representable-tries.cabal +42/−0
+ Control/Monad/Reader/Trie.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, UndecidableInstances #-}+{-# OPTIONS_GHC -fenable-rewrite-rules #-}+----------------------------------------------------------------------+-- |+-- Module : Control.Monad.Representable.Trie+-- Copyright : (c) Edward Kmett 2011+-- (c) Conal Elliott 2008+-- License : BSD3+-- +-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- +----------------------------------------------------------------------++module Control.Monad.Reader.Trie+ ( + -- * Representations of polynomial functors+ HasTrie(..)+ -- * A Trie-based Reader monad transformer+ , ReaderTrieT(..)+ -- * Memoizing functions+ , mup, memo, memo2, memo3+ , inTrie, inTrie2, inTrie3+ -- * Workarounds for current GHC limitations+ , (:=)(..)+ , trie, untrie+ , coerceKey, uncoerceKey+ ) where++import Control.Applicative+import Control.Arrow (first,(&&&))+import Control.Comonad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Identity+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.Representable+import Control.Monad.Writer.Class as Writer+import Data.Bits+import Data.Distributive+import Data.Int+import Data.Function (on)+import Data.Functor.Bind+import Data.Functor.Identity+import Data.Foldable+import Data.Key+import Data.Monoid+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Word+import Prelude hiding (lookup)++data a := b where Refl :: a := a++-- class (TraversableWithKey1 (Trie a), Representable (Trie a), Key (Trie a) ~ a) => HasTrie a where+class (TraversableWithKey1 (Trie a), Representable (Trie a)) => HasTrie a where+ type Trie a :: * -> *+ -- | Ideally we would have the constraint @Key (Trie a) ~ a@ as a class constraint. + -- We are forced to approximate this using an explicit equality witness until GHC implements this feature.+ keyRefl :: a := Key (Trie a)++coerceKey :: HasTrie a => a -> Key (Trie a)+coerceKey = go keyRefl where+ go :: HasTrie a => (a := Key (Trie a)) -> a -> Key (Trie a)+ go Refl = id++uncoerceKey :: HasTrie a => Key (Trie a) -> a+uncoerceKey = go keyRefl where+ go :: HasTrie a => (a := Key (Trie a)) -> Key (Trie a) -> a+ go Refl = id++instance HasTrie () where+ type Trie () = Identity+ keyRefl = Refl++-- Matt Hellige's notation for @argument f . result g@.+-- <http://matt.immute.net/content/pointless-fun>+(~>) :: (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'+g ~> f = (f .) . (. g)++untrie :: HasTrie t => Trie t a -> t -> a+untrie = go keyRefl where+ go :: HasTrie t => (t := Key (Trie t)) -> Trie t a -> t -> a+ go Refl = index++trie :: HasTrie t => (t -> a) -> Trie t a+trie = go keyRefl where+ go :: HasTrie t => (t := Key (Trie t)) -> (t -> a) -> Trie t a+ go Refl = tabulate++memo :: HasTrie t => (t -> a) -> t -> a+memo = untrie . trie++-- | Lift a memoizer to work with one more argument.+mup :: HasTrie t => (b -> c) -> (t -> b) -> t -> c+mup mem f = memo (mem . f)++-- | Memoize a binary function, on its first argument and then on its+-- second. Take care to exploit any partial evaluation.+memo2 :: (HasTrie s, HasTrie t) => (s -> t -> a) -> s -> t -> a+memo2 = mup memo++-- | Memoize a ternary function on successive arguments. Take care to+-- exploit any partial evaluation.+memo3 :: (HasTrie r, HasTrie s, HasTrie t) => (r -> s -> t -> a) -> r -> s -> t -> a+memo3 = mup memo2++-- | Apply a unary function inside of a tabulate+inTrie + :: (HasTrie a, HasTrie c) + => ((a -> b) -> c -> d)+ -> Trie a b -> Trie c d+inTrie = untrie ~> trie++-- | Apply a binary function inside of a tabulate+inTrie2 + :: (HasTrie a, HasTrie c, HasTrie e) + => ((a -> b) -> (c -> d) -> e -> f)+ -> Trie a b -> Trie c d -> Trie e f+inTrie2 = untrie ~> inTrie++-- | Apply a ternary function inside of a tabulate+inTrie3 + :: (HasTrie a, HasTrie c, HasTrie e, HasTrie g) + => ((a -> b) -> (c -> d) -> (e -> f) -> g -> h)+ -> Trie a b -> Trie c d -> Trie e f -> Trie g h+inTrie3 = untrie ~> inTrie2++instance (HasTrie a, HasTrie b) => HasTrie (a,b) where+ type Trie (a,b) = RepT (Trie a) (Trie b)+ keyRefl = go keyRefl keyRefl where+ go :: (a := Key (Trie a)) -> (b := Key (Trie b)) -> (a, b) := Key (Trie (a,b))+ go Refl Refl = Refl++type instance Key (ReaderTrieT a m) = (a, Key m)++newtype ReaderTrieT a m b = ReaderTrieT { runReaderTrieT :: Trie a (m b) } ++instance (HasTrie a, Functor m) => Functor (ReaderTrieT a m) where+ fmap f = ReaderTrieT . fmap (fmap f) . runReaderTrieT++instance (HasTrie a, Apply m) => Apply (ReaderTrieT a m) where+ ReaderTrieT ff <.> ReaderTrieT fa = ReaderTrieT ((<.>) <$> ff <.> fa)++instance (HasTrie a, Applicative m) => Applicative (ReaderTrieT a m) where+ pure = ReaderTrieT . pure . pure + ReaderTrieT ff <*> ReaderTrieT fa = ReaderTrieT ((<*>) <$> ff <*> fa)++instance (HasTrie a, Bind m) => Bind (ReaderTrieT a m) where+ ReaderTrieT fm >>- f = ReaderTrieT $ tabulate (\a -> index fm a >>- flip index a . runReaderTrieT . f)++instance (HasTrie a, Monad m) => Monad (ReaderTrieT a m) where+ return = ReaderTrieT . pure . return+ ReaderTrieT fm >>= f = ReaderTrieT $ tabulate (\a -> index fm a >>= flip index a . runReaderTrieT . f)++instance (HasTrie a, Monad m) => MonadReader a (ReaderTrieT a m) where + ask = ReaderTrieT (trie return)+ local f (ReaderTrieT fm) = ReaderTrieT (tabulate (index fm . coerceKey . f . uncoerceKey))++instance HasTrie a => MonadTrans (ReaderTrieT a) where+ lift = ReaderTrieT . pure ++instance (HasTrie a, Distributive m) => Distributive (ReaderTrieT a m) where+ distribute = ReaderTrieT . fmap distribute . collect runReaderTrieT++instance (HasTrie a, Keyed m) => Keyed (ReaderTrieT a m) where+ mapWithKey f = ReaderTrieT . mapWithKey (\k -> mapWithKey (f . (,) (uncoerceKey k))) . runReaderTrieT++instance (HasTrie a, Index m) => Index (ReaderTrieT a m) where+ index = uncurry . fmap index . untrie . runReaderTrieT++instance (HasTrie a, Lookup (Trie a), Lookup m) => Lookup (ReaderTrieT a m) where+ lookup (k,k') (ReaderTrieT fm) = lookup (coerceKey k) fm >>= lookup k'++instance (HasTrie a, Representable m) => Representable (ReaderTrieT a m) where+ tabulate = ReaderTrieT . trie . fmap tabulate . curry+ +instance (HasTrie a, Foldable m) => Foldable (ReaderTrieT a m) where+ foldMap f = foldMap (foldMap f) . runReaderTrieT++instance (HasTrie a, Foldable1 m) => Foldable1 (ReaderTrieT a m) where+ foldMap1 f = foldMap1 (foldMap1 f) . runReaderTrieT++instance (HasTrie a, FoldableWithKey m) => FoldableWithKey (ReaderTrieT a m) where+ foldMapWithKey f = foldMapWithKey (\k -> foldMapWithKey (f . (,) (uncoerceKey k))) . runReaderTrieT++instance (HasTrie a, FoldableWithKey1 m) => FoldableWithKey1 (ReaderTrieT a m) where+ foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) (uncoerceKey k))) . runReaderTrieT ++instance (HasTrie a, Traversable m) => Traversable (ReaderTrieT a m) where+ traverse f = fmap ReaderTrieT . traverse (traverse f) . runReaderTrieT++instance (HasTrie a, Traversable1 m) => Traversable1 (ReaderTrieT a m) where+ traverse1 f = fmap ReaderTrieT . traverse1 (traverse1 f) . runReaderTrieT++instance (HasTrie a, TraversableWithKey m) => TraversableWithKey (ReaderTrieT a m) where+ traverseWithKey f = fmap ReaderTrieT . traverseWithKey (\k -> traverseWithKey (f . (,) (uncoerceKey k))) . runReaderTrieT++instance (HasTrie a, TraversableWithKey1 m) => TraversableWithKey1 (ReaderTrieT a m) where+ traverseWithKey1 f = fmap ReaderTrieT . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) (uncoerceKey k))) . runReaderTrieT++instance (HasTrie a, Representable m, Semigroup a, Semigroup (Key m)) => Extend (ReaderTrieT a m) where+ extend = extendRep+ duplicate = duplicateRep++instance (HasTrie a, Representable m, Semigroup a, Semigroup (Key m), Monoid a, Monoid (Key m)) => Comonad (ReaderTrieT a m) where+ extract = extractRep++instance (HasTrie a, MonadIO m) => MonadIO (ReaderTrieT a m) where+ liftIO = lift . liftIO ++instance (HasTrie a, MonadWriter w m) => MonadWriter w (ReaderTrieT a m) where+ tell = lift . tell+ listen = ReaderTrieT . tabulate . fmap Writer.listen . index . runReaderTrieT+ pass = ReaderTrieT . tabulate . fmap Writer.pass . index . runReaderTrieT
+ Data/Semigroupoid/Trie.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+----------------------------------------------------------------------+-- |+-- Module : Data.Semigroupoid.Trie+-- Copyright : (c) Edward Kmett 2011+-- License : BSD3+-- +-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- +-- We may not be able to build a category out of tries, but we can+-- consruct a semigroupoid.+----------------------------------------------------------------------++module Data.Semigroupoid.Trie+ ( (:->:)(..)+ , Entry(..)+ , runT+ ) where++import Control.Applicative+import Control.Arrow (first,(&&&))+import Control.Comonad+import Control.Monad.Representable+import Control.Monad.Reader+import Control.Monad.Reader.Trie+import Data.Bits+import Data.Distributive+import Data.Function (on)+import Data.Functor.Adjunction+import Data.Functor.Bind+import Data.Foldable+import Data.Int+import Data.Key+import Data.Monoid+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+import Data.Semigroupoid+-- import Data.Semigroupoid.Ob+import Data.Word++data a :->: b where+ T :: HasTrie a => Trie a b -> a :->: b++type instance Key ((:->:) a) = a++data Entry a b = Entry a b++instance Functor (Entry a) where+ fmap f (Entry a b) = Entry a (f b)++runT :: (a :->: b) -> Trie a b+runT (T f) = f++instance Index ((:->:)e) where+ index (T f) = untrie f++instance HasTrie e => Distributive ((:->:)e) where+ distribute = distributeRep++instance HasTrie e => Representable ((:->:) e) where+ tabulate f = T (trie f)++instance HasTrie e => Adjunction (Entry e) ((:->:) e) where+ unit = mapWithKey Entry . pure+ counit (Entry a t) = index t a++instance Functor ((:->:) a) where+ fmap f (T g) = T (fmap f g)++instance Keyed ((:->:) a) where+ mapWithKey f (T a) = T (mapWithKey (f . uncoerceKey) a)++instance Foldable ((:->:) a) where+ foldMap f (T a) = foldMap f a++instance FoldableWithKey ((:->:) a) where+ foldMapWithKey f (T a) = foldMapWithKey (f . uncoerceKey) a++instance Traversable ((:->:) a) where+ traverse f (T a) = T <$> traverse f a++instance TraversableWithKey ((:->:) a) where+ traverseWithKey f (T a) = T <$> traverseWithKey (f . uncoerceKey) a++instance Foldable1 ((:->:) a) where+ foldMap1 f (T a) = foldMap1 f a++instance FoldableWithKey1 ((:->:) a) where+ foldMapWithKey1 f (T a) = foldMapWithKey1 (f . uncoerceKey) a++instance Traversable1 ((:->:) a) where+ traverse1 f (T a) = T <$> traverse1 f a++instance TraversableWithKey1 ((:->:) a) where+ traverseWithKey1 f (T a) = T <$> traverseWithKey1 (f . uncoerceKey) a++instance Eq b => Eq (a :->: b) where+ (==) = (==) `on` toList++instance Ord b => Ord (a :->: b) where+ compare = compare `on` toList++instance (Show a, Show b) => Show (a :->: b) where + showsPrec d t = showsPrec d (toIndexedList t)++instance Apply ((:->:) a) where+ T f <.> T g = T (f <.> g)+ a <. _ = a+ _ .> b = b++instance Semigroupoid (:->:) where+ o (T f) = fmap (index f . coerceKey)++-- instance HasTrie a => Ob (:->:) a where semiid = T return++instance HasTrie a => Applicative ((:->:) a) where+ pure a = T (pure a)+ T f <*> T g = T (f <*> g)+ a <* _ = a+ _ *> b = b++instance Bind ((:->:) a) where+ T m >>- f = T (tabulate (\a -> index (runT (f (index m a))) a))+ +instance HasTrie a => Monad ((:->:) a) where+ return a = T (return a)+ (>>=) = (>>-)+ _ >> m = m++instance HasTrie a => MonadReader a ((:->:) a) where+ ask = askRep+ local = localRep++instance (HasTrie m, Semigroup m, Monoid m) => Comonad ((:->:) m) where+ extract = flip index mempty++-- TODO: remove dependency on HasTrie+instance (HasTrie m, Semigroup m) => Extend ((:->:) m) where+ duplicate = duplicateRep
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ representable-tries.cabal view
@@ -0,0 +1,42 @@+name: representable-tries+category: Data Structures, Functors, Monads, Comonads+version: 0.1+license: BSD3+cabal-version: >= 1.6+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/representable-tries/+copyright: Copyright (C) 2011 Edward A. Kmett+synopsis: Tries from representations of polynomial functors+description: Tries from representations of polynomial functors+build-type: Simple++source-repository head+ type: git+ location: git://github.com/ekmett/representable-tries.git++library+ build-depends: + adjunctions >= 0.7 && < 0.8,+ array >= 0.3.0.2 && < 0.4,+ base >= 4 && < 4.4,+ comonad >= 1.0 && < 1.1,+ comonad-transformers >= 1.5.0.3 && < 1.6,+ containers >= 0.4 && < 0.5,+ contravariant >= 0.1.2 && < 0.2,+ distributive >= 0.1.1 && < 0.2,+ keys >= 0.1.0.1 && < 0.2,+ mtl >= 2.0.1.0 && < 2.1,+ representable-functors >= 0.1.0.1 && < 0.2,+ semigroups >= 0.3.4 && < 0.4,+ semigroupoids >= 1.1.1 && < 1.2.0,+ transformers >= 0.2.0 && < 0.3++ exposed-modules:+ Control.Monad.Reader.Trie+ Data.Semigroupoid.Trie++ ghc-options: -Wall -fno-warn-unused-imports+