diff --git a/Data/Function/Memoize.hs b/Data/Function/Memoize.hs deleted file mode 100644 --- a/Data/Function/Memoize.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE - DeriveFunctor, - GeneralizedNewtypeDeriving, - TemplateHaskell, - UnicodeSyntax - #-} -{- | - A function memoization library. - - This includes a class for memoizable argument types and a Template - Haskell expander for deriving instances of the class. - - Note that most memoization in this style relies on assumptions about - the implementation of non-strictness (as laziness) that are not - guaranteed by the semantics. However, it appears to work. --} -module Data.Function.Memoize ( - -- * Memoization class - Memoizable(..), - -- ** Operations - -- *** Higher-arity memoize - memoize2, memoize3, memoize4, memoize5, memoize6, memoize7, - -- *** Memoizing open recursion - memoFix, memoFix2, memoFix3, memoFix4, memoFix5, memoFix6, memoFix7, - -- *** Tracing memoization - traceMemoize, - - -- * For making instances for finite types - memoizeFinite, - - -- * Deriving 'Memoizable' - deriveMemoizable, deriveMemoizableParams, deriveMemoize, -) where - -import Control.Applicative -import Control.Monad -import Debug.Trace - -import Data.Function.Memoize.Class -import Data.Function.Memoize.TH - --- | Memoize a two argument function -memoize2 ∷ (Memoizable a, Memoizable b) ⇒ - (a → b → v) → a → b → v -memoize2 v = memoize (memoize . v) - --- | Memoize a three argument function -memoize3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒ - (a → b → c → v) → a → b → c → v -memoize3 v = memoize (memoize2 . v) - --- | Memoize a four argument function -memoize4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒ - (a → b → c → d → v) → - a → b → c → d → v -memoize4 v = memoize (memoize3 . v) - --- | Memoize a five argument function -memoize5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e) ⇒ - (a → b → c → d → e → v) → - a → b → c → d → e → v -memoize5 v = memoize (memoize4 . v) - --- | Memoize a six argument function -memoize6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e, Memoizable f) ⇒ - (a → b → c → d → e → f → v) → - a → b → c → d → e → f → v -memoize6 v = memoize (memoize5 . v) - --- | Memoize a seven argument function -memoize7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e, Memoizable f, Memoizable g) ⇒ - (a → b → c → d → e → f → g → v) → - a → b → c → d → e → f → g → v -memoize7 v = memoize (memoize6 . v) - --- | Memoizes the least fixed point of a function. This is like --- 'Data.Function.fix', but it passes the fixed function a memoized --- version of itself, so this memoizes using all recursive calls as well. -memoFix ∷ Memoizable a ⇒ ((a → v) → a → v) → a → v -memoFix ff = f where f = memoize (ff f) - --- | Two argument version of 'memoFix'. -memoFix2 ∷ (Memoizable a, Memoizable b) ⇒ - ((a → b → v) → a → b → v) → a → b → v -memoFix2 ff = f where f = memoize2 (ff f) - --- | Three argument version of 'memoFix'. -memoFix3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒ - ((a → b → c → v) → a → b → c → v) → a → b → c → v -memoFix3 ff = f where f = memoize3 (ff f) - --- | Four argument version of 'memoFix'. -memoFix4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒ - ((a → b → c → d → v) → (a → b → c → d → v)) → - a → b → c → d → v -memoFix4 ff = f where f = memoize4 (ff f) - --- | Five argument version of 'memoFix'. -memoFix5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e) ⇒ - ((a → b → c → d → e → v) → (a → b → c → d → e → v)) → - a → b → c → d → e → v -memoFix5 ff = f where f = memoize5 (ff f) - --- | Six argument version of 'memoFix'. -memoFix6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e, Memoizable f) ⇒ - ((a → b → c → d → e → f → v) → (a → b → c → d → e → f → v)) → - a → b → c → d → e → f → v -memoFix6 ff = f where f = memoize6 (ff f) - --- | Seven argument version of 'memoFix'. -memoFix7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, - Memoizable e, Memoizable f, Memoizable g) ⇒ - ((a → b → c → d → e → f → g → v) → (a → b → c → d → e → f → g → v)) → - a → b → c → d → e → f → g → v -memoFix7 ff = f where f = memoize7 (ff f) - --- | Give a one-argument function whose argument satisfies 'Show', --- this memoizes the function such that the argument is shown (using --- 'Debug.Trace.trace') only when the function has to be applied, as --- opposed to when the answer is available in the memo cache. -traceMemoize ∷ (Memoizable a, Show a) ⇒ (a → b) → a → b -traceMemoize f = memoize (\a → traceShow a (f a)) - ---- ---- Derived instances ---- - -deriveMemoizable ''() -deriveMemoizable ''Bool -deriveMemoizable ''Ordering -deriveMemoizable ''Maybe -deriveMemoizable ''Either -deriveMemoizable ''[] - -deriveMemoizable ''(,) -deriveMemoizable ''(,,) -deriveMemoizable ''(,,,) -deriveMemoizable ''(,,,,) -deriveMemoizable ''(,,,,,) -deriveMemoizable ''(,,,,,,) -deriveMemoizable ''(,,,,,,,) -deriveMemoizable ''(,,,,,,,,) -deriveMemoizable ''(,,,,,,,,,) -deriveMemoizable ''(,,,,,,,,,,) -deriveMemoizable ''(,,,,,,,,,,,) - ---- ---- Binary-tree based memo caches ---- - --- Used for both 'Integer' and arbitrary 'Int'-like types. - -data BinaryTreeCache v - = BinaryTreeCache { - btValue ∷ v, - btLeft, btRight ∷ BinaryTreeCache v - } - deriving Functor - ---- ---- 'Integer' memoization ---- - -instance Memoizable Integer where - memoize f = integerLookup (f <$> theIntegers) - --- | An integer cache stores a value for 0 and separate caches for the --- positive and negative integers. -data IntegerCache v - = IntegerCache { - icZero ∷ v, - icNegative, icPositive ∷ PosIntCache v - } - deriving Functor - --- | A positive integer cache is represented as a little-ending bitwise --- trie -type PosIntCache v = BinaryTreeCache v - -theIntegers ∷ IntegerCache Integer -theIntegers - = IntegerCache { - icZero = 0, - icNegative = negate <$> thePosInts, - icPositive = thePosInts - } - -thePosInts ∷ PosIntCache Integer -thePosInts = - BinaryTreeCache { - btValue = 1, - btLeft = fmap (* 2) thePosInts, - btRight = fmap (succ . (* 2)) thePosInts - } - -integerLookup ∷ IntegerCache v → Integer → v -integerLookup cache n = - case n `compare` 0 of - EQ → icZero cache - GT → posIntLookup (icPositive cache) n - LT → posIntLookup (icNegative cache) (negate n) - --- PRECONDITION: @n@ is a positive 'Integer' -posIntLookup ∷ PosIntCache v → Integer → v -posIntLookup cache 1 = btValue cache -posIntLookup cache n - | even n = posIntLookup (btLeft cache) (n `div` 2) - | otherwise = posIntLookup (btRight cache) (n `div` 2) - ---- ---- Enumerable types using binary search trees ---- - -newtype Finite a = ToFinite { fromFinite ∷ a } - deriving (Eq, Bounded, Enum) - -instance (Bounded a, Enum a) ⇒ Memoizable (Finite a) where - memoize f = finiteLookup (f <$> theFinites) - --- | For finite 'Int'-like types, we use a balanced binary search tree --- indexed to every element from 'minBound' to 'maxBound' -theFinites ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache a -theFinites = loop minBound maxBound where - loop start stop = - BinaryTreeCache { - btValue = mean, - btLeft = loop start (pred mean), - btRight = loop (succ mean) stop - } - where mean = meanFinite start stop - -finiteLookup ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache v → a → v -finiteLookup cache0 a0 = - loop start0 stop0 cache0 where - start0 = fromEnum (minBound `asTypeOf` a0) - stop0 = fromEnum (maxBound `asTypeOf` a0) - a = fromEnum a0 - loop start stop cache = - let mean = meanFinite start stop in - case a `compare` mean of - EQ → btValue cache - LT → loop start (pred mean) (btLeft cache) - GT → loop (succ mean) stop (btRight cache) - -meanFinite ∷ (Bounded a, Enum a) ⇒ a → a → a -meanFinite a b = toEnum (ia `div` 2 + ib `div` 2 + - if odd ia && odd ib then 1 else 0) - where - ia = fromEnum a - ib = fromEnum b - --- | Can be used to memoize over any "finite" type satisfying --- 'Enum' and 'Bounded'. This builds a binary search tree, treating --- the memoized type as isomorphic to a range of 'Int', so it will be --- only as efficient as 'toEnum', 'fromEnum', 'succ', and 'pred'. --- --- This can be used to make instances for finite types. For example, the --- instances for 'Int' and 'Char' are declared as: --- --- @ --- instance Memoizable Int where memoize = memoizeFinite --- instance Memoizable Char where memoize = memoizeFinite --- @ -memoizeFinite ∷ (Enum a, Bounded a) ⇒ (a → v) → a → v -memoizeFinite f = memoize (f . fromFinite) . ToFinite - -instance Memoizable Int where memoize = memoizeFinite -instance Memoizable Char where memoize = memoizeFinite - ---- ---- Functions ---- - -instance (Eq a, Bounded a, Enum a, Memoizable b) ⇒ Memoizable (a → b) where - memoize = functionLookup . theFunctions - -functionLookup ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒ - FunctionCache b v → (a → b) → v -functionLookup cache f = - fcNil (foldl fcCons cache (f <$> [minBound .. maxBound])) - -theFunctions ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒ - ((a → b) → v) → FunctionCache b v -theFunctions f = - FunctionCache { - fcNil = f undefined, - fcCons = memoize (\b → theFunctions (f . extend b)) - } - where - extend b g a - | a == minBound = b - | otherwise = g (pred a) - -data FunctionCache b v - = FunctionCache { - fcNil ∷ v, - fcCons ∷ b → FunctionCache b v - } - ---- ---- Example functions ---- - --- Memoize on 'Integer'. If memoization doesn't work, this will be --- horribly slow. -_fib ∷ Integer → Integer -_fib = memoFix $ \fib n → case n of - 0 → 1 - 1 → 1 - _ → fib (n - 1) + fib (n - 2) - --- Memoize on a function. The use of 'trace' will indicate when --- the function is called to fill in the memo cache. -_isNot ∷ (Bool → Bool) → Bool -_isNot = memoize $ \f → - trace "_isNot" $ - f True == False && f False == True - --- Memoize on a curried function! -_countTrue ∷ (Bool → Bool → Bool) → Integer -_countTrue = memoize $ \f → - trace "_countTrue" $ - toInteger (length (f <$> [False,True] <*> [False,True] >>= guard)) - diff --git a/Data/Function/Memoize/Class.hs b/Data/Function/Memoize/Class.hs deleted file mode 100644 --- a/Data/Function/Memoize/Class.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} -{- | - The 'Memoizable' type class. --} -module Data.Function.Memoize.Class ( - Memoizable(..) -) where - --- | A memoization class. An instance @'Memoizable' T@ for some --- type @T@ means that that 'memoize' method can memoize for --- parameters of type @T@. -class Memoizable a where - memoize ∷ (a → v) → a → v diff --git a/Data/Function/Memoize/TH.hs b/Data/Function/Memoize/TH.hs deleted file mode 100644 --- a/Data/Function/Memoize/TH.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, - UnicodeSyntax, - CPP - #-} -{- | - Exports functions for deriving instances of 'Memoizable' using - Template Haskell. The @TemplateHaskell@ language extension must be - enabled to use the functions exported from this module. --} -module Data.Function.Memoize.TH ( - deriveMemoizable, deriveMemoizableParams, deriveMemoize, -) where - -import Control.Applicative -import Control.Monad -import Language.Haskell.TH - -import Data.Function.Memoize.Class - --- | --- To derive 'Memoizable' instances for the given data types. --- In the simplest usage, to derive 'Memoizable' for an algebraic --- datatype named @T@, write: --- --- @ --- deriveMemoizable ''T --- @ --- --- This assumes that all the type parameters of @T@ that are not --- annotated with a kind other than @*@ should be listed as requiring --- 'Memoizable' instances in the instance context. For example, given --- a data type declared as --- --- @ --- data T a (b :: * -> *) c = ... --- @ --- --- the generated instance will look like --- --- @ --- instance ('Memoizable' a, 'Memoizable' c) => --- 'Memoizable' (T a b c) where ... --- @ --- --- For more precise control over the context, use --- 'deriveMemoizableParams'. --- --- N.B.: The @TemplateHaskell@ language extension must be enabled to use --- this function. -deriveMemoizable ∷ Name → Q [Dec] -deriveMemoizable n = deriveMemoizable' n Nothing - --- | --- Like 'deriveMemoizable' but takes a second argument, which is a list --- of 'Int's to specify which type parameters of the type should be --- mentioned in the context. For example, given the same definition for --- @T@ as above, we can write --- --- @ --- deriveMemoizableParams ''T [3] --- @ --- --- to leave the first parameter of @T@ out of the context and show --- only the third, yielding the instance --- --- @ --- instance 'Memoizable' c => 'Memoizable' (T a b c) where ... --- @ --- --- N.B.: The @TemplateHaskell@ language extension must be enabled to use --- this function. -deriveMemoizableParams ∷ Name → [Int] → Q [Dec] -deriveMemoizableParams n indices = deriveMemoizable' n (Just indices) - --- | In cases where neither 'deriveMemoizable' nor --- 'deriveMemoizableParams' can figure out the right context for an --- instance declaration, one can declare the instance manually and use --- this function to derive the method body for 'memoize'. For example, --- suppose that a data type @T@ is defined as: --- --- @ --- data T a b = T (a -> Bool) b --- @ --- --- For @T a b@ to be memoizable, @a -> Bool@ must be, and based on the --- instance for '(->)', this means that @a@ must satisfy --- 'Bounded' and 'Enum', so 'deriveMemoizable' cannot build the right --- context for the 'Memoizable' instance. Instead, one can write: --- --- @ --- instance ('Enum' a, 'Bounded' a, 'Memoizable' b) => --- 'Memoizable' (T a b) where --- memoize = $(deriveMemoize ''T) --- @ -deriveMemoize ∷ Name → ExpQ -deriveMemoize name0 = do - (_, _, cons) ← checkName name0 - buildMethodExp cons - --- | The main entry point delegates to check given type name, renames type --- parameters, and generates the instance. -deriveMemoizable' ∷ Name → Maybe [Int] → Q [Dec] -deriveMemoizable' name0 mindices = do - (name, tvbs, cons) ← checkName name0 - let tvs = freshNames tvbs - inst ← instanceD - (buildContext mindices tvbs tvs) - (buildHead name tvs) - [buildMethodDec cons] - return [inst] - --- | Given the type name for the requested instance, checks if it --- corresponds to a @data@ or @newtype@, and if so, returns the name, --- a list of its parameters, and a list of constructor names with --- their arities. -checkName ∷ Name → Q (Name, [TyVarBndr], [(Name, Int)]) -checkName name0 = do - info ← reify name0 - case info of - TyConI (DataD _ name tvbs cons _) - → return (name, tvbs, stdizeCon <$> cons) - TyConI (NewtypeD _ name tvbs con _) - → return (name, tvbs, [stdizeCon con]) - _ → fail $ - "deriveMemoizable: Can't derive a Memoizable instance for `" ++ - show name0 ++ "' because it isn't a type constructor." - where - stdizeCon (NormalC name params) = (name, length params) - stdizeCon (RecC name fields) = (name, length fields) - stdizeCon (InfixC _ name _) = (name, 2) - stdizeCon (ForallC _ _ con) = stdizeCon con - --- | Given a list, produces a list of nicely printable, distinct names. --- Used so that instances print with nice parameters names, like --- --- @ --- instance Memoizable (T a b c) where --- @ --- --- instead of --- --- @ --- instance Memoizable (T a[1] b[2] c32424534) where --- @ -freshNames ∷ [a] → [Name] -freshNames xs = take (length xs) alphabet - where - alphabet = [ mkName (c:s) - | s ← "" : (show <$> [1 ∷ Integer ..]) - , c ← ['a' .. 'z'] ] - --- | Build the type class instance context, give the necessary --- information to select which parameters to include. If the first --- argument is @Just ixs@, then there should be 'Memoizable' instances --- for exactly those parameters, by index, in the context. Otherwise, --- choose the parameters that have no explicit kind from the --- list of binders. The third argument gives the actual type variable --- names to use. -buildContext ∷ Maybe [Int] → [TyVarBndr] → [Name] → CxtQ -buildContext mindices tvbs tvs = - cxt (classP ''Memoizable . (:[]) . varT <$> cxttvs) - where - cxttvs = case mindices of - Just ixs → filterBy (`elem` ixs) [1 ..] tvs - Nothing → filterBy isStar tvbs tvs - -- - isStar (PlainTV _) = True -#if __GLASGOW_HASKELL__ >= 706 - isStar (KindedTV _ StarT) = True -#else - isStar (KindedTV _ StarK) = True -#endif - isStar (KindedTV _ _) = False - -- - filterBy ∷ (a → Bool) → [a] → [b] → [b] - filterBy p xs ys = snd <$> filter (p . fst) (zip xs ys) - --- | Build the 'Memoizable' instance head for the given type name --- and parameter type variables. -buildHead ∷ Name → [Name] → TypeQ -buildHead name tvs = - appT (conT ''Memoizable) (foldl appT (conT name) (varT <$> tvs)) - --- | Build the 'memoize' method. The form of 'memoize' is always --- --- @ --- memoize f = lookup where --- cache1 = memoize $ \x1 -> ... memoize $ \x(a1) -> f (C1 x1 ...) --- ... --- cacheN = memoize $ \x1 -> ... memoize $ \x(aN) -> f (CN x1 ...) --- lookup (C1 x1 ...) = cache1 x1 ... --- ... --- lookup (CN xN ...) = cacheN xN ... --- @ --- --- where @C1@ ... @CN@ are the constructors of the data type and --- @aj@ is the arity of constructor @Cj@. --- --- In this method, we allocate fresh names for the parameter @f@, the --- lookup function, and the @N@ caches. We then delegate to build --- the definitions of @look@ and the caches. -buildMethodDec ∷ [(Name, Int)] → DecQ -buildMethodDec cons = do - valD (varP 'memoize) - (normalB (buildMethodExp cons)) - [] - --- | Build the body of the 'memoize' method, as described in the comment --- above 'buildMethodDec' -buildMethodExp ∷ [(Name, Int)] → ExpQ -buildMethodExp cons = do - f ← newName "f" - look ← newName "look" - caches ← mapM (\ _ -> newName "cache") cons - lam1E (varP f) - (letE - (buildLookup look cons caches - : zipWith (buildCache f) cons caches) - (varE look)) - --- | Build the look function by building a clause for each constructor --- of the datatype. -buildLookup ∷ Name → [(Name, Int)] → [Name] → DecQ -buildLookup look cons caches = - funD look (zipWith buildLookupClause cons caches) - --- | Build a lookup clause for one constructor. We lookup a value --- by matching that constructor and then passing its parameters to --- the cache for that constructor. -buildLookupClause ∷ (Name, Int) → Name → ClauseQ -buildLookupClause (con, arity) cache = do - params ← replicateM arity (newName "a") - clause [conP con (varP <$> params)] - (normalB (foldl appE (varE cache) (varE <$> params))) - [] - --- | Build the definition of a cache for the given constructor. We do --- this by binding the cache name to a cascading sequence of --- memoizations for each component in the constructor's arity. -buildCache ∷ Name → (Name, Int) → Name → DecQ -buildCache f (con, arity) cache = - valD (varP cache) (normalB (composeMemos arity f (conE con))) [] - --- | Given the remaining arity to memoize, the name of the function to --- memoize, and the accumulated parameter so far, build the --- memoization chain. -composeMemos ∷ Int → Name → ExpQ → ExpQ -composeMemos 0 f arg = [| $(varE f) $arg |] -composeMemos arity f arg = do - [| memoize $ \b -> $(composeMemos (arity - 1) f [| $arg b |]) |] - diff --git a/memoize.cabal b/memoize.cabal --- a/memoize.cabal +++ b/memoize.cabal @@ -1,6 +1,6 @@ name: memoize -version: 0.7 -cabal-version: >= 1.6 +version: 0.8 +cabal-version: >= 1.8 license: BSD3 license-file: LICENSE stability: experimental @@ -9,6 +9,7 @@ category: Data synopsis: A memoization library build-type: Simple +tested-with: GHC == 7.4.1, GHC == 7.0.2, GHC == 6.12.3 description: This library provides a type class 'Memoizable' for memoizing @@ -26,13 +27,25 @@ template-haskell >=2 && <3 ghc-options: -Wall -fno-warn-orphans - + hs-source-dirs: src exposed-modules: Data.Function.Memoize other-modules: Data.Function.Memoize.TH Data.Function.Memoize.Class +test-suite memoize-test1 + Hs-Source-Dirs: test + Type: exitcode-stdio-1.0 + Main-is: test1.hs + build-depends: base, memoize + +test-suite memoize-test2 + Hs-Source-Dirs: test + Type: exitcode-stdio-1.0 + Main-is: test2.hs + build-depends: base, memoize + source-repository head type: git location: git://github.com/tov/memoize.git diff --git a/src/Data/Function/Memoize.hs b/src/Data/Function/Memoize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function/Memoize.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE + DeriveFunctor, + GeneralizedNewtypeDeriving, + TemplateHaskell, + UnicodeSyntax + #-} +{- | + A function memoization library. + + This includes a class for memoizable argument types and a Template + Haskell expander for deriving instances of the class. + + Note that most memoization in this style relies on assumptions about + the implementation of non-strictness (as laziness) that are not + guaranteed by the semantics. However, it appears to work. +-} +module Data.Function.Memoize ( + -- * Memoization class + Memoizable(..), + -- ** Operations + -- *** Higher-arity memoize + memoize2, memoize3, memoize4, memoize5, memoize6, memoize7, + -- *** Memoizing open recursion + memoFix, memoFix2, memoFix3, memoFix4, memoFix5, memoFix6, memoFix7, + -- *** Tracing memoization + traceMemoize, + + -- * For making instances for finite types + memoizeFinite, + + -- * Deriving 'Memoizable' + deriveMemoizable, deriveMemoizableParams, deriveMemoize, +) where + +import Control.Applicative +import Control.Monad +import Debug.Trace + +import Data.Function.Memoize.Class +import Data.Function.Memoize.TH + +-- | Memoize a two argument function +memoize2 ∷ (Memoizable a, Memoizable b) ⇒ + (a → b → v) → a → b → v +memoize2 v = memoize (memoize . v) + +-- | Memoize a three argument function +memoize3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒ + (a → b → c → v) → a → b → c → v +memoize3 v = memoize (memoize2 . v) + +-- | Memoize a four argument function +memoize4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒ + (a → b → c → d → v) → + a → b → c → d → v +memoize4 v = memoize (memoize3 . v) + +-- | Memoize a five argument function +memoize5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e) ⇒ + (a → b → c → d → e → v) → + a → b → c → d → e → v +memoize5 v = memoize (memoize4 . v) + +-- | Memoize a six argument function +memoize6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e, Memoizable f) ⇒ + (a → b → c → d → e → f → v) → + a → b → c → d → e → f → v +memoize6 v = memoize (memoize5 . v) + +-- | Memoize a seven argument function +memoize7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e, Memoizable f, Memoizable g) ⇒ + (a → b → c → d → e → f → g → v) → + a → b → c → d → e → f → g → v +memoize7 v = memoize (memoize6 . v) + +-- | Memoizes the least fixed point of a function. This is like +-- 'Data.Function.fix', but it passes the fixed function a memoized +-- version of itself, so this memoizes using all recursive calls as well. +memoFix ∷ Memoizable a ⇒ ((a → v) → a → v) → a → v +memoFix ff = f where f = memoize (ff f) + +-- | Two argument version of 'memoFix'. +memoFix2 ∷ (Memoizable a, Memoizable b) ⇒ + ((a → b → v) → a → b → v) → a → b → v +memoFix2 ff = f where f = memoize2 (ff f) + +-- | Three argument version of 'memoFix'. +memoFix3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒ + ((a → b → c → v) → a → b → c → v) → a → b → c → v +memoFix3 ff = f where f = memoize3 (ff f) + +-- | Four argument version of 'memoFix'. +memoFix4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒ + ((a → b → c → d → v) → (a → b → c → d → v)) → + a → b → c → d → v +memoFix4 ff = f where f = memoize4 (ff f) + +-- | Five argument version of 'memoFix'. +memoFix5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e) ⇒ + ((a → b → c → d → e → v) → (a → b → c → d → e → v)) → + a → b → c → d → e → v +memoFix5 ff = f where f = memoize5 (ff f) + +-- | Six argument version of 'memoFix'. +memoFix6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e, Memoizable f) ⇒ + ((a → b → c → d → e → f → v) → (a → b → c → d → e → f → v)) → + a → b → c → d → e → f → v +memoFix6 ff = f where f = memoize6 (ff f) + +-- | Seven argument version of 'memoFix'. +memoFix7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d, + Memoizable e, Memoizable f, Memoizable g) ⇒ + ((a → b → c → d → e → f → g → v) → (a → b → c → d → e → f → g → v)) → + a → b → c → d → e → f → g → v +memoFix7 ff = f where f = memoize7 (ff f) + +-- | Give a one-argument function whose argument satisfies 'Show', +-- this memoizes the function such that the argument is shown (using +-- 'Debug.Trace.trace') only when the function has to be applied, as +-- opposed to when the answer is available in the memo cache. +traceMemoize ∷ (Memoizable a, Show a) ⇒ (a → b) → a → b +traceMemoize f = memoize (\a → traceShow a (f a)) + +--- +--- Derived instances +--- + +deriveMemoizable ''() +deriveMemoizable ''Bool +deriveMemoizable ''Ordering +deriveMemoizable ''Maybe +deriveMemoizable ''Either +deriveMemoizable ''[] + +deriveMemoizable ''(,) +deriveMemoizable ''(,,) +deriveMemoizable ''(,,,) +deriveMemoizable ''(,,,,) +deriveMemoizable ''(,,,,,) +deriveMemoizable ''(,,,,,,) +deriveMemoizable ''(,,,,,,,) +deriveMemoizable ''(,,,,,,,,) +deriveMemoizable ''(,,,,,,,,,) +deriveMemoizable ''(,,,,,,,,,,) +deriveMemoizable ''(,,,,,,,,,,,) + +--- +--- Binary-tree based memo caches +--- + +-- Used for both 'Integer' and arbitrary 'Int'-like types. + +data BinaryTreeCache v + = BinaryTreeCache { + btValue ∷ v, + btLeft, btRight ∷ BinaryTreeCache v + } + deriving Functor + +--- +--- 'Integer' memoization +--- + +instance Memoizable Integer where + memoize f = integerLookup (f <$> theIntegers) + +-- | An integer cache stores a value for 0 and separate caches for the +-- positive and negative integers. +data IntegerCache v + = IntegerCache { + icZero ∷ v, + icNegative, icPositive ∷ PosIntCache v + } + deriving Functor + +-- | A positive integer cache is represented as a little-ending bitwise +-- trie +type PosIntCache v = BinaryTreeCache v + +theIntegers ∷ IntegerCache Integer +theIntegers + = IntegerCache { + icZero = 0, + icNegative = negate <$> thePosInts, + icPositive = thePosInts + } + +thePosInts ∷ PosIntCache Integer +thePosInts = + BinaryTreeCache { + btValue = 1, + btLeft = fmap (* 2) thePosInts, + btRight = fmap (succ . (* 2)) thePosInts + } + +integerLookup ∷ IntegerCache v → Integer → v +integerLookup cache n = + case n `compare` 0 of + EQ → icZero cache + GT → posIntLookup (icPositive cache) n + LT → posIntLookup (icNegative cache) (negate n) + +-- PRECONDITION: @n@ is a positive 'Integer' +posIntLookup ∷ PosIntCache v → Integer → v +posIntLookup cache 1 = btValue cache +posIntLookup cache n + | even n = posIntLookup (btLeft cache) (n `div` 2) + | otherwise = posIntLookup (btRight cache) (n `div` 2) + +--- +--- Enumerable types using binary search trees +--- + +newtype Finite a = ToFinite { fromFinite ∷ a } + deriving (Eq, Bounded, Enum) + +instance (Bounded a, Enum a) ⇒ Memoizable (Finite a) where + memoize f = finiteLookup (f <$> theFinites) + +-- | For finite 'Int'-like types, we use a balanced binary search tree +-- indexed to every element from 'minBound' to 'maxBound' +theFinites ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache a +theFinites = loop minBound maxBound where + loop start stop = + BinaryTreeCache { + btValue = mean, + btLeft = loop start (pred mean), + btRight = loop (succ mean) stop + } + where mean = meanFinite start stop + +finiteLookup ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache v → a → v +finiteLookup cache0 a0 = + loop start0 stop0 cache0 where + start0 = fromEnum (minBound `asTypeOf` a0) + stop0 = fromEnum (maxBound `asTypeOf` a0) + a = fromEnum a0 + loop start stop cache = + let mean = meanFinite start stop in + case a `compare` mean of + EQ → btValue cache + LT → loop start (pred mean) (btLeft cache) + GT → loop (succ mean) stop (btRight cache) + +meanFinite ∷ (Bounded a, Enum a) ⇒ a → a → a +meanFinite a b = toEnum (ia `div` 2 + ib `div` 2 + + if odd ia && odd ib then 1 else 0) + where + ia = fromEnum a + ib = fromEnum b + +-- | Can be used to memoize over any "finite" type satisfying +-- 'Enum' and 'Bounded'. This builds a binary search tree, treating +-- the memoized type as isomorphic to a range of 'Int', so it will be +-- only as efficient as 'toEnum', 'fromEnum', 'succ', and 'pred'. +-- +-- This can be used to make instances for finite types. For example, the +-- instances for 'Int' and 'Char' are declared as: +-- +-- @ +-- instance Memoizable Int where memoize = memoizeFinite +-- instance Memoizable Char where memoize = memoizeFinite +-- @ +memoizeFinite ∷ (Enum a, Bounded a) ⇒ (a → v) → a → v +memoizeFinite f = memoize (f . fromFinite) . ToFinite + +instance Memoizable Int where memoize = memoizeFinite +instance Memoizable Char where memoize = memoizeFinite + +--- +--- Functions +--- + +instance (Eq a, Bounded a, Enum a, Memoizable b) ⇒ Memoizable (a → b) where + memoize = functionLookup . theFunctions + +functionLookup ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒ + FunctionCache b v → (a → b) → v +functionLookup cache f = + fcNil (foldl fcCons cache (f <$> [minBound .. maxBound])) + +theFunctions ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒ + ((a → b) → v) → FunctionCache b v +theFunctions f = + FunctionCache { + fcNil = f undefined, + fcCons = memoize (\b → theFunctions (f . extend b)) + } + where + extend b g a + | a == minBound = b + | otherwise = g (pred a) + +data FunctionCache b v + = FunctionCache { + fcNil ∷ v, + fcCons ∷ b → FunctionCache b v + } + +--- +--- Example functions +--- + +-- Memoize on 'Integer'. If memoization doesn't work, this will be +-- horribly slow. +_fib ∷ Integer → Integer +_fib = memoFix $ \fib n → case n of + 0 → 1 + 1 → 1 + _ → fib (n - 1) + fib (n - 2) + +-- Memoize on a function. The use of 'trace' will indicate when +-- the function is called to fill in the memo cache. +_isNot ∷ (Bool → Bool) → Bool +_isNot = memoize $ \f → + trace "_isNot" $ + f True == False && f False == True + +-- Memoize on a curried function! +_countTrue ∷ (Bool → Bool → Bool) → Integer +_countTrue = memoize $ \f → + trace "_countTrue" $ + toInteger (length (f <$> [False,True] <*> [False,True] >>= guard)) + diff --git a/src/Data/Function/Memoize/Class.hs b/src/Data/Function/Memoize/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function/Memoize/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE + UnicodeSyntax + #-} +{- | + The 'Memoizable' type class. +-} +module Data.Function.Memoize.Class ( + Memoizable(..) +) where + +-- | A memoization class. An instance @'Memoizable' T@ for some +-- type @T@ means that that 'memoize' method can memoize for +-- parameters of type @T@. +class Memoizable a where + memoize ∷ (a → v) → a → v diff --git a/src/Data/Function/Memoize/TH.hs b/src/Data/Function/Memoize/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function/Memoize/TH.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE + TemplateHaskell, + UnicodeSyntax, + CPP + #-} +{- | + Exports functions for deriving instances of 'Memoizable' using + Template Haskell. The @TemplateHaskell@ language extension must be + enabled to use the functions exported from this module. +-} +module Data.Function.Memoize.TH ( + deriveMemoizable, deriveMemoizableParams, deriveMemoize, +) where + +import Control.Applicative +import Control.Monad +import Language.Haskell.TH + +import Data.Function.Memoize.Class + +-- | +-- To derive 'Memoizable' instances for the given data types. +-- In the simplest usage, to derive 'Memoizable' for an algebraic +-- datatype named @T@, write: +-- +-- @ +-- deriveMemoizable ''T +-- @ +-- +-- This assumes that all the type parameters of @T@ that are not +-- annotated with a kind other than @*@ should be listed as requiring +-- 'Memoizable' instances in the instance context. For example, given +-- a data type declared as +-- +-- @ +-- data T a (b :: * -> *) c = ... +-- @ +-- +-- the generated instance will look like +-- +-- @ +-- instance ('Memoizable' a, 'Memoizable' c) => +-- 'Memoizable' (T a b c) where ... +-- @ +-- +-- For more precise control over the context, use +-- 'deriveMemoizableParams'. +-- +-- N.B.: The @TemplateHaskell@ language extension must be enabled to use +-- this function. +deriveMemoizable ∷ Name → Q [Dec] +deriveMemoizable n = deriveMemoizable' n Nothing + +-- | +-- Like 'deriveMemoizable' but takes a second argument, which is a list +-- of 'Int's to specify which type parameters of the type should be +-- mentioned in the context. For example, given the same definition for +-- @T@ as above, we can write +-- +-- @ +-- deriveMemoizableParams ''T [3] +-- @ +-- +-- to leave the first parameter of @T@ out of the context and show +-- only the third, yielding the instance +-- +-- @ +-- instance 'Memoizable' c => 'Memoizable' (T a b c) where ... +-- @ +-- +-- N.B.: The @TemplateHaskell@ language extension must be enabled to use +-- this function. +deriveMemoizableParams ∷ Name → [Int] → Q [Dec] +deriveMemoizableParams n indices = deriveMemoizable' n (Just indices) + +-- | In cases where neither 'deriveMemoizable' nor +-- 'deriveMemoizableParams' can figure out the right context for an +-- instance declaration, one can declare the instance manually and use +-- this function to derive the method body for 'memoize'. For example, +-- suppose that a data type @T@ is defined as: +-- +-- @ +-- data T a b = T (a -> Bool) b +-- @ +-- +-- For @T a b@ to be memoizable, @a -> Bool@ must be, and based on the +-- instance for '(->)', this means that @a@ must satisfy +-- 'Bounded' and 'Enum', so 'deriveMemoizable' cannot build the right +-- context for the 'Memoizable' instance. Instead, one can write: +-- +-- @ +-- instance ('Enum' a, 'Bounded' a, 'Memoizable' b) => +-- 'Memoizable' (T a b) where +-- memoize = $(deriveMemoize ''T) +-- @ +deriveMemoize ∷ Name → ExpQ +deriveMemoize name0 = do + (_, _, cons) ← checkName name0 + buildMethodExp cons + +-- | The main entry point delegates to check given type name, renames type +-- parameters, and generates the instance. +deriveMemoizable' ∷ Name → Maybe [Int] → Q [Dec] +deriveMemoizable' name0 mindices = do + (name, tvbs, cons) ← checkName name0 + let tvs = freshNames tvbs + inst ← instanceD + (buildContext mindices tvbs tvs) + (buildHead name tvs) + [buildMethodDec cons] + return [inst] + +-- | Given the type name for the requested instance, checks if it +-- corresponds to a @data@ or @newtype@, and if so, returns the name, +-- a list of its parameters, and a list of constructor names with +-- their arities. +checkName ∷ Name → Q (Name, [TyVarBndr], [(Name, Int)]) +checkName name0 = do + info ← reify name0 + case info of +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (DataD _ name tvbs _ cons _) +#else + TyConI (DataD _ name tvbs cons _) +#endif + → return (name, tvbs, stdizeCon <$> cons) +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (NewtypeD _ name tvbs _ con _) +#else + TyConI (NewtypeD _ name tvbs con _) +#endif + → return (name, tvbs, [stdizeCon con]) + _ → fail $ + "deriveMemoizable: Can't derive a Memoizable instance for `" ++ + show name0 ++ "' because it isn't a type constructor." + where + stdizeCon (NormalC name params) = (name, length params) + stdizeCon (RecC name fields) = (name, length fields) + stdizeCon (InfixC _ name _) = (name, 2) + stdizeCon (ForallC _ _ con) = stdizeCon con + +-- | Given a list, produces a list of nicely printable, distinct names. +-- Used so that instances print with nice parameters names, like +-- +-- @ +-- instance Memoizable (T a b c) where +-- @ +-- +-- instead of +-- +-- @ +-- instance Memoizable (T a[1] b[2] c32424534) where +-- @ +freshNames ∷ [a] → [Name] +freshNames xs = take (length xs) alphabet + where + alphabet = [ mkName (c:s) + | s ← "" : (show <$> [1 ∷ Integer ..]) + , c ← ['a' .. 'z'] ] + +-- | Build the type class instance context, give the necessary +-- information to select which parameters to include. If the first +-- argument is @Just ixs@, then there should be 'Memoizable' instances +-- for exactly those parameters, by index, in the context. Otherwise, +-- choose the parameters that have no explicit kind from the +-- list of binders. The third argument gives the actual type variable +-- names to use. +buildContext ∷ Maybe [Int] → [TyVarBndr] → [Name] → CxtQ +buildContext mindices tvbs tvs = + cxt (classP ''Memoizable . (:[]) . varT <$> cxttvs) + where + cxttvs = case mindices of + Just ixs → filterBy (`elem` ixs) [1 ..] tvs + Nothing → filterBy isStar tvbs tvs + -- + isStar (PlainTV _) = True +#if __GLASGOW_HASKELL__ >= 706 + isStar (KindedTV _ StarT) = True +#else + isStar (KindedTV _ StarK) = True +#endif + isStar (KindedTV _ _) = False + -- + filterBy ∷ (a → Bool) → [a] → [b] → [b] + filterBy p xs ys = snd <$> filter (p . fst) (zip xs ys) + +-- | Build the 'Memoizable' instance head for the given type name +-- and parameter type variables. +buildHead ∷ Name → [Name] → TypeQ +buildHead name tvs = + appT (conT ''Memoizable) (foldl appT (conT name) (varT <$> tvs)) + +-- | Build the 'memoize' method. The form of 'memoize' is always +-- +-- @ +-- memoize f = lookup where +-- cache1 = memoize $ \x1 -> ... memoize $ \x(a1) -> f (C1 x1 ...) +-- ... +-- cacheN = memoize $ \x1 -> ... memoize $ \x(aN) -> f (CN x1 ...) +-- lookup (C1 x1 ...) = cache1 x1 ... +-- ... +-- lookup (CN xN ...) = cacheN xN ... +-- @ +-- +-- where @C1@ ... @CN@ are the constructors of the data type and +-- @aj@ is the arity of constructor @Cj@. +-- +-- In this method, we allocate fresh names for the parameter @f@, the +-- lookup function, and the @N@ caches. We then delegate to build +-- the definitions of @look@ and the caches. +buildMethodDec ∷ [(Name, Int)] → DecQ +buildMethodDec cons = do + valD (varP 'memoize) + (normalB (buildMethodExp cons)) + [] + +-- | Build the body of the 'memoize' method, as described in the comment +-- above 'buildMethodDec' +buildMethodExp ∷ [(Name, Int)] → ExpQ +buildMethodExp cons = do + f ← newName "f" + look ← newName "look" + caches ← mapM (\ _ -> newName "cache") cons + lam1E (varP f) + (letE + (buildLookup look cons caches + : zipWith (buildCache f) cons caches) + (varE look)) + +-- | Build the look function by building a clause for each constructor +-- of the datatype. +buildLookup ∷ Name → [(Name, Int)] → [Name] → DecQ +buildLookup look cons caches = + funD look (zipWith buildLookupClause cons caches) + +-- | Build a lookup clause for one constructor. We lookup a value +-- by matching that constructor and then passing its parameters to +-- the cache for that constructor. +buildLookupClause ∷ (Name, Int) → Name → ClauseQ +buildLookupClause (con, arity) cache = do + params ← replicateM arity (newName "a") + clause [conP con (varP <$> params)] + (normalB (foldl appE (varE cache) (varE <$> params))) + [] + +-- | Build the definition of a cache for the given constructor. We do +-- this by binding the cache name to a cascading sequence of +-- memoizations for each component in the constructor's arity. +buildCache ∷ Name → (Name, Int) → Name → DecQ +buildCache f (con, arity) cache = + valD (varP cache) (normalB (composeMemos arity f (conE con))) [] + +-- | Given the remaining arity to memoize, the name of the function to +-- memoize, and the accumulated parameter so far, build the +-- memoization chain. +composeMemos ∷ Int → Name → ExpQ → ExpQ +composeMemos 0 f arg = [| $(varE f) $arg |] +composeMemos arity f arg = do + [| memoize $ \b -> $(composeMemos (arity - 1) f [| $arg b |]) |] + diff --git a/test/test1.hs b/test/test1.hs new file mode 100644 --- /dev/null +++ b/test/test1.hs @@ -0,0 +1,8 @@ +import Data.Function.Memoize +import Data.Function (fix) -- for comparison + +main = print $ + let fib :: Integer -> Integer + fib = memoFix $ \ f -> \ x -> if x < 2 then x else f (x-1) + f (x-2) + -- and it would take much longer with fib = fix $ \ f -> ... + in take 100 $ map fib [0..] diff --git a/test/test2.hs b/test/test2.hs new file mode 100644 --- /dev/null +++ b/test/test2.hs @@ -0,0 +1,17 @@ +{-# language TemplateHaskell #-} + +import Data.Function.Memoize +import Data.Function ( fix ) + +data List a = Nil | Cons a (List a) + +$(deriveMemoizable ''List) + +main = print $ + let lcs = memoFix2 -- exponential time if you put fix here + $ \ f -> \ a b -> case (a,b) of + (Cons x a', Cons y b') -> + maximum [ if x == y then 1 + f a' b' else 0, f a b', f a' b ] + _ -> 0 + a = iterate (Cons ()) Nil !! 20 + in lcs a a