@@ -9,7 +9,7 @@
99----------------------------------------------------------------------
1010-- |
1111-- Module : Data.MemoTrie
12−-- Copyright : (c) Conal Elliott 2008-2012
12+-- Copyright : (c) Conal Elliott 2008-2016
1313-- License : BSD3
1414--
1515-- Maintainer : conal@conal.net
@@ -55,22 +55,28 @@ module Data.MemoTrie
5555 , memo, memo2, memo3, mup
5656 , inTrie, inTrie2, inTrie3
5757 -- , untrieBits
58− , trieGeneric, untrieGeneric, enumerateGeneric, Reg
58+ , trieGeneric, untrieGeneric, enumerateGeneric, Reg
59+ , memoFix
5960 ) where
6061
6162-- Export the parts of HasTrie separately in order to get the associated data
6263-- type constructors, so I can define instances of other classes on them.
6364
65+import Data.Function (fix)
6466import Data.Bits
6567import Data.Word
6668import Data.Int
67−-- import Control.Applicative
69+#if !MIN_VERSION_base(4,8,0)
70+import Control.Applicative
71+#endif
6872import Control.Arrow (first,(&&&))
69−-- import Data.Monoid
73+#if !MIN_VERSION_base(4,8,0)
74+import Data.Monoid
75+#endif
7076import Data.Function (on)
7177import GHC.Generics
7278
73−import Control.Newtype
79+import Control.Newtype.Generics
7480
7581import Data.Void (Void)
7682
@@ -164,6 +170,42 @@ mup mem f = memo (mem . f)
164170memo2 = mup memo
165171memo3 = mup memo2
166172
173+-- | Memoizing recursion. Use like `fix`.
174+memoFix :: HasTrie a => ((a -> b) -> (a -> b)) -> (a -> b)
175+memoFix h = fix (memo . h)
176+
177+#if 0
178+-- Equivalently,
179+
180+memoFix h = fix (\ f' -> memo (h f'))
181+
182+memoFix h = f'
183+ where f' = memo (h f')
184+
185+memoFix h = f'
186+ where
187+ f' = memo f
188+ f = h f'
189+#endif
190+
191+#if 0
192+-- Example
193+
194+fibF :: (Integer -> Integer) -> (Integer -> Integer)
195+fibF _ 0 = 1
196+fibF _ 1 = 1
197+fibF f n = f (n-1) + f (n-2)
198+
199+fib :: Integer -> Integer
200+fib = fix fibF
201+
202+fib' :: Integer -> Integer
203+fib' = memoFix fibF
204+
205+-- Try fib 30 vs fib' 30
206+#endif
207+
208+
167209-- | Apply a unary function inside of a trie
168210inTrie :: (HasTrie a, HasTrie c) =>
169211 ((a -> b) -> (c -> d))
@@ -273,6 +315,16 @@ if' _ e True = e
273315 BoolTrie f t
274316-}
275317
318+instance HasTrie a => HasTrie (Maybe a) where
319+ data (:->:) (Maybe a) b = MaybeTrie b (a :->: b)
320+ trie f = MaybeTrie (f Nothing) (trie (f . Just))
321+ untrie (MaybeTrie nothing_val a_trie) = maybe nothing_val (untrie a_trie)
322+ enumerate (MaybeTrie nothing_val a_trie) = (Nothing, nothing_val) : enum' Just a_trie
323+
324+instance Newtype (Maybe a :->: x) where
325+ type O (Maybe a :->: x) = (x, a :->: x)
326+ pack (a,f) = MaybeTrie a f
327+ unpack (MaybeTrie a f) = (a,f)
276328
277329instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
278330 data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
@@ -535,7 +587,12 @@ instance HasTrie a => Monad ((:->:) a) where
535587
536588instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
537589 mempty = trie mempty
590+#if !MIN_VERSION_base(4,11,0)
538591 mappend = inTrie2 mappend
592+#else
593+instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where
594+ (<>) = inTrie2 (<>)
595+#endif
539596
540597instance HasTrie a => Functor ((:->:) a) where
541598 fmap f = inTrie (fmap f)
@@ -681,4 +738,3 @@ dropSum s = case s of
681738liftSum :: Either (f a) (g a) -> (f :+: g) a
682739liftSum = either L1 R1
683740{-# INLINEABLE liftSum #-}
684−