@@ -1,5 +1,6 @@
11{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}
2−{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}
2+{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}
3+{-# LANGUAGE DefaultSignatures, FlexibleContexts, EmptyCase, LambdaCase #-}
34{-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-}
45-- ScopedTypeVariables works around a 6.10 bug. The forall keyword is
56-- supposed to be recognized in a RULES pragma.
@@ -18,6 +19,25 @@
1819-- Adapted from sjanssen's paste: \"a lazy trie\" <http://hpaste.org/3839>,
1920-- which I think is based on Ralf Hinze's paper "Memo Functions,
2021-- Polytypically!".
22+--
23+-- You can automatically derive generic instances. for example:
24+--
25+-- @
26+-- -- LANGUAGE DeriveGeneric, TypeOperators
27+--
28+-- data Color
29+-- = RGB Int Int Int
30+-- | Color String
31+-- deriving (Generic)
32+--
33+-- 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
38+-- @
39+--
40+--
2141----------------------------------------------------------------------
2242
2343module Data.MemoTrie
@@ -27,6 +47,7 @@ module Data.MemoTrie
2747 , memo, memo2, memo3, mup
2848 , inTrie, inTrie2, inTrie3
2949 -- , untrieBits
50+ , trieGeneric, untrieGeneric, enumerateGeneric, Reg
3051 ) where
3152
3253-- Export the parts of HasTrie separately in order to get the associated data
@@ -39,6 +60,7 @@ import Control.Applicative
3960import Control.Arrow (first,(&&&))
4061import Data.Monoid
4162import Data.Function (on)
63+import GHC.Generics
4264
4365import Data.Void
4466
@@ -530,3 +552,107 @@ f1 n = n + n
530552
531553f1' = memo f1
532554-}
555+
556+-- | just like @void@
557+instance HasTrie (V1 x) where
558+ data (V1 x :->: b) = V1Trie
559+ trie _ = V1Trie
560+ untrie V1Trie = \case
561+ enumerate V1Trie = []
562+
563+-- | just like @()@
564+instance 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)]
569+
570+-- | wraps @Either (f x) (g x)@
571+instance (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
576+
577+-- | wraps @(f x, g x)@
578+instance (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
583+
584+-- | wraps @a@
585+instance (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
590+
591+-- | wraps @f x@
592+instance (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
597+
598+-- | "unlifted" generic representation. (i.e. is a unary type constructor).
599+type Reg a = Rep a ()
600+
601+trieGeneric
602+ :: (Generic a, HasTrie (Reg a))
603+ => ((Reg a :->: b) -> (a :->: b))
604+ -> (a -> b)
605+ -> (a :->: b)
606+trieGeneric theConstructor f = theConstructor (trie (f . to))
607+{-# INLINEABLE trieGeneric #-}
608+
609+untrieGeneric
610+ :: (Generic a, HasTrie (Reg a))
611+ => ((a :->: b) -> (Reg a :->: b))
612+ -> (a :->: b)
613+ -> (a -> b)
614+untrieGeneric theDestructor t = \a -> (untrie (theDestructor t)) (from a)
615+{-# INLINEABLE untrieGeneric #-}
616+
617+enumerateGeneric
618+ :: (Generic a, HasTrie (Reg a))
619+ => ((a :->: b) -> (Reg a :->: b))
620+ -> (a :->: b)
621+ -> [(a, b)]
622+enumerateGeneric theDestructor t = enum' to (theDestructor t)
623+{-# INLINEABLE enumerateGeneric #-}
624+
625+dropProduct :: (f :*: g) a -> (f a, g a)
626+dropProduct (a :*: b) = (a, b)
627+{-# INLINEABLE dropProduct #-}
628+
629+liftProduct :: (f a, g a) -> (f :*: g) a
630+liftProduct (a, b) = (a :*: b)
631+{-# INLINEABLE liftProduct #-}
632+
633+dropSum :: (f :+: g) a -> Either (f a) (g a)
634+dropSum s = case s of
635+ L1 x -> Left x
636+ R1 x -> Right x
637+{-# INLINEABLE dropSum #-}
638+
639+liftSum :: Either (f a) (g a) -> (f :+: g) a
640+liftSum = either L1 R1
641+{-# 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+-}