diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -66,7 +66,7 @@ $(RM) html -VERSION = 0.6.6 +VERSION = 0.6.7 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz diff --git a/alms.cabal b/alms.cabal --- a/alms.cabal +++ b/alms.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Util/Undo.hs b/src/Util/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Util/Undo.hs @@ -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 + diff --git a/src/Util/UndoIO.hs b/src/Util/UndoIO.hs deleted file mode 100644 --- a/src/Util/UndoIO.hs +++ /dev/null @@ -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 diff --git a/src/extensions.txt b/src/extensions.txt --- a/src/extensions.txt +++ b/src/extensions.txt @@ -17,6 +17,7 @@ StandaloneDeriving TemplateHaskell TupleSections +TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax diff --git a/util b/util --- a/util +++ b/util @@ -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