diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | CacheArrow.cabal | 16 | ||||
| -rw-r--r-- | LICENSE | 26 | ||||
| -rw-r--r-- | Setup.lhs | 3 | ||||
| -rw-r--r-- | src/Control/CacheArrow.hs | 48 |
5 files changed, 95 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..733412c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +dist diff --git a/CacheArrow.cabal b/CacheArrow.cabal new file mode 100644 index 0000000..4401e9d --- /dev/null +++ b/CacheArrow.cabal @@ -0,0 +1,16 @@ +name: CacheArrow +version: 0.1 +synopsis: Caching arrow +description: Arrow transformer that adds caching to an arrow +category: Control, Data +license: BSD3 +license-file: LICENSE +author: Matthias Schiffer +maintainer: mschiffer@universe-factory.net +build-type: Simple +Cabal-Version: >=1.2 + +library + build-depends: base >= 4, arrows + exposed-modules: Control.CacheArrow + hs-source-dirs: src @@ -0,0 +1,26 @@ +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Control/CacheArrow.hs b/src/Control/CacheArrow.hs new file mode 100644 index 0000000..d701986 --- /dev/null +++ b/src/Control/CacheArrow.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, MultiParamTypeClasses, Arrows #-} + +module Control.CacheArrow ( CacheArrow + , runCache' + , runCache + ) where + +import Prelude hiding ((.), id) +import Control.Arrow +import Control.Arrow.Transformer +import Control.Category + + +data CacheArrow a b c = CacheArrow (Maybe (b, c)) (a b c) + +instance Arrow a => Category (CacheArrow a) where + (CacheArrow _ g) . (CacheArrow _ f) = CacheArrow Nothing (g . f) + + id = arr id + +instance Arrow a => Arrow (CacheArrow a) where + arr = lift . arr + first (CacheArrow _ f) = lift . first $ f + second (CacheArrow _ f) = lift . second $ f + +instance ArrowChoice a => ArrowChoice (CacheArrow a) where + left (CacheArrow _ f) = lift . left $ f + right (CacheArrow _ f) = lift . right $ f + +instance Arrow a => ArrowTransformer CacheArrow a where + lift = CacheArrow Nothing + + +runCacheAlways :: (ArrowChoice a, Eq b) => CacheArrow a b c -> a b (c, CacheArrow a b c) +runCacheAlways (CacheArrow _ f) = proc b -> do + c <- f -< b + returnA -< (c, CacheArrow (Just (b, c)) f) + +runCache' :: (ArrowChoice a, Eq b) => CacheArrow a b c -> a b (c, Bool, CacheArrow a b c) +runCache' a@(CacheArrow cache _) = proc b -> + case cache of + (Just (b', c')) | b == b' -> returnA -< (c', False, a) + _ -> do + (c, cache') <- runCacheAlways a -< b + returnA -< (c, True, cache') + +runCache :: (ArrowChoice a, Eq b) => CacheArrow a b c -> a b (c, CacheArrow a b c) +runCache a = runCache' a >>^ (\(c, _, cache) -> (c, cache)) |