representable-tries 2.5 → 3.0

raw patch · 15 files changed

+1230/−1224 lines, 15 filesdep ~adjunctionsdep ~bifunctorsdep ~comonad

Dependency ranges changed: adjunctions, bifunctors, comonad, comonad-transformers, keys, representable-functors, semigroupoids

Files

• Control/Monad/Reader/Trie.hs +0/−127
• Data/Functor/Representable/Trie.hs +0/−387
• Data/Functor/Representable/Trie/Bool.hs +0/−109
• Data/Functor/Representable/Trie/Either.hs +0/−123
• Data/Functor/Representable/Trie/List.hs +0/−114
• Data/Traversable/Fair.hs +0/−130
• Numeric/Nat/Zeroless.hs +0/−225
• representable-tries.cabal +11/−9
• src/Control/Monad/Reader/Trie.hs +130/−0
• src/Data/Functor/Representable/Trie.hs +388/−0
• src/Data/Functor/Representable/Trie/Bool.hs +109/−0
• src/Data/Functor/Representable/Trie/Either.hs +123/−0
• src/Data/Functor/Representable/Trie/List.hs +114/−0
• src/Data/Traversable/Fair.hs +130/−0
• src/Numeric/Nat/Zeroless.hs +225/−0

@@ -1,127 +0,0 @@-{-# LANGUAGE TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}-------------------------------------------------------------------------- |--- Module      :  Control.Monad.Reader.Trie--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- -------------------------------------------------------------------------module Control.Monad.Reader.Trie ( -  -- * A "Representable Trie"-based Reader monad transformer-    ReaderTrieT(..)-  , module Data.Functor.Representable.Trie-  ) where--import Control.Applicative-import Control.Comonad-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Control.Monad.Reader.Class-import Control.Monad.Writer.Class as Writer-import Data.Distributive-import Data.Functor.Bind-import Data.Functor.Representable-import Data.Functor.Representable.Trie-import Data.Foldable-import Data.Key-import Data.Traversable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Prelude hiding (lookup,zipWith)--type instance Key (ReaderTrieT a m) = (a, Key m)--newtype ReaderTrieT a m b = ReaderTrieT { runReaderTrieT :: 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 . f))--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, Zip m) => Zip (ReaderTrieT a m) where-  zipWith f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWith (zipWith f) m n --instance (HasTrie a, ZipWithKey m) => ZipWithKey (ReaderTrieT a m) where-  zipWithKey f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWithKey (\k -> zipWithKey (f . (,) k)) m n --instance (HasTrie a, Keyed m) => Keyed (ReaderTrieT a m) where-  mapWithKey f = ReaderTrieT . mapWithKey (\k -> mapWithKey (f . (,) k)) . runReaderTrieT--instance (HasTrie a, Indexable m) => Indexable (ReaderTrieT a m) where-  index = uncurry . fmap index . untrie . runReaderTrieT--instance (HasTrie a, Adjustable m) => Adjustable (ReaderTrieT a m) where-  adjust f (a,k) = ReaderTrieT . adjust (adjust f k) a . runReaderTrieT --instance (HasTrie a, Lookup ((:->:) a), Lookup m) => Lookup (ReaderTrieT a m) where-  lookup (k,k') (ReaderTrieT fm) = lookup 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 . (,) k)) . runReaderTrieT--instance (HasTrie a, FoldableWithKey1 m) => FoldableWithKey1 (ReaderTrieT a m) where-  foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) 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 . (,) k)) . runReaderTrieT--instance (HasTrie a, TraversableWithKey1 m) => TraversableWithKey1 (ReaderTrieT a m) where-  traverseWithKey1 f = fmap ReaderTrieT . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) 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-

@@ -1,387 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, UndecidableInstances #-}-{-# OPTIONS_GHC -fenable-rewrite-rules #-}-------------------------------------------------------------------------- |--- Module      :  Data.Functor.Representable.Trie--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- -------------------------------------------------------------------------module Data.Functor.Representable.Trie-  ( -  -- * Representations of polynomial functors-    HasTrie(..)-  -- * Memoizing functions-  , mup, memo, memo2, memo3-  , inTrie, inTrie2, inTrie3-  -- * Workarounds for current GHC limitations-  , trie, untrie-  , (:->:)(..)-  , Entry(..)-  ) where--import Control.Applicative-import Control.Arrow-import Control.Comonad-import Control.Monad.Reader.Class-import Control.Monad.Representable.Reader-import Data.Bits-import Data.Distributive-import Data.Semigroup-import Data.Word-import Data.Int-import Data.Foldable-import Data.Function (on)-import Data.Functor.Adjunction-import Data.Functor.Bind-import Data.Functor.Identity-import Data.Functor.Representable.Trie.Bool-import Data.Functor.Representable.Trie.Either-import Data.Functor.Representable.Trie.List-import Data.Key-import qualified Data.Monoid as Monoid-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Sequence (Seq, (<|))-import qualified Data.Sequence as Seq-import Data.Map (Map)-import qualified Data.Map as Map-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Traversable-import Prelude hiding (lookup, foldr)--class (Adjustable (BaseTrie a), TraversableWithKey1 (BaseTrie a), Representable (BaseTrie a)) => HasTrie a where-  type BaseTrie a :: * -> *-  -- projectKey . embedKey = id-  embedKey   :: a -> Key (BaseTrie a)-  projectKey :: Key (BaseTrie a) -> a-{--  validKey   :: Key (BaseTrie a) -> Bool-  validKey _ = True--}--newtype a :->: b = Trie { runTrie :: BaseTrie a b } --type instance Key ((:->:) a) = a--data Entry a b = Entry a b---- * Combinators---- 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 => (t :->: a) -> t -> a-untrie = index--trie :: HasTrie t => (t -> a) -> (t :->: a)-trie = tabulate--{-# RULES-"trie/untrie" forall t. trie (untrie t) = t-"embedKey/projectKey" forall t. projectKey (embedKey t) = t- #-}--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)-  -> (a :->: b) -> 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)-  -> (a :->: b) -> (c :->: d) -> 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)-  -> (a :->: b) -> (c :->: d) -> (e :->: f) -> g :->: h-inTrie3 = untrie ~> inTrie2---- * Implementation details--instance Functor (Entry a) where-  fmap f (Entry a b) = Entry a (f b)--instance HasTrie e => Lookup ((:->:)e) where-  lookup = lookupDefault--instance HasTrie e => Indexable ((:->:)e) where-  index (Trie f) = index f . embedKey--instance HasTrie e => Distributive ((:->:) e) where-  distribute = distributeRep--instance HasTrie e => Representable ((:->:) e) where-  tabulate f = Trie $ tabulate (f . projectKey)--instance HasTrie e => Adjustable ((:->:) e) where-  adjust f k (Trie as) = Trie (adjust f (embedKey k) as)--instance HasTrie e => Zip ((:->:) e)--instance HasTrie e => ZipWithKey ((:->:) e) --instance HasTrie e => Adjunction (Entry e) ((:->:) e) where-  unit = mapWithKey Entry . pure-  counit (Entry a t) = index t a--instance HasTrie a => Functor ((:->:) a) where-  fmap f (Trie g) = Trie (fmap f g)--instance HasTrie a => Keyed ((:->:) a) where-  mapWithKey f (Trie a) = Trie (mapWithKey (f . projectKey) a)--instance HasTrie a => Foldable ((:->:) a) where-  foldMap f (Trie a) = foldMap f a--instance HasTrie a => FoldableWithKey ((:->:) a) where-  foldMapWithKey f (Trie a) = foldMapWithKey (f . projectKey) a--instance HasTrie a => Traversable ((:->:) a) where-  traverse f (Trie a) = Trie <$> traverse f a--instance HasTrie a => TraversableWithKey ((:->:) a) where-  traverseWithKey f (Trie a) = Trie <$> traverseWithKey (f . projectKey) a--instance HasTrie a => Foldable1 ((:->:) a) where-  foldMap1 f (Trie a) = foldMap1 f a--instance HasTrie a => FoldableWithKey1 ((:->:) a) where-  foldMapWithKey1 f (Trie a) = foldMapWithKey1 (f . projectKey) a--instance HasTrie a => Traversable1 ((:->:) a) where-  traverse1 f (Trie a) = Trie <$> traverse1 f a--instance HasTrie a => TraversableWithKey1 ((:->:) a) where-  traverseWithKey1 f (Trie a) = Trie <$> traverseWithKey1 (f . projectKey) a--instance (HasTrie a, Eq b) => Eq (a :->: b) where-  (==) = (==) `on` toList--instance (HasTrie a, Ord b) => Ord (a :->: b) where-  compare = compare `on` toList--instance (HasTrie a, Show a, Show b) => Show (a :->: b) where -  showsPrec d = showsPrec d . toKeyedList--instance HasTrie a => Apply ((:->:) a) where-  (<.>) = apRep-  a <. _ = a-  _ .> b = b--instance HasTrie a => Applicative ((:->:) a) where-  pure a = Trie (pureRep a)-  (<*>) = apRep-  a <* _ = a-  _ *> b = b--instance HasTrie a => Bind ((:->:) a) where-  Trie m >>- f = Trie (tabulate (\a -> index (runTrie (f (index m a))) a))-  -instance HasTrie a => Monad ((:->:) a) where-  return a = Trie (pureRep a)-  (>>=) = (>>-)-  _ >> m = m--instance HasTrie a => MonadReader a ((:->:) a) where-  ask = askRep-  local = localRep---- TODO: remove dependency on HasTrie in these: --instance (HasTrie m, Semigroup m, Monoid m) => Comonad ((:->:) m) where-  extract = flip index mempty---instance (HasTrie m, Semigroup m) => Extend ((:->:) m) where-  duplicate = duplicateRep---- * Instances--instance HasTrie () where-  type BaseTrie () = Identity-  embedKey = id-  projectKey = id--instance HasTrie Bool where-  type BaseTrie Bool = BoolTrie-  embedKey = id-  projectKey = id--instance HasTrie Any where-  type BaseTrie Any = BoolTrie-  embedKey = getAny-  projectKey = Any--instance HasTrie a => HasTrie (Dual a) where-  type BaseTrie (Dual a) = BaseTrie a-  embedKey = embedKey . getDual-  projectKey = Dual . projectKey --instance HasTrie a => HasTrie (Sum a) where-  type BaseTrie (Sum a) = BaseTrie a-  embedKey = embedKey . getSum-  projectKey = Sum . projectKey --instance HasTrie a => HasTrie (Monoid.Product a) where-  type BaseTrie (Monoid.Product a) = BaseTrie a-  embedKey = embedKey . Monoid.getProduct-  projectKey = Monoid.Product . projectKey --instance (HasTrie a, HasTrie b) => HasTrie (a, b) where-  type BaseTrie (a, b) = ReaderT (BaseTrie a) (BaseTrie b)-  embedKey = embedKey *** embedKey-  projectKey = projectKey *** projectKey--instance (HasTrie a, HasTrie b) => HasTrie (Entry a b) where-  type BaseTrie (Entry a b) = ReaderT (BaseTrie a) (BaseTrie b)-  embedKey (Entry a b) = (embedKey a, embedKey b)-  projectKey (a, b) = Entry (projectKey a) (projectKey b)--instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where-  type BaseTrie (Either a b) = EitherTrie (BaseTrie a) (BaseTrie b)-  embedKey = embedKey +++ embedKey-  projectKey = projectKey +++ projectKey--instance HasTrie a => HasTrie (Maybe a) where-  type BaseTrie (Maybe a) = EitherTrie Identity (BaseTrie a)-  embedKey   = maybe (Left ()) (Right . embedKey)-  projectKey = either (const Nothing) (Just . projectKey)--instance HasTrie a => HasTrie [a] where-  type BaseTrie [a] = ListTrie (BaseTrie a)-  embedKey = map embedKey-  projectKey = map projectKey--instance HasTrie a => HasTrie (Seq a) where-  type BaseTrie (Seq a) = ListTrie (BaseTrie a)-  embedKey = foldr ((:) . embedKey) []-  projectKey = foldr ((<|) . projectKey) (Seq.empty)--instance (HasTrie k, HasTrie v) => HasTrie (Map k v) where-  type BaseTrie (Map k v) = ListTrie (BaseTrie (k, v))-  embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) []-  projectKey = Map.fromDistinctAscList . map projectKey--instance (HasTrie v) => HasTrie (IntMap v) where-  type BaseTrie (IntMap v) = ListTrie (BaseTrie (Int, v))-  embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) []-  projectKey = IntMap.fromDistinctAscList . map projectKey--  --- | Extract bits in little-endian order-bits :: Bits t => t -> [Bool]-bits 0 = []-bits x = testBit x 0 : bits (shiftR x 1)---- | Convert boolean to 0 (False) or 1 (True)-unbit :: Num t => Bool -> t-unbit False = 0-unbit True  = 1---- | Bit list to value-unbits :: Bits t => [Bool] -> t-unbits [] = 0-unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1--unbitsZ :: (Bits n) => (Bool,[Bool]) -> n-unbitsZ (positive,bs) = sig (unbits bs)- where-   sig | positive  = id-       | otherwise = negate--bitsZ :: (Ord n, Bits n) => n -> (Bool,[Bool])-bitsZ = (>= 0) &&& (bits . abs)---- TODO: fix the show instance of this-instance HasTrie Int where-  type BaseTrie Int = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey--instance HasTrie Int8 where-  type BaseTrie Int8 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey--instance HasTrie Int16 where-  type BaseTrie Int16 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey--instance HasTrie Int32 where-  type BaseTrie Int32 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey--instance HasTrie Int64 where-  type BaseTrie Int64 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey--instance HasTrie Word where-  type BaseTrie Word = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey-instance HasTrie Word8 where-  type BaseTrie Word8 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey-instance HasTrie Word16 where-  type BaseTrie Word16 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey-instance HasTrie Word32 where-  type BaseTrie Word32 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey-instance HasTrie Word64 where-  type BaseTrie Word64 = BaseTrie (Bool, [Bool])-  embedKey = embedKey . bitsZ -  projectKey = unbitsZ . projectKey---- TODO: fix tree to 21 bit depth-instance HasTrie Char where-  type BaseTrie Char = BaseTrie [Bool]-  embedKey = bits . fromEnum-  projectKey = toEnum . unbits--instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where-  type BaseTrie (a,b,c) = BaseTrie (a,(b,c))-  embedKey (a,b,c) = embedKey (a,(b,c))-  projectKey p = let (a,(b,c)) = projectKey p in (a,b,c)--instance (HasTrie a, HasTrie b, HasTrie c, HasTrie d) => HasTrie (a,b,c,d) where-  type BaseTrie (a,b,c,d) = BaseTrie ((a,b),(c,d))-  embedKey (a,b,c,d) = embedKey ((a,b),(c,d))-  projectKey p = let ((a,b),(c,d)) = projectKey p in (a,b,c,d)

@@ -1,109 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-------------------------------------------------------------------------- |--- Module      :  Data.Functor.Representable.Trie.Bool--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- -------------------------------------------------------------------------module Data.Functor.Representable.Trie.Bool ( BoolTrie (..) ) where--import Control.Applicative-import Data.Distributive-import Data.Functor.Representable-import Data.Functor.Bind-import Data.Foldable-import Data.Traversable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Key-import Prelude hiding (lookup)---- (Bool, -) -| BoolTrie-data BoolTrie a = BoolTrie a a deriving (Eq,Ord,Show,Read)--false :: BoolTrie a -> a-false (BoolTrie a _) = a--true :: BoolTrie a -> a-true (BoolTrie _ b) = b--type instance Key BoolTrie = Bool--instance Functor BoolTrie where-  fmap f (BoolTrie a b) = BoolTrie (f a) (f b)-  b <$ _ = pure b--instance Apply BoolTrie where-  BoolTrie a b <.> BoolTrie c d = BoolTrie (a c) (b d)-  a <. _ = a-  _ .> b = b--instance Applicative BoolTrie where-  pure a = BoolTrie a a-  (<*>) = (<.>) -  a <* _ = a-  _ *> b = b--instance Bind BoolTrie where-  BoolTrie a b >>- f = BoolTrie (false (f a)) (true (f b))--instance Monad BoolTrie where-  return = pure-  BoolTrie a b >>= f = BoolTrie (false (f a)) (true (f b))-  _ >> a = a--instance Keyed BoolTrie where-  mapWithKey f (BoolTrie a b) = BoolTrie (f False a) (f True b)--instance Zip BoolTrie where-  zipWith f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f a c) (f b d)--instance ZipWithKey BoolTrie where-  zipWithKey f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f False a c) (f True b d)--instance Foldable BoolTrie where-  foldMap f (BoolTrie a b) = f a `mappend` f b--instance Foldable1 BoolTrie where-  foldMap1 f (BoolTrie a b) = f a <> f b--instance Traversable BoolTrie where-  traverse f (BoolTrie a b) = BoolTrie <$> f a <*> f b--instance Traversable1 BoolTrie where-  traverse1 f (BoolTrie a b) = BoolTrie <$> f a <.> f b--instance FoldableWithKey BoolTrie where-  foldMapWithKey f (BoolTrie a b) = f False a `mappend` f True b--instance FoldableWithKey1 BoolTrie where-  foldMapWithKey1 f (BoolTrie a b) = f False a <> f True b--instance TraversableWithKey BoolTrie where-  traverseWithKey f (BoolTrie a b) = BoolTrie <$> f False a <*> f True b--instance TraversableWithKey1 BoolTrie where-  traverseWithKey1 f (BoolTrie a b) = BoolTrie <$> f False a <.> f True b--instance Distributive BoolTrie where-  distribute = distributeRep--instance Indexable BoolTrie where-  index (BoolTrie a _) False = a-  index (BoolTrie _ b) True  = b--instance Adjustable BoolTrie where-  adjust f False (BoolTrie a b) = BoolTrie (f a) b-  adjust f True (BoolTrie a b) = BoolTrie a (f b)--instance Lookup BoolTrie where-  lookup = lookupDefault--instance Representable BoolTrie where-  tabulate f = BoolTrie (f False) (f True)

@@ -1,123 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-------------------------------------------------------------------------- |--- Module      :  Data.Functor.Representable.Trie.Bool--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- -------------------------------------------------------------------------module Data.Functor.Representable.Trie.Either ( -    EitherTrie (..) -  , left-  , right-  ) where--import Control.Applicative-import Data.Distributive-import Data.Functor.Representable-import Data.Functor.Bind-import Data.Foldable-import Data.Traversable-import Data.Traversable.Fair-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Key-import Prelude hiding (lookup,zipWith)---- the product functor would be the trie of an either, but we fair traversal-data EitherTrie f g a = EitherTrie (f a) (g a)--type instance Key (EitherTrie f g) = Either (Key f) (Key g)--left :: EitherTrie f g a -> f a-left (EitherTrie f _) = f--right :: EitherTrie f g a -> g a-right (EitherTrie _ g) = g--instance (Apply f, Apply g, Semigroup s) => Semigroup (EitherTrie f g s) where-  EitherTrie a b <> EitherTrie c d = EitherTrie ((<>) <$> a <.> c) ((<>) <$> b <.> d)--instance (Applicative f, Applicative g, Monoid a) => Monoid (EitherTrie f g a) where-  mempty = EitherTrie (pure mempty) (pure mempty)-  EitherTrie a b `mappend` EitherTrie c d = EitherTrie (mappend <$> a <*> c) (mappend <$> b <*> d)--instance (Functor f, Functor g) => Functor (EitherTrie f g) where-  fmap f (EitherTrie fs gs) = EitherTrie (fmap f fs) (fmap f gs)-  b <$ EitherTrie fs gs = EitherTrie (b <$ fs) (b <$ gs)--instance (Apply f, Apply g) => Apply (EitherTrie f g) where-  EitherTrie ff fg <.> EitherTrie af ag = EitherTrie (ff <.> af) (fg <.> ag)-  a <. _ = a-  _ .> b = b--instance (Applicative f, Applicative g) => Applicative (EitherTrie f g) where-  pure a = EitherTrie (pure a) (pure a)-  EitherTrie ff fg <*> EitherTrie af ag = EitherTrie (ff <*> af) (fg <*> ag)-  a <* _ = a-  _ *> b = b---- the direct implementation in terms of Bind is inefficient, using bindRep instead-instance (Apply f, Representable f, Apply g, Representable g) => Bind (EitherTrie f g) where-  (>>-) = bindRep--instance (Representable f, Representable g) => Monad (EitherTrie f g) where-  return = pureRep-  (>>=) = bindRep-  _ >> a = a--instance (Keyed f, Keyed g) => Keyed (EitherTrie f g) where-  mapWithKey f (EitherTrie fs gs) = EitherTrie (mapWithKey (f . Left) fs) (mapWithKey (f . Right) gs)--instance (Zip f, Zip g) => Zip (EitherTrie f g) where-  zipWith f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWith f fs hs) (zipWith f gs is)--instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (EitherTrie f g) where-  zipWithKey f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWithKey (f . Left) fs hs) (zipWithKey (f . Right) gs is)--instance (Foldable f, Foldable g) => Foldable (EitherTrie f g) where-  foldMap f (EitherTrie fs gs) = foldMapBoth f fs gs--instance (Foldable1 f, Foldable1 g) => Foldable1 (EitherTrie f g) where-  foldMap1 f (EitherTrie fs gs) = foldMapBoth1 f fs gs--instance (Traversable f, Traversable g) => Traversable (EitherTrie f g) where-  traverse f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth f fs gs--instance (Traversable1 f, Traversable1 g) => Traversable1 (EitherTrie f g) where-  traverse1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth1 f fs gs--instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (EitherTrie f g) where-  foldMapWithKey f (EitherTrie fs gs) = foldMapWithKeyBoth (f . Left) (f . Right) fs gs--instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (EitherTrie f g) where-  foldMapWithKey1 f (EitherTrie fs gs) = foldMapWithKeyBoth1 (f . Left) (f . Right) fs gs--instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (EitherTrie f g) where-  traverseWithKey f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth (f . Left) (f . Right) fs gs--instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (EitherTrie f g) where-  traverseWithKey1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth1 (f . Left) (f . Right) fs gs--instance (Representable f, Representable g) => Distributive (EitherTrie f g) where-  distribute = distributeRep--instance (Indexable f, Indexable g) => Indexable (EitherTrie f g) where-  index (EitherTrie fs _) (Left  i) = index fs i-  index (EitherTrie _ gs) (Right j) = index gs j--instance (Adjustable f, Adjustable g) => Adjustable (EitherTrie f g) where-  adjust f (Left i) (EitherTrie fs gs)  = EitherTrie (adjust f i fs) gs-  adjust f (Right j) (EitherTrie fs gs) = EitherTrie fs (adjust f j gs)--instance (Lookup f, Lookup g) => Lookup (EitherTrie f g) where-  lookup (Left i) (EitherTrie fs _)  = lookup i fs-  lookup (Right j) (EitherTrie _ gs) = lookup j gs--instance (Representable f, Representable g) => Representable (EitherTrie f g) where-  tabulate f = EitherTrie (tabulate (f . Left)) (tabulate (f . Right))

@@ -1,114 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-------------------------------------------------------------------------- |--- Module      :  Data.Functor.Representable.Trie.List--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental----------------------------------------------------------------------------module Data.Functor.Representable.Trie.List (-    ListTrie (..)-  , nil-  , cons-  ) where--import Control.Applicative-import Data.Distributive-import Data.Functor.Representable-import Data.Functor.Bind-import Data.Foldable-import Data.Traversable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Key-import Prelude hiding (lookup,zipWith)---- the f-branching stream comonad is the trie of a list-data ListTrie f a = ListTrie a (f (ListTrie f a)) -- deriving (Eq,Ord,Show,Read)--type instance Key (ListTrie f) = [Key f]--nil :: ListTrie f a -> a-nil (ListTrie x _) = x--cons :: Indexable f => Key f -> ListTrie f a -> ListTrie f a-cons a (ListTrie _ xs) = index xs a--instance Functor f => Functor (ListTrie f) where-  fmap f (ListTrie a as) = ListTrie (f a) (fmap (fmap f) as)--- b <$ _ = pure b--instance Representable f => Apply (ListTrie f) where-  (<.>) = apRep-  a <. _ = a-  _ .> b = b--instance Representable f => Applicative (ListTrie f) where-  pure a = as where as = ListTrie a (pureRep as)-  (<*>) = apRep-  a <* _ = a-  _ *> b = b--instance Representable f => Bind (ListTrie f) where-  (>>-) = bindRep--instance Representable f => Monad (ListTrie f) where-  return a = as where as = ListTrie a (pureRep as)-  (>>=) = bindRep-  _ >> a = a--instance Zip f => Zip (ListTrie f) where-  zipWith f (ListTrie a as) (ListTrie b bs) = ListTrie (f a b) (zipWith (zipWith f) as bs)--instance ZipWithKey f => ZipWithKey (ListTrie f) where-  zipWithKey f (ListTrie a as) (ListTrie b bs) = ListTrie (f [] a b) (zipWithKey (\x -> zipWithKey (f . (x:))) as bs)--instance Keyed f => Keyed (ListTrie f) where-  mapWithKey f (ListTrie a as) = ListTrie (f [] a) (mapWithKey (\x -> mapWithKey (f . (x:))) as)--instance Foldable f => Foldable (ListTrie f) where-  foldMap f (ListTrie a as) = f a `mappend` foldMap (foldMap f) as--instance Foldable1 f => Foldable1 (ListTrie f) where-  foldMap1 f (ListTrie a as) = f a <> foldMap1 (foldMap1 f) as--instance Traversable f => Traversable (ListTrie f) where-  traverse f (ListTrie a as) = ListTrie <$> f a <*> traverse (traverse f) as--instance Traversable1 f => Traversable1 (ListTrie f) where-  traverse1 f (ListTrie a as) = ListTrie <$> f a <.> traverse1 (traverse1 f) as--instance FoldableWithKey f => FoldableWithKey (ListTrie f) where-  foldMapWithKey f (ListTrie a as) = f [] a `mappend` foldMapWithKey (\x -> foldMapWithKey (f . (x:))) as--instance FoldableWithKey1 f => FoldableWithKey1 (ListTrie f) where-  foldMapWithKey1 f (ListTrie a as) = f [] a <> foldMapWithKey1 (\x -> foldMapWithKey1 (f . (x:))) as--instance TraversableWithKey f => TraversableWithKey (ListTrie f) where-  traverseWithKey f (ListTrie a as) = ListTrie <$> f [] a <*> traverseWithKey (\x -> traverseWithKey (f . (x:))) as--instance TraversableWithKey1 f => TraversableWithKey1 (ListTrie f) where-  traverseWithKey1 f (ListTrie a as) = ListTrie <$> f [] a <.> traverseWithKey1 (\x -> traverseWithKey1 (f . (x:))) as--instance Representable f => Distributive (ListTrie f) where-  distribute = distributeRep--instance Indexable f => Indexable (ListTrie f) where-  index (ListTrie x _) [] = x-  index (ListTrie _ xs) (a:as) = index (index xs a) as--instance Adjustable f => Adjustable (ListTrie f) where-  adjust f [] (ListTrie x xs) = ListTrie (f x) xs-  adjust f (a:as) (ListTrie x xs) = ListTrie x (adjust (adjust f as) a xs)--instance Lookup f => Lookup (ListTrie f) where-  lookup [] (ListTrie x _) = Just x-  lookup (a:as) (ListTrie _ xs) = lookup a xs >>= lookup as--instance Representable f => Representable (ListTrie f) where-  tabulate f = ListTrie (f []) (tabulate (\x -> tabulate (f . (x:))))

@@ -1,130 +0,0 @@-module Data.Traversable.Fair -  ( foldMapBoth-  , traverseBoth-  , foldMapWithKeyBoth-  , traverseWithKeyBoth-  , foldMapBoth1-  , traverseBoth1-  , foldMapWithKeyBoth1-  , traverseWithKeyBoth1-  ) where--import Control.Applicative-import Control.Arrow-import Data.Key-import Data.Functor.Apply-import Data.Foldable-import Data.Traversable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.List.NonEmpty as NonEmpty hiding (toList)--refill :: Traversable t => t a -> [b] -> t b-refill t l = snd (mapAccumL (\xs _ -> (Prelude.tail xs, Prelude.head xs)) l t)--toNonEmptyList :: Foldable1 f => f a -> NonEmpty a-toNonEmptyList = NonEmpty.fromList . toList--toKeyedNonEmptyList :: FoldableWithKey1 f => f a -> NonEmpty (Key f, a)-toKeyedNonEmptyList = NonEmpty.fromList . toKeyedList--foldMapBoth :: (Foldable f, Foldable g, Monoid m) => (a -> m) -> f a -> g a -> m-foldMapBoth f as bs = go (toList as) (toList bs) where-  go [] [] = mempty-  go xs [] = foldMap f xs-  go [] ys = foldMap f ys-  go (x:xs) (y:ys) = f x `mappend` f y `mappend` go xs ys---- | traverse both containers, interleaving effects for fairness-traverseBoth :: (Traversable f, Traversable g, Applicative m) => (a -> m b) -> f a -> g a -> m (f b, g b)-traverseBoth f as bs = (refill as *** refill bs) <$> go (toList as) (toList bs)-  where-  go [] []         = pure ([],[])-  go xs []         = flip (,) [] <$> traverse f xs-  go [] ys         = (,) [] <$> traverse f ys-  go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f x <*> f y <*> go xs ys---- | fold both containers, interleaving results for fairness-foldMapBoth1 :: (Foldable1 f, Foldable1 g, Semigroup m) => (a -> m) -> f a -> g a -> m-foldMapBoth1 f as bs = go (toNonEmptyList as) (toNonEmptyList bs)-  where-  go (x:|[])   (y:|[])   = f x <> f y-  go (x:|z:zs) (y:|[])   = f x <> f y <> foldMap1 f (z:|zs)-  go (x:|[])   ys        = f x <> foldMap1 f ys-  go (x:|z:zs) (y:|w:ws) = f x <> f y <> go (z:|zs) (w:|ws)---- | traverse both containers, interleaving effects for fairness-traverseBoth1 :: (Traversable1 f, Traversable1 g, Apply m) => (a -> m b) -> f a -> g a -> m (f b, g b)-traverseBoth1 f as bs = (refill as *** refill bs) <$> go (toNonEmptyList as) (toNonEmptyList bs)-  where-  go (x:|[])   (y:|[])   = (\x' y'            -> ([x'],       [y']  )) <$> f x <.> f y-  go (x:|z:zs) (y:|[])   = (\x' y' (x'':|xs') -> (x':x'':xs', [y']  )) <$> f x <.> f y <.> traverse1 f (z:|zs)-  go (x:|[])   ys        = (\x' (y':|ys')     -> ([x'],       y':ys')) <$> f x <.> traverse1 f ys-  go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs',     y':ys')) <$> f x <.> f y <.> go (z:|zs) (w:|ws)--foldMapWithKeyBoth -  :: (FoldableWithKey f, FoldableWithKey g, Monoid m) -  => (Key f -> a -> m) -  -> (Key g -> a -> m)-  -> f a -  -> g a -  -> m-foldMapWithKeyBoth f g as bs = go (toKeyedList as) (toKeyedList bs) where-  f' = uncurry f-  g' = uncurry g-  go [] [] = mempty-  go xs [] = foldMap f' xs-  go [] ys = foldMap g' ys-  go (x:xs) (y:ys) = f' x `mappend` g' y `mappend` go xs ys---- | traverse both containers, interleaving effects for fairness-traverseWithKeyBoth -  :: (TraversableWithKey f, TraversableWithKey g, Applicative m) -  => (Key f -> a -> m b) -  -> (Key g -> a -> m b) -  -> f a -  -> g a -  -> m (f b, g b)-traverseWithKeyBoth f g as bs = (refill as *** refill bs) <$> go (toKeyedList as) (toKeyedList bs)-  where-  f' = uncurry f-  g' = uncurry g-  go [] []         = pure ([],[])-  go xs []         = flip (,) [] <$> traverse f' xs-  go [] ys         = (,) [] <$> traverse g' ys-  go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f' x <*> g' y <*> go xs ys---- | fold both containers, interleaving results for fairness-foldMapWithKeyBoth1 -  :: (FoldableWithKey1 f, FoldableWithKey1 g, Semigroup m) -  => (Key f -> a -> m) -  -> (Key g -> a -> m) -  -> f a -  -> g a -  -> m-foldMapWithKeyBoth1 f g as bs = go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)-  where-  f' = uncurry f-  g' = uncurry g-  go (x:|[])   (y:|[])   = f' x <> g' y-  go (x:|z:zs) (y:|[])   = f' x <> g' y <> foldMap1 f' (z:|zs)-  go (x:|[])   ys        = f' x <> foldMap1 g' ys-  go (x:|z:zs) (y:|w:ws) = f' x <> g' y <> go (z:|zs) (w:|ws)---- | traverse both containers, interleaving effects for fairness-traverseWithKeyBoth1 -  :: (TraversableWithKey1 f, TraversableWithKey1 g, Apply m) -  => (Key f -> a -> m b) -  -> (Key g -> a -> m b) -  -> f a -  -> g a -  -> m (f b, g b)-traverseWithKeyBoth1 f g as bs = (refill as *** refill bs) <$> go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)-  where-  f' = uncurry f-  g' = uncurry g-  go (x:|[])   (y:|[])   = (\x' y'            -> ([x'],      [y']  )) <$> f' x <.> g' y-  go (x:|z:zs) (y:|[])   = (\x' y' (z':|zs')  -> (x':z':zs', [y']  )) <$> f' x <.> g' y <.> traverse1 f' (z:|zs)-  go (x:|[])   ys        = (\x' (y':|ys')     -> ([x'],      y':ys')) <$> f' x <.> traverse1 g' ys-  go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs',    y':ys')) <$> f' x <.> g' y <.> go (z:|zs) (w:|ws)

@@ -1,225 +0,0 @@-{-# LANGUAGE TypeFamilies, Rank2Types, TypeOperators, GADTs, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}-------------------------------------------------------------------------- |--- Module      :  Numeric.Nat.Zeroless--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- --- Zeroless numbers encoded in zeroless binary numbers-------------------------------------------------------------------------module Numeric.Nat.Zeroless-  ( D0(..), D1(..), D2(..), (:+:), (:*:), Zeroless(..)-  , Succ, Pred-  , LT, GT, EQ-  , Compare-  , N1, N8, N16, N32, N64-  , Nat(..), nat -  , Fin(..)-  , Reverse-  ) where--import Data.Function (on)-import Prelude hiding (lookup)--infixl 7 :*:-infixl 6 :+: ---- * Type-level naturals using zeroless binary numbers--data D0 = D0 -- ^ 0 -data D1 n = D1 n -- ^ 2n + 1-data D2 n = D2 n -- ^ 2n + 2---- * useful numbers-type N1 = D1 D0-type N8  = D2 (D1 (D1 D0))-type N16 = D2 (D1 (D1 (D1 D0)))-type N32 = D2 (D1 (D1 (D1 (D1 D0))))-type N64 = D2 (D1 (D1 (D1 (D1 (D1 D0)))))---- * Successor -type family Succ n-type instance Succ D0 = D1 D0-type instance Succ (D1 n) = D2 n-type instance Succ (D2 n) = D1 (Succ n)--type family Pred n-type instance Pred (D1 D0) = D0-type instance Pred (D1 (D1 n)) = D2 (Pred (D1 n))-type instance Pred (D1 (D2 n)) = D2 (D1 n)-type instance Pred (D2 n) = D1 n---- * Carry flags-data C0-data C1-data C2---- * Add with carry-type family Add c n m-type instance Add C0 D0 n = n-type instance Add C1 D0 D0 = D1 D0-type instance Add C2 D0 D0 = D2 D0-type instance Add C1 D0 (D1 n) = D2 n-type instance Add C1 D0 (D2 n) = D1 (Add C1 D0 n) -type instance Add C2 D0 (D1 n) = D1 (Add C1 D0 n)-type instance Add C2 D0 (D2 n) = D2 (Add C1 D0 n)-type instance Add C0 (D1 n) D0 = D1 n-type instance Add C1 (D1 n) D0 = D2 n-type instance Add C2 (D1 n) D0 = D1 (Add C1 D0 n)-type instance Add C0 (D1 n) (D1 m) = D2 (Add C0 n m)-type instance Add C1 (D1 n) (D1 m) = D1 (Add C1 n m)-type instance Add C2 (D1 n) (D1 m) = D2 (Add C1 n m)-type instance Add C0 (D1 n) (D2 m) = D1 (Add C1 n m)-type instance Add C1 (D1 n) (D2 m) = D2 (Add C1 n m)-type instance Add C2 (D1 n) (D2 m) = D1 (Add C2 n m)-type instance Add C0 (D2 n) D0 = D2 n-type instance Add C1 (D2 n) D0 = D1 (Add C1 D0 n)-type instance Add C2 (D2 n) D0 = D2 (Add C1 D0 n)-type instance Add C0 (D2 n) (D1 m) = D1 (Add C1 n m)-type instance Add C1 (D2 n) (D1 m) = D2 (Add C1 n m)-type instance Add C2 (D2 n) (D1 m) = D1 (Add C2 n m)-type instance Add C0 (D2 n) (D2 m) = D2 (Add C1 n m)-type instance Add C1 (D2 n) (D2 m) = D1 (Add C2 n m)-type instance Add C2 (D2 n) (D2 m) = D2 (Add C2 n m)---- * Adder-type n :+: m = Add C0 n m--data LT-data EQ-data GT--type family   Compare' a l      r-type instance Compare' a D0     D0     = a-type instance Compare' a D0     (D1 r) = LT-type instance Compare' a D0     (D2 r) = LT-type instance Compare' a (D1 r) D0     = GT-type instance Compare' a (D1 l) (D1 r) = Compare' a l r-type instance Compare' a (D1 l) (D2 r) = Compare' LT l r-type instance Compare' a (D2 l) D0     = GT-type instance Compare' a (D2 l) (D1 r) = Compare' GT l r-type instance Compare' a (D2 l) (D2 r) = Compare' a l r--type Compare m n = Compare' EQ m n ---- * Multiplier-type family n :*: m-type instance D0 :*: m = D0-type instance D1 n :*: m = (n :*: m) :+: (n :*: m) :+: m-type instance D2 n :*: m = (n :*: m) :+: (n :*: m) :+: m :+: m---- * Digit Counter-type family Digits n-type instance Digits D0 = D0-type instance Digits (D1 n) = Succ (Digits n)-type instance Digits (D2 n) = Succ (Digits n)--type family Reverse' n m-type instance Reverse' m D0     = m -type instance Reverse' m (D1 n) = Reverse' (D1 m) n -type instance Reverse' m (D2 n) = Reverse' (D2 m) n---- * bitwise reversal-type Reverse n = Reverse' D0 n--{--data Z = Z-newtype S n = S n-class Nat n where-  caseNat :: forall n. ((n ~ Z) => r) -> (forall x. (n ~ (S x), Nat x) => x -> r) -> r--}---- * Class of zeroless-binary numbers-class Zeroless n where-  ind :: f D0 -      -> (forall m. Zeroless m => f m -> f (D1 m)) -      -> (forall m. Zeroless m => f m -> f (D2 m))-      -> f n-  caseNat-    :: ((n ~ D0) => r) -    -> (forall x. (n ~ D1 x, Zeroless x) => x -> r)-    -> (forall x. (n ~ D2 x, Zeroless x) => x -> r)-    -> n -> r--instance Zeroless D0 where-  ind z _ _ = z -  caseNat z _ _ _ = z--instance Zeroless n => Zeroless (D1 n) where-  ind z f g = f (ind z f g)-  caseNat _ f _ (D1 x) = f x--instance Zeroless n => Zeroless (D2 n) where-  ind z f g = g (ind z f g)-  caseNat _ _ g (D2 x) = g x--class Zeroless n => Positive n-instance Zeroless n => Positive (D1 n)-instance Zeroless n => Positive (D2 n)--newtype Nat n = Nat { fromNat :: Int }--instance Zeroless n => Eq (Nat n) where-  _ == _ = True--instance Zeroless n => Ord (Nat n) where-  compare _ _ = EQ--instance Zeroless n => Show (Nat n) where-  showsPrec d (Nat n) = showsPrec d n--instance Zeroless n => Bounded (Nat n) where-  minBound = nat-  maxBound = nat--instance Zeroless n => Enum (Nat n) where-  fromEnum (Nat n) = n-  toEnum _ = nat--nat :: Zeroless n => Nat n -nat = ind (Nat 0) -          (Nat . (+1) . (*2) . fromNat) -          (Nat . (+2) . (*2) . fromNat)---- * A finite number @m < n@-newtype Fin n = Fin { fromFin :: Int } --instance Show (Fin n) where-  showsPrec d = showsPrec d . fromFin--instance Eq (Fin n) where-  (==) = (==) `on` fromFin--instance Ord (Fin n) where-  compare = compare `on` fromFin --instance Positive n => Num (Fin n) where-  fromInteger = toEnum . fromInteger-  a + b = toEnum (fromFin a + fromFin b)-  a * b = toEnum (fromFin a * fromFin b)-  a - b = toEnum (fromFin a - fromFin b)-  abs a = a-  signum 0 = 0-  signum _ = 1--inFin :: (Int -> Int) -> Fin n -> Fin n-inFin f = Fin . f . fromFin--instance Positive n => Bounded (Fin n) where-  minBound = Fin 0-  maxBound = inFin (subtract 1) $ -             ind (Fin 0) -                 (Fin . ((+1) . (*2)) . fromFin)-                 (Fin . ((+2) . (*2)) . fromFin)--instance Positive n => Enum (Fin n) where-  fromEnum = fromFin-  toEnum n = r where-    r | n < 0 = error "Fin.toEnum: negative number"-      | Fin n <= b = Fin n `asTypeOf` b-      | otherwise = error "Fin.toEnum: index out of range"-    b = maxBound

@@ -1,6 +1,6 @@ name:          representable-tries category:      Data Structures, Functors, Monads, Comonads-version:       2.5+version:       3.0 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -20,6 +20,8 @@   location: git://github.com/ekmett/representable-tries.git  library+  hs-source-dirs: src+   other-extensions:     CPP     EmptyDataDecls@@ -34,19 +36,19 @@     UndecidableInstances    build-depends:+    adjunctions            == 3.0.*,     base                   >= 4       && < 5,+    bifunctors             == 3.0.*,+    comonad                == 3.0.*,+    comonad-transformers   == 3.0.*,     containers             >= 0.3     && < 0.6,+    distributive           >= 0.2.2   && < 0.3,+    keys                   == 3.0.*,     mtl                    >= 2.0.1   && < 2.2,     transformers           >= 0.2     && < 0.4,-    bifunctors             >= 0.1.3.1 && < 0.2,-    comonad                >= 1.1.1.5 && < 1.2,-    distributive           >= 0.2.2   && < 0.3,+    representable-functors == 3.0.*,     semigroups             >= 0.8.3.1 && < 0.9,-    semigroupoids          >= 1.3.1.2 && < 1.4,-    keys                   >= 2.2     && < 2.3,-    comonad-transformers   >= 2.1.1.1 && < 2.2,-    adjunctions            >= 2.5     && < 2.6,-    representable-functors >= 2.5     && < 2.6+    semigroupoids          == 3.0.*    exposed-modules:     Control.Monad.Reader.Trie

@@ -0,0 +1,130 @@+{-# LANGUAGE TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+----------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Reader.Trie+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+--+----------------------------------------------------------------------++module Control.Monad.Reader.Trie (+  -- * A "Representable Trie"-based Reader monad transformer+    ReaderTrieT(..)+  , module Data.Functor.Representable.Trie+  ) where++import Control.Applicative+import Control.Comonad+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class as Writer+import Data.Distributive+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Key+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Prelude hiding (lookup,zipWith)++type instance Key (ReaderTrieT a m) = (a, Key m)++newtype ReaderTrieT a m b = ReaderTrieT { runReaderTrieT :: 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 . f))++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, Zip m) => Zip (ReaderTrieT a m) where+  zipWith f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWith (zipWith f) m n++instance (HasTrie a, ZipWithKey m) => ZipWithKey (ReaderTrieT a m) where+  zipWithKey f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWithKey (\k -> zipWithKey (f . (,) k)) m n++instance (HasTrie a, Keyed m) => Keyed (ReaderTrieT a m) where+  mapWithKey f = ReaderTrieT . mapWithKey (\k -> mapWithKey (f . (,) k)) . runReaderTrieT++instance (HasTrie a, Indexable m) => Indexable (ReaderTrieT a m) where+  index = uncurry . fmap index . untrie . runReaderTrieT++instance (HasTrie a, Adjustable m) => Adjustable (ReaderTrieT a m) where+  adjust f (a,k) = ReaderTrieT . adjust (adjust f k) a . runReaderTrieT++instance (HasTrie a, Lookup ((:->:) a), Lookup m) => Lookup (ReaderTrieT a m) where+  lookup (k,k') (ReaderTrieT fm) = lookup 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 . (,) k)) . runReaderTrieT++instance (HasTrie a, FoldableWithKey1 m) => FoldableWithKey1 (ReaderTrieT a m) where+  foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) 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 . (,) k)) . runReaderTrieT++instance (HasTrie a, TraversableWithKey1 m) => TraversableWithKey1 (ReaderTrieT a m) where+  traverseWithKey1 f = fmap ReaderTrieT . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) k)) . runReaderTrieT++instance (HasTrie a, Representable m, Semigroup a, Semigroup (Key m)) => Extend (ReaderTrieT a m) where+  extended = extendedRep+  duplicated = duplicatedRep++instance (HasTrie a, Representable m, Monoid a, Monoid (Key m)) => Comonad (ReaderTrieT a m) where+  extend = extendRep+  duplicate = duplicateRep+  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+

@@ -0,0 +1,388 @@+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, UndecidableInstances #-}+{-# OPTIONS_GHC -fenable-rewrite-rules #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Representable.Trie+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+--+----------------------------------------------------------------------++module Data.Functor.Representable.Trie+  (+  -- * Representations of polynomial functors+    HasTrie(..)+  -- * Memoizing functions+  , mup, memo, memo2, memo3+  , inTrie, inTrie2, inTrie3+  -- * Workarounds for current GHC limitations+  , trie, untrie+  , (:->:)(..)+  , Entry(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Comonad+import Control.Monad.Reader.Class+import Control.Monad.Representable.Reader+import Data.Bits+import Data.Distributive+import Data.Semigroup+import Data.Word+import Data.Int+import Data.Foldable+import Data.Function (on)+import Data.Functor.Adjunction+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Identity+import Data.Functor.Representable.Trie.Bool+import Data.Functor.Representable.Trie.Either+import Data.Functor.Representable.Trie.List+import Data.Key+import qualified Data.Monoid as Monoid+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Sequence (Seq, (<|))+import qualified Data.Sequence as Seq+import Data.Map (Map)+import qualified Data.Map as Map+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Traversable+import Prelude hiding (lookup, foldr)++class (Adjustable (BaseTrie a), TraversableWithKey1 (BaseTrie a), Representable (BaseTrie a)) => HasTrie a where+  type BaseTrie a :: * -> *+  -- projectKey . embedKey = id+  embedKey   :: a -> Key (BaseTrie a)+  projectKey :: Key (BaseTrie a) -> a+{-+  validKey   :: Key (BaseTrie a) -> Bool+  validKey _ = True+-}++newtype a :->: b = Trie { runTrie :: BaseTrie a b }++type instance Key ((:->:) a) = a++data Entry a b = Entry a b++-- * Combinators++-- 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 => (t :->: a) -> t -> a+untrie = index++trie :: HasTrie t => (t -> a) -> (t :->: a)+trie = tabulate++{-# RULES+"trie/untrie" forall t. trie (untrie t) = t+"embedKey/projectKey" forall t. projectKey (embedKey t) = t+ #-}++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)+  -> (a :->: b) -> 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)+  -> (a :->: b) -> (c :->: d) -> 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)+  -> (a :->: b) -> (c :->: d) -> (e :->: f) -> g :->: h+inTrie3 = untrie ~> inTrie2++-- * Implementation details++instance Functor (Entry a) where+  fmap f (Entry a b) = Entry a (f b)++instance HasTrie e => Lookup ((:->:)e) where+  lookup = lookupDefault++instance HasTrie e => Indexable ((:->:)e) where+  index (Trie f) = index f . embedKey++instance HasTrie e => Distributive ((:->:) e) where+  distribute = distributeRep++instance HasTrie e => Representable ((:->:) e) where+  tabulate f = Trie $ tabulate (f . projectKey)++instance HasTrie e => Adjustable ((:->:) e) where+  adjust f k (Trie as) = Trie (adjust f (embedKey k) as)++instance HasTrie e => Zip ((:->:) e)++instance HasTrie e => ZipWithKey ((:->:) e)++instance HasTrie e => Adjunction (Entry e) ((:->:) e) where+  unit = mapWithKey Entry . pure+  counit (Entry a t) = index t a++instance HasTrie a => Functor ((:->:) a) where+  fmap f (Trie g) = Trie (fmap f g)++instance HasTrie a => Keyed ((:->:) a) where+  mapWithKey f (Trie a) = Trie (mapWithKey (f . projectKey) a)++instance HasTrie a => Foldable ((:->:) a) where+  foldMap f (Trie a) = foldMap f a++instance HasTrie a => FoldableWithKey ((:->:) a) where+  foldMapWithKey f (Trie a) = foldMapWithKey (f . projectKey) a++instance HasTrie a => Traversable ((:->:) a) where+  traverse f (Trie a) = Trie <$> traverse f a++instance HasTrie a => TraversableWithKey ((:->:) a) where+  traverseWithKey f (Trie a) = Trie <$> traverseWithKey (f . projectKey) a++instance HasTrie a => Foldable1 ((:->:) a) where+  foldMap1 f (Trie a) = foldMap1 f a++instance HasTrie a => FoldableWithKey1 ((:->:) a) where+  foldMapWithKey1 f (Trie a) = foldMapWithKey1 (f . projectKey) a++instance HasTrie a => Traversable1 ((:->:) a) where+  traverse1 f (Trie a) = Trie <$> traverse1 f a++instance HasTrie a => TraversableWithKey1 ((:->:) a) where+  traverseWithKey1 f (Trie a) = Trie <$> traverseWithKey1 (f . projectKey) a++instance (HasTrie a, Eq b) => Eq (a :->: b) where+  (==) = (==) `on` toList++instance (HasTrie a, Ord b) => Ord (a :->: b) where+  compare = compare `on` toList++instance (HasTrie a, Show a, Show b) => Show (a :->: b) where+  showsPrec d = showsPrec d . toKeyedList++instance HasTrie a => Apply ((:->:) a) where+  (<.>) = apRep+  a <. _ = a+  _ .> b = b++instance HasTrie a => Applicative ((:->:) a) where+  pure a = Trie (pureRep a)+  (<*>) = apRep+  a <* _ = a+  _ *> b = b++instance HasTrie a => Bind ((:->:) a) where+  Trie m >>- f = Trie (tabulate (\a -> index (runTrie (f (index m a))) a))++instance HasTrie a => Monad ((:->:) a) where+  return a = Trie (pureRep a)+  (>>=) = (>>-)+  _ >> m = m++instance HasTrie a => MonadReader a ((:->:) a) where+  ask = askRep+  local = localRep++-- TODO: remove dependency on HasTrie in these:++instance (HasTrie m, Monoid m) => Comonad ((:->:) m) where+  duplicate = duplicateRep+  extract = flip index mempty++instance (HasTrie m, Semigroup m) => Extend ((:->:) m) where+  duplicated = duplicatedRep++-- * Instances++instance HasTrie () where+  type BaseTrie () = Identity+  embedKey = id+  projectKey = id++instance HasTrie Bool where+  type BaseTrie Bool = BoolTrie+  embedKey = id+  projectKey = id++instance HasTrie Any where+  type BaseTrie Any = BoolTrie+  embedKey = getAny+  projectKey = Any++instance HasTrie a => HasTrie (Dual a) where+  type BaseTrie (Dual a) = BaseTrie a+  embedKey = embedKey . getDual+  projectKey = Dual . projectKey++instance HasTrie a => HasTrie (Sum a) where+  type BaseTrie (Sum a) = BaseTrie a+  embedKey = embedKey . getSum+  projectKey = Sum . projectKey++instance HasTrie a => HasTrie (Monoid.Product a) where+  type BaseTrie (Monoid.Product a) = BaseTrie a+  embedKey = embedKey . Monoid.getProduct+  projectKey = Monoid.Product . projectKey++instance (HasTrie a, HasTrie b) => HasTrie (a, b) where+  type BaseTrie (a, b) = ReaderT (BaseTrie a) (BaseTrie b)+  embedKey = embedKey *** embedKey+  projectKey = projectKey *** projectKey++instance (HasTrie a, HasTrie b) => HasTrie (Entry a b) where+  type BaseTrie (Entry a b) = ReaderT (BaseTrie a) (BaseTrie b)+  embedKey (Entry a b) = (embedKey a, embedKey b)+  projectKey (a, b) = Entry (projectKey a) (projectKey b)++instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where+  type BaseTrie (Either a b) = EitherTrie (BaseTrie a) (BaseTrie b)+  embedKey = embedKey +++ embedKey+  projectKey = projectKey +++ projectKey++instance HasTrie a => HasTrie (Maybe a) where+  type BaseTrie (Maybe a) = EitherTrie Identity (BaseTrie a)+  embedKey   = maybe (Left ()) (Right . embedKey)+  projectKey = either (const Nothing) (Just . projectKey)++instance HasTrie a => HasTrie [a] where+  type BaseTrie [a] = ListTrie (BaseTrie a)+  embedKey = map embedKey+  projectKey = map projectKey++instance HasTrie a => HasTrie (Seq a) where+  type BaseTrie (Seq a) = ListTrie (BaseTrie a)+  embedKey = foldr ((:) . embedKey) []+  projectKey = foldr ((<|) . projectKey) (Seq.empty)++instance (HasTrie k, HasTrie v) => HasTrie (Map k v) where+  type BaseTrie (Map k v) = ListTrie (BaseTrie (k, v))+  embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) []+  projectKey = Map.fromDistinctAscList . map projectKey++instance (HasTrie v) => HasTrie (IntMap v) where+  type BaseTrie (IntMap v) = ListTrie (BaseTrie (Int, v))+  embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) []+  projectKey = IntMap.fromDistinctAscList . map projectKey+++-- | Extract bits in little-endian order+bits :: Bits t => t -> [Bool]+bits 0 = []+bits x = testBit x 0 : bits (shiftR x 1)++-- | Convert boolean to 0 (False) or 1 (True)+unbit :: Num t => Bool -> t+unbit False = 0+unbit True  = 1++-- | Bit list to value+unbits :: Bits t => [Bool] -> t+unbits [] = 0+unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1++unbitsZ :: (Bits n) => (Bool,[Bool]) -> n+unbitsZ (positive,bs) = sig (unbits bs)+ where+   sig | positive  = id+       | otherwise = negate++bitsZ :: (Ord n, Bits n) => n -> (Bool,[Bool])+bitsZ = (>= 0) &&& (bits . abs)++-- TODO: fix the show instance of this+instance HasTrie Int where+  type BaseTrie Int = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++instance HasTrie Int8 where+  type BaseTrie Int8 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++instance HasTrie Int16 where+  type BaseTrie Int16 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++instance HasTrie Int32 where+  type BaseTrie Int32 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++instance HasTrie Int64 where+  type BaseTrie Int64 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++instance HasTrie Word where+  type BaseTrie Word = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey+instance HasTrie Word8 where+  type BaseTrie Word8 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey+instance HasTrie Word16 where+  type BaseTrie Word16 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey+instance HasTrie Word32 where+  type BaseTrie Word32 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey+instance HasTrie Word64 where+  type BaseTrie Word64 = BaseTrie (Bool, [Bool])+  embedKey = embedKey . bitsZ+  projectKey = unbitsZ . projectKey++-- TODO: fix tree to 21 bit depth+instance HasTrie Char where+  type BaseTrie Char = BaseTrie [Bool]+  embedKey = bits . fromEnum+  projectKey = toEnum . unbits++instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where+  type BaseTrie (a,b,c) = BaseTrie (a,(b,c))+  embedKey (a,b,c) = embedKey (a,(b,c))+  projectKey p = let (a,(b,c)) = projectKey p in (a,b,c)++instance (HasTrie a, HasTrie b, HasTrie c, HasTrie d) => HasTrie (a,b,c,d) where+  type BaseTrie (a,b,c,d) = BaseTrie ((a,b),(c,d))+  embedKey (a,b,c,d) = embedKey ((a,b),(c,d))+  projectKey p = let ((a,b),(c,d)) = projectKey p in (a,b,c,d)

@@ -0,0 +1,109 @@+{-# LANGUAGE TypeFamilies #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Representable.Trie.Bool+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+-- +-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- +----------------------------------------------------------------------++module Data.Functor.Representable.Trie.Bool ( BoolTrie (..) ) where++import Control.Applicative+import Data.Distributive+import Data.Functor.Representable+import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Key+import Prelude hiding (lookup)++-- (Bool, -) -| BoolTrie+data BoolTrie a = BoolTrie a a deriving (Eq,Ord,Show,Read)++false :: BoolTrie a -> a+false (BoolTrie a _) = a++true :: BoolTrie a -> a+true (BoolTrie _ b) = b++type instance Key BoolTrie = Bool++instance Functor BoolTrie where+  fmap f (BoolTrie a b) = BoolTrie (f a) (f b)+  b <$ _ = pure b++instance Apply BoolTrie where+  BoolTrie a b <.> BoolTrie c d = BoolTrie (a c) (b d)+  a <. _ = a+  _ .> b = b++instance Applicative BoolTrie where+  pure a = BoolTrie a a+  (<*>) = (<.>) +  a <* _ = a+  _ *> b = b++instance Bind BoolTrie where+  BoolTrie a b >>- f = BoolTrie (false (f a)) (true (f b))++instance Monad BoolTrie where+  return = pure+  BoolTrie a b >>= f = BoolTrie (false (f a)) (true (f b))+  _ >> a = a++instance Keyed BoolTrie where+  mapWithKey f (BoolTrie a b) = BoolTrie (f False a) (f True b)++instance Zip BoolTrie where+  zipWith f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f a c) (f b d)++instance ZipWithKey BoolTrie where+  zipWithKey f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f False a c) (f True b d)++instance Foldable BoolTrie where+  foldMap f (BoolTrie a b) = f a `mappend` f b++instance Foldable1 BoolTrie where+  foldMap1 f (BoolTrie a b) = f a <> f b++instance Traversable BoolTrie where+  traverse f (BoolTrie a b) = BoolTrie <$> f a <*> f b++instance Traversable1 BoolTrie where+  traverse1 f (BoolTrie a b) = BoolTrie <$> f a <.> f b++instance FoldableWithKey BoolTrie where+  foldMapWithKey f (BoolTrie a b) = f False a `mappend` f True b++instance FoldableWithKey1 BoolTrie where+  foldMapWithKey1 f (BoolTrie a b) = f False a <> f True b++instance TraversableWithKey BoolTrie where+  traverseWithKey f (BoolTrie a b) = BoolTrie <$> f False a <*> f True b++instance TraversableWithKey1 BoolTrie where+  traverseWithKey1 f (BoolTrie a b) = BoolTrie <$> f False a <.> f True b++instance Distributive BoolTrie where+  distribute = distributeRep++instance Indexable BoolTrie where+  index (BoolTrie a _) False = a+  index (BoolTrie _ b) True  = b++instance Adjustable BoolTrie where+  adjust f False (BoolTrie a b) = BoolTrie (f a) b+  adjust f True (BoolTrie a b) = BoolTrie a (f b)++instance Lookup BoolTrie where+  lookup = lookupDefault++instance Representable BoolTrie where+  tabulate f = BoolTrie (f False) (f True)

@@ -0,0 +1,123 @@+{-# LANGUAGE TypeFamilies #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Representable.Trie.Bool+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+-- +-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- +----------------------------------------------------------------------++module Data.Functor.Representable.Trie.Either ( +    EitherTrie (..) +  , left+  , right+  ) where++import Control.Applicative+import Data.Distributive+import Data.Functor.Representable+import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Traversable.Fair+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Key+import Prelude hiding (lookup,zipWith)++-- the product functor would be the trie of an either, but we fair traversal+data EitherTrie f g a = EitherTrie (f a) (g a)++type instance Key (EitherTrie f g) = Either (Key f) (Key g)++left :: EitherTrie f g a -> f a+left (EitherTrie f _) = f++right :: EitherTrie f g a -> g a+right (EitherTrie _ g) = g++instance (Apply f, Apply g, Semigroup s) => Semigroup (EitherTrie f g s) where+  EitherTrie a b <> EitherTrie c d = EitherTrie ((<>) <$> a <.> c) ((<>) <$> b <.> d)++instance (Applicative f, Applicative g, Monoid a) => Monoid (EitherTrie f g a) where+  mempty = EitherTrie (pure mempty) (pure mempty)+  EitherTrie a b `mappend` EitherTrie c d = EitherTrie (mappend <$> a <*> c) (mappend <$> b <*> d)++instance (Functor f, Functor g) => Functor (EitherTrie f g) where+  fmap f (EitherTrie fs gs) = EitherTrie (fmap f fs) (fmap f gs)+  b <$ EitherTrie fs gs = EitherTrie (b <$ fs) (b <$ gs)++instance (Apply f, Apply g) => Apply (EitherTrie f g) where+  EitherTrie ff fg <.> EitherTrie af ag = EitherTrie (ff <.> af) (fg <.> ag)+  a <. _ = a+  _ .> b = b++instance (Applicative f, Applicative g) => Applicative (EitherTrie f g) where+  pure a = EitherTrie (pure a) (pure a)+  EitherTrie ff fg <*> EitherTrie af ag = EitherTrie (ff <*> af) (fg <*> ag)+  a <* _ = a+  _ *> b = b++-- the direct implementation in terms of Bind is inefficient, using bindRep instead+instance (Apply f, Representable f, Apply g, Representable g) => Bind (EitherTrie f g) where+  (>>-) = bindRep++instance (Representable f, Representable g) => Monad (EitherTrie f g) where+  return = pureRep+  (>>=) = bindRep+  _ >> a = a++instance (Keyed f, Keyed g) => Keyed (EitherTrie f g) where+  mapWithKey f (EitherTrie fs gs) = EitherTrie (mapWithKey (f . Left) fs) (mapWithKey (f . Right) gs)++instance (Zip f, Zip g) => Zip (EitherTrie f g) where+  zipWith f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWith f fs hs) (zipWith f gs is)++instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (EitherTrie f g) where+  zipWithKey f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWithKey (f . Left) fs hs) (zipWithKey (f . Right) gs is)++instance (Foldable f, Foldable g) => Foldable (EitherTrie f g) where+  foldMap f (EitherTrie fs gs) = foldMapBoth f fs gs++instance (Foldable1 f, Foldable1 g) => Foldable1 (EitherTrie f g) where+  foldMap1 f (EitherTrie fs gs) = foldMapBoth1 f fs gs++instance (Traversable f, Traversable g) => Traversable (EitherTrie f g) where+  traverse f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth f fs gs++instance (Traversable1 f, Traversable1 g) => Traversable1 (EitherTrie f g) where+  traverse1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth1 f fs gs++instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (EitherTrie f g) where+  foldMapWithKey f (EitherTrie fs gs) = foldMapWithKeyBoth (f . Left) (f . Right) fs gs++instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (EitherTrie f g) where+  foldMapWithKey1 f (EitherTrie fs gs) = foldMapWithKeyBoth1 (f . Left) (f . Right) fs gs++instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (EitherTrie f g) where+  traverseWithKey f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth (f . Left) (f . Right) fs gs++instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (EitherTrie f g) where+  traverseWithKey1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth1 (f . Left) (f . Right) fs gs++instance (Representable f, Representable g) => Distributive (EitherTrie f g) where+  distribute = distributeRep++instance (Indexable f, Indexable g) => Indexable (EitherTrie f g) where+  index (EitherTrie fs _) (Left  i) = index fs i+  index (EitherTrie _ gs) (Right j) = index gs j++instance (Adjustable f, Adjustable g) => Adjustable (EitherTrie f g) where+  adjust f (Left i) (EitherTrie fs gs)  = EitherTrie (adjust f i fs) gs+  adjust f (Right j) (EitherTrie fs gs) = EitherTrie fs (adjust f j gs)++instance (Lookup f, Lookup g) => Lookup (EitherTrie f g) where+  lookup (Left i) (EitherTrie fs _)  = lookup i fs+  lookup (Right j) (EitherTrie _ gs) = lookup j gs++instance (Representable f, Representable g) => Representable (EitherTrie f g) where+  tabulate f = EitherTrie (tabulate (f . Left)) (tabulate (f . Right))

@@ -0,0 +1,114 @@+{-# LANGUAGE TypeFamilies #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Representable.Trie.List+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+--+----------------------------------------------------------------------++module Data.Functor.Representable.Trie.List (+    ListTrie (..)+  , nil+  , cons+  ) where++import Control.Applicative+import Data.Distributive+import Data.Functor.Representable+import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Key+import Prelude hiding (lookup,zipWith)++-- the f-branching stream comonad is the trie of a list+data ListTrie f a = ListTrie a (f (ListTrie f a)) -- deriving (Eq,Ord,Show,Read)++type instance Key (ListTrie f) = [Key f]++nil :: ListTrie f a -> a+nil (ListTrie x _) = x++cons :: Indexable f => Key f -> ListTrie f a -> ListTrie f a+cons a (ListTrie _ xs) = index xs a++instance Functor f => Functor (ListTrie f) where+  fmap f (ListTrie a as) = ListTrie (f a) (fmap (fmap f) as)+-- b <$ _ = pure b++instance Representable f => Apply (ListTrie f) where+  (<.>) = apRep+  a <. _ = a+  _ .> b = b++instance Representable f => Applicative (ListTrie f) where+  pure a = as where as = ListTrie a (pureRep as)+  (<*>) = apRep+  a <* _ = a+  _ *> b = b++instance Representable f => Bind (ListTrie f) where+  (>>-) = bindRep++instance Representable f => Monad (ListTrie f) where+  return a = as where as = ListTrie a (pureRep as)+  (>>=) = bindRep+  _ >> a = a++instance Zip f => Zip (ListTrie f) where+  zipWith f (ListTrie a as) (ListTrie b bs) = ListTrie (f a b) (zipWith (zipWith f) as bs)++instance ZipWithKey f => ZipWithKey (ListTrie f) where+  zipWithKey f (ListTrie a as) (ListTrie b bs) = ListTrie (f [] a b) (zipWithKey (\x -> zipWithKey (f . (x:))) as bs)++instance Keyed f => Keyed (ListTrie f) where+  mapWithKey f (ListTrie a as) = ListTrie (f [] a) (mapWithKey (\x -> mapWithKey (f . (x:))) as)++instance Foldable f => Foldable (ListTrie f) where+  foldMap f (ListTrie a as) = f a `mappend` foldMap (foldMap f) as++instance Foldable1 f => Foldable1 (ListTrie f) where+  foldMap1 f (ListTrie a as) = f a <> foldMap1 (foldMap1 f) as++instance Traversable f => Traversable (ListTrie f) where+  traverse f (ListTrie a as) = ListTrie <$> f a <*> traverse (traverse f) as++instance Traversable1 f => Traversable1 (ListTrie f) where+  traverse1 f (ListTrie a as) = ListTrie <$> f a <.> traverse1 (traverse1 f) as++instance FoldableWithKey f => FoldableWithKey (ListTrie f) where+  foldMapWithKey f (ListTrie a as) = f [] a `mappend` foldMapWithKey (\x -> foldMapWithKey (f . (x:))) as++instance FoldableWithKey1 f => FoldableWithKey1 (ListTrie f) where+  foldMapWithKey1 f (ListTrie a as) = f [] a <> foldMapWithKey1 (\x -> foldMapWithKey1 (f . (x:))) as++instance TraversableWithKey f => TraversableWithKey (ListTrie f) where+  traverseWithKey f (ListTrie a as) = ListTrie <$> f [] a <*> traverseWithKey (\x -> traverseWithKey (f . (x:))) as++instance TraversableWithKey1 f => TraversableWithKey1 (ListTrie f) where+  traverseWithKey1 f (ListTrie a as) = ListTrie <$> f [] a <.> traverseWithKey1 (\x -> traverseWithKey1 (f . (x:))) as++instance Representable f => Distributive (ListTrie f) where+  distribute = distributeRep++instance Indexable f => Indexable (ListTrie f) where+  index (ListTrie x _) [] = x+  index (ListTrie _ xs) (a:as) = index (index xs a) as++instance Adjustable f => Adjustable (ListTrie f) where+  adjust f [] (ListTrie x xs) = ListTrie (f x) xs+  adjust f (a:as) (ListTrie x xs) = ListTrie x (adjust (adjust f as) a xs)++instance Lookup f => Lookup (ListTrie f) where+  lookup [] (ListTrie x _) = Just x+  lookup (a:as) (ListTrie _ xs) = lookup a xs >>= lookup as++instance Representable f => Representable (ListTrie f) where+  tabulate f = ListTrie (f []) (tabulate (\x -> tabulate (f . (x:))))

@@ -0,0 +1,130 @@+module Data.Traversable.Fair +  ( foldMapBoth+  , traverseBoth+  , foldMapWithKeyBoth+  , traverseWithKeyBoth+  , foldMapBoth1+  , traverseBoth1+  , foldMapWithKeyBoth1+  , traverseWithKeyBoth1+  ) where++import Control.Applicative+import Control.Arrow+import Data.Key+import Data.Functor.Apply+import Data.Foldable+import Data.Traversable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.List.NonEmpty as NonEmpty hiding (toList)++refill :: Traversable t => t a -> [b] -> t b+refill t l = snd (mapAccumL (\xs _ -> (Prelude.tail xs, Prelude.head xs)) l t)++toNonEmptyList :: Foldable1 f => f a -> NonEmpty a+toNonEmptyList = NonEmpty.fromList . toList++toKeyedNonEmptyList :: FoldableWithKey1 f => f a -> NonEmpty (Key f, a)+toKeyedNonEmptyList = NonEmpty.fromList . toKeyedList++foldMapBoth :: (Foldable f, Foldable g, Monoid m) => (a -> m) -> f a -> g a -> m+foldMapBoth f as bs = go (toList as) (toList bs) where+  go [] [] = mempty+  go xs [] = foldMap f xs+  go [] ys = foldMap f ys+  go (x:xs) (y:ys) = f x `mappend` f y `mappend` go xs ys++-- | traverse both containers, interleaving effects for fairness+traverseBoth :: (Traversable f, Traversable g, Applicative m) => (a -> m b) -> f a -> g a -> m (f b, g b)+traverseBoth f as bs = (refill as *** refill bs) <$> go (toList as) (toList bs)+  where+  go [] []         = pure ([],[])+  go xs []         = flip (,) [] <$> traverse f xs+  go [] ys         = (,) [] <$> traverse f ys+  go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f x <*> f y <*> go xs ys++-- | fold both containers, interleaving results for fairness+foldMapBoth1 :: (Foldable1 f, Foldable1 g, Semigroup m) => (a -> m) -> f a -> g a -> m+foldMapBoth1 f as bs = go (toNonEmptyList as) (toNonEmptyList bs)+  where+  go (x:|[])   (y:|[])   = f x <> f y+  go (x:|z:zs) (y:|[])   = f x <> f y <> foldMap1 f (z:|zs)+  go (x:|[])   ys        = f x <> foldMap1 f ys+  go (x:|z:zs) (y:|w:ws) = f x <> f y <> go (z:|zs) (w:|ws)++-- | traverse both containers, interleaving effects for fairness+traverseBoth1 :: (Traversable1 f, Traversable1 g, Apply m) => (a -> m b) -> f a -> g a -> m (f b, g b)+traverseBoth1 f as bs = (refill as *** refill bs) <$> go (toNonEmptyList as) (toNonEmptyList bs)+  where+  go (x:|[])   (y:|[])   = (\x' y'            -> ([x'],       [y']  )) <$> f x <.> f y+  go (x:|z:zs) (y:|[])   = (\x' y' (x'':|xs') -> (x':x'':xs', [y']  )) <$> f x <.> f y <.> traverse1 f (z:|zs)+  go (x:|[])   ys        = (\x' (y':|ys')     -> ([x'],       y':ys')) <$> f x <.> traverse1 f ys+  go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs',     y':ys')) <$> f x <.> f y <.> go (z:|zs) (w:|ws)++foldMapWithKeyBoth +  :: (FoldableWithKey f, FoldableWithKey g, Monoid m) +  => (Key f -> a -> m) +  -> (Key g -> a -> m)+  -> f a +  -> g a +  -> m+foldMapWithKeyBoth f g as bs = go (toKeyedList as) (toKeyedList bs) where+  f' = uncurry f+  g' = uncurry g+  go [] [] = mempty+  go xs [] = foldMap f' xs+  go [] ys = foldMap g' ys+  go (x:xs) (y:ys) = f' x `mappend` g' y `mappend` go xs ys++-- | traverse both containers, interleaving effects for fairness+traverseWithKeyBoth +  :: (TraversableWithKey f, TraversableWithKey g, Applicative m) +  => (Key f -> a -> m b) +  -> (Key g -> a -> m b) +  -> f a +  -> g a +  -> m (f b, g b)+traverseWithKeyBoth f g as bs = (refill as *** refill bs) <$> go (toKeyedList as) (toKeyedList bs)+  where+  f' = uncurry f+  g' = uncurry g+  go [] []         = pure ([],[])+  go xs []         = flip (,) [] <$> traverse f' xs+  go [] ys         = (,) [] <$> traverse g' ys+  go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f' x <*> g' y <*> go xs ys++-- | fold both containers, interleaving results for fairness+foldMapWithKeyBoth1 +  :: (FoldableWithKey1 f, FoldableWithKey1 g, Semigroup m) +  => (Key f -> a -> m) +  -> (Key g -> a -> m) +  -> f a +  -> g a +  -> m+foldMapWithKeyBoth1 f g as bs = go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)+  where+  f' = uncurry f+  g' = uncurry g+  go (x:|[])   (y:|[])   = f' x <> g' y+  go (x:|z:zs) (y:|[])   = f' x <> g' y <> foldMap1 f' (z:|zs)+  go (x:|[])   ys        = f' x <> foldMap1 g' ys+  go (x:|z:zs) (y:|w:ws) = f' x <> g' y <> go (z:|zs) (w:|ws)++-- | traverse both containers, interleaving effects for fairness+traverseWithKeyBoth1 +  :: (TraversableWithKey1 f, TraversableWithKey1 g, Apply m) +  => (Key f -> a -> m b) +  -> (Key g -> a -> m b) +  -> f a +  -> g a +  -> m (f b, g b)+traverseWithKeyBoth1 f g as bs = (refill as *** refill bs) <$> go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)+  where+  f' = uncurry f+  g' = uncurry g+  go (x:|[])   (y:|[])   = (\x' y'            -> ([x'],      [y']  )) <$> f' x <.> g' y+  go (x:|z:zs) (y:|[])   = (\x' y' (z':|zs')  -> (x':z':zs', [y']  )) <$> f' x <.> g' y <.> traverse1 f' (z:|zs)+  go (x:|[])   ys        = (\x' (y':|ys')     -> ([x'],      y':ys')) <$> f' x <.> traverse1 g' ys+  go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs',    y':ys')) <$> f' x <.> g' y <.> go (z:|zs) (w:|ws)

@@ -0,0 +1,225 @@+{-# LANGUAGE TypeFamilies, Rank2Types, TypeOperators, GADTs, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}+----------------------------------------------------------------------+-- |+-- Module      :  Numeric.Nat.Zeroless+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+-- +-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- +-- Zeroless numbers encoded in zeroless binary numbers+----------------------------------------------------------------------++module Numeric.Nat.Zeroless+  ( D0(..), D1(..), D2(..), (:+:), (:*:), Zeroless(..)+  , Succ, Pred+  , LT, GT, EQ+  , Compare+  , N1, N8, N16, N32, N64+  , Nat(..), nat +  , Fin(..)+  , Reverse+  ) where++import Data.Function (on)+import Prelude hiding (lookup)++infixl 7 :*:+infixl 6 :+: ++-- * Type-level naturals using zeroless binary numbers++data D0 = D0 -- ^ 0 +data D1 n = D1 n -- ^ 2n + 1+data D2 n = D2 n -- ^ 2n + 2++-- * useful numbers+type N1 = D1 D0+type N8  = D2 (D1 (D1 D0))+type N16 = D2 (D1 (D1 (D1 D0)))+type N32 = D2 (D1 (D1 (D1 (D1 D0))))+type N64 = D2 (D1 (D1 (D1 (D1 (D1 D0)))))++-- * Successor +type family Succ n+type instance Succ D0 = D1 D0+type instance Succ (D1 n) = D2 n+type instance Succ (D2 n) = D1 (Succ n)++type family Pred n+type instance Pred (D1 D0) = D0+type instance Pred (D1 (D1 n)) = D2 (Pred (D1 n))+type instance Pred (D1 (D2 n)) = D2 (D1 n)+type instance Pred (D2 n) = D1 n++-- * Carry flags+data C0+data C1+data C2++-- * Add with carry+type family Add c n m+type instance Add C0 D0 n = n+type instance Add C1 D0 D0 = D1 D0+type instance Add C2 D0 D0 = D2 D0+type instance Add C1 D0 (D1 n) = D2 n+type instance Add C1 D0 (D2 n) = D1 (Add C1 D0 n) +type instance Add C2 D0 (D1 n) = D1 (Add C1 D0 n)+type instance Add C2 D0 (D2 n) = D2 (Add C1 D0 n)+type instance Add C0 (D1 n) D0 = D1 n+type instance Add C1 (D1 n) D0 = D2 n+type instance Add C2 (D1 n) D0 = D1 (Add C1 D0 n)+type instance Add C0 (D1 n) (D1 m) = D2 (Add C0 n m)+type instance Add C1 (D1 n) (D1 m) = D1 (Add C1 n m)+type instance Add C2 (D1 n) (D1 m) = D2 (Add C1 n m)+type instance Add C0 (D1 n) (D2 m) = D1 (Add C1 n m)+type instance Add C1 (D1 n) (D2 m) = D2 (Add C1 n m)+type instance Add C2 (D1 n) (D2 m) = D1 (Add C2 n m)+type instance Add C0 (D2 n) D0 = D2 n+type instance Add C1 (D2 n) D0 = D1 (Add C1 D0 n)+type instance Add C2 (D2 n) D0 = D2 (Add C1 D0 n)+type instance Add C0 (D2 n) (D1 m) = D1 (Add C1 n m)+type instance Add C1 (D2 n) (D1 m) = D2 (Add C1 n m)+type instance Add C2 (D2 n) (D1 m) = D1 (Add C2 n m)+type instance Add C0 (D2 n) (D2 m) = D2 (Add C1 n m)+type instance Add C1 (D2 n) (D2 m) = D1 (Add C2 n m)+type instance Add C2 (D2 n) (D2 m) = D2 (Add C2 n m)++-- * Adder+type n :+: m = Add C0 n m++data LT+data EQ+data GT++type family   Compare' a l      r+type instance Compare' a D0     D0     = a+type instance Compare' a D0     (D1 r) = LT+type instance Compare' a D0     (D2 r) = LT+type instance Compare' a (D1 r) D0     = GT+type instance Compare' a (D1 l) (D1 r) = Compare' a l r+type instance Compare' a (D1 l) (D2 r) = Compare' LT l r+type instance Compare' a (D2 l) D0     = GT+type instance Compare' a (D2 l) (D1 r) = Compare' GT l r+type instance Compare' a (D2 l) (D2 r) = Compare' a l r++type Compare m n = Compare' EQ m n ++-- * Multiplier+type family n :*: m+type instance D0 :*: m = D0+type instance D1 n :*: m = (n :*: m) :+: (n :*: m) :+: m+type instance D2 n :*: m = (n :*: m) :+: (n :*: m) :+: m :+: m++-- * Digit Counter+type family Digits n+type instance Digits D0 = D0+type instance Digits (D1 n) = Succ (Digits n)+type instance Digits (D2 n) = Succ (Digits n)++type family Reverse' n m+type instance Reverse' m D0     = m +type instance Reverse' m (D1 n) = Reverse' (D1 m) n +type instance Reverse' m (D2 n) = Reverse' (D2 m) n++-- * bitwise reversal+type Reverse n = Reverse' D0 n++{-+data Z = Z+newtype S n = S n+class Nat n where+  caseNat :: forall n. ((n ~ Z) => r) -> (forall x. (n ~ (S x), Nat x) => x -> r) -> r+-}++-- * Class of zeroless-binary numbers+class Zeroless n where+  ind :: f D0 +      -> (forall m. Zeroless m => f m -> f (D1 m)) +      -> (forall m. Zeroless m => f m -> f (D2 m))+      -> f n+  caseNat+    :: ((n ~ D0) => r) +    -> (forall x. (n ~ D1 x, Zeroless x) => x -> r)+    -> (forall x. (n ~ D2 x, Zeroless x) => x -> r)+    -> n -> r++instance Zeroless D0 where+  ind z _ _ = z +  caseNat z _ _ _ = z++instance Zeroless n => Zeroless (D1 n) where+  ind z f g = f (ind z f g)+  caseNat _ f _ (D1 x) = f x++instance Zeroless n => Zeroless (D2 n) where+  ind z f g = g (ind z f g)+  caseNat _ _ g (D2 x) = g x++class Zeroless n => Positive n+instance Zeroless n => Positive (D1 n)+instance Zeroless n => Positive (D2 n)++newtype Nat n = Nat { fromNat :: Int }++instance Zeroless n => Eq (Nat n) where+  _ == _ = True++instance Zeroless n => Ord (Nat n) where+  compare _ _ = EQ++instance Zeroless n => Show (Nat n) where+  showsPrec d (Nat n) = showsPrec d n++instance Zeroless n => Bounded (Nat n) where+  minBound = nat+  maxBound = nat++instance Zeroless n => Enum (Nat n) where+  fromEnum (Nat n) = n+  toEnum _ = nat++nat :: Zeroless n => Nat n +nat = ind (Nat 0) +          (Nat . (+1) . (*2) . fromNat) +          (Nat . (+2) . (*2) . fromNat)++-- * A finite number @m < n@+newtype Fin n = Fin { fromFin :: Int } ++instance Show (Fin n) where+  showsPrec d = showsPrec d . fromFin++instance Eq (Fin n) where+  (==) = (==) `on` fromFin++instance Ord (Fin n) where+  compare = compare `on` fromFin ++instance Positive n => Num (Fin n) where+  fromInteger = toEnum . fromInteger+  a + b = toEnum (fromFin a + fromFin b)+  a * b = toEnum (fromFin a * fromFin b)+  a - b = toEnum (fromFin a - fromFin b)+  abs a = a+  signum 0 = 0+  signum _ = 1++inFin :: (Int -> Int) -> Fin n -> Fin n+inFin f = Fin . f . fromFin++instance Positive n => Bounded (Fin n) where+  minBound = Fin 0+  maxBound = inFin (subtract 1) $ +             ind (Fin 0) +                 (Fin . ((+1) . (*2)) . fromFin)+                 (Fin . ((+2) . (*2)) . fromFin)++instance Positive n => Enum (Fin n) where+  fromEnum = fromFin+  toEnum n = r where+    r | n < 0 = error "Fin.toEnum: negative number"+      | Fin n <= b = Fin n `asTypeOf` b+      | otherwise = error "Fin.toEnum: index out of range"+    b = maxBound