Adaptive-Blaisorblade (empty) → 0.23
raw patch · 12 files changed
+860/−0 lines, 12 filesdep +basesetup-changed
Dependencies added: base
Files
- Adaptive-Blaisorblade.cabal +31/−0
- ChangeLog +17/−0
- Control/Monad/Adaptive.hs +212/−0
- Control/Monad/Adaptive/CircularList.hs +72/−0
- Control/Monad/Adaptive/MonadUtil.hs +10/−0
- Control/Monad/Adaptive/OrderedList.hs +233/−0
- Control/Monad/Adaptive/PriorityQueue.hs +41/−0
- Control/Monad/Adaptive/Ref.hs +33/−0
- LICENSE +29/−0
- README +54/−0
- Setup.lhs +4/−0
- spreadsheet.hs +124/−0
+ Adaptive-Blaisorblade.cabal view
@@ -0,0 +1,31 @@+Name: Adaptive-Blaisorblade+Version: 0.23+Synopsis: Library for incremental computing.+Description: This is a Haskell (plus some extensions) implementation + of a library for incremental computing. It closely + follows the implementation in the nice POPL 2002 paper + "Adaptive Functional Programming", by Umut Acar, + Guy Blelloch and Bob Harper.+ This is a small fork of the original library named+ "Adaptive", with the same interface but small adaptations+ to GHC 7.4.+License: BSD3+License-file: LICENSE+Author: Magnus Carlsson+Maintainer: none+data-files: ChangeLog, README+build-type: Simple+Cabal-version: >= 1.6+Category: Control++Library+ Build-Depends: base >= 4.5 && < 5+ Exposed-modules: Control.Monad.Adaptive, Control.Monad.Adaptive.Ref,Control.Monad.Adaptive.PriorityQueue, Control.Monad.Adaptive.OrderedList, Control.Monad.Adaptive.CircularList, Control.Monad.Adaptive.MonadUtil++--category: +Executable spreadsheet+ Main-is: spreadsheet.hs++source-repository head+ type: git+ location: git://github.com/Blaisorblade/Haskell-Adaptive.git
+ ChangeLog view
@@ -0,0 +1,17 @@+2013-01-26 <p.giarrusso@gmail.com>++ * Version 0.23, adapted for ghc 7.4.+ * Updated Cabal file with extra metadata.++2008-07-14 <pj@csee.ltu.se>++ * Version 0.22, adapted for Hugs 20060908 and ghc 6.8.2.++2005-07-09 <magnus@cse.ogi.edu>++ * Version 0.21, adapted for Hugs 20050308 and ghc 6.4, by+ Andrew Pimlott <andrew@pimlott.net>.++2002-03-18 <magnus@cse.ogi.edu>++ * Version 0.2, public release.
+ Control/Monad/Adaptive.hs view
@@ -0,0 +1,212 @@+-- -*- haskell-hugs-program-args: ("+." "-98") -*-+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- An monadic variant of the library from "Adaptive Functional+-- Programming", by Acar, Blelloch and Harper (POPL 2002).++-- Magnus Carlsson, magnus@cse.ogi.edu++module Control.Monad.Adaptive+ ( Adaptive+ , Changeable+ , Modifiable+ , readMod+ , InM(..)+ , change+ , propagate+ , run+ , inCh+ , NewMod(..)+ , newMod++ ) where++import Prelude +import Control.Monad(ap,unless)+import Control.Monad.Adaptive.MonadUtil+import Control.Monad.Adaptive.Ref+import qualified Control.Monad.Adaptive.OrderedList as OL+import Control.Monad.Adaptive.OrderedList(OrderedList)+import qualified Control.Monad.Adaptive.PriorityQueue as PQ+import Control.Monad.Adaptive.PriorityQueue(PriorityQueue)++-- Export:+class InM m' where+ inM :: Ref m r => m a -> m' m r a++class (Monad (n m r), Ref m r) => NewMod n m r where+ newModBy :: (a -> a -> Bool) -> Changeable m r a -> n m r (Modifiable m r a)+++newMod :: (Eq a, NewMod n m r) => + Changeable m r a -> n m r (Modifiable m r a)+change :: Ref m r => Modifiable m r a -> a -> Adaptive m r ()+propagate :: Ref m r => Adaptive m r ()+readMod :: Ref m r => Modifiable m r a -> Changeable m r a+run :: Ref m r => Adaptive m r a -> m a+inCh :: Ref m r => Changeable m r a -> Adaptive m r a++-- Local:++type ReComp m r = (Adaptive m r (), TimeStamp m r, TimeStamp m r)+startTime (_,s,_) = s++type TimeStamp m r = OL.Record m r ()++newtype Adaptive m r a = + Ad ((r (PriorityQueue (ReComp m r)), r (TimeStamp m r)) -> + OrderedList m r () a)++newtype Changeable m r a = Ch (K (Adaptive m r ()) a)+type K b a = (a -> b) -> b++newtype Modifiable m r a = Mo (r a, r (a -> Adaptive m r ()), r [ReComp m r])++cont :: Ref m r => + ((a -> Adaptive m r ()) -> Adaptive m r ()) -> Changeable m r a+cont m = Ch m++deCh (Ch m) = m+deAd (Ad m) = m++inAd :: Ref m r => Adaptive m r a -> Changeable m r a+inAd m = Ch $ (m >>=)++class InOL m' where+ inOL :: Ref m r => OrderedList m r () b -> m' m r b++instance InOL Adaptive where+ inOL m = Ad $ const m++instance InOL Changeable where+ inOL m = inAd (inOL m)++instance Ref m r => Ref (Changeable m r) r where+ newRef v = inM $ newRef v+ readRef x = inM $ readRef x+ writeRef x v = inM $ writeRef x v++instance Ref m r => Monad (Changeable m r) where+ return a = Ch $ \k -> k a+ Ch m >>= f = Ch $ \k -> m $ \a -> deCh (f a) k++instance Ref m r => Functor (Changeable m r) where+ fmap f m = m >>= return . f++instance Ref m r => Ref (Adaptive m r) r where+ newRef v = inM $ newRef v+ readRef x = inM $ readRef x+ writeRef x v = inM $ writeRef x v++instance Ref m r => Monad (Adaptive m r) where+ return a = Ad $ \e -> return a+ Ad m >>= f = Ad $ \e -> m e >>= \a -> deAd (f a) e++instance Ref m r => Functor (Adaptive m r) where+ fmap f m = m >>= return . f++readMod (Mo (r,chg,es)) = do+ start <- inAd stepTime+ cont $ \k -> do+ let reader = do readRef r >>= k+ now <- readCurrentTime+ mapRef ((reader,start,now):) es+ reader++pqRef :: Ref m r => Adaptive m r (r (PriorityQueue (ReComp m r)))+pqRef = Ad $ \ (pq,ct) -> return pq++readPq :: Ref m r => Adaptive m r (PriorityQueue (ReComp m r))+readPq = pqRef >>= readRef+writePq a = pqRef >>= flip writeRef a++ctRef :: Ref m r => Adaptive m r (r (TimeStamp m r))+ctRef = Ad $ \ (pq,ct) -> return ct+readCurrentTime :: Ref m r => Adaptive m r (TimeStamp m r)+readCurrentTime = ctRef >>= readRef+writeCurrentTime a = ctRef >>= flip writeRef a++stepTime :: Ref m r => Adaptive m r (TimeStamp m r)+stepTime = do+ readCurrentTime >>= inOL . flip OL.insert () >>= writeCurrentTime+ readCurrentTime++instance InM Changeable where+ inM m = Ch $ (inM m >>=)++instance InM Adaptive where+ inM m = Ad $ const (OL.inM m)++change (Mo (r,changeR,es)) a = do+ chg <- readRef changeR+ chg a++propagate = do+ let prop = do+ pq <- readPq+ case PQ.min pq of+ Nothing -> return ()+ Just ((reader,start,stop),pq') -> do+ writePq pq'+ unlessM (inOL (OL.deleted start)) $ do+ inOL (OL.spliceOut start stop)+ writeCurrentTime start+ reader+ prop+ now <- readCurrentTime+ prop+ writeCurrentTime now+++run m = OL.run $ do + pq <- newRef PQ.empty+ ct <- OL.base >>= newRef+ deAd m (pq,ct)++inCh (Ch m) = do+ x <- newRef (error "inCh")+ m (writeRef x)+ readRef x++instance EqRef r => Eq (Modifiable m r a) where+ (Mo (r1,_,_)) == (Mo (r2,_,_)) = eqRef r1 r2++newMod = newModBy (==)++instance Ref m r => NewMod Changeable m r where+ newModBy c ch = inAd $ newModBy c ch++insertPQ :: Ref m r => + r [ReComp m r] -> Adaptive m r ()+insertPQ esR = do+ es <- readRef esR+ pqR <- pqRef+ readRef pqR >>= ins es >>= writeRef pqR+ where+ ins [] pq = return pq+ ins (e:es) pq = PQ.insertM (\x y -> inOL $ + OL.order (startTime x) (startTime y))+ e pq >>= ins es++instance Ref m r => NewMod Adaptive m r where+ newModBy cmp c = do+ m <- newRef (error "newMod")+ changeR <- newRef (error "changeR")+ es <- newRef []+ let writeFirst v = do+ writeRef m v+ now <- stepTime+ writeRef changeR (writeAgain now)+ writeAgain t v = do+ v' <- readRef m+ unless (cmp v' v) $ do+ writeRef m v+ insertPQ es+ writeRef es []+ writeCurrentTime t+ writeRef changeR writeFirst+ inCh $ do+ v <- c+ write <- readRef changeR+ inAd $ write v+ return (Mo (m, changeR, es))
+ Control/Monad/Adaptive/CircularList.hs view
@@ -0,0 +1,72 @@+-- -*- haskell-hugs-program-args: ("+." "-98") -*-++-- A monad of mutable circular lists.++module Control.Monad.Adaptive.CircularList(+ CircularList,+ circularList,+ val,+ update,+ next,+ previous,+ insert,+ delete) where++import Control.Monad.Adaptive.Ref++-- Export:+circularList :: Ref m r => a -> m (CircularList m r a)+val :: Ref m r => CircularList m r a -> m a+next :: Ref m r => CircularList m r a -> m (CircularList m r a)+update :: Ref m r => CircularList m r a -> a -> m ()+previous :: Ref m r => CircularList m r a -> m (CircularList m r a)+insert :: Ref m r => CircularList m r a -> a -> m (CircularList m r a)+delete :: Ref m r => CircularList m r a -> m ()++-- Local:++data CircularList m r a = CL (r (CircularList m r a,a,CircularList m r a))+ | DummyCL (m a)++deCL (CL l) = l++circularList a = do+ r <- newRef undefined+ let l = CL r+ writeRef r (l,a,l)+ return l++get :: Ref m r => CircularList m r a -> + m (CircularList m r a, a,CircularList m r a)+get = readRef . deCL++set :: Ref m r => CircularList m r a -> + (CircularList m r a, a,CircularList m r a) -> m ()+set = writeRef . deCL++update l a = do+ (p,_,n) <- get l+ set l (p,a,n)++val l = (\ (p,a,n) -> a) `fmap` get l++next l = (\ (p,a,n) -> n) `fmap` get l++previous l = (\ (p,a,n) -> p) `fmap` get l++insert l a = do+ (p,b,n) <- get l+ n' <- CL `fmap` newRef (l,a,n)+ set l (p,b,n')+ nl <- next n'+ (_,nb,nn) <- get nl+ set nl (n',nb,nn)+ return n'+++delete l = do+ (p,_,n) <- get l+ (pp,a,_) <- get p+ set p (pp,a,n)+ (_,a',nn) <- get n+ set n (p,a',nn)
+ Control/Monad/Adaptive/MonadUtil.hs view
@@ -0,0 +1,10 @@+module Control.Monad.Adaptive.MonadUtil where++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b a c = do b' <- b; if b' then a else c++whenM :: Monad m => m Bool -> m () -> m ()+whenM b a = ifM b a (return ())++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM b a = ifM b (return ()) a
+ Control/Monad/Adaptive/OrderedList.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- A monad for manipulating ordered lists. Follows the implementation+-- given in the appendix of O'Neill's and Burton's JFP paper, but+-- doesn't impose any fixed limit of the number of elements.++-- References:++-- Dietz and Sleator: "Two algorithms for maintaining order in a+-- list", in Proc. of 19th ACM Symposium of Theory of Computing, 1987.++-- O'Neill and Burton: "A New Method For Functional Arrays", Journal+-- of Functional Programming, vol7, no 5, September 1997.++module Control.Monad.Adaptive.OrderedList(+ Record,+ OrderedList,+ rval,+ next,+ order,+ delete,+ spliceOut,+ deleted,+ insert,+ base,+ run,+ inM,+ record+ ) where++import Control.Monad(ap,unless)+import Control.Monad.Adaptive.MonadUtil+import Control.Monad.Adaptive.Ref+import Control.Monad.Adaptive.CircularList hiding (delete,insert,next,update)+import qualified Control.Monad.Adaptive.CircularList as CircularList++import System.IO.Unsafe(unsafePerformIO) -- for diagnostic++-- Export:+insert :: Ref m r => Record m r a -> a -> OrderedList m r a (Record m r a)+next :: Ref m r => Record m r a -> OrderedList m r a (Record m r a)+delete :: Ref m r => Record m r a -> OrderedList m r a ()+spliceOut :: Ref m r => Record m r a -> Record m r a -> OrderedList m r a ()+deleted :: Ref m r => Record m r a -> OrderedList m r a Bool+order :: Ref m r => Record m r a -> Record m r a -> + OrderedList m r a Ordering+rval :: Ref m r => Record m r a -> OrderedList m r a a+run :: Ref m r => OrderedList m r a b -> m b+inM :: Ref m r => m b -> OrderedList m r a b+base :: Ref m r => OrderedList m r a (Record m r a)+++-- Local:++newtype Record m r a = Record (CircularList m r (Bool,Integer,a))+deR (Record r) = r++data OrderedList m r a b = OL ((r Integer,r Integer,Record m r a) -> m b)+deOL (OL f) = f++run l = do+ base <- Record `fmap` circularList (False,0,undefined)+ s <- newRef 0+ mr <- newRef m+ deOL l (mr,s,base)+ where + m = 2^16++inM m = OL $ \e -> m++instance Ref m r => Monad (OrderedList m r a) where+ return a = inM (return a)+ (OL m) >>= f = OL $ \e -> m e >>= \a -> deOL (f a) e++instance Ref m r => Functor (OrderedList m r a) where + fmap f m = m >>= return . f++instance Ref m r => Ref (OrderedList m r a) r where+ newRef v = inM (newRef v)+ readRef r = inM (readRef r)+ writeRef r v = inM (writeRef r v)++mop a o b = op2 o a b+op2 f a b = op1 f a `ap` b+op1 f a = return f `ap` a++instance Eq (OrderedList m r a b) where { }+instance Show (OrderedList m r a b) where { }++instance (Ref m r, Num b) => Num (OrderedList m r a b) where+ (+) = op2 (+)+ (-) = op2 (-)+ (*) = op2 (*)+ negate = op1 negate+ abs = op1 abs+ signum = op1 signum+ fromInteger = return . fromInteger+-- fromInt = return . fromInt++instance Ord (OrderedList m r a b) where { }+instance (Ref m r, Real b) => Real (OrderedList m r a b) where { }+instance Enum (OrderedList m r a b) where { }++instance (Ref m r, Integral b) => Integral (OrderedList m r a b) where+ rem = op2 rem+ div = op2 div+ mod = op2 mod++base = OL $ \(m,n,b) -> return b++bigM :: Ref m r => OrderedList m r a Integer+bigM = OL $ \(m,n,b) -> readRef m++size :: Ref m r => OrderedList m r a Integer+size = OL $ \(m,n,b) -> readRef n++adjsize :: Ref m r => Integer -> OrderedList m r a ()+adjsize i = OL $ \(m,n,b) -> do s <- readRef n+ writeRef n (s+i)++setSize :: Ref m r => Integer -> OrderedList m r a ()+setSize n' = OL $ \(m,n,b) -> writeRef n n'++record :: Ref m r => Record m r a -> OrderedList m r a (Bool,Integer,a)+record r = inM (val (deR r))++rval r = (\ (d,i,a) -> a) `fmap` record r++next r = Record `fmap` inM (CircularList.next (deR r))++s x = next x++-- label+l :: Ref m r => Record m r a -> OrderedList m r a Integer+l r = (\ (d,i,a) -> i) `fmap` record r++-- gap+g e f = (l f - l e) `mod` bigM++deleted r = (\ (d,i,a) -> d) `fmap` record r++lbase :: Ref m r => OrderedList m r a Integer+lbase = base >>= l++gstar :: Ref m r => Record m r a -> Record m r a -> OrderedList m r a Integer+gstar e f = ifM (mop (l e) (==) (l f))+ bigM+ (g e f)++order x y = do b <- base+ return (compare) `ap` g b x `ap` g b y++++update :: Ref m r => ((Bool,Integer)->(Bool,Integer)) -> + Record m r a -> OrderedList m r a ()+update f r = do+ (d,i,a) <- record r+ let (d',i') = f (d,i)+ inM (CircularList.update (deR r) (d',i',a))+ +delete r = unlessM (deleted r) $ do+ ifM (mop lbase (==) (l r))+ (error "OrderedList.delete on base element")+ (do inM (CircularList.delete (deR r))+ update (\ (_,i) -> (True,i)) r+ adjsize (-1)+ checkinvariant)++spliceOut r s = next r >>= spl where+ spl r = do + unlessM (mop lbase (==) (l r)) $+ whenM ((==LT) `fmap` order r s)+ (do r' <- next r+ delete r+ spl r')++increaseBigM :: Ref m r => OrderedList m r a ()+increaseBigM = do OL $ \(m,n,b) -> mapRef (*2) m++insert r a = do+ ifM (deleted r) + (error "insert: deleted") $ do+ whenM (mop bigM (<=) (4*(size+1)*(size+1)))+ increaseBigM+ r' <- s r+ d <- gstar r r'+ unless (d > 1)+ (renumber r)+ li <- (l r + (gstar r r' `div` 2)) `mod` bigM+ inM (CircularList.insert (deR r) (False,li,a))+ adjsize 1+ checkinvariant+ next r++renumber :: Ref m r => Record m r a -> OrderedList m r a ()+renumber e = do+ let getj j e0 ej = do+ ifM (mop (g e0 ej) (>) (return (j * j)))+ (return (j,ej)) $ do+ ej' <- s ej+ ifM (mop (l ej') (==) (l e))+ (return (j,ej)) $ do+ getj (j+1) e0 ej'+ (j,sje) <- s e >>= getj 1 e+ d <- gstar e sje+ le <- l e+ m <- bigM+ let ren k ek | k == j = return ()+ | otherwise = do+ update (const (False,(le + ((k * d) `div` j)) `mod` m)) ek+ s ek >>= ren (k+1)+ s e >>= ren 1++checkinvariant :: Ref m r => OrderedList m r a ()+checkinvariant = return () -- prall >> base >>= inv+ where inv r = do+ r' <- s r+ unlessM (mop lbase (==) (l r')) $ do+ ifM (mop (order r r') (==) (return LT))+ (inv r')+ (error "invariant")+++prall :: Ref m r => OrderedList m r a ()+prall = uprint "prall:" >> base >>= pr where+ pr r = do+ x <- l r+ uprint (show x)+ r' <- s r+ unlessM (mop (base >>= order r') (==) (return EQ))+ (pr r')++uprint s = OL$ (\s' -> unsafePerformIO (putStrLn s) `seq` return ())
+ Control/Monad/Adaptive/PriorityQueue.hs view
@@ -0,0 +1,41 @@++-- A naive priority queue implementation, with an insert operation+-- that uses a monadic comparison operation.++module Control.Monad.Adaptive.PriorityQueue(+ PriorityQueue,+ empty,+ insert,+ insertM,+ min+ ) where++import Prelude hiding(min)++import qualified Data.List(insert)+import Control.Monad(ap)++-- Export:+empty :: PriorityQueue a+insert :: Ord a => a -> PriorityQueue a -> PriorityQueue a+insertM :: Monad m => + (a -> a -> m Ordering) -> a -> PriorityQueue a -> m (PriorityQueue a)+min :: PriorityQueue a -> Maybe (a, PriorityQueue a)++-- Local++newtype PriorityQueue a = PQ [a]++empty = PQ []++insert a (PQ l) = PQ (Data.List.insert a l)+++insertM cmp a (PQ l) = return PQ `ap` ins l+ where ins [] = return [a]+ ins (b:l) = do o <- cmp a b+ case o of LT -> return (a:b:l)+ _ -> return (b:) `ap` ins l++min (PQ []) = Nothing+min (PQ (x:xs)) = Just (x,PQ xs)
+ Control/Monad/Adaptive/Ref.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+-- A class for monads with mutable references++module Control.Monad.Adaptive.Ref where++import Control.Monad.ST+import Data.IORef+import Data.STRef++class EqRef r where+ eqRef :: r a -> r a -> Bool++class (EqRef r, Functor m, Monad m) => Ref m r | m -> r where+ newRef :: a -> m (r a)+ readRef :: r a -> m a+ writeRef :: r a -> a -> m ()++instance EqRef (STRef s) where eqRef = (==)++instance Ref (ST s) (STRef s) where+ newRef = newSTRef+ readRef = readSTRef+ writeRef = writeSTRef++instance EqRef IORef where eqRef = (==)++instance Ref IO IORef where+ newRef = newIORef+ readRef = readIORef+ writeRef = writeIORef++mapRef :: Ref m r => (a -> a) -> r a -> m ()+mapRef f r = readRef r >>= writeRef r . f
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright 2002-2008 Magnus Carlsson <magnus@galois.com>+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 author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ README view
@@ -0,0 +1,54 @@+Adaptive version 0.23 2013-01-26+================================++This is a minor update to Adaptive version 0.22 to make it work with+recent versions of GHC. Any problems with the result is my fault.++Paolo G. Giarrusso, p.giarrusso@gmail.com++Adaptive version 0.22 2008-07-14+================================++This is a minor update to Adaptive version 0.21 to make it work with+recent versions of GHC and Hugs. Adaptive is now cabalized, and any+problems with the packaging is my fault, not Magnus.++Peter A. Jonsson, pj@csee.ltu.se+++Adaptive version 0.21 2005-07-09+=================================++This is a Haskell (plus some extensions) implementation of a library+for incremental computing. It closely follows the implementation in+the nice POPL 2002 paper "Adaptive Functional Programming", by Umut+Acar, Guy Blelloch and Bob Harper. As of writing, their paper can be+found at++ http://ttic.uchicago.edu/~umut/papers/popl02.html++However, this Haskell library provides a monadic interface, which+doesn't need the "write" operation or the "destination" type. In+addition, the monadic types enforce correct usage, which means that a+modifiable variable must be defined before it can be used. This is+achieved within Haskell's type system plus some popular extensions+(multi-parameter classes and functional dependencies).++The library is parameterised over any monad that has references (such+as IO and ST). This means that it should be possible to put it on top+of e.g. many GUI monads too.++There is a small demo program of a classical incremental computation+problem: a spreadsheet. Try it by typing++ runhugs -98 spreadsheet.hs++and type, say ++ c0 <Return> Cell c1 <Return> c1 <Return> Const 42 <Return>.++This has been tested with the Hugs September 2006 version.++Feedback is welcome!++Magnus Carlsson, magnus@galois.com
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ spreadsheet.hs view
@@ -0,0 +1,124 @@+-- -*- haskell-hugs-program-args: ("+." "-98") -*-+{-# LANGUAGE FlexibleContexts #-}++-- A demo program of the Adaptive library, implementing a simple+-- spreadsheet. Requires a VT100-like terminal to work. Expressions+-- have to be entered according to the Expr datatype.++-- Magnus Carlsson, magnus@cse.ogi.edu++import Control.Monad.Adaptive+import Data.Char+import Control.Monad.Adaptive.Ref+import Control.Monad(ap,when)+import Data.IORef(IORef)+import System.Exit++type InIO m a = m IO IORef a+type IOMod a = InIO Modifiable a++data CellRef = CR String (IOMod Integer) deriving Eq+instance Show CellRef where show (CR s _) = s++data Expr c = Const Integer | Add (Expr c) (Expr c) | Cell c+ deriving (Eq,Read,Show)++eval :: Expr CellRef -> InIO Changeable Integer+eval (Const i) = return i+eval (Add e1 e2) = return (+) `ap` eval e1 `ap` eval e2+eval (Cell (CR _ n)) = readMod n++memo ma = readMod =<< newMod ma++instance Eq (a -> b) where a == b = False++ap' mf ma = do+ m <- newMod mf+ a <- memo ma+ f <- readMod m+ return (f a)++newCell :: NewMod m IO IORef => + String -> InIO m (IOMod (Expr CellRef), CellRef)+newCell s = do+ c <- newMod (return (Const 0))+ v <- newMod $ readMod c >>= eval+ return (c,CR s v)++newCell' n = do+ let s = "c" ++ show n+ inM $ prAt (n+2) 0 3 (s++": ")+ a@(c,CR s v) <- newCell s+ newMod $ readMod v >>= inM . prAt (n+2) 5 10 . show+ newMod $ readMod c >>= inM . prAt (n+2) 15 40 . show+ return (s,a)++prAt l c w s = putStr (pos l c ++ replicate w ' ' ++ pos l c++s)+esc = ("\ESC["++)+pos l c = esc (show l++";"++show c++"H")+clear = pos 0 0 ++ esc "J"+cleareol = esc "K"++readPrompt c s = do prAt 20 c 0 (s++"> "++ cleareol)+ s <- getLine+ when (s == "quit") $ exitWith ExitSuccess+ return s++msg s = prAt 19 0 0 (s ++ cleareol)++prompt env = inM p where+ p = do s <- readPrompt 0 "Cell"+ case lookup s env of+ Nothing -> do msg ("Cell " ++ show s ++ " not found")+ p+ Just (c,v) -> do let r = do s <- readPrompt 10 "Expr"+ case reads s of + [(e,"")] -> msg "" >> return (c,e)+ _ -> do msg "Syntax error"+ r+ r++data CellName = CN String+instance Read CellName where readsPrec _ s = [(CN $ takeWhile isAlphaNum s',+ dropWhile isAlphaNum s')]+ where s' = dropWhile isSpace s++instance Show CellName where show (CN s) = s++subst m env (Const i) = Const i+subst m env (Add e1 e2) = Add (subst m env e1) (subst m env e2)+subst m env (Cell (CN s)) = Cell $ case lookup s env of+ Nothing -> m+ Just (c,v) -> v++main :: IO ()+main = run $ do+ inM $ putStr clear+ env <- mapM newCell' [0..9]+ m0 <- CR "?" `fmap` newMod (return 0)+ let loop = do (c,e) <- prompt env+ let e' = subst m0 env e+ change c e'+ propagate+ loop+ loop++-- small non-interactive example++newCellPr s = do+ a@(c,CR s v) <- newCell s+ newMod $ do e <- readMod c+ x <- readMod v+ inM $ putStrLn (s++" = "++show e ++ " = " ++ show x)+ return a++test = run $ do+ [(c1,v1),(c2,v2)] <- mapM newCellPr ["c1","c2"]+ change c1 (Const 10)+ change c2 (Add (Cell v1) (Const 5))+ inM (putStrLn "Propagate") >> propagate+ change c1 (Add (Cell v2) (Const 4))+ change c2 (Const 1)+ inM (putStrLn "Propagate") >> propagate+ change c2 (Const 2)+ inM (putStrLn "Propagate") >> propagate