@@ -1,14 +1,15 @@
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 #-}
5+
56-- ScopedTypeVariables works around a 6.10 bug. The forall keyword is
67-- supposed to be recognized in a RULES pragma.
78
89----------------------------------------------------------------------
910-- |
1011-- Module : Data.MemoTrie
11−-- Copyright : (c) Conal Elliott 2008-2012
12+-- Copyright : (c) Conal Elliott 2008-2016
1213-- License : BSD3
1314--
1415-- Maintainer : conal@conal.net
@@ -16,26 +17,33 @@
1617--
1718-- Trie-based memoizer
1819--
19−-- Adapted from sjanssen's paste: \"a lazy trie\" <http://hpaste.org/3839>,
20+-- Adapted from sjanssen's paste: <http://hpaste.org/3839 \"a lazy trie\">,
2021-- which I think is based on Ralf Hinze's paper "Memo Functions,
2122-- Polytypically!".
2223--
2324-- You can automatically derive generic instances. for example:
2425--
2526-- @
26−-- -- LANGUAGE DeriveGeneric, TypeOperators
27+-- {-# LANGUAGE <https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html DeriveGeneric>, TypeOperators, TypeFamilies #-}
28+-- import Data.MemoTrie
29+-- import GHC.Generics (Generic)
2730--
28−-- data Color
29−-- = RGB Int Int Int
30−-- | Color String
31−-- deriving (Generic)
31+-- data Color = RGB Int Int Int
32+-- | NamedColor String
33+-- deriving ('Generic')
3234--
3335-- instance HasTrie Color where
34−-- newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b }
35−-- trie = 'trieGeneric' ColorTrie
36−-- untrie = 'untrieGeneric' unColorTrie
37−-- enumerate = 'enumerateGeneric' unColorTrie
36+-- newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b }
37+-- trie = 'trieGeneric' ColorTrie
38+-- untrie = 'untrieGeneric' unColorTrie
39+-- enumerate = 'enumerateGeneric' unColorTrie
40+-- @
41+--
42+-- see @examples/Generic.hs@, which can be run with:
43+--
3844-- @
45+-- cabal configure -fexamples && cabal run generic
46+-- @
3947--
4048--
4149----------------------------------------------------------------------
@@ -47,23 +55,31 @@ module Data.MemoTrie
4755 , memo, memo2, memo3, mup
4856 , inTrie, inTrie2, inTrie3
4957 -- , untrieBits
50− , trieGeneric, untrieGeneric, enumerateGeneric, Reg
58+ , trieGeneric, untrieGeneric, enumerateGeneric, Reg
59+ , memoFix
5160 ) where
5261
5362-- Export the parts of HasTrie separately in order to get the associated data
5463-- type constructors, so I can define instances of other classes on them.
5564
65+import Data.Function (fix)
5666import Data.Bits
5767import Data.Word
5868import Data.Int
69+#if !MIN_VERSION_base(4,8,0)
5970import Control.Applicative
71+#endif
6072import Control.Arrow (first,(&&&))
73+#if !MIN_VERSION_base(4,8,0)
6174import Data.Monoid
75+#endif
6276import Data.Function (on)
6377import GHC.Generics
6478
65−import Data.Void
79+import Control.Newtype.Generics
6680
81+import Data.Void (Void)
82+
6783-- import Prelude hiding (id,(.))
6884-- import Control.Category
6985-- import Control.Arrow
@@ -120,7 +136,13 @@ untrie3 tt = untrie2 . untrie tt
120136-}
121137
122138
123−{-# 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+
124146
125147-- Don't include the dual rule:
126148-- "untrie/trie" forall f. untrie (trie f) = f
@@ -148,6 +170,42 @@ mup mem f = memo (mem . f)
148170memo2 = mup memo
149171memo3 = mup memo2
150172
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+
151209-- | Apply a unary function inside of a trie
152210inTrie :: (HasTrie a, HasTrie c) =>
153211 ((a -> b) -> (c -> d))
@@ -171,16 +229,27 @@ inTrie3 = untrie ~> inTrie2
171229
172230instance HasTrie Void where
173231 -- As suggested by Audun Skaugen
174− data Void :->: a = VoidTrie
232+ data Void :->: a = VoidTrie
175233 trie _ = VoidTrie
176− untrie VoidTrie = absurd
234+ untrie VoidTrie = \ _ -> error "untrie VoidTrie"
235+ -- \case -- needs EmptyCase
177236 enumerate VoidTrie = []
178237
238+instance Newtype (Void :->: a) where
239+ type O (Void :->: a) = ()
240+ pack () = VoidTrie
241+ unpack VoidTrie = ()
242+
179243instance HasTrie () where
180− newtype () :->: a = UnitTrie a
181− trie f = UnitTrie (f ())
182− untrie (UnitTrie a) = \ () -> a
183− enumerate (UnitTrie a) = [((),a)]
244+ newtype () :->: a = UnitTrie a
245+ trie f = UnitTrie (f ())
246+ untrie (UnitTrie a) = \ () -> a
247+ enumerate (UnitTrie a) = [((),a)]
248+
249+instance Newtype (() :->: a) where
250+ type O (() :->: a) = a
251+ pack a = UnitTrie a
252+ unpack (UnitTrie a) = a
184253
185254-- Proofs of inverse properties:
186255
@@ -212,10 +281,15 @@ memoizing hyper-strict functions.
212281
213282
214283instance HasTrie Bool where
215− data Bool :->: x = BoolTrie x x
216− trie f = BoolTrie (f False) (f True)
217− untrie (BoolTrie f t) = if' f t
218− enumerate (BoolTrie f t) = [(False,f),(True,t)]
284+ data Bool :->: x = BoolTrie x x
285+ trie f = BoolTrie (f False) (f True)
286+ untrie (BoolTrie f t) = if' f t
287+ enumerate (BoolTrie f t) = [(False,f),(True,t)]
288+
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')
219293
220294-- | Conditional with boolean last.
221295-- Spec: @if' (f False) (f True) == f@
@@ -241,12 +315,27 @@ if' _ e True = e
241315 BoolTrie f t
242316-}
243317
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)
244328
245329instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
246− data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
247− trie f = EitherTrie (trie (f . Left)) (trie (f . Right))
248− untrie (EitherTrie s t) = either (untrie s) (untrie t)
249− enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t
330+ data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
331+ trie f = EitherTrie (trie (f . Left)) (trie (f . Right))
332+ untrie (EitherTrie s t) = either (untrie s) (untrie t)
333+ enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t
334+
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)
250339
251340enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
252341enum' f = (fmap.first) f . enumerate
@@ -281,11 +370,16 @@ as `weave` [] = as
281370
282371
283372instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
284− newtype (a,b) :->: x = PairTrie (a :->: (b :->: x))
285− trie f = PairTrie (trie (trie . curry f))
286− untrie (PairTrie t) = uncurry (untrie . untrie t)
287− enumerate (PairTrie tt) =
288− [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]
373+ newtype (a,b) :->: x = PairTrie (a :->: (b :->: x))
374+ trie f = PairTrie (trie (trie . curry f))
375+ untrie (PairTrie t) = uncurry (untrie . untrie t)
376+ enumerate (PairTrie tt) =
377+ [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]
378+
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
289383
290384{-
291385 untrie (trie f)
@@ -314,10 +408,10 @@ instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
314408-}
315409
316410instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where
317− newtype (a,b,c) :->: x = TripleTrie (((a,b),c) :->: x)
318− trie f = TripleTrie (trie (f . trip))
319− untrie (TripleTrie t) = untrie t . detrip
320− enumerate (TripleTrie t) = enum' trip t
411+ newtype (a,b,c) :->: x = TripleTrie (((a,b),c) :->: x)
412+ trie f = TripleTrie (trie (f . trip))
413+ untrie (TripleTrie t) = untrie t . detrip
414+ enumerate (TripleTrie t) = enum' trip t
321415
322416trip :: ((a,b),c) -> (a,b,c)
323417trip ((a,b),c) = (a,b,c)
@@ -327,10 +421,10 @@ detrip (a,b,c) = ((a,b),c)
327421
328422
329423instance HasTrie x => HasTrie [x] where
330− newtype [x] :->: a = ListTrie (Either () (x,[x]) :->: a)
331− trie f = ListTrie (trie (f . list))
332− untrie (ListTrie t) = untrie t . delist
333− enumerate (ListTrie t) = enum' list t
424+ newtype [x] :->: a = ListTrie (Either () (x,[x]) :->: a)
425+ trie f = ListTrie (trie (f . list))
426+ untrie (ListTrie t) = untrie t . delist
427+ enumerate (ListTrie t) = enum' list t
334428
335429list :: Either () (x,[x]) -> [x]
336430list = either (const []) (uncurry (:))
@@ -341,10 +435,10 @@ delist (x:xs) = Right (x,xs)
341435
342436#define WordInstance(Type,TrieType)\
343437instance HasTrie Type where \
344− newtype Type :->: a = TrieType ([Bool] :->: a);\
345− trie f = TrieType (trie (f . unbits));\
346− untrie (TrieType t) = untrie t . bits;\
347− enumerate (TrieType t) = enum' unbits t
438+ newtype Type :->: a = TrieType ([Bool] :->: a);\
439+ trie f = TrieType (trie (f . unbits));\
440+ untrie (TrieType t) = untrie t . bits;\
441+ enumerate (TrieType t) = enum' unbits t
348442
349443WordInstance(Word,WordTrie)
350444WordInstance(Word8,Word8Trie)
@@ -353,10 +447,10 @@ WordInstance(Word32,Word32Trie)
353447WordInstance(Word64,Word64Trie)
354448
355449-- instance HasTrie Word where
356−-- newtype Word :->: a = WordTrie ([Bool] :->: a)
357−-- trie f = WordTrie (trie (f . unbits))
358−-- untrie (WordTrie t) = untrie t . bits
359−-- enumerate (WordTrie t) = enum' unbits t
450+-- newtype Word :->: a = WordTrie ([Bool] :->: a)
451+-- trie f = WordTrie (trie (f . unbits))
452+-- untrie (WordTrie t) = untrie t . bits
453+-- enumerate (WordTrie t) = enum' unbits t
360454
361455
362456-- | Extract bits in little-endian order
@@ -375,10 +469,10 @@ unbits [] = 0
375469unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1
376470
377471instance HasTrie Char where
378− newtype Char :->: a = CharTrie (Int :->: a)
379− untrie (CharTrie t) n = untrie t (fromEnum n)
380− trie f = CharTrie (trie (f . toEnum))
381− enumerate (CharTrie t) = enum' toEnum t
472+ newtype Char :->: a = CharTrie (Int :->: a)
473+ untrie (CharTrie t) n = untrie t (fromEnum n)
474+ trie f = CharTrie (trie (f . toEnum))
475+ enumerate (CharTrie t) = enum' toEnum t
382476
383477-- Although Int is a Bits instance, we can't use bits directly for
384478-- memoizing, because the "bits" function gives an infinite result, since
@@ -387,10 +481,10 @@ instance HasTrie Char where
387481
388482#define IntInstance(IntType,WordType,TrieType) \
389483instance HasTrie IntType where \
390− newtype IntType :->: a = TrieType (WordType :->: a); \
391− untrie (TrieType t) n = untrie t (fromIntegral n); \
392− trie f = TrieType (trie (f . fromIntegral)); \
393− enumerate (TrieType t) = enum' fromIntegral t
484+ newtype IntType :->: a = TrieType (WordType :->: a); \
485+ untrie (TrieType t) n = untrie t (fromIntegral n); \
486+ trie f = TrieType (trie (f . fromIntegral)); \
487+ enumerate (TrieType t) = enum' fromIntegral t
394488
395489IntInstance(Int,Word,IntTrie)
396490IntInstance(Int8,Word8,Int8Trie)
@@ -402,10 +496,10 @@ IntInstance(Int64,Word64,Int64Trie)
402496-- extract the sign bit.
403497
404498instance HasTrie Integer where
405− newtype Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a)
406− trie f = IntegerTrie (trie (f . unbitsZ))
407− untrie (IntegerTrie t) = untrie t . bitsZ
408− enumerate (IntegerTrie t) = enum' unbitsZ t
499+ newtype Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a)
500+ trie f = IntegerTrie (trie (f . unbitsZ))
501+ untrie (IntegerTrie t) = untrie t . bitsZ
502+ enumerate (IntegerTrie t) = enum' unbitsZ t
409503
410504
411505unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n
@@ -493,7 +587,12 @@ instance HasTrie a => Monad ((:->:) a) where
493587
494588instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
495589 mempty = trie mempty
590+#if !MIN_VERSION_base(4,11,0)
496591 mappend = inTrie2 mappend
592+#else
593+instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where
594+ (<>) = inTrie2 (<>)
595+#endif
497596
498597instance HasTrie a => Functor ((:->:) a) where
499598 fmap f = inTrie (fmap f)
@@ -517,7 +616,6 @@ infixr 9 @.@
517616(@.@) = inTrie2 (.)
518617
519618
520−
521619-- instance Category (:->:) where
522620-- id = idTrie
523621-- (.) = (.:)
@@ -536,7 +634,6 @@ necessary but disallowed `HasTrie` constraints on the domain type.
536634
537635-}
538636
539−
540637---- To go elsewhere
541638
542639-- Matt Hellige's notation for @argument f . result g@.
@@ -555,70 +652,72 @@ f1' = memo f1
555652
556653-- | just like @void@
557654instance HasTrie (V1 x) where
558− data (V1 x :->: b) = V1Trie
559− trie _ = V1Trie
560− untrie V1Trie = \case
561− enumerate V1Trie = []
655+ data (V1 x :->: b) = V1Trie
656+ trie _ = V1Trie
657+ untrie V1Trie = \ _ -> error "untrie V1Trie"
658+ -- \case -- needs EmptyCase
659+ enumerate V1Trie = []
562660
563661-- | just like @()@
564662instance HasTrie (U1 x) where
565− data (U1 x :->: b) = U1Trie b
566− trie f = U1Trie (f U1)
567− untrie (U1Trie b) = \U1 -> b
568− enumerate (U1Trie b) = [(U1, b)]
663+ data (U1 x :->: b) = U1Trie b
664+ trie f = U1Trie (f U1)
665+ untrie (U1Trie b) = \U1 -> b
666+ enumerate (U1Trie b) = [(U1, b)]
569667
570668-- | wraps @Either (f x) (g x)@
571669instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :+: g) x) where
572− newtype ((f :+: g) x :->: b) = EitherTrie1 (Either (f x) (g x) :->: b)
573− trie f = EitherTrie1 (trie (f . liftSum))
574− untrie (EitherTrie1 t) = (untrie t) . dropSum
575− enumerate (EitherTrie1 t) = enum' liftSum t
670+ newtype ((f :+: g) x :->: b) = EitherTrie1 (Either (f x) (g x) :->: b)
671+ trie f = EitherTrie1 (trie (f . liftSum))
672+ untrie (EitherTrie1 t) = (untrie t) . dropSum
673+ enumerate (EitherTrie1 t) = enum' liftSum t
576674
577675-- | wraps @(f x, g x)@
578676instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :*: g) x) where
579− newtype ((f :*: g) x :->: b) = PairTrie1 ((f x, g x) :->: b)
580− trie f = PairTrie1 (trie (f . liftProduct))
581− untrie (PairTrie1 t) = (untrie t) . dropProduct
582− enumerate (PairTrie1 t) = enum' liftProduct t
677+ newtype ((f :*: g) x :->: b) = PairTrie1 ((f x, g x) :->: b)
678+ trie f = PairTrie1 (trie (f . liftProduct))
679+ untrie (PairTrie1 t) = (untrie t) . dropProduct
680+ enumerate (PairTrie1 t) = enum' liftProduct t
583681
584682-- | wraps @a@
585683instance (HasTrie a) => HasTrie (K1 i a x) where
586− data (K1 i a x :->: b) = K1Trie (a :->: b)
587− trie f = K1Trie (trie (f . K1))
588− untrie (K1Trie t) = \(K1 a) -> (untrie t) a
589− enumerate (K1Trie t) = enum' K1 t
684+ data (K1 i a x :->: b) = K1Trie (a :->: b)
685+ trie f = K1Trie (trie (f . K1))
686+ untrie (K1Trie t) = \(K1 a) -> (untrie t) a
687+ enumerate (K1Trie t) = enum' K1 t
590688
591689-- | wraps @f x@
592690instance (HasTrie (f x)) => HasTrie (M1 i t f x) where
593− data (M1 i t f x :->: b) = M1Trie (f x :->: b)
594− trie f = M1Trie (trie (f . M1))
595− untrie (M1Trie t) = \(M1 a) -> (untrie t) a
596− enumerate (M1Trie t) = enum' M1 t
691+ data (M1 i t f x :->: b) = M1Trie (f x :->: b)
692+ trie f = M1Trie (trie (f . M1))
693+ untrie (M1Trie t) = \(M1 a) -> (untrie t) a
694+ enumerate (M1Trie t) = enum' M1 t
597695
598−-- | "unlifted" generic representation. (i.e. is a unary type constructor).
696+-- | the data type in a __reg__ular form.
697+-- "unlifted" generic representation. (i.e. is a unary type constructor).
599698type Reg a = Rep a ()
600699
601−trieGeneric
602− :: (Generic a, HasTrie (Reg a))
603− => ((Reg a :->: b) -> (a :->: b))
604− -> (a -> b)
605− -> (a :->: b)
700+-- | 'Generic'-friendly default for 'trie'
701+trieGeneric :: (Generic a, HasTrie (Reg a))
702+ => ((Reg a :->: b) -> (a :->: b))
703+ -> (a -> b)
704+ -> (a :->: b)
606705trieGeneric theConstructor f = theConstructor (trie (f . to))
607706{-# INLINEABLE trieGeneric #-}
608707
609−untrieGeneric
610− :: (Generic a, HasTrie (Reg a))
611− => ((a :->: b) -> (Reg a :->: b))
612− -> (a :->: b)
613− -> (a -> b)
708+-- | 'Generic'-friendly default for 'untrie'
709+untrieGeneric :: (Generic a, HasTrie (Reg a))
710+ => ((a :->: b) -> (Reg a :->: b))
711+ -> (a :->: b)
712+ -> (a -> b)
614713untrieGeneric theDestructor t = \a -> (untrie (theDestructor t)) (from a)
615714{-# INLINEABLE untrieGeneric #-}
616715
617−enumerateGeneric
618− :: (Generic a, HasTrie (Reg a))
619− => ((a :->: b) -> (Reg a :->: b))
620− -> (a :->: b)
621− -> [(a, b)]
716+-- | 'Generic'-friendly default for 'enumerate'
717+enumerateGeneric :: (Generic a, HasTrie (Reg a))
718+ => ((a :->: b) -> (Reg a :->: b))
719+ -> (a :->: b)
720+ -> [(a, b)]
622721enumerateGeneric theDestructor t = enum' to (theDestructor t)
623722{-# INLINEABLE enumerateGeneric #-}
624723
@@ -632,27 +731,10 @@ liftProduct (a, b) = (a :*: b)
632731
633732dropSum :: (f :+: g) a -> Either (f a) (g a)
634733dropSum s = case s of
635− L1 x -> Left x
636− R1 x -> Right x
734+ L1 x -> Left x
735+ R1 x -> Right x
637736{-# INLINEABLE dropSum #-}
638737
639738liftSum :: Either (f a) (g a) -> (f :+: g) a
640739liftSum = either L1 R1
641740{-# INLINEABLE liftSum #-}
642−
643−{- example:
644−
645−{-# LANGUAGE DeriveGeneric, TypeOperators #-}
646−
647−data Color
648− = RGB Int Int Int
649− | Color String
650− deriving (Generic)
651−
652−instance HasTrie Color where
653− newtype (Color :->: b) = ColorTrie { unColorTrie :: Reg Color :->: b }
654− trie = trieGeneric ColorTrie
655− untrie = untrieGeneric unColorTrie
656− enumerate = enumerateGeneric unColorTrie
657−
658−-}