alms 0.6.6 → 0.6.7
raw patch · 7 files changed
+144/−104 lines, 7 files
Files
- Makefile +1/−1
- alms.cabal +3/−2
- src/Main.hs +1/−1
- src/Util/Undo.hs +94/−0
- src/Util/UndoIO.hs +0/−77
- src/extensions.txt +1/−0
- util +44/−23
Makefile view
@@ -66,7 +66,7 @@ $(RM) html -VERSION = 0.6.6+VERSION = 0.6.7 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz
alms.cabal view
@@ -1,5 +1,5 @@ Name: alms-Version: 0.6.6+Version: 0.6.7 Copyright: 2012-2015, Jesse A. Tov Cabal-Version: >= 1.8 License: BSD3@@ -160,7 +160,7 @@ Util.Eq1 Util.MonadRef Util.Trace- Util.UndoIO+ Util.Undo Util.Viewable Util Value@@ -184,6 +184,7 @@ StandaloneDeriving TemplateHaskell TupleSections+ TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax
src/Main.hs view
@@ -8,7 +8,7 @@ import Util import Util.MonadRef-import Util.UndoIO+import Util.Undo (runUndoIO) import Syntax.ImplicitThreading import Syntax.Ppr (Doc, Ppr(..), (<+>), (<>), text, char, hang, printDoc, hPrintDoc)
+ src/Util/Undo.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE ConstraintKinds, TypeFamilies #-}+-- | An extension of the IO monad with an undo facility+module Util.Undo (+ -- * The 'UndoT' monad transformer and 'UndoIO' monad+ UndoT(..), UndoIO,+ -- ** Running+ runUndoT, runUndoT',+ runUndoIO, runUndoIO',+ -- ** Operation+ addUndo+) where++import Prelude+import Util.MonadRef+import Control.Applicative+import Control.Monad.Error+import Data.IORef++-- | A layer on top of the IO monad with an undo facility.+type UndoIO a = UndoT IORef IO a++newtype UndoT r m a+ = UndoT {+ unUndoT ∷ r [m ()] → m a+ }++instance Applicative m => Applicative (UndoT r m) where+ pure = UndoT . const . pure+ UndoT f <*> UndoT a = UndoT (liftA2 (<*>) f a)++instance Functor m => Functor (UndoT r m) where+ fmap f = UndoT . (fmap f .) . unUndoT++instance Monad m => Monad (UndoT r m) where+ return = lift . return+ m >>= k = UndoT $ \undo → do+ a ← unUndoT m undo+ unUndoT (k a) undo++instance MonadTrans (UndoT r) where+ lift = UndoT . const++instance MonadIO m => MonadIO (UndoT r m) where+ liftIO = lift . liftIO++-- | Run an 'UndoT' computation, running the undo list actions+-- if it raises an exception.+runUndoT ∷ (MonadError e m, MonadRef r m) => UndoT r m a → m a+runUndoT action = do+ undo ← newRef []+ unUndoT action undo `catchError` \e → do+ sequence_ =<< readRef undo+ throwError e++-- | Run an 'UndoT' computation, without checking for an escaping+-- exception.+runUndoT' ∷ MonadRef r m => UndoT r m a → m a+runUndoT' action = unUndoT action =<< newRef []++-- | Run an 'UndoIO' computation, running the undo list actions+-- if it raises an exception.+runUndoIO ∷ UndoIO a → IO a+runUndoIO = runUndoT++-- | Run an 'UndoT' computation, without checking for an escaping+-- exception.+runUndoIO' ∷ UndoIO a → IO a+runUndoIO' = runUndoT'++---+--- OPERATIONS+---++-- | Add an action to the front of the undo list+addUndo ∷ MonadRef r m => m () → UndoT r m ()+addUndo action = UndoT (modifyRef (action :))++instance MonadRef r m => MonadRef r (UndoT r m) where+ newRef = lift . newRef+ readRef = lift . readRef+ writeRef r a = modifyRef (const a) r+ modifyRef f r = UndoT $ \undo → do+ old ← readRef r+ writeRef r (f old)+ modifyRef (writeRef r old :) undo++instance (MonadError e m, MonadRef r m) => MonadError e (UndoT r m) where+ throwError = lift . throwError+ catchError action handler = UndoT $ \undo → do+ undo' ← newRef []+ unUndoT action undo' `catchError` \exn → do+ sequence_ =<< readRef undo'+ unUndoT (handler exn) undo+
− src/Util/UndoIO.hs
@@ -1,77 +0,0 @@--- | An extension of the IO monad with an undo facility-module Util.UndoIO (- -- * The 'UndoIO' monad- UndoIO(..),- -- ** Running- runUndoIO, runUndoIO',- -- ** Operation- addUndo-) where--import Prelude hiding (catch)-import Util.MonadRef-import Control.Applicative-import Control.Exception-import Control.Monad.Error-import Data.IORef---- | A layer on top of the IO monad with an undo facility.-newtype UndoIO a- = UndoIO {- unUndoIO ∷ IORef [IO ()] → IO a- }--instance Applicative UndoIO where- pure = return- (<*>) = ap--instance Functor UndoIO where- fmap = liftM--instance Monad UndoIO where- return = UndoIO . const . return- m >>= k = UndoIO $ \undo → do- a ← unUndoIO m undo- unUndoIO (k a) undo--instance MonadIO UndoIO where- liftIO = UndoIO . const---- | Run an 'UndoIO' computation, running the undo list actions--- if it raises an exception.-runUndoIO ∷ UndoIO a → IO a-runUndoIO action = do- undo ← newRef []- unUndoIO action undo `catch` \e → do- sequence_ =<< readRef undo- throwIO (e ∷ SomeException)---- | Run an 'UndoIO' computation, without checking for an escaping--- exception.-runUndoIO' ∷ UndoIO a → IO a-runUndoIO' action = unUndoIO action =<< newRef []--------- OPERATIONS-------- | Add an action to the front of the undo list-addUndo ∷ IO () → UndoIO ()-addUndo action = UndoIO (modifyRef (action :))--instance MonadRef IORef UndoIO where- newRef = UndoIO . const . newRef- readRef = UndoIO . const . readRef- writeRef r a = modifyRef (const a) r- modifyRef f r = UndoIO $ \undo → do- old ← readRef r- writeRef r (f old)- modifyRef (writeRef r old :) undo--instance MonadError SomeException UndoIO where- throwError = liftIO . throwIO- catchError action handler = UndoIO $ \undo → do- undo' ← newRef []- unUndoIO action undo' `catch` \exn → do- sequence_ =<< readRef undo'- unUndoIO (handler exn) undo
src/extensions.txt view
@@ -17,6 +17,7 @@ StandaloneDeriving TemplateHaskell TupleSections+TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax
util view
@@ -1,23 +1,34 @@ #!/bin/sh+# vim: sw=2 name=alms host=login.ccs.neu.edu remote=.www/pubs/$name+extensions=src/extensions.txt version="`awk '$0 ~ /^VERSION *= / { print $3 }' Makefile`" +assert_has_argument () {+ local argument expected+ argument="$1"; shift+ expected="$1"; shift+ if [ -z "$argument" ]; then+ echo "$0 $cmd: $expected expected\nUsage: $0 $cmd $@" >&2+ exit 1+ fi+}+ if [ -z "$1" ]; then set showVersion fi while [ -n "$1" ]; do- cmd="$1"- shift+ cmd="$1"; shift case "$cmd" in release)+ assert_has_argument "$1" 'version number' VERSION ver="$1"; shift- set version "$ver" ci "version bump: $ver" tagversion "$ver" \- clean dist send link $@+ set version "$ver" clean dist send link "$@" ;; hackage-check) cabal upload -c $name-$version.tar.gz@@ -26,7 +37,7 @@ cabal upload $name-$version.tar.gz ;; hackage)- set dist hackage-upload $@+ set dist hackage-upload "$@" ;; clean) rm $name*.tar.gz@@ -46,7 +57,16 @@ edit) ssh $host -t vim $remote/index.html ;;+ extensions)+ perl -pe 's/\n/ /; s/\b\w+\b/-X$&/' $extensions+ ;;+ ghci)+ ghci -isrc `$0 extensions` "$@"+ set --+ ;; mv)+ assert_has_argument "$1" 'source path' SRC DST+ assert_has_argument "$2" 'destination path' SRC DST src="$1"; shift dst="$1"; shift git mv "$src" "$dst" &&@@ -54,31 +74,32 @@ svn mv "$src" "$dst" ;; ci)+ git log svn-head..HEAD | svn ci -F -+ git tag -f svn-head+ ;;+ ci-m)+ assert_has_argument "$1" 'commit message' MESSAGE msg="$1"; shift git ca -m "$msg"- svn ci -m "$msg"+ set ci "$@" ;; add)- git add $@- svn add $@+ assert_has_argument "$1" 'something to add' PATH...+ git add "$@"+ svn add "$@" set -- ;;- tagversion)- gitversion="$1"- shift- git tag "$gitversion"- ;; version)- version="$1"- shift- if [ -n "$version" ]; then- ex -c "/^VERSION *=/s/=.*/= $version/|:wq" Makefile- make $name.cabal- $0 showVersion- else- echo "Need to specify a version" >&2- exit 1- fi+ assert_has_argument "$1" 'version number' VERSION+ version="$1"; shift+ git stash+ ex -c "/^VERSION *=/s/=.*/= $version/|:wq" Makefile+ make $name.cabal+ git add Makefile $name.cabal+ git commit -m "version bump: $version"+ git tag "$version"+ git stash apply+ set showVersion "$@" ;; showVersion) echo $version