From 26c51b9e152bce3a3ceea99763b0f7eb1e589720 Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <mschiffer@universe-factory.net>
Date: Fri, 19 Aug 2011 19:56:36 +0200
Subject: Initial implementation

---
 .gitignore                |  2 ++
 CacheArrow.cabal          | 16 ++++++++++++++++
 LICENSE                   | 26 +++++++++++++++++++++++++
 Setup.lhs                 |  3 +++
 src/Control/CacheArrow.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 95 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 CacheArrow.cabal
 create mode 100644 LICENSE
 create mode 100644 Setup.lhs
 create mode 100644 src/Control/CacheArrow.hs

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))
-- 
cgit v1.2.3