MemoTrie 0.6.2 → 0.6.3
raw patch · 2 files changed
+129/−3 lines, 2 filesdep ~base
Dependency ranges changed: base
Files
- MemoTrie.cabal +2/−2
- src/Data/MemoTrie.hs +127/−1
MemoTrie.cabal view
@@ -1,5 +1,5 @@ Name: MemoTrie-Version: 0.6.2+Version: 0.6.3 Cabal-Version: >= 1.6 Synopsis: Trie-based memo functions Category: Data@@ -11,7 +11,7 @@ Project wiki page: <http://haskell.org/haskellwiki/MemoTrie> . © 2008-2012 by Conal Elliott; BSD3 license.-Homepage: http://haskell.org/haskellwiki/MemoTrie+Homepage: https://github.com/conal/MemoTrie Author: Conal Elliott Maintainer: conal@conal.net Copyright: (c) 2008-2012 by Conal Elliott
src/Data/MemoTrie.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}-{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures, FlexibleContexts, EmptyCase, LambdaCase #-} {-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-} -- ScopedTypeVariables works around a 6.10 bug. The forall keyword is -- supposed to be recognized in a RULES pragma.@@ -18,6 +19,25 @@ -- Adapted from sjanssen's paste: \"a lazy trie\" <http://hpaste.org/3839>, -- which I think is based on Ralf Hinze's paper "Memo Functions, -- Polytypically!".+-- +-- You can automatically derive generic instances. for example: +-- +-- @+-- -- LANGUAGE DeriveGeneric, TypeOperators +-- +-- data Color +-- = RGB Int Int Int+-- | Color String +-- deriving (Generic) +-- +-- instance HasTrie Color where+-- newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b } +-- trie = 'trieGeneric' ColorTrie +-- untrie = 'untrieGeneric' unColorTrie+-- enumerate = 'enumerateGeneric' unColorTrie+-- @+-- +-- ---------------------------------------------------------------------- module Data.MemoTrie@@ -27,6 +47,7 @@ , memo, memo2, memo3, mup , inTrie, inTrie2, inTrie3 -- , untrieBits+ , trieGeneric, untrieGeneric, enumerateGeneric, Reg ) where -- Export the parts of HasTrie separately in order to get the associated data@@ -39,6 +60,7 @@ import Control.Arrow (first,(&&&)) import Data.Monoid import Data.Function (on)+import GHC.Generics import Data.Void @@ -529,4 +551,108 @@ f1 n = n + n f1' = memo f1+-}++-- | just like @void@ +instance HasTrie (V1 x) where+ data (V1 x :->: b) = V1Trie + trie _ = V1Trie + untrie V1Trie = \case + enumerate V1Trie = [] ++-- | just like @()@ +instance HasTrie (U1 x) where+ data (U1 x :->: b) = U1Trie b + trie f = U1Trie (f U1)+ untrie (U1Trie b) = \U1 -> b+ enumerate (U1Trie b) = [(U1, b)] ++-- | wraps @Either (f x) (g x)@ +instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :+: g) x) where+ newtype ((f :+: g) x :->: b) = EitherTrie1 (Either (f x) (g x) :->: b)+ trie f = EitherTrie1 (trie (f . liftSum))+ untrie (EitherTrie1 t) = (untrie t) . dropSum+ enumerate (EitherTrie1 t) = enum' liftSum t++-- | wraps @(f x, g x)@ +instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :*: g) x) where+ newtype ((f :*: g) x :->: b) = PairTrie1 ((f x, g x) :->: b)+ trie f = PairTrie1 (trie (f . liftProduct))+ untrie (PairTrie1 t) = (untrie t) . dropProduct + enumerate (PairTrie1 t) = enum' liftProduct t++-- | wraps @a@ +instance (HasTrie a) => HasTrie (K1 i a x) where+ data (K1 i a x :->: b) = K1Trie (a :->: b) + trie f = K1Trie (trie (f . K1)) + untrie (K1Trie t) = \(K1 a) -> (untrie t) a + enumerate (K1Trie t) = enum' K1 t ++-- | wraps @f x@ +instance (HasTrie (f x)) => HasTrie (M1 i t f x) where+ data (M1 i t f x :->: b) = M1Trie (f x :->: b) + trie f = M1Trie (trie (f . M1)) + untrie (M1Trie t) = \(M1 a) -> (untrie t) a + enumerate (M1Trie t) = enum' M1 t ++-- | "unlifted" generic representation. (i.e. is a unary type constructor). +type Reg a = Rep a () ++trieGeneric+ :: (Generic a, HasTrie (Reg a))+ => ((Reg a :->: b) -> (a :->: b))+ -> (a -> b)+ -> (a :->: b)+trieGeneric theConstructor f = theConstructor (trie (f . to))+{-# INLINEABLE trieGeneric #-}++untrieGeneric+ :: (Generic a, HasTrie (Reg a))+ => ((a :->: b) -> (Reg a :->: b))+ -> (a :->: b)+ -> (a -> b)+untrieGeneric theDestructor t = \a -> (untrie (theDestructor t)) (from a)+{-# INLINEABLE untrieGeneric #-}++enumerateGeneric + :: (Generic a, HasTrie (Reg a))+ => ((a :->: b) -> (Reg a :->: b))+ -> (a :->: b)+ -> [(a, b)]+enumerateGeneric theDestructor t = enum' to (theDestructor t) +{-# INLINEABLE enumerateGeneric #-}++dropProduct :: (f :*: g) a -> (f a, g a) +dropProduct (a :*: b) = (a, b)+{-# INLINEABLE dropProduct #-}++liftProduct :: (f a, g a) -> (f :*: g) a +liftProduct (a, b) = (a :*: b)+{-# INLINEABLE liftProduct #-}++dropSum :: (f :+: g) a -> Either (f a) (g a) +dropSum s = case s of + L1 x -> Left x + R1 x -> Right x +{-# INLINEABLE dropSum #-}++liftSum :: Either (f a) (g a) -> (f :+: g) a +liftSum = either L1 R1+{-# INLINEABLE liftSum #-}++{- example: ++{-# LANGUAGE DeriveGeneric, TypeOperators #-}++data Color + = RGB Int Int Int+ | Color String + deriving (Generic) ++instance HasTrie Color where+ newtype (Color :->: b) = ColorTrie { unColorTrie :: Reg Color :->: b } + trie = trieGeneric ColorTrie + untrie = untrieGeneric unColorTrie+ enumerate = enumerateGeneric unColorTrie+ -}