@@ -1,6 +1,6 @@
11{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}
22{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}
3−{-# LANGUAGE DefaultSignatures, FlexibleContexts, EmptyCase, LambdaCase #-}
3+{-# LANGUAGE DefaultSignatures, FlexibleContexts, LambdaCase #-}
44{-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-}
55
66-- ScopedTypeVariables works around a 6.10 bug. The forall keyword is
@@ -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
@@ -42,7 +42,7 @@
4242-- see @examples/Generic.hs@, which can be run with:
4343--
4444-- @
45−-- $ cabal configure -fexamples && cabal run generic
45+-- cabal configure -fexamples && cabal run generic
4646-- @
4747--
4848--
@@ -55,21 +55,29 @@ 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
69+#if !MIN_VERSION_base(4,8,0)
6770import Control.Applicative
71+#endif
6872import Control.Arrow (first,(&&&))
73+#if !MIN_VERSION_base(4,8,0)
6974import Data.Monoid
75+#endif
7076import Data.Function (on)
7177import GHC.Generics
7278
79+import Control.Newtype.Generics
80+
7381import Data.Void (Void)
7482
7583-- import Prelude hiding (id,(.))
@@ -128,7 +136,13 @@ untrie3 tt = untrie2 . untrie tt
128136-}
129137
130138
131−{-# RULES "trie/untrie" forall t. trie (untrie t) = t #-}
139+-- {-# RULES "trie/untrie" forall t. trie (untrie t) = t #-}
140+
141+-- warning: [-Winline-rule-shadowing] …
142+-- Rule "trie/untrie" may never fire
143+-- because rule "Class op untrie" for ‘untrie’ might fire first
144+-- Probable fix: add phase [n] or [~n] to the competing rule
145+
132146
133147-- Don't include the dual rule:
134148-- "untrie/trie" forall f. untrie (trie f) = f
@@ -156,6 +170,42 @@ mup mem f = memo (mem . f)
156170memo2 = mup memo
157171memo3 = mup memo2
158172
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+
159209-- | Apply a unary function inside of a trie
160210inTrie :: (HasTrie a, HasTrie c) =>
161211 ((a -> b) -> (c -> d))
@@ -179,17 +229,28 @@ inTrie3 = untrie ~> inTrie2
179229
180230instance HasTrie Void where
181231 -- As suggested by Audun Skaugen
182− data Void :->: a = VoidTrie
232+ data Void :->: a = VoidTrie
183233 trie _ = VoidTrie
184− untrie VoidTrie = \case
234+ untrie VoidTrie = \ _ -> error "untrie VoidTrie"
235+ -- \case -- needs EmptyCase
185236 enumerate VoidTrie = []
186237
238+instance Newtype (Void :->: a) where
239+ type O (Void :->: a) = ()
240+ pack () = VoidTrie
241+ unpack VoidTrie = ()
242+
187243instance HasTrie () where
188244 newtype () :->: a = UnitTrie a
189245 trie f = UnitTrie (f ())
190246 untrie (UnitTrie a) = \ () -> a
191247 enumerate (UnitTrie a) = [((),a)]
192248
249+instance Newtype (() :->: a) where
250+ type O (() :->: a) = a
251+ pack a = UnitTrie a
252+ unpack (UnitTrie a) = a
253+
193254-- Proofs of inverse properties:
194255
195256{-
@@ -225,6 +286,11 @@ instance HasTrie Bool where
225286 untrie (BoolTrie f t) = if' f t
226287 enumerate (BoolTrie f t) = [(False,f),(True,t)]
227288
289+instance Newtype (Bool :->: a) where
290+ type O (Bool :->: a) = (a,a)
291+ pack (a,a') = BoolTrie a a'
292+ unpack (BoolTrie a a') = (a,a')
293+
228294-- | Conditional with boolean last.
229295-- Spec: @if' (f False) (f True) == f@
230296if' :: x -> x -> Bool -> x
@@ -249,6 +315,16 @@ if' _ e True = e
249315 BoolTrie f t
250316-}
251317
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)
252328
253329instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
254330 data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
@@ -256,6 +332,11 @@ instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
256332 untrie (EitherTrie s t) = either (untrie s) (untrie t)
257333 enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t
258334
335+instance Newtype (Either a b :->: x) where
336+ type O (Either a b :->: x) = (a :->: x, b :->: x)
337+ pack (f,g) = EitherTrie f g
338+ unpack (EitherTrie f g) = (f,g)
339+
259340enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
260341enum' f = (fmap.first) f . enumerate
261342
@@ -295,6 +376,11 @@ instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
295376 enumerate (PairTrie tt) =
296377 [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]
297378
379+instance Newtype ((a,b) :->: x) where
380+ type O ((a,b) :->: x) = a :->: b :->: x
381+ pack abx = PairTrie abx
382+ unpack (PairTrie abx) = abx
383+
298384{-
299385 untrie (trie f)
300386 == { trie def }
@@ -501,7 +587,12 @@ instance HasTrie a => Monad ((:->:) a) where
501587
502588instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
503589 mempty = trie mempty
590+#if !MIN_VERSION_base(4,11,0)
504591 mappend = inTrie2 mappend
592+#else
593+instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where
594+ (<>) = inTrie2 (<>)
595+#endif
505596
506597instance HasTrie a => Functor ((:->:) a) where
507598 fmap f = inTrie (fmap f)
@@ -563,7 +654,8 @@ f1' = memo f1
563654instance HasTrie (V1 x) where
564655 data (V1 x :->: b) = V1Trie
565656 trie _ = V1Trie
566− untrie V1Trie = \case
657+ untrie V1Trie = \ _ -> error "untrie V1Trie"
658+ -- \case -- needs EmptyCase
567659 enumerate V1Trie = []
568660
569661-- | just like @()@
@@ -605,6 +697,7 @@ instance (HasTrie (f x)) => HasTrie (M1 i t f x) where
605697-- "unlifted" generic representation. (i.e. is a unary type constructor).
606698type Reg a = Rep a ()
607699
700+-- | 'Generic'-friendly default for 'trie'
608701trieGeneric :: (Generic a, HasTrie (Reg a))
609702 => ((Reg a :->: b) -> (a :->: b))
610703 -> (a -> b)
@@ -612,6 +705,7 @@ trieGeneric :: (Generic a, HasTrie (Reg a))
612705trieGeneric theConstructor f = theConstructor (trie (f . to))
613706{-# INLINEABLE trieGeneric #-}
614707
708+-- | 'Generic'-friendly default for 'untrie'
615709untrieGeneric :: (Generic a, HasTrie (Reg a))
616710 => ((a :->: b) -> (Reg a :->: b))
617711 -> (a :->: b)
@@ -619,6 +713,7 @@ untrieGeneric :: (Generic a, HasTrie (Reg a))
619713untrieGeneric theDestructor t = \a -> (untrie (theDestructor t)) (from a)
620714{-# INLINEABLE untrieGeneric #-}
621715
716+-- | 'Generic'-friendly default for 'enumerate'
622717enumerateGeneric :: (Generic a, HasTrie (Reg a))
623718 => ((a :->: b) -> (Reg a :->: b))
624719 -> (a :->: b)
@@ -643,4 +738,3 @@ dropSum s = case s of
643738liftSum :: Either (f a) (g a) -> (f :+: g) a
644739liftSum = either L1 R1
645740{-# INLINEABLE liftSum #-}
646−