@@ -1,15 +1,14 @@
11{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}
22{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}
3−{-# LANGUAGE DefaultSignatures, FlexibleContexts, LambdaCase #-}
3+{-# LANGUAGE DefaultSignatures, FlexibleContexts, EmptyCase, LambdaCase #-}
44{-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-}
5−
65-- ScopedTypeVariables works around a 6.10 bug. The forall keyword is
76-- supposed to be recognized in a RULES pragma.
87
98----------------------------------------------------------------------
109-- |
1110-- Module : Data.MemoTrie
12−-- Copyright : (c) Conal Elliott 2008-2016
11+-- Copyright : (c) Conal Elliott 2008-2012
1312-- License : BSD3
1413--
1514-- Maintainer : conal@conal.net
@@ -17,33 +16,26 @@
1716--
1817-- Trie-based memoizer
1918--
20−-- Adapted from sjanssen's paste: <http://hpaste.org/3839 \"a lazy trie\">,
19+-- Adapted from sjanssen's paste: \"a lazy trie\" <http://hpaste.org/3839>,
2120-- which I think is based on Ralf Hinze's paper "Memo Functions,
2221-- Polytypically!".
2322--
2423-- You can automatically derive generic instances. for example:
2524--
2625-- @
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)
26+-- -- LANGUAGE DeriveGeneric, TypeOperators
3027--
31−-- data Color = RGB Int Int Int
32−-- | NamedColor String
33−-- deriving ('Generic')
28+-- data Color
29+-- = RGB Int Int Int
30+-- | Color String
31+-- deriving (Generic)
3432--
3533-- instance HasTrie Color where
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−--
34+-- newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b }
35+-- trie = 'trieGeneric' ColorTrie
36+-- untrie = 'untrieGeneric' unColorTrie
37+-- enumerate = 'enumerateGeneric' unColorTrie
4438-- @
45−-- cabal configure -fexamples && cabal run generic
46−-- @
4739--
4840--
4941----------------------------------------------------------------------
@@ -55,31 +47,23 @@ module Data.MemoTrie
5547 , memo, memo2, memo3, mup
5648 , inTrie, inTrie2, inTrie3
5749 -- , untrieBits
58− , trieGeneric, untrieGeneric, enumerateGeneric, Reg
59− , memoFix
50+ , trieGeneric, untrieGeneric, enumerateGeneric, Reg
6051 ) where
6152
6253-- Export the parts of HasTrie separately in order to get the associated data
6354-- type constructors, so I can define instances of other classes on them.
6455
65−import Data.Function (fix)
6656import Data.Bits
6757import Data.Word
6858import Data.Int
69−#if !MIN_VERSION_base(4,8,0)
7059import Control.Applicative
71−#endif
7260import Control.Arrow (first,(&&&))
73−#if !MIN_VERSION_base(4,8,0)
7461import Data.Monoid
75−#endif
7662import Data.Function (on)
7763import GHC.Generics
7864
79−import Control.Newtype.Generics
65+import Data.Void
8066
81−import Data.Void (Void)
82−
8367-- import Prelude hiding (id,(.))
8468-- import Control.Category
8569-- import Control.Arrow
@@ -136,13 +120,7 @@ untrie3 tt = untrie2 . untrie tt
136120-}
137121
138122
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−
123+{-# RULES "trie/untrie" forall t. trie (untrie t) = t #-}
146124
147125-- Don't include the dual rule:
148126-- "untrie/trie" forall f. untrie (trie f) = f
@@ -170,42 +148,6 @@ mup mem f = memo (mem . f)
170148memo2 = mup memo
171149memo3 = mup memo2
172150
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−
209151-- | Apply a unary function inside of a trie
210152inTrie :: (HasTrie a, HasTrie c) =>
211153 ((a -> b) -> (c -> d))
@@ -229,27 +171,16 @@ inTrie3 = untrie ~> inTrie2
229171
230172instance HasTrie Void where
231173 -- As suggested by Audun Skaugen
232− data Void :->: a = VoidTrie
174+ data Void :->: a = VoidTrie
233175 trie _ = VoidTrie
234− untrie VoidTrie = \ _ -> error "untrie VoidTrie"
235− -- \case -- needs EmptyCase
176+ untrie VoidTrie = absurd
236177 enumerate VoidTrie = []
237178
238−instance Newtype (Void :->: a) where
239− type O (Void :->: a) = ()
240− pack () = VoidTrie
241− unpack VoidTrie = ()
242−
243179instance HasTrie () where
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
180+ newtype () :->: a = UnitTrie a
181+ trie f = UnitTrie (f ())
182+ untrie (UnitTrie a) = \ () -> a
183+ enumerate (UnitTrie a) = [((),a)]
253184
254185-- Proofs of inverse properties:
255186
@@ -281,15 +212,10 @@ memoizing hyper-strict functions.
281212
282213
283214instance HasTrie Bool where
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')
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)]
293219
294220-- | Conditional with boolean last.
295221-- Spec: @if' (f False) (f True) == f@
@@ -315,27 +241,12 @@ if' _ e True = e
315241 BoolTrie f t
316242-}
317243
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)
328244
329245instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
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)
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
339250
340251enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
341252enum' f = (fmap.first) f . enumerate
@@ -370,16 +281,11 @@ as `weave` [] = as
370281
371282
372283instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
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
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 ]
383289
384290{-
385291 untrie (trie f)
@@ -408,10 +314,10 @@ instance Newtype ((a,b) :->: x) where
408314-}
409315
410316instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where
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
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
415321
416322trip :: ((a,b),c) -> (a,b,c)
417323trip ((a,b),c) = (a,b,c)
@@ -421,10 +327,10 @@ detrip (a,b,c) = ((a,b),c)
421327
422328
423329instance HasTrie x => HasTrie [x] where
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
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
428334
429335list :: Either () (x,[x]) -> [x]
430336list = either (const []) (uncurry (:))
@@ -435,10 +341,10 @@ delist (x:xs) = Right (x,xs)
435341
436342#define WordInstance(Type,TrieType)\
437343instance HasTrie Type where \
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
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
442348
443349WordInstance(Word,WordTrie)
444350WordInstance(Word8,Word8Trie)
@@ -447,10 +353,10 @@ WordInstance(Word32,Word32Trie)
447353WordInstance(Word64,Word64Trie)
448354
449355-- instance HasTrie Word where
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
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
454360
455361
456362-- | Extract bits in little-endian order
@@ -469,10 +375,10 @@ unbits [] = 0
469375unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1
470376
471377instance HasTrie Char where
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
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
476382
477383-- Although Int is a Bits instance, we can't use bits directly for
478384-- memoizing, because the "bits" function gives an infinite result, since
@@ -481,10 +387,10 @@ instance HasTrie Char where
481387
482388#define IntInstance(IntType,WordType,TrieType) \
483389instance HasTrie IntType where \
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
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
488394
489395IntInstance(Int,Word,IntTrie)
490396IntInstance(Int8,Word8,Int8Trie)
@@ -496,10 +402,10 @@ IntInstance(Int64,Word64,Int64Trie)
496402-- extract the sign bit.
497403
498404instance HasTrie Integer where
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
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
503409
504410
505411unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n
@@ -587,12 +493,7 @@ instance HasTrie a => Monad ((:->:) a) where
587493
588494instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
589495 mempty = trie mempty
590−#if !MIN_VERSION_base(4,11,0)
591496 mappend = inTrie2 mappend
592−#else
593−instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where
594− (<>) = inTrie2 (<>)
595−#endif
596497
597498instance HasTrie a => Functor ((:->:) a) where
598499 fmap f = inTrie (fmap f)
@@ -616,6 +517,7 @@ infixr 9 @.@
616517(@.@) = inTrie2 (.)
617518
618519
520+
619521-- instance Category (:->:) where
620522-- id = idTrie
621523-- (.) = (.:)
@@ -634,6 +536,7 @@ necessary but disallowed `HasTrie` constraints on the domain type.
634536
635537-}
636538
539+
637540---- To go elsewhere
638541
639542-- Matt Hellige's notation for @argument f . result g@.
@@ -652,72 +555,70 @@ f1' = memo f1
652555
653556-- | just like @void@
654557instance HasTrie (V1 x) where
655− data (V1 x :->: b) = V1Trie
656− trie _ = V1Trie
657− untrie V1Trie = \ _ -> error "untrie V1Trie"
658− -- \case -- needs EmptyCase
659− enumerate V1Trie = []
558+ data (V1 x :->: b) = V1Trie
559+ trie _ = V1Trie
560+ untrie V1Trie = \case
561+ enumerate V1Trie = []
660562
661563-- | just like @()@
662564instance HasTrie (U1 x) where
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)]
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)]
667569
668570-- | wraps @Either (f x) (g x)@
669571instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :+: g) x) where
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
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
674576
675577-- | wraps @(f x, g x)@
676578instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :*: g) x) where
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
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
681583
682584-- | wraps @a@
683585instance (HasTrie a) => HasTrie (K1 i a x) where
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
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
688590
689591-- | wraps @f x@
690592instance (HasTrie (f x)) => HasTrie (M1 i t f x) where
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
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
695597
696−-- | the data type in a __reg__ular form.
697−-- "unlifted" generic representation. (i.e. is a unary type constructor).
598+-- | "unlifted" generic representation. (i.e. is a unary type constructor).
698599type Reg a = Rep a ()
699600
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)
601+trieGeneric
602+ :: (Generic a, HasTrie (Reg a))
603+ => ((Reg a :->: b) -> (a :->: b))
604+ -> (a -> b)
605+ -> (a :->: b)
705606trieGeneric theConstructor f = theConstructor (trie (f . to))
706607{-# INLINEABLE trieGeneric #-}
707608
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)
609+untrieGeneric
610+ :: (Generic a, HasTrie (Reg a))
611+ => ((a :->: b) -> (Reg a :->: b))
612+ -> (a :->: b)
613+ -> (a -> b)
713614untrieGeneric theDestructor t = \a -> (untrie (theDestructor t)) (from a)
714615{-# INLINEABLE untrieGeneric #-}
715616
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)]
617+enumerateGeneric
618+ :: (Generic a, HasTrie (Reg a))
619+ => ((a :->: b) -> (Reg a :->: b))
620+ -> (a :->: b)
621+ -> [(a, b)]
721622enumerateGeneric theDestructor t = enum' to (theDestructor t)
722623{-# INLINEABLE enumerateGeneric #-}
723624
@@ -731,10 +632,27 @@ liftProduct (a, b) = (a :*: b)
731632
732633dropSum :: (f :+: g) a -> Either (f a) (g a)
733634dropSum s = case s of
734− L1 x -> Left x
735− R1 x -> Right x
635+ L1 x -> Left x
636+ R1 x -> Right x
736637{-# INLINEABLE dropSum #-}
737638
738639liftSum :: Either (f a) (g a) -> (f :+: g) a
739640liftSum = either L1 R1
740641{-# 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+-}