memoize 0.7 → 0.8

raw patch · 9 files changed

+645/−599 lines, 9 filesdep +memoizedep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: memoize

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• Data/Function/Memoize.hs +0/−329
• Data/Function/Memoize/Class.hs +0/−15
• Data/Function/Memoize/TH.hs +0/−252
• memoize.cabal +16/−3
• src/Data/Function/Memoize.hs +329/−0
• src/Data/Function/Memoize/Class.hs +15/−0
• src/Data/Function/Memoize/TH.hs +260/−0
• test/test1.hs +8/−0
• test/test2.hs +17/−0

@@ -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))-

@@ -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

@@ -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 |]) |]-

@@ -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

@@ -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))+

@@ -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

@@ -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 |]) |]+

@@ -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..]

@@ -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