summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--CacheArrow.cabal16
-rw-r--r--LICENSE26
-rw-r--r--Setup.lhs3
-rw-r--r--src/Control/CacheArrow.hs48
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
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c7a0aa4
--- /dev/null
+++ b/LICENSE
@@ -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))