packages feed

uni-util (empty) → 2.2.0.0

raw patch · 60 files changed

+10948/−0 lines, 60 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, directory, ghc-prim, mtl, network, old-time, parsec

Files

+ LICENSE view
@@ -0,0 +1,123 @@+License Agreement++Preamble++The aim of this licence agreement is to enable the free use of the+software that is described in the sequel by anyone. In order to+guarantee this, it is necessary to set up rules for the use of the+software that hold for any user.++Provider of this licence is the University of Bremen, represented by+its principal (called "licence provider" in the sequel). The provider+of the licence has developed the "Uniform Workbench" (just+called "software" in the sequel). The software includes a+graphical tool for accessing documents stored in a versioned repository,+but also contains libraries and some other tools.++Following the ideas of open source software, the licence provider+gives access to the software without fee for anyone (called "licence+taker" in the sequel) under the following conditions which are similar+to the Lesser Gnu Public License (LGPL). Each licence taker obligates+himself to follow the terms of use below.++++1 Principle++Each licence taker appreciating these terms of use receives a simple+right, not resctricted in time and space and without any fee, to use+the software, in particular, to copy, distribute and process+it. Exclusively the following terms of use do hold.  The licence+provider explicitly contradicts any conflicting terms of business. By+making use of the rights described below, in particular by copying or+distributing it, a licence treaty between the licence provider and the+licence takes is concluded.++++2 Copying++The licence taker has the right to make and distribute unmodified+copies of the software on any media. Prerequisite for this is that the+licence provider and this licence agreement is clearly recognizable,+and that the sources are distributed together with the software.++++3 Modification and Distribution++The licence taker has the right to modify copies of the software (or+parts thereof) and to distribute these modifications under the terms+of 2 above and the following conditions:++1. The modified software has to carry a clear mark that points to the+original licence provider, the modification that has been made, and+the date of the modification.++2. The licence taker has to ensure that the software as a whole or+parts of it are accessible to third parties under the terms of this+licence agreement without fee.++3. If during the modification a copyright of the licence taker+emerges, then this copyright must be put under the terms of this+licence if the modified software is distributed.+++4 Other duties++1. Reference to the validity of this licence agreement must not be+modified or deleted by the licence taker.++2. The use of the software by third parties must not be conditioned by+the fulfilment of duties that are not mentioned in this licence+agreement.++3. The use of the software must not be prevented or complicated by+means fo technical protection, in particular copy protection means.++++5 Liability, Update++1. Liability of the licence provider is restriced to fraudulent+withheld factual or legal errors. The licence provider does not give+any warranty, and neither ensures any properties of the+software. Furthermore, he is liable only for those damages that are+caused by willful or grossly negligent violation of duty.++2. The licence provider has the right to update these terms of use at+any time.+++++6 Forum for users++The licence provider does provide neither support nor+consultation. Without acknowledgement of any legal duty, the licence+provider will care about the installation of a user forum for+discussions about the software and its further development.+++7 Legal domicile++It is agreed that the law of the Federal Republic of Germany is valid+for this licence agreement. For any lawsuits or legal actions emerging+from this licence agreement, it is agreed that exclusively German+courts are competent. Legal domicile is Bremen.+++8 Termination through Offence++Any violation of a duty of this agreement automatically terminates the+rights of use of the offender.++++9 Salvatorian Clause++If any rule of this agreement should be or become inoperative,+validity of the other rules is not affected. The parties will care+about replacing the invalid rule by some valid rule that comes close+to the purpose of this agreement.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Util/AtomString.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}++-- | AtomString atomises strings.  Right now this code+-- is not very efficient but it shouldn't be too hard+-- to improve.+--+-- This code includes no less that 3 uses of unsafePerformIO.  Oh well.+module Util.AtomString(+   AtomString,+      -- represents a string.  Instance of Ord, Eq, StringClass,+      -- Read and Show.  There is no guarantee that Ord on AtomString+      -- corresponds to Ord on the corresponding String.+   firstAtomString,+      -- :: AtomString+      -- However firstAtomString is guaranteed to be the first AtomString+      -- in the ordering.++   StringClass(..),+      -- encodes that a type encodes strings in some way.++   fromStringWEHacked,+   fromStringError,+      -- provide a primitive way for decoding String's to return an error.++   Str(..),+      -- WRAP+++   mkFromStringWE,+      --  :: Parser stringClass -> String -> (String -> WithError stringClass)+      -- Make a fromStringWE function given a parser.+      -- The error message is of the form "/string/ is not a valid /typename/"+      -- where /typename/ is the first String argument to mkFromStringWE.+   ) where++import Control.Concurrent+import qualified Data.Map as Map+import System.IO.Unsafe+import qualified Data.ByteString.Char8 as BS+import Control.Exception+import Text.ParserCombinators.Parsec+++import Util.QuickReadShow+import Util.Dynamics+import Util.DeepSeq+import Util.Computation+import Util.BinaryAll++data AtomSource = AtomSource (MVar (Map.Map BS.ByteString AtomString))+   -- where AtomStrings come from+   -- Here the key for an element is itself.+++emptyAtomSource :: IO AtomSource+emptyAtomSource =+   do+      mVar <- newMVar Map.empty+      return (AtomSource mVar)++theAtomSource :: AtomSource+theAtomSource = unsafePerformIO emptyAtomSource+{-# NOINLINE theAtomSource #-}+-- avoid GHC bug with Linux optimisation which can clone MVars.++newtype AtomString = AtomString BS.ByteString deriving (Ord,Eq,Typeable)+-- in fact Eq could be unsafePtrEq++firstAtomString :: AtomString+firstAtomString = AtomString (BS.pack "")++------------------------------------------------------------------------+-- StringClass+------------------------------------------------------------------------++class StringClass stringClass where+   toString :: stringClass -> String++   -- We leave it up to the instance whether fromString or fromStringWE or both+   -- are defined.  Most of the time we only use fromString, but there are+   -- just a few cases (such as EntityNames) where we need fromStringWE.+   --+   -- For cases where we don't have fromStringWE fromStringWEHacked provides+   -- an alternative solution, if you can bear it.+   fromString :: String -> stringClass+   fromString s = coerceWithError (fromStringWE s)++   fromStringWE :: String -> WithError stringClass+   fromStringWE s = hasValue (fromString s)++instance StringClass AtomString where+   fromString string = unsafePerformIO (mkAtom string)++   toString atom = unsafePerformIO (readAtom atom)++instance StringClass stringClass => QuickRead stringClass where+   quickRead = WrapRead fromString++instance StringClass stringClass => QuickShow stringClass where+   quickShow = WrapShow toString++------------------------------------------------------------------------+-- We provide a way for instances of StringClass to return errors from+-- fromString by using the usual dreadful hack with Exception.+------------------------------------------------------------------------++fromStringWEHacked :: (StringClass stringClass,DeepSeq stringClass)+   => String -> IO (WithError stringClass)+fromStringWEHacked str =+   do+      either <- tryJust+         (\ exception -> case dynExceptions exception of+            Nothing -> Nothing -- don't handle this as it's not even a dyn.+            Just dyn ->+               case fromDynamic dyn of+                  Nothing -> Nothing -- not a fromStringError.+                  Just (FromStringExcep mess) -> Just mess+            )+         (do+             let+                value = fromString str+             deepSeq value done+             return value+         )+      return (toWithError either)++fromStringError :: String -> a+fromStringError mess = throwDyn (FromStringExcep mess)++newtype FromStringExcep = FromStringExcep String deriving (Typeable)++------------------------------------------------------------------------+-- StringClass instance+------------------------------------------------------------------------++mkAtom :: String -> IO AtomString+mkAtom str =+   do+      let+         packed = BS.pack str+         AtomSource mVar = theAtomSource++      map <- takeMVar mVar+      let+         (result,newMap) = case Map.lookup packed map of+            Nothing ->+               (AtomString packed,Map.insert packed (AtomString packed) map)+            Just newPacked -> (newPacked,map)+            -- now original copy of packed can be GC'd.+      putMVar mVar newMap+      return result+++readAtom :: AtomString -> IO String+readAtom (AtomString packedString) =+   return(BS.unpack packedString)++------------------------------------------------------------------------+-- How to make a fromStringWE given a Parsec parser.+------------------------------------------------------------------------++mkFromStringWE :: Parser stringClass -> String+   -> (String -> WithError stringClass)+mkFromStringWE (parser0 :: Parser stringClass) typeName str =+   let+      parser1 =+         do+            result <- parser0+            eof+            return result+   in+      case parse parser1 "" str of+         Right stringClass -> hasValue stringClass+         Left _ -> hasError (show str ++ " is not a valid " ++ typeName)++------------------------------------------------------------------------+-- The Str class.  Wrapping an instance of StringClass in this gives+-- you an instance of HasBinary.+------------------------------------------------------------------------++newtype Str a = Str a++instance (Monad m,StringClass a) => HasBinary (Str a) m where+   writeBin = mapWrite (\ (Str a) -> toString a)+   readBin = mapRead (\ str -> Str (fromString str))
+ Util/Binary.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Library for converting types to and from binary, so that they can+-- be written to and from files, stored compactly in memory, and so on.+--+-- This is a preliminary version of the library, hence I have decided+-- /not/ to optimise heavily, beyond putting in strictness annotations+-- in where they seem appropriate.+--+-- A good place to start optimising would probably be the separate+-- "Bytes" libary.+--+-- See also "BinaryInstances", which declares instances for the standard+-- types (and one or two others), "BinaryUtils", which contains+-- (mostly) material for declaring new instances, "BinaryExtras",+-- which contains other miscellaneous utilities, and finally+-- "BinaryAll" which just imports and reexports everything.+module Util.Binary (++   hWrite, -- :: HasBinary a IO => Handle -> a -> IO ()+   hRead, -- :: HasBinary a IO => Handle -> IO a++   writeToBytes, -- :: HasBinary a StateBinArea => a -> IO (Bytes,Int)+   writeToBytes0, -- :: HasBinary a StateBinArea => Int -> a -> IO (Bytes,Int)+   readFromBytes, -- :: HasBinary a StateBinArea => (Bytes,Int) -> IO a+++   HasBinary(..),+   WriteBinary(..),+   ReadBinary(..),++   -- Ways of constructing WriteBinary/ReadBinary instances (not usually+   -- required explicitly).+   toWriteBinaryHandle, -- :: Handle -> WriteBinary IO+   toReadBinaryHandle, -- :: Handle -> ReadBinary IO++   -- Functions required for writing directly to binary areas.+   BinArea,+   StateBinArea, -- = StateT BinArea IO++   -- writing a BinArea++   -- create+   mkEmptyBinArea, -- :: Int -> IO BinArea+   -- pass as argument to writeBin+   writeBinaryBinArea, -- :: WriteBinary StateBinArea+   -- close and get contents.+   closeBinArea, -- :: BinArea -> IO (Bytes,Int)++   -- reading a BinArea++   -- create+   mkBinArea, -- :: (Bytes,Int) -> BinArea+   -- pass to things which read.+   readBinaryBinArea, -- :: ReadBinary StateBinArea+   -- check that the BinArea is completely read.+   checkFullBinArea, -- :: BinArea -> IO ()+++   -- Functions for transforming WriteBinary/ReadBinary values.+   liftWriteBinary,+      -- :: (forall a . m a -> n a) -> WriteBinary m -> WriteBinary n+   liftReadBinary,+      -- :: (forall a . m a -> n a) -> ReadBinary m -> ReadBinary n++   ) where++-- Standard imports+import System.IO++-- GHC imports+import Control.Monad.State++-- Our imports+import Util.Bytes++-- ----------------------------------------------------------------------+-- The general framework+-- Type variable "m" is a monad; "a" is the thing to read or write.+--+-- NB.  Bytes values are currently not subject to the garbage-collector,+-- and so need to be explicitly freed.   The following rules for this+-- should be observed.+--+-- (1) For writeBytes, it is only guaranteed that the argument "Bytes"+--     will be valid at the actual time of evaluation.+-- (2) For readBytes, it is the caller's responsibility to free the returned+--     area.+-- ----------------------------------------------------------------------++-- | A consumer of binary data+data WriteBinary m =+   WriteBinary {+      writeByte :: Byte -> m (),+         -- ^ write one byte+      writeBytes :: Bytes -> Int -> m ()+         -- ^ write multiple bytes+      }++-- | A source of binary data+data ReadBinary m =+   ReadBinary {+      readByte :: m Byte,+         -- ^ read one byte+      readBytes :: Int -> m Bytes+         -- ^ read multiple bytes+      }++class HasBinary a m where+   writeBin :: WriteBinary m -> a -> m ()+      -- ^ Given a consumer of binary data, and an (a), write out the (a)+   readBin :: ReadBinary m -> m a+      -- ^ Given a source of binary data, provide an (a)++-- ----------------------------------------------------------------------+-- Reading/Writing HasBinary instances to Handles.+-- ----------------------------------------------------------------------++-- | Write an (a) to a 'Handle'+hWrite :: HasBinary a IO => Handle -> a -> IO ()+hWrite handle a = writeBin (toWriteBinaryHandle handle) a+++-- | Read an (a) from a 'Handle'+hRead :: HasBinary a IO => Handle -> IO a+hRead handle = readBin (toReadBinaryHandle handle)++toWriteBinaryHandle :: Handle -> WriteBinary IO+toWriteBinaryHandle handle =+   WriteBinary {+      writeByte = hPutByte handle,+      writeBytes = hPutBytes handle+      }++toReadBinaryHandle :: Handle -> ReadBinary IO+toReadBinaryHandle handle =+   ReadBinary {+      readByte = hGetByte handle,+      readBytes = hGetBytes handle+      }++toWriteBinaryHandleDebug :: Handle -> WriteBinary IO+toWriteBinaryHandleDebug handle =+   WriteBinary {+      writeByte = (\ b -> bracketDebug 1 (hPutByte handle b)),+      writeBytes = (\ b i -> bracketDebug i (hPutBytes handle b i))+      }++toReadBinaryHandleDebug :: Handle -> ReadBinary IO+toReadBinaryHandleDebug handle =+   ReadBinary {+      readByte = bracketDebug 1 (hGetByte handle),+      readBytes = (\ i -> bracketDebug i (hGetBytes handle i))+      }++bracketDebug :: Int -> IO a -> IO a+bracketDebug i act =+   do+      putStr ("[" ++ show i)+      hFlush stdout+      a <- act+      putStr "]"+      hFlush stdout+      return a++-- ----------------------------------------------------------------------+-- Writing HasBinary instances to a memory area+--+-- We do this by allocating an area, and then doubling its size as+-- necessary.+-- ----------------------------------------------------------------------++-- | Somewhere to where you write binary data in memory.+data BinArea = BinArea {+   bytes :: ! Bytes, -- current storage area+   len :: ! Int, -- its length+   next :: ! Int -- where to write next bit of data.+   }++-- | Write an (a) to memory.  The 'Int' is the length of the area.+writeToBytes :: HasBinary a StateBinArea => a -> IO (Bytes,Int)+writeToBytes = writeToBytes0 1000+   -- Be generous, since memory is cheap.  Make it a bit less than a power+   -- of two, since some memory allocation algorithms (buddy algorithm)+   -- like this.++-- | Write an (a) to memory.+-- The integer argument is an initial guess at the number of bytes+-- that will be needed.  This should be greater than 0.  If it is+-- too small, there will be unnecessary reallocations; if too large,+-- too much memory will be used.+writeToBytes0 :: HasBinary a StateBinArea => Int -> a -> IO (Bytes,Int)+--+-- The result is returned as a pair (data area,length)+writeToBytes0 len0 a =+   do+      binArea0 <- mkEmptyBinArea len0+      ((),binArea1) <- runStateT (writeBin writeBinaryBinArea a) binArea0+      closeBinArea binArea1++-- | Create an empty 'BinArea', given the initial size.+mkEmptyBinArea :: Int -> IO BinArea+-- the argument gives the initial size to use (which had better be positive).+mkEmptyBinArea len =+   do+      bytes <- bytesMalloc len+      return (BinArea {+         bytes = bytes,+         len = len,+         next = 0+         })++-- | Return all the data currently in the 'BinArea'+closeBinArea :: BinArea -> IO (Bytes,Int)+closeBinArea binArea =+   do+      let+         bytes1 = bytes binArea+         len = next binArea+      bytes2 <- bytesReAlloc bytes1 len+      return (bytes2,len)++-- | a state monad containing the BinArea.+type StateBinArea = StateT BinArea IO++-- | A 'BinArea' as somewhere to put binary data.+writeBinaryBinArea :: WriteBinary StateBinArea+writeBinaryBinArea = WriteBinary {+   writeByte = (\ byte ->+      StateT (\ binArea0 ->+         do+            let+               next0 = next binArea0+               next1 = next0 + 1+            binArea1 <- ensureBinArea binArea0 next1+            putByteToBytes byte (bytes binArea1) next0+            return ((),binArea1 {next = next1})+         )+      ),+   writeBytes = (\ bytes' len ->+      StateT (\ binArea0 ->+         do+            let+               next0 = next binArea0+               next1 = next0 + len+            binArea1 <- ensureBinArea binArea0 next1+            putBytesToBytes bytes' 0 (bytes binArea1) next0 len+            return ((),binArea1 {next = next1})+         )+      )+   }+++-- | ensure that the given BinArea can hold at least len bytes.+ensureBinArea :: BinArea -> Int -> IO BinArea+ensureBinArea binArea size =+   if size <= len binArea+      then+         return binArea+      else+        do+           let+              len1 = 2*size+           bytes1 <- bytesReAlloc (bytes binArea) len1+           return (BinArea {+              bytes = bytes1,+              len = len1,+              next = next binArea+              })++-- ----------------------------------------------------------------------+-- Reading Binary instances from a memory area+-- We use BinArea's for this too.  But this is simpler, because we don't have to+-- worry about reallocing.+-- ----------------------------------------------------------------------++-- | Read a value from binary data in memory.  The 'Int' is the length,+-- and there will be an error if this is either too small or too large.+readFromBytes :: HasBinary a StateBinArea => (Bytes,Int) -> IO a+readFromBytes (bl@(bytes',len')) =+   do+      let+         binArea0 = mkBinArea bl++      (a,binArea1) <- runStateT (readBin readBinaryBinArea) binArea0+      checkFullBinArea binArea1+      return a++-- | Turn binary data in memory into a 'BinArea' (so that you can+-- read from it).+mkBinArea :: (Bytes,Int) -> BinArea+mkBinArea (bytes',len') =+   BinArea {+      bytes = bytes',+      len = len',+      next = 0+      }++checkFullBinArea :: BinArea -> IO ()+checkFullBinArea binArea =+   if next binArea == len binArea+      then+         return ()+      else+         error "Binary.checkFullBinArea: mysterious extra bytes"+++-- | A BinArea as a source of binary data.+readBinaryBinArea :: ReadBinary StateBinArea+readBinaryBinArea = ReadBinary {+   readByte = StateT (\ binArea0 ->+      do+         let+            next0 = next binArea0+            next1 = next0 + 1+         checkBinArea binArea0 next1+         byte <- getByteFromBytes (bytes binArea0) next0+         return (byte,binArea0 {next = next1})+      ),+   readBytes = (\ len ->+      StateT (\ binArea0 ->+         do+            let+               next0 = next binArea0+               next1 = next0 + len+            checkBinArea binArea0 next1+            bytes' <- bytesMalloc len+            putBytesToBytes (bytes binArea0) next0 bytes' 0 len+            return (bytes',binArea0 {next = next1})+         )+      )+   }++checkBinArea :: BinArea -> Int -> IO ()+-- check that the given BinArea can hold at least len bytes.+checkBinArea binArea newNext =+   if newNext > len binArea+      then+         error "Binary.checkBinArea - BinArea overflow on read"+      else+         return ()++-- ----------------------------------------------------------------------+-- Lifting writeBinary and readBinary instances.+-- ----------------------------------------------------------------------++-- | Transform the monad used by a 'WriteBinary'+liftWriteBinary :: (forall a . m a -> n a) -> WriteBinary m -> WriteBinary n+liftWriteBinary lift wb =+   let+      writeByte2 b = lift (writeByte wb b)+      writeBytes2 b i = lift (writeBytes wb b i)+   in+      WriteBinary {writeByte = writeByte2,writeBytes = writeBytes2}++-- | Transform the monad used by a 'ReadBinary'+liftReadBinary :: (forall a . m a -> n a) -> ReadBinary m -> ReadBinary n+liftReadBinary lift rb =+   let+      readByte2 = lift (readByte rb)+      readBytes2 i = lift (readBytes rb i)+   in+      ReadBinary {readByte = readByte2,readBytes = readBytes2}+
+ Util/BinaryAll.hs view
@@ -0,0 +1,16 @@+-- |+-- Description: Conversion to\/from binary.+--+-- Module which includes all the Binary stuff.+module Util.BinaryAll(+   module Util.Binary,+   module Util.BinaryUtils,+   module Util.BinaryInstances,+   module Util.BinaryExtras,+   ) where++import Util.Binary+import Util.BinaryUtils+import Util.BinaryInstances+import Util.BinaryExtras+
+ Util/BinaryExtras.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}++-- | This module contains various extra Binary instances, for example ones+-- which are particular GHC or uni-specific.+module Util.BinaryExtras(+   hReadLtd, -- :: HasBinary a IO => Int -> Handle -> IO (WithError a)+++   initialClockTime, -- :: ClockTime+      -- static clock time, used in other modules.+   ) where++import System.IO++import Data.IORef+import System.Time++import Util.Binary+import Util.BinaryUtils++import Util.Computation+import Util.ExtendedPrelude+import Util.IOExtras+import Util.BinaryInstances()++-- | Read something, but throw an exception if there is an attempt to+-- read too many characters.+hReadLtd :: HasBinary a IO =>+   Int -- ^ the maximum number of characters+   -> Handle -> IO (WithError a)+hReadLtd limit handle =+   addFallOutWE (\ break ->+      do+         lenIORef <- newIORef 0+         let+            ensure :: Int -> IO ()+            ensure i =+               do+                  len1 <- simpleModifyIORef lenIORef+                     (\ len0 ->+                        let+                           len1 = len0 + i+                        in+                           (len1,len1)+                        )+                  if len1 > limit+                     then+                        break "BinaryExtras.hReadLtd: limit exceeded"+                     else+                        done+++            (ReadBinary {readByte = readByte1,readBytes = readBytes1})+               = toReadBinaryHandle handle++            readByte2 =+               do+                  ensure 1+                  readByte1+            readBytes2 len =+               do+                  ensure len+                  readBytes1 len++            rb2 = ReadBinary {readByte = readByte2,readBytes = readBytes2}++         readBin rb2+      )++-- ----------------------------------------------------------------------+-- Instance for ClockTime+-- ----------------------------------------------------------------------+++instance Monad m => HasBinary ClockTime m where+   writeBin = mapWrite (\ (TOD i j) -> (i,j))+   readBin = mapRead (\ (i,j) -> TOD i j)++-- | Time this code was written.  We bung this definition in here+-- because this module needs GHC-specific access to ClockTime anyway.+initialClockTime :: ClockTime+initialClockTime = TOD 1052391874 190946000000+
+ Util/BinaryInstances.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}++-- | Instances of the 'Binary.HasBinary' class.  This includes the+-- standard types (except of course for things like function types and+-- IO) plus a few others.+module Util.BinaryInstances(+   -- Methods provided for encoding alternatives+   Choice5(..),+      -- 5-way alternatives.++   HasWrapper(..), -- class for unlimited (well, up to 256) alternatives.+      -- instance this class and you get an instance of HasBinary+   Wrapped(..),+   UnWrap(..),+   wrap0,wrap1,wrap2,wrap3,wrap4,+      -- used for instancing.++   ReadShow(..),+      -- A wrapper for things which are to be represented by their+      -- Read/Show instances.+   ViaEnum(..),+      -- A wrapper for things which are to be represented by their+      -- Enum instances.++   Unsigned(..),+      -- A wrapper for unsigned integral types.+   ) where++import Data.Char++-- GHC modules+import Data.Bits+import Data.Word+import GHC.Int(Int32)+import Foreign.C.Types++-- Our modules+import Util.Bytes+import Util.Binary+import Util.BinaryUtils++-- -----------------------------------------------------------------------+-- Encoding tuples (we go up to 5).+-- -----------------------------------------------------------------------++instance Monad m => HasBinary () m where+   writeBin wb () = return ()+   readBin rb = return ()++instance (Monad m,HasBinary v1 m,HasBinary v2 m) => HasBinary (v1,v2) m where+   writeBin wb (v1,v2) =+      do+         writeBin wb v1+         writeBin wb v2+   readBin wb =+      do+         v1 <- readBin wb+         v2 <- readBin wb+         return (v1,v2)++instance (Monad m,HasBinary v1 m,HasBinary (v2,v3) m)+   => HasBinary (v1,v2,v3) m where+   writeBin = mapWrite (\ (v1,v2,v3) -> (v1,(v2,v3)))+   readBin = mapRead (\ (v1,(v2,v3)) -> (v1,v2,v3))++instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4) m)+   => HasBinary (v1,v2,v3,v4) m where+   writeBin = mapWrite (\ (v1,v2,v3,v4) -> (v1,(v2,v3,v4)))+   readBin = mapRead (\ (v1,(v2,v3,v4)) -> (v1,v2,v3,v4))++instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5) m)+   => HasBinary (v1,v2,v3,v4,v5) m where+   writeBin = mapWrite (\ (v1,v2,v3,v4,v5) -> (v1,(v2,v3,v4,v5)))+   readBin = mapRead (\ (v1,(v2,v3,v4,v5)) -> (v1,v2,v3,v4,v5))++instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5,v6) m)+   => HasBinary (v1,v2,v3,v4,v5,v6) m where+   writeBin = mapWrite (\ (v1,v2,v3,v4,v5,v6) -> (v1,(v2,v3,v4,v5,v6)))+   readBin = mapRead (\ (v1,(v2,v3,v4,v5,v6)) -> (v1,v2,v3,v4,v5,v6))+++instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5,v6,v7) m)+   => HasBinary (v1,v2,v3,v4,v5,v6,v7) m where+   writeBin = mapWrite (\ (v1,v2,v3,v4,v5,v6,v7) -> (v1,(v2,v3,v4,v5,v6,v7)))+   readBin = mapRead (\ (v1,(v2,v3,v4,v5,v6,v7)) -> (v1,v2,v3,v4,v5,v6,v7))++-- -----------------------------------------------------------------------+-- Encoding Byte and (Bytes,Int).+-- NB.  We assume that the (Int) is non-negative!!!+-- -----------------------------------------------------------------------++instance HasBinary Byte m where+   writeBin wb byte = writeByte wb byte+   readBin wb = readByte wb++instance Monad m => HasBinary (Bytes,Int) m where+   writeBin wb (bytes,len) =+      do+         writeBin wb ( (fromIntegral len) :: Word)+         writeBytes wb bytes len+   readBin wb =+      do+         (lenW :: Word) <- readBin wb+         let+            len = fromIntegral lenW+         bytes <- readBytes wb len+         return (bytes,len)++-- -----------------------------------------------------------------------+-- Encoding Either/Maybe/Bool+-- -----------------------------------------------------------------------++instance (Monad m,HasBinary a m) => HasBinary (Maybe a) m where+   writeBin = mapWrite (\ aOpt -> case aOpt of+      Nothing -> Left ()+      Just a -> Right a+      )+   readBin = mapRead (\ aEither -> case aEither of+      Left () -> Nothing+      Right a -> Just a+     )++instance (Monad m,HasBinary a m,HasBinary b m)+   => HasBinary (Either a b) m where++   writeBin wb (Left a) =+      do+         writeBin wb False+         writeBin wb a+   writeBin wb (Right b) =+      do+         writeBin wb True+         writeBin wb b+   readBin rb =+      do+         isRight <- readBin rb+         if isRight+            then+               do+                  b <- readBin rb+                  return (Right b)+            else+               do+                  a <- readBin rb+                  return (Left a)+++instance Monad m => HasBinary Bool m where+   writeBin = mapWrite (\ b -> if b then (1 :: Byte) else 0)+   readBin rb =+      do+         (switch :: Byte) <- readBin rb+         case switch of+            0 -> return False+            1 -> return True+            _ -> fail ("BinaryInstances.Bool - unexpected switch "+               ++ show switch)+++-- -----------------------------------------------------------------------+-- Encoding Char (yes, we do Unicode, although this costs us)+-- -----------------------------------------------------------------------++instance Monad m => HasBinary Char m where+   writeBin = mapWrite (\ c -> (fromIntegral . ord $ c) :: Word)+   readBin = mapRead (\ (w :: Word) -> chr . fromIntegral $ w)++-- -----------------------------------------------------------------------+-- Encoding lists+-- -----------------------------------------------------------------------++instance (Monad m,HasBinary a m) => HasBinary [a] m where+   writeBin wb as =+      do+         writeBin wb (fromIntegral (length as) :: Word)+         mapM_ (\ a -> writeBin wb a) as+   readBin wb =+      do+         (len :: Word)<- readBin wb+         as <- mapM (\ _ -> readBin wb) [1..len]+         return as+++-- -----------------------------------------------------------------------+-- Encoding integers+-- Some features of our encoding.+-- (1) integers have the same encoding and words have the same encoding,+--     however the two encodings differ slightly, since words don't have+--     to store the sign.  This is important since it means ASCII characters+--     can be stored in one byte (they go via word).+-- (1) it is independent of the sort of integer in question.+-- (2) it is variable size, so that small integers (which are rather common)+-- fit into one byte.+-- -----------------------------------------------------------------------++instance Monad m => HasBinary Int m where+   writeBin = mapWrite encodeIntegral+   readBin = mapRead decodeIntegral++instance Monad m => HasBinary Word m where+   writeBin = mapWrite encodeWord+   readBin = mapRead decodeWord++instance Monad m => HasBinary Int32 m where+   writeBin = mapWrite encodeIntegral+   readBin = mapRead decodeIntegral++instance Monad m => HasBinary Word32 m where+   writeBin = mapWrite encodeWord+   readBin = mapRead decodeWord++instance Monad m => HasBinary Integer m where+   writeBin = mapWrite encodeIntegral+   readBin = mapRead decodeIntegral++instance Monad m => HasBinary CSize m where+   writeBin = mapWrite encodeWord+   readBin = mapRead decodeWord++encodeIntegral :: (Integral integral,Bits integral) => integral -> CodedList+encodeIntegral (i :: integral) =+   if isLarge i+      then+         let+            lowestPart = i .&. mask+            highPart = i `shiftR` bitsPerByte+            CodedList codedHigh = encodeIntegral highPart+         in+            CodedList ((fromIntegral lowestPart) : codedHigh)+      else+         let+            wrapped =+               if i < 0+                  then+                     topBit + i+                  else+                     i+         in+            CodedList [fromIntegral wrapped]+   where+      isLarge :: integral -> Bool+      isLarge = (\ i -> (i >= nextBit) || (i < -nextBit))+++decodeIntegral :: (Integral integral,Bits integral) => CodedList -> integral+decodeIntegral (CodedList []) = error "empty CodedList"+decodeIntegral (CodedList [wpped]) =+   let+      wrapped = fromIntegral wpped+   in+      if wrapped >= nextBit+         then+            wrapped - topBit+         else+            wrapped+decodeIntegral (CodedList (lPart : codedHigh)) =+   let+      lowestPart = fromIntegral lPart+      highPart = decodeIntegral (CodedList codedHigh)+   in+      lowestPart + (highPart `shiftL` bitsPerByte)++encodeWord :: (Integral integral,Bits integral) => integral -> CodedList+encodeWord (i :: integral) =+   if isLarge i+      then+         let+            lowestPart = i .&. mask+            highPart = i `shiftR` bitsPerByte+            CodedList codedHigh = encodeWord highPart+         in+            CodedList ((fromIntegral lowestPart) : codedHigh)+      else+         let+            wrapped = i+         in+            CodedList [fromIntegral wrapped]+   where+      isLarge :: integral -> Bool+      isLarge = (\ i -> i >= topBit)++decodeWord :: (Integral integral,Bits integral) => CodedList -> integral+decodeWord (CodedList []) = error "empty CodedList2"+decodeWord (CodedList [wpped]) =+   let+      wrapped = fromIntegral wpped+   in+      wrapped+decodeWord (CodedList (lPart : codedHigh)) =+   let+      lowestPart = fromIntegral lPart+      highPart = decodeWord (CodedList codedHigh)+   in+      lowestPart + (highPart `shiftL` bitsPerByte)++-- -----------------------------------------------------------------------+-- We make the word encoding (which is slightly more efficient for+-- unsigned integers) available via the Unsigned type.+-- -----------------------------------------------------------------------++-- | This is an @newtype@ alias for integral types where the user promises+-- that the value will be non-negative, and so saves us a bit.+-- This is what we use for character data incidentally, so that+-- ASCII characters with codes <128 can be encoded (as themselves) in+-- just one byte.+newtype Unsigned integral = Unsigned integral++instance (Monad m,Integral integral,Bits integral)+   => HasBinary (Unsigned integral) m where++   writeBin = mapWrite (\ (Unsigned i) -> encodeWord i)+   readBin = mapRead (\ i -> Unsigned (decodeWord i))++-- -----------------------------------------------------------------------+-- Bit constants+-- -----------------------------------------------------------------------++bitsInByte :: Int+-- Number of bits stored in a byte.  (+bitsInByte = 8++bitsPerByte :: Int+-- Number of bits of an integer we will store per char.+-- (The remaining one is used to mark the end of the sequence.)+bitsPerByte = bitsInByte - 1++-- Here are some useful abbreviations in this connection+topBit :: Bits integral => integral+topBit = bit bitsPerByte++mask :: (Integral integral,Bits integral) => integral+mask = topBit - 1++nextBit :: Bits integral => integral+nextBit = bit (bitsInByte - 2)++-- -----------------------------------------------------------------------+-- CodedList's.  These are used as an intermediate stage to integers.+-- -----------------------------------------------------------------------+++newtype CodedList = CodedList [Byte]+-- This is a nonempty list of integers in [0,2^(bitsInByte-1)).+-- We code them by setting the top bit of all but the last item.++instance Monad m => HasBinary CodedList m where+   writeBin _ (CodedList []) = error "empty CodedList3"+   writeBin (WriteBinary {writeByte = writeByte}) (CodedList [b]) =+      writeByte b+   writeBin (wb @ WriteBinary {writeByte = writeByte}) (CodedList (b:bs)) =+      do+         writeByte (b .|. topBit)+         writeBin wb (CodedList bs)++   readBin (rb @ ReadBinary {readByte = readByte}) =+      do+         b <- readByte+         if b < topBit+            then+               return (CodedList [b])+            else+               do+                  (CodedList bs) <- readBin rb+                  return (CodedList ( (b `xor` topBit) :bs))+++-- ----------------------------------------------------------------------+-- 5-way choices.  This is probably a bit clumsier than the HasWrapper+-- method (see next section), on the other hand perhaps a bit more+-- efficient for up to 5 alternatives, since decoding doesn't have to+-- hunt through the wraps list.+-- ----------------------------------------------------------------------++-- | This is a rather inelegant way of encoding a type with up to+-- 5 alternatives.  If 5 is too many, use () for the others, if too+-- few use 'HasWrapper'.  In fact 'HasWrapper' is probably better+-- anyway.+data Choice5 v1 v2 v3 v4 v5 =+      Choice1 v1+   |  Choice2 v2+   |  Choice3 v3+   |  Choice4 v4+   |  Choice5 v5 deriving (Eq)++instance (Monad m,+   HasBinary v1 m,HasBinary v2 m,HasBinary v3 m,HasBinary v4 m,HasBinary v5 m)+   => HasBinary (Choice5 v1 v2 v3 v4 v5) m+   where++   writeBin wb (Choice1 v) =+      do+         writeByte wb 1+         writeBin wb v+   writeBin wb (Choice2 v) =+      do+         writeByte wb 2+         writeBin wb v+   writeBin wb (Choice3 v) =+      do+         writeByte wb 3+         writeBin wb v+   writeBin wb (Choice4 v) =+      do+         writeByte wb 4+         writeBin wb v+   writeBin wb (Choice5 v) =+      do+         writeByte wb 5+         writeBin wb v++   readBin rb =+      do+         switch <- readByte rb+         case switch of+            1 ->+                do+                   v <- readBin rb+                   return (Choice1 v)+            2 ->+                do+                   v <- readBin rb+                   return (Choice2 v)+            3 ->+                do+                   v <- readBin rb+                   return (Choice3 v)+            4 ->+                do+                   v <- readBin rb+                   return (Choice4 v)+            5 ->+                do+                   v <- readBin rb+                   return (Choice5 v)+            _ -> fail ("BinaryInstances.Choice5 - unexpected switch "+               ++ show switch)++-- ----------------------------------------------------------------------+-- convenient (if inefficient) way of encoding algebraic datatypes.+-- ----------------------------------------------------------------------++-- | A class allowing you to handle types with up to 256 alternatives.+-- If this all seems to complicated, look at the source file and+-- the example for the \"Tree\" data type.+class HasWrapper wrapper m where+   wraps :: [Wrap wrapper m]+      -- ^ For each alternative in the type, provide a recognition+      -- 'Byte', and a way of mapping that alternative to the (wrapper)+   unWrap :: wrapper -> UnWrap m+      -- ^ Map a (wrapper) to the corresponding recognition 'Byte'+      -- and the type within the alternative.+++-- | Newtype alias you need to wrap around something which instances+-- 'HasWrapper' to get an actual HasBinary instance.  You will then+-- need something like this:+--+-- > instance Monad m => HasBinary a m where+-- >   writeBin = mapWrite Wrapped+-- >   readBin = mapRead wrapped+--+newtype Wrapped a = Wrapped {wrapped :: a}++-- | Value the 'HasWrapper' instance generates from 'unWrap' to+-- indicate how we should write some value to binary.+data UnWrap m = forall val . HasBinary val m+   => UnWrap+      Byte --  label for this type on writing.+      val --  value inside this wrapped type.++-- | Some alternative the user provides in 'wraps' in the+-- 'HasWrapper' instance, to indicate one particular alternative we use+-- when reading from binary.+data Wrap wrapper m = forall val . HasBinary val m+   => Wrap+      Byte --  label for this type on reading.  This must, of course, be the+           -- same as for the corresponding UnWrap.+      (val -> wrapper)+           --  how to wrap this sort of value.++-- some abbreviations for construtor functions with varying numbers of+-- arguments.++-- | 'Wrap' value for constructor with no arguments.+wrap0 :: Monad m => Byte -> wrapper -> Wrap wrapper m+wrap0 label wrapper = Wrap label (\ () -> wrapper)+++-- | 'Wrap' value for constructor with 1 argument.+wrap1 :: HasBinary val m => Byte -> (val -> wrapper) -> Wrap wrapper m+wrap1 = Wrap+++-- | 'Wrap' value for constructor with 2 arguments.+wrap2 :: (HasBinary (val1,val2) m) => Byte+   -> (val1 -> val2 -> wrapper) -> Wrap wrapper m+wrap2 char con = Wrap char (\ (val1,val2) -> con val1 val2)+++-- | 'Wrap' value for constructor with 3 arguments.+wrap3 :: (HasBinary (val1,val2,val3) m) => Byte+   -> (val1 -> val2 -> val3 -> wrapper) -> Wrap wrapper m+wrap3 char con = Wrap char (\ (val1,val2,val3) -> con val1 val2 val3)++-- | 'Wrap' value for constructor with 4 arguments.+wrap4 :: (HasBinary (val1,val2,val3,val4) m)+   => Byte -> (val1 -> val2 -> val3 -> val4 -> wrapper) -> Wrap wrapper m+wrap4 char con = Wrap char (\ (val1,val2,val3,val4) -> con val1 val2 val3 val4)++instance (Monad m,HasWrapper wrapper m) => HasBinary (Wrapped wrapper) m where+   writeBin wb (Wrapped wrapper) = writeBin' (unWrap wrapper)+      where+         writeBin' :: UnWrap m -> m ()+         writeBin' (UnWrap label val) =+            do+               writeBin wb label+               writeBin wb val++   readBin rb =+      do+         thisLabel <- readBin rb+         let+            innerWrap :: HasBinary v m => (v -> wrapper) -> m (Wrapped wrapper)+            innerWrap wrapFn =+               do+                  val <- readBin rb+                  return (Wrapped (wrapFn val))++         case findJust+            (\ (Wrap label wrapFn :: Wrap wrapper m) ->+               if label == thisLabel then Just (innerWrap wrapFn) else Nothing+               )+            (wraps :: [Wrap wrapper m]) of++            Nothing -> fail ("BinaryInstances.Wrapper - bad switch "+               ++ show thisLabel)+            Just (getWrap :: m (Wrapped wrapper)) -> getWrap++findJust :: (a -> Maybe b) -> [a] -> Maybe b+findJust f [] = Nothing+findJust f (x:xs) = case f x of+   (y@ (Just _)) -> y+   Nothing -> findJust f xs++{- Here is a little example -}+data Tree val =+      Leaf val+   |  Node [Tree val]++instance (Monad m,HasBinary val m) => HasWrapper (Tree val) m where+   wraps = [+      wrap1 0 Leaf,+      wrap1 1 Node+      ]+   unWrap = (\ wrapper -> case wrapper of+      Leaf v -> UnWrap 0 v+      Node l -> UnWrap 1 l+      )++instance (Monad m,HasWrapper (Tree val) m) => HasBinary (Tree val) m where+   writeBin = mapWrite Wrapped+   readBin = mapRead wrapped++-- ----------------------------------------------------------------------+-- HasBinary via Strings for things that are instances of Read/Show+-- ----------------------------------------------------------------------++-- | Newtype alias for things we want to encode or decode via their+-- 'Read' or 'Show' 'String' representation.+newtype ReadShow a = ReadShow a++instance (Read a,Show a,Monad m) => HasBinary (ReadShow a) m where+   writeBin = mapWrite (\ (ReadShow a) -> show a)+   readBin = mapRead (\ str ->+      case reads str of+         [(a,"")] -> ReadShow a+         _ -> error ("BinaryUtils.readBin -- couldn't parse " ++ show str)+      )++-- ----------------------------------------------------------------------+-- HasBinary via numbers for things that are instances of Enum.+-- ----------------------------------------------------------------------+++newtype ViaEnum a = ViaEnum {enum :: a}++instance (Monad m,Enum a) => HasBinary (ViaEnum a) m where+   writeBin = mapWrite (\ (ViaEnum a)+      -> (fromEnum a) :: Int+      )+   readBin = mapRead (\ (aInt :: Int) -> ViaEnum (toEnum aInt))
+ Util/BinaryUtils.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}++-- | Various functions for declaring new instances of Binary for types.+module Util.BinaryUtils(+   mapWrite, -- :: HasBinary b m => (a -> b) -> (WriteBinary m -> a -> m ())+   mapRead, -- :: (Monad m,HasBinary b m) => (b -> a) -> (ReadBinary m -> m a)+   mapWriteIO,+      -- :: (HasBinary b m,MonadIO m)+      -- => (a -> IO b) -> (WriteBinary m -> a -> m ())+   mapReadIO,+      -- :: (HasBinary b m,MonadIO m)+      -- => (b -> IO a) -> (ReadBinary m -> m a)++   ArgMonad,+      -- A type for encoding a monadic action which requires an+      -- extra argument (of type "arg").+      --    ArgMonad arg m+      -- is an instance of Monad (and Functor), if m is.+      --+      -- ArgMonad is intended as a way of writing instances of Binary which+      -- require a bit of context.  Thus you would write something like+      --+      -- instance Monad m => HasBinary MyType1 (ArgMonad context m) where+      --    writeBinary wb (MyType1 v1 v2) = mkArgMonad+      --       (\ context ->+      --           do+      --              runArgMonad context (writeBinary rb v1)+      --                 -- this is something which is automatically+      --                 -- an instance of HasBinary for (ArgMonad context m)+      --                 -- like the standard types.+      --              runArgMonad context (writeBinary rb (f v2 context))+      --                 -- this is something which needs to be changed by+      --                 -- f, using context, to give a suitable instance.+      --           )+      --  (and likewise for readBinary).+      --+      --+      -- Then if you want to encode MyType2, containing MyType1, and providing+      -- this context, you could write+      --+      -- instance Monad m => HasBinary MyType2 m where+      --    writeBinary wb (MyType2 v3 v4) =+      --       do+      --          context <- ...+      --          writeBinary wb v3 -- encoding v3 doesn't need context+      --          runArgMonad context+      --             (writeBinary (writeBinaryToArgMonad wb) v4)+      --             -- encoding v4 does need context.+   mkArgMonad, -- :: (arg -> m a) -> ArgMonad arg m a+   toArgMonad, -- :: m a -> ArgMonad arg m a+   runArgMonad, -- :: arg -> ArgMonad arg m a -> m a++   writeBinaryToArgMonad, -- :: WriteBinary m -> WriteBinary (ArgMonad arg m)+   readBinaryToArgMonad, -- :: ReadBinary m -> ReadBinary (ArgMonad arg m)+++   WrappedBinary(..),+      -- a wrapper for instances of HasBinary _ IO.+   hWriteWrappedBinary, -- :: Handle -> WrappedBinary -> IO ()++   WrapBinary(..),+      -- more general wrapped for any monad.+   ) where++import System.IO(Handle)++-- GHC imports+import Control.Monad.Trans++-- our imports+import Util.Binary++-- ----------------------------------------------------------------------+-- Mapping HasBinary instances+-- ----------------------------------------------------------------------++-- | Given a function which converts an (a) to something we can already+-- convert to binary, return a 'writeBin' function to be used in+-- instances of 'HasBinary' (a).+mapWrite :: HasBinary b m => (a -> b) -> (WriteBinary m -> a -> m ())+mapWrite  fn wb a = writeBin wb (fn a)++-- | Given a function which converts something we can already read from+-- binary to (a), return a 'readBin' function to be used in instances+-- of 'HasBinary' (a).+mapRead :: (Monad m,HasBinary b m) => (b -> a) -> (ReadBinary m -> m a)+mapRead fn rb =+   do+      b <- readBin rb+      return (fn b)++-- | Like 'mapWrite', but the conversion function is also allowed to use+-- 'IO'.+mapWriteIO :: (HasBinary b m,MonadIO m)+   => (a -> IO b) -> (WriteBinary m -> a -> m ())+mapWriteIO fn wb a =+   do+      b <- liftIO (fn a)+      writeBin wb b++-- | LIke 'mapRead', but the conversion function is also allowed to use+-- 'IO'.+mapReadIO :: (HasBinary b m,MonadIO m)+   => (b -> IO a) -> (ReadBinary m -> m a)+mapReadIO fn rb =+   do+      b <- readBin rb+      liftIO (fn b)+++-- ----------------------------------------------------------------------+-- Creating HasBinary instances that need extra information about their+-- context+-- ----------------------------------------------------------------------++-- | A monad which hides an additional value which the 'HasBinary'+-- instances should be able to get at.  This is used, for example,+-- by "CodedValue", to make the 'View' available to instances.+newtype ArgMonad arg m a = ArgMonad (arg -> m a)++mkArgMonad :: (arg -> m a) -> ArgMonad arg m a+mkArgMonad = ArgMonad++toArgMonad :: m a -> ArgMonad arg m a+toArgMonad act = ArgMonad (const act)++writeBinaryToArgMonad :: WriteBinary m -> WriteBinary (ArgMonad arg m)+writeBinaryToArgMonad = liftWriteBinary toArgMonad++readBinaryToArgMonad :: ReadBinary m -> ReadBinary (ArgMonad arg m)+readBinaryToArgMonad = liftReadBinary toArgMonad++runArgMonad :: arg -> ArgMonad arg m a -> m a+runArgMonad arg (ArgMonad fn) = fn arg++instance Functor m => Functor (ArgMonad arg m) where+   fmap mapFn (ArgMonad fn) =+      let+         fn2 arg = fmap mapFn (fn arg)+      in+         ArgMonad fn2++instance Monad m => Monad (ArgMonad arg m) where+   (>>=) (ArgMonad fn1) getArgMonad =+      let+         fn arg =+            do+               v1 <- fn1 arg+               let+                  (ArgMonad fn2) = getArgMonad v1+               fn2 arg+      in+         ArgMonad fn++   return v = ArgMonad (const (return v))++   fail s = ArgMonad (const (fail s))++instance MonadIO m => MonadIO (ArgMonad arg m) where+   liftIO act = ArgMonad (\ arg -> liftIO act)++-- ----------------------------------------------------------------------+-- A wrapper for instances of Binary.  This can be written, but not+-- read (since we wouldn't know what type to decode).+-- ----------------------------------------------------------------------++-- | A wrapper for instances of Binary.  This can be written, but not+-- read (since we wouldn't know what type to decode).+data WrappedBinary =+   forall v . HasBinary v IO => WrappedBinary v++-- | Write a 'WrappedBinary'+hWriteWrappedBinary :: Handle -> WrappedBinary -> IO ()+hWriteWrappedBinary handle (WrappedBinary v) = hWrite handle v+++-- ----------------------------------------------------------------------+-- More generally we provide a wrapped type for each monad, and a way+-- of writing it.  Of course we have to leave the method for reading it+-- undefined+-- ----------------------------------------------------------------------++data WrapBinary m = forall v . HasBinary v m => WrapBinary v++instance HasBinary (WrapBinary m) m where+   writeBin wb (WrapBinary v) = writeBin wb v++   readBin = error "BinaryUtils: can't read a general wrapped binary type"
+ Util/Broadcaster.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}++-- | A Broadcaster/SimpleBroadcaster is a variable Source/SimpleSource paired+-- with its update function+module Util.Broadcaster(+   -- instances of HasSource (and so CanAddSinks)+   GeneralBroadcaster,+   Broadcaster,+   SimpleBroadcaster,++   newBroadcaster, -- :: x -> IO (Broadcaster x d)+   newSimpleBroadcaster, -- :: x -> IO (SimpleBroadcaster x)+   newGeneralBroadcaster, -- :: x -> IO (GeneralBroadcaster x d)++   BroadcasterClass(broadcast),+      -- sends an update to a broadcaster.++   applySimpleUpdate, -- :: SimpleBroadcaster x -> (x -> x) -> IO ()+   applySimpleUpdate', -- :: SimpleBroadcaster x -> (x -> (x,y)) -> IO y+++   applyUpdate, -- :: Broadcaster x d -> (x -> (x,[d])) -> IO ()++   applyGeneralUpdate, -- :: GeneralBroadcaster x d -> (x -> (x,[d],extra)) -> IO extra++   switchOffSimpleSource,+      -- :: SimpleSource a -> IO (SimpleSource a,IO (IO ()))+      -- Replace a SimpleSource by another which comes with a switch-off+      -- function, which temporarily blocks further updates.+      -- The action returned by the switch-off function switches the source+      -- again.++   mirrorSimpleSource,+      -- :: SimpleSource a -> IO (SimpleSource a,IO ())+      -- Replace a SimpleSource by another which mirrors it, but only copies+      -- from it once, hopefully saving CPU time.+      -- The IO action stops the mirroring.++   mirrorSimpleSourceWithDelayer,+      -- :: Delayer -> (a -> IO ()) -> SimpleSource a+      -- -> IO (SimpleSource a,IO ())+      -- Replace a SimpleSource by another which mirrors it, but only copies+      -- from it once, hopefully saving CPU time.  In addition, block all+      -- update while the Delayer is delaying things.++   ) where++import Data.IORef+import qualified Control.Concurrent.MVar as MVar+import System.IO.Unsafe++import Util.Sink+import Util.Sources+import Util.Delayer+import Util.Debug(debug)++-- -----------------------------------------------------------------+-- Datatypes+-- -----------------------------------------------------------------++data GeneralBroadcaster x d = GeneralBroadcaster {+   source' :: Source x d,+   updater :: Updater x d+   }++data Broadcaster x d = Broadcaster {+   source :: Source x d,+   updateAct :: (x -> (x,[d])) -> IO ()+   }++data SimpleBroadcaster x = SimpleBroadcaster {+   simpleSource :: SimpleSource x,+   updateAct3 :: (forall y . (x -> (x,y)) -> IO y)+   }++-- | old field name, preserved here for compatibility.+updateAct2 :: SimpleBroadcaster x -> (x -> x) -> IO ()+updateAct2 broadcaster fn =+   updateAct3 broadcaster (\ x -> (fn x,()))++-- -----------------------------------------------------------------+-- Creation+-- -----------------------------------------------------------------++newBroadcaster :: x -> IO (Broadcaster x d)+newBroadcaster x =+   do+      (source,updateAct) <- variableSource x+      return (Broadcaster {source = source,updateAct = updateAct})++newSimpleBroadcaster :: x -> IO (SimpleBroadcaster x)+newSimpleBroadcaster (x :: x) =+   do+      (source,updater :: Updater x x) <- variableGeneralSource x+      let+         updateAct3 :: (x -> (x,y)) -> IO y+         updateAct3 fn = applyToUpdater updater+            (\ x0 ->+               let+                  (x1,y) = fn x0+               in+                  (x1,[x1],y)+               )+      return (SimpleBroadcaster {simpleSource = SimpleSource source,+         updateAct3 = updateAct3})++newGeneralBroadcaster :: x -> IO (GeneralBroadcaster x d)+newGeneralBroadcaster x =+   do+      (source,updater) <- variableGeneralSource x+      return (GeneralBroadcaster {source' = source,updater = updater})++-- -----------------------------------------------------------------+-- Sending values+-- -----------------------------------------------------------------++class BroadcasterClass broadcaster value | broadcaster -> value where+   broadcast :: broadcaster -> value -> IO ()++instance BroadcasterClass (Broadcaster x d) (x,[d]) where+   broadcast (Broadcaster {updateAct = updateAct}) (x,ds) =+      updateAct (\ _ -> (x,ds))++instance BroadcasterClass (SimpleBroadcaster x) x where+   broadcast broadcaster x =+      updateAct2 broadcaster (\ _ -> x)++applySimpleUpdate :: SimpleBroadcaster x -> (x -> x) -> IO ()+applySimpleUpdate simpleBroadcaster updateFn =+   updateAct2 simpleBroadcaster updateFn++applySimpleUpdate' :: SimpleBroadcaster x -> (x -> (x,y)) -> IO y+applySimpleUpdate' simpleBroadcaster updateFn =+   updateAct3 simpleBroadcaster updateFn++applyUpdate :: Broadcaster x d -> (x -> (x,[d])) -> IO ()+applyUpdate (Broadcaster {updateAct = updateAct}) updateFn =+   updateAct updateFn++applyGeneralUpdate :: GeneralBroadcaster x d -> (x -> (x,[d],extra)) -> IO extra+applyGeneralUpdate (GeneralBroadcaster {updater = updater}) updateAct =+   applyToUpdater updater updateAct++-- -----------------------------------------------------------------+-- Instances of HasSource and HasSimpleSource+-- -----------------------------------------------------------------++instance HasSource (Broadcaster x d) x d where+   toSource broadcaster = source broadcaster++instance HasSource (SimpleBroadcaster x) x x where+   toSource broadcaster = toSource . toSimpleSource $ broadcaster++instance HasSource (GeneralBroadcaster x d) x d where+   toSource generalBroadcaster = source' generalBroadcaster++instance HasSimpleSource (SimpleBroadcaster x) x where+   toSimpleSource simpleBroadcaster = simpleSource simpleBroadcaster+++-- -----------------------------------------------------------------+-- switchOffSimpleSource+-- -----------------------------------------------------------------++-- | Replace a SimpleSource by another which comes with a switch-off function,+-- which temporarily blocks further updates.+-- The action returned by the switch-off function switches the source back on+-- again.+switchOffSimpleSource :: SimpleSource a -> IO (SimpleSource a,IO (IO ()))+switchOffSimpleSource simpleSource =+   do+      broadcaster <- newSimpleBroadcaster simpleSource+      let+         switchOffSource = staticSimpleSourceIO (readContents simpleSource)++         switchOff =+            do+               broadcast broadcaster switchOffSource+               return (broadcast broadcaster simpleSource)++         newSource =+            do+               source <- toSimpleSource broadcaster+               source+      return (newSource,switchOff)++-- -----------------------------------------------------------------+-- mirrorSimpleSource and mirrorSimpleSourceWithDelayer+-- -----------------------------------------------------------------++-- | Replace a SimpleSource by another which mirrors it, but only copies+-- from it once, hopefully saving CPU time.+-- The IO action stops the mirroring.+mirrorSimpleSource :: SimpleSource a -> IO (SimpleSource a,IO ())+mirrorSimpleSource (simpleSource :: SimpleSource a) =+   do+      (sourceMVar :: MVar.MVar (Maybe (SimpleSource a)))+         <- MVar.newMVar Nothing+      sinkId <- newSinkID++      let+         getSource :: IO (SimpleSource a)+         getSource = MVar.modifyMVar sourceMVar+            (\ sourceOpt -> case sourceOpt of+               Just source -> return (sourceOpt,source)+               Nothing ->+                  do+                     parallelX <- newParallelExec+                     broadcaster <- newSimpleBroadcaster+                        (error "mirrorSimpleSource: 1")+                     initialised <- MVar.newEmptyMVar++                     let+                        writeX a =+                           do+                              broadcast broadcaster a+                              MVar.putMVar initialised ()+                        writeD a =+                           do+                              broadcast broadcaster a++                     addNewSourceActions (toSource simpleSource) writeX writeD+                        sinkId parallelX+                     MVar.takeMVar initialised+                     let+                        source = toSimpleSource broadcaster+                     return (Just source,source)+               )++      source <- getSource++      return (source,invalidate sinkId)+++-- | Replace a SimpleSource by another which mirrors it, but only copies+-- from it once, hopefully saving CPU time.  In addition, block all+-- update while the Delayer is delaying things.+mirrorSimpleSourceWithDelayer :: Delayer -> SimpleSource a -> IO (SimpleSource a,IO ())+mirrorSimpleSourceWithDelayer delayer (simpleSource :: SimpleSource a) =+   do+      sinkId <- newSinkID+      parallelX <- newParallelExec+      let+         -- emergencyRead should not be used too often I hope.+         emergencyRead =+            do+               debug "Broadcaster: emergency read"+               readContents simpleSource++      broadcaster <- newSimpleBroadcaster (unsafePerformIO emergencyRead)+      ref <- newIORef (error "mirrorSimpleSource: 3")++      let+         writeAct val = writeIORef ref val++         bumpAct =+            do+               val <- readIORef ref+               broadcast broadcaster val++      delayedBumpAct <- newDelayedAction bumpAct++      let+         updateAct val =+            do+               writeAct val+               delayedAct delayer delayedBumpAct++      addNewSourceActions (toSource simpleSource)+         (broadcast broadcaster) updateAct sinkId parallelX++      return (toSimpleSource broadcaster,invalidate sinkId)
+ Util/Bytes.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | This defines primitive byte operations, to be used with binary conversion.+-- For the present we use the FFI.  There are probably lots of better ways.++module Util.Bytes(+   Byte,+      -- this type is expected to be an instance of Eq, Ord, Num, Bits,+      -- Integral, Show and contain (at least) the values 0..255.+   Bytes,+      -- an array of values of type Byte.+      -- NB.  The caller is responsible for making sure writes to and from+      -- this array are within bounds.+++   putByteToBytes,+      -- :: Byte -> Bytes -> Int -> IO ()+      -- write byte to index.+   getByteFromBytes,+      -- :: Bytes -> Int -> IO Byte++   putBytesToBytes,+      -- :: Bytes -> Int -> Byte -> Int -> Int -> IO ()+      -- putBytesToBytes source sourceIndex dest destIndex length+      --    copies length bytes starting at source[sourceIndex] to+      --    dest[destIndex]+      -- It assumes that the source and destination areas don't overlap.+   hPutByte,+      -- :: Handle -> Byte -> IO ()+   hGetByte,+      -- :: Handle -> IO Byte++   hPutBytes,+      -- :: Handle -> Bytes -> Int -> IO ()+   hGetBytes,+      -- :: Handle -> Int -> IO Bytes+      -- hGetBytes allocates an area, which needs to be+      -- freed using freeBytes.++   -- the following are similar to C's malloc/alloc/realloc/free.+   bytesMalloc,+      -- :: Int -> IO Bytes+   bytesReAlloc,+      -- :: Bytes -> Int -> IO Bytes.+   bytesAlloca,+      -- :: Int -> (Bytes -> IO a) -> IO a+   bytesFree,+      -- :: Bytes -> IO ()++   withBytesAsCChars,+      -- :: Bytes -> (Ptr CChar -> IO a) -> IO a+      -- This gives you access to the contents of Bytes as a Ptr CChar.+      -- The length will be the number of Bytes in the array.+      -- NB.  The Ptr CChar may become invalid (or garbage) after the+      -- function supplied by the caller returns.++   mkBytes,+      -- :: Ptr CChar -> Bytes+   unMkBytes,+      -- :: Bytes -> Ptr CChar+      -- low-level interface (and therefore likely to change)+++   compareBytes, -- :: Bytes -> Bytes -> Int -> IO Ordering+      -- Compare two Bytes items up to the given length, in a consistent+      -- way.+   ) where++-- FFI imports+import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Marshal.Alloc+import Foreign.Ptr++-- Other GHC imports.+import Data.Bits(Bits)+import Data.Char++import System.IO++import System.IO.Error+import Control.Exception(Exception(IOException),throw)++++-- ----------------------------------------------------------------------+-- The datatypes+-- ----------------------------------------------------------------------++newtype Byte = Byte CUChar deriving (Eq,Ord,Num,Bits,Show,Real,Enum,Integral)++newtype Bytes = Bytes (Ptr CChar)++-- ----------------------------------------------------------------------+-- The exported functions+--  ----------------------------------------------------------------------++putByteToBytes :: Byte -> Bytes -> Int -> IO ()+putByteToBytes (Byte u) (Bytes ptr) i+   = pokeArray (advancePtr ptr i) [fromIntegral u]++getByteFromBytes :: Bytes -> Int -> IO Byte+getByteFromBytes (Bytes ptr) i =+   do+      [c] <- peekArray 1 (advancePtr ptr i)+      return (Byte (fromIntegral c))++putBytesToBytes :: Bytes -> Int -> Bytes -> Int -> Int -> IO ()+putBytesToBytes (Bytes sourcePtr) sourceIndex (Bytes destPtr) destIndex len+   = copyArray (advancePtr destPtr destIndex)+      (advancePtr sourcePtr sourceIndex) len++hPutByte :: Handle -> Byte -> IO ()+hPutByte handle (Byte u) = hPutChar handle (chr (fromIntegral u))++hGetByte :: Handle -> IO Byte+hGetByte handle =+   do+      char <- hGetChar handle+      return (Byte (fromIntegral (ord char)))++hPutBytes :: Handle -> Bytes -> Int -> IO ()+hPutBytes handle (Bytes ptr) len =+   hPutBuf handle ptr len++hGetBytes ::  Handle -> Int -> IO Bytes+hGetBytes handle len =+   do+      (bytes@(Bytes ptr)) <- bytesMalloc len+      lenRead <- hGetBuf handle ptr len+      if lenRead < len+         then+            do+               bytesFree bytes+               throwEOF handle+         else+            return bytes++bytesMalloc :: Int -> IO Bytes+bytesMalloc i =+   do+      ptr <- mallocBytes i+      return (Bytes ptr)++bytesReAlloc :: Bytes -> Int -> IO Bytes+bytesReAlloc (Bytes ptr1) newLen =+   do+      ptr2 <- reallocBytes ptr1 newLen+      return (Bytes ptr2)++bytesAlloca :: Int -> (Bytes -> IO a) -> IO a+bytesAlloca len fn = allocaBytes len (\ ptr -> fn (Bytes ptr))++bytesFree :: Bytes -> IO ()+bytesFree (Bytes ptr) = free ptr+++withBytesAsCChars :: Bytes -> (Ptr CChar -> IO a) -> IO a+withBytesAsCChars (Bytes ptr) fn = fn ptr++++mkBytes :: Ptr CChar -> Bytes+mkBytes = Bytes++unMkBytes :: Bytes -> Ptr CChar+unMkBytes (Bytes ptr) = ptr++-- ----------------------------------------------------------------------+-- Throw an EOF error+-- ----------------------------------------------------------------------++throwEOF :: Handle -> IO a+throwEOF handle =+   do+      let+         eofError = IOException (+            mkIOError eofErrorType+               "BinaryIO" (Just handle)+               Nothing+            )+      throw eofError++-- ----------------------------------------------------------------------+-- Compare two Bytes values in an unspecified but consistent way.+-- ----------------------------------------------------------------------++compareBytes :: Bytes -> Bytes -> Int -> IO Ordering+compareBytes (Bytes p1) (Bytes p2) len =+   do+      res <- compareBytesPrim p1 p2 (fromIntegral len)+      return (compare res 0)++foreign import ccall unsafe "string.h memcmp"+   compareBytesPrim :: Ptr CChar -> Ptr CChar -> CSize -> IO CInt
+ Util/Cache.hs view
@@ -0,0 +1,43 @@+-- | The Cache module allows us to cache results of expensive stateful+-- computations in memory.+-- Possible improvements -+--    (1) use hashing instead+module Util.Cache(+   Cache,    -- a cache (a stateful object).  Takes parameters key and elt.+             -- key must be an instance of Ord.+   newCache, -- :: Ord key => (key -> IO elt) -> IO(Cache key elt)+   getCached -- :: Ord key => Cache key elt -> key -> IO elt+   ) where++import qualified Data.Map as Map+import Control.Concurrent++data Ord key =>+   Cache key elt = Cache (MVar(Map.Map key (MVar elt))) (key -> IO elt)++newCache :: Ord key => (key -> IO elt) -> IO(Cache key elt)+newCache getAct =+   do+      cacheMVar <- newMVar Map.empty+      return (Cache cacheMVar getAct)++{- We do this in two stages so as not to hold up the whole+   cache at once. -}+getCached :: Ord key => Cache key elt -> key -> IO elt+getCached (Cache cacheMVar getAct) key =+   do+      cacheMap <- takeMVar cacheMVar+      case Map.lookup key cacheMap of+         Just mVar ->+            do+               putMVar cacheMVar cacheMap+               readMVar mVar+         Nothing ->+            do+               mVar <- newEmptyMVar+               putMVar cacheMVar (Map.insert key mVar cacheMap)+               value <- getAct key+               putMVar mVar value+               return value++
+ Util/ClockTimeToString.hs view
@@ -0,0 +1,25 @@+-- | This module implements displaying ClockTime as a String which does NOT+-- depend on the time-zone.+module Util.ClockTimeToString(+   clockTimeToString, -- :: ClockTime -> String+   stringToClockTime, -- :: String -> ClockTime+   ) where++import System.Time++import Util.ExtendedPrelude++-- | Convert a ClockTime to a String.+-- This has the format+--    \<optional sign\>\<digits\>+\<digits\>+-- where the digits encode two integers N1 and N2 (in order) representing+-- the time elapsed since 00:00:00 UTC on 1 Jan 1970.  This will be+-- N1 + (N2 \/ 10^12) seconds.  0<=N2<10^12.+clockTimeToString :: ClockTime -> String+clockTimeToString (TOD n1 n2) = show n1 ++ "+" ++ show n2++-- | Convert a validly formatted String to a ClockTime.+stringToClockTime :: String -> ClockTime+stringToClockTime s = case splitByChar '+' s of+   [n1s,n2s] -> TOD (read n1s) (read n2s)+   _ -> error "Badly formatted clock time"
+ Util/CommandStringSub.hs view
@@ -0,0 +1,231 @@+-- | We provide a format-string-like way of describing how to call particular+-- tools.  Thus the input is+-- (1) a particular format string+-- (2) a partial map from upper-case letters to strings; we call these strings+--     the _insert_ strings.+-- We map the format string to an output string in which combinations+-- of the form+-- %[upper-case-letter]+-- in the format string are replaced by the corresponding insert string; if no+-- such string exists this is an error.+--+-- We also provide a mechanism for "escaping" the insert strings.+-- Specifically, there is a fixed partial map from lower-case letters to+-- functions :: String -> String; these functions we call the transformers.+-- For a combination of the form+-- %[lower-case-letter-1]...[lower-case-letter-n][upper-case-letter]+-- we take the insert string corresponding to upper-case-letter, and then+-- pass it through the transformers corresponding to lower-case-letter-n,+-- and so on down to the transformer corresponding to lower-case-letter-1.+--+-- Instead of [upper-case-letter] we may also write "%" in which case the+-- insert string is just "%"; thus "%%" transforms to "%".+--+-- Sections of the input string not containing % are left untouched.+--+-- Defined transformers with their corresponding letters:+--    b  transformer suitable for escaping bash strings quoted with ".+--    e  transformer suitable for escaping emacs lisp strings quoted with ".+-- None of these transformers insert the closing or end quotes, allowing you+-- to use them in the middle of strings.+--+-- Other transformers will be added as the need arises.+module Util.CommandStringSub(+   CompiledFormatString,+      -- This represents a format string in which all the transformers and+      -- escapes (apart from escaped upper-case letters) have been parsed.++   -- compileFormatString and runFormatString split the computation into+   -- two stages so we can save a bit of time if the same format string is+   -- used more than once.+   compileFormatString,+      -- :: String -> WithError CompiledFormatString+   runFormatString,+      -- :: CompiledFormatString -> (Char -> Maybe String) -> WithError String++   -- doFormatString does everything at once, throwing an error if necessary.+   doFormatString,+      -- :: String -> (Char -> Maybe String) -> String+++   -- Some transformers we export for use as simple Haskell functions+   -- NB - these do not delimit the input strings.+   emacsEscape, -- :: String -> String+   bashEscape, -- :: String -> String+   ) where++import Data.Char++import Util.Computation++-- --------------------------------------------------------------------------+-- The datatypes+-- --------------------------------------------------------------------------++data FormatItem =+      Unescaped String+   |  Escaped (String -> String) Char++newtype CompiledFormatString = CompiledFormatString [FormatItem]++-- --------------------------------------------------------------------------+-- compileFormatString+-- --------------------------------------------------------------------------++compileFormatString :: String -> WithError CompiledFormatString+compileFormatString str =+   case splitToDollar str of+      Nothing -> hasValue (prependLiteral str (CompiledFormatString []))+      Just (s1,s2) ->+         mapWithError'+            (\ (ch,transformer,withError) ->+               mapWithError+                  (\ (CompiledFormatString l) ->+                     prependLiteral s1+                        (CompiledFormatString ((Escaped transformer ch):l))+                     )+                  withError+               )+            (compileFromEscape s2)++-- | Return portion up to (not including) first %, and portion after it.+splitToDollar :: String -> Maybe (String,String)+splitToDollar "" = Nothing+splitToDollar ('%':rest) = Just ("",rest)+splitToDollar (c:rest) = fmap (\ (s1,s2) -> (c:s1,s2)) (splitToDollar rest)++prependLiteral :: String -> CompiledFormatString -> CompiledFormatString+prependLiteral "" compiledFormatString = compiledFormatString+prependLiteral s (CompiledFormatString l) =+   CompiledFormatString (Unescaped s:l)++compileFromEscape :: String+   -> WithError (Char,String -> String,WithError CompiledFormatString)+compileFromEscape "" = hasError "Format string ends unexpectedly"+compileFromEscape (c:rest) =+   if isUpper c || c == '%' then hasValue (c,id,compileFormatString rest)+   else case c of+      'e' -> mapEscapeFunction emacsEscape rest+      'b' -> mapEscapeFunction bashEscape rest+      _ ->+         let+            compiledRest = compileFormatString rest+            e = error "Attempt to run bad format string"+            restFaked = hasValue (e,e,compiledRest)+            message = if isLower c then+               "Transformer character " ++ [c] ++ " not recognised."+               else "Unexpected character "++ show c ++ " in format string."+         in+            mapWithError snd (pairWithError (hasError message) restFaked)++mapEscapeFunction :: (String -> String) -> String ->+   WithError (Char,String -> String,WithError CompiledFormatString)+mapEscapeFunction escapeFunction s =+   mapWithError+      (\ (ch,transformer,rest) -> (ch,escapeFunction . transformer,rest))+      (compileFromEscape s)++-- --------------------------------------------------------------------------+-- The escape functions+-- --------------------------------------------------------------------------++mkEscapeFunction :: (Char -> String) -> (String -> String)+mkEscapeFunction chEscape str =+   concat (map chEscape str)++bashEscape :: String -> String+bashEscape = mkEscapeFunction chbashEscape++chbashEscape :: Char -> String+chbashEscape ch =+   case ch of+      '\\' -> "\\\\"+      '\"' -> "\\\""+      '$' -> "\\$"+      '`' -> "\\`"+      _ -> [ch]++emacsEscape :: String -> String+emacsEscape = mkEscapeFunction chEmacsEscape++chEmacsEscape :: Char -> String+chEmacsEscape ch =+   case ch of+      '\n' -> "\\n"+      '\t' -> "\\t"+      '\r' -> "\\r"+      '\f' -> "\\f"+      '\b' -> "\\b"+      '\\' -> "\\\\"+      '\"' -> "\\\""+      ch -> if isPrint ch then [ch] else "\\"++to3Oct ch+   where+      -- Converts to octal representation padded to 3 digits.+      to3Oct :: Char -> String+      to3Oct ch =+         let+            chOct = toOctal ch+         in+            case chOct of+               "" -> "000"+               [_] -> "00"++chOct+               [_,_] -> "0" ++ chOct+               [_,_,_] -> chOct+               _ -> error+                  "Character with enormous character code can't be emacs-escaped"+++-- | Converts character to representation.+toOctal :: Char -> String+toOctal ch =+   -- We can't use Numeric.showOpt because GHC5.02.1 doesn't+   -- implement it!!!+   let+      toOct :: Int -> String+      toOct i =+         let+            (q,r) = divMod i 8+            e = [intToDigit r]+         in+            if q==0 then e else toOct q++e+   in+      toOct (ord ch)++-- --------------------------------------------------------------------------+-- runFormatString+-- --------------------------------------------------------------------------++runFormatString :: CompiledFormatString -> (Char -> Maybe String)+   -> WithError String+runFormatString (CompiledFormatString l) lookup =+   let+      withErrors =+         map+           (\ formatItem -> case formatItem of+              Unescaped str -> hasValue str+              Escaped transformer '%' -> hasValue "%"+              Escaped transformer ch -> case lookup ch of+                 Nothing -> hasError ("%"++[ch]++" not defined")+                 Just str -> hasValue (transformer str)+              )+           l+      appendWithError we1 we2 = mapWithError (uncurry (++))+         (pairWithError we1 we2)+   in+      foldr appendWithError (hasValue "") withErrors+++-- --------------------------------------------------------------------------+-- doFormatString+-- --------------------------------------------------------------------------++  -- doFormatString does everything at once, throwing an error if necessary.+doFormatString :: String -> (Char -> Maybe String) -> String+doFormatString format lookup =+   let+      we1 = compileFormatString format+      we2 = mapWithError'+         (\ compiled -> runFormatString compiled lookup)+         we1+   in+      coerceWithError we2
+ Util/CompileFlags.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}++-- | This module contains flags which control compilation.+module Util.CompileFlags where++isDebug :: Bool+#ifdef DEBUG+isDebug = True+#else+isDebug = False+#endif++uniVersion :: String+uniVersion = "2.2"
+ Util/Computation.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Description : Miscellaneous Monads, in particular 'Computation.WithError'.+module Util.Computation (+        Answer,++        done,++        ( # ), -- reverse of application++        -- * exceptions and handlers+        propagate,+        try, -- re-export from Control.Exception+        tryUntilOK,+        raise,++        -- * selectors+        when, -- re-export from Control.Monad+        unless, -- re-export from Control.Monad+        incase,++        -- * iterators+        forever, -- re-export from Control.Monad+        foreverUntil,+        foreach,+        while,++        -- * configure command+        Config,+        configure,+        config,++        -- * The new-style configuration command+        HasConfig(..),++        -- * Returning results or error messages.+        WithError,++        hasError, -- :: String -> WithError a+        -- pass on an error++        hasValue, -- :: a -> WithError a+        -- pass on a value++        fromWithError, -- :: WithError a -> Either String a+        -- unpack a WithError+        fromWithError1, -- :: a -> WithError a -> a+        -- simpler form.+        toWithError, -- :: Either String a -> WithError a+        -- pack a WithError+        isError, -- :: WithError a -> Bool+        -- returns True if this value indicates an error.++        mapWithError, -- :: (a -> b) -> WithError a -> WithError b+        mapWithError', -- :: (a -> WithError b) -> WithError a -> WithError b+        mapWithErrorIO,+        -- :: (a -> IO b) -> WithError a -> IO (WithError b)+        mapWithErrorIO',+        -- :: (a -> IO (WithError b)) -> WithError a -> IO (WithError b)+        pairWithError, -- :: WithError a -> WithError b -> WithError (a,b)+        -- we concatenate the errors, inserting a newline between them if+        -- there are two.+        listWithError, -- :: [WithError a] -> WithError [a]+        coerceWithError, -- :: WithError a -> a+        coerceWithErrorIO, -- :: WithError a -> IO a+        -- get out result or throw error.+        -- The second throws the error immediately.+        coerceWithErrorStringIO, -- :: String -> WithError a -> IO a+        -- Like coerceWithErrorIO but also takes a String, which will+        -- be included in the eventual error message.++        coerceWithErrorOrBreakIOPrefix,+           -- :: String -> (String -> a) -> WithError a -> IO a+        coerceWithErrorOrBreakPrefix,+           -- :: String -> (String -> a) -> WithError a -> a++        MonadWithError(..),+        -- newtype which wraps a monadic action returning a WithError a.+        -- This is itself an instance of Monad, allowing functions defined+        -- on monads, such as mapM, work on them.+        monadifyWithError, -- :: Monad m => WithError a -> MonadWithError m a+        toMonadWithError, -- :: Monad m => m a -> MonadWithError m a++        coerceWithErrorOrBreak, -- :: (String -> a) -> WithError a -> a+        -- coerce or use the supplied break function (to be used with+        -- ExtendedPrelude.addFallOut)++        coerceWithErrorOrBreakIO, -- :: (String -> a) -> WithError a -> IO a+        -- coerce or use the supplied break function (to be used with+        -- ExtendedPrelude.addFallOut)+        -- The value is evaluated immediately.++        concatWithError, -- :: [WithError a] -> WithError [a]+        -- like pair but using lists.++        swapIOWithError, -- :: WithError (IO a) -> IO (WithError a)+        -- Intended for use on result of mapWithError, for example.++        exceptionToError,+        -- :: (Exception -> Maybe String) -> IO a -> IO (WithError a)+        -- Exception wrapper that turns those exceptions which map to+        -- (Just message) into an error.+        )+where++import Control.Monad++import Control.Exception++import Util.Debug(debug)++infixr 2 #+++-- --------------------------------------------------------------------------+-- Type Definitions+-- --------------------------------------------------------------------------++type Answer a = Either Exception a++-- --------------------------------------------------------------------------+-- Done+-- --------------------------------------------------------------------------++done :: Monad m => m ()+done = return ()+++-- --------------------------------------------------------------------------+-- Method Application+-- --------------------------------------------------------------------------++( # ) :: a -> (a -> b) -> b+o # f = f o+++-- --------------------------------------------------------------------------+-- IOError and Exception Handling+-- --------------------------------------------------------------------------++raise :: IOError -> IO a+raise e =+   do+      debug ("RAISED EXCP: " ++ (show e) ++ "\n")+      ioError e++propagate :: Answer a -> IO a+propagate (Left e) = throw e+propagate (Right v) = return v++catchall :: IO a -> IO a -> IO a+catchall c1 c2 = Control.Exception.catch c1 (\ _ -> c2)++tryUntilOK :: IO a -> IO a+tryUntilOK c = catchall c (tryUntilOK c)++-- --------------------------------------------------------------------------+-- Values paired with error messages+-- --------------------------------------------------------------------------++data WithError a =+      Error String+   |  Value a -- error or result++hasError :: String -> WithError a+hasError str = Error str++hasValue :: a -> WithError a+hasValue a = Value a++toWithError :: Either String a -> WithError a+toWithError (Left s) = Error s+toWithError (Right a) = Value a++isError :: WithError a -> Bool+isError (Error _) = True+isError (Value _) = False++fromWithError :: WithError a -> Either String a+fromWithError (Error s) = Left s+fromWithError (Value a) = Right a++fromWithError1 :: a -> WithError a -> a+fromWithError1 _ (Value a) = a+fromWithError1 a (Error _) = a++mapWithError :: (a -> b) -> WithError a -> WithError b+mapWithError f (Error e) = Error e+mapWithError f (Value x) = Value (f x)++mapWithError' :: (a -> WithError b) -> WithError a -> WithError b+mapWithError' f (Error e) = Error e+mapWithError' f (Value a) = f a+++mapWithErrorIO :: (a -> IO b) -> WithError a -> IO (WithError b)+mapWithErrorIO f (Error e) = return (Error e)+mapWithErrorIO f (Value a) =+   do+      b <- f a+      return (Value b)++mapWithErrorIO' :: (a -> IO (WithError b)) -> WithError a -> IO (WithError b)+mapWithErrorIO' f (Error e) = return (Error e)+mapWithErrorIO' f (Value a) = f a++pairWithError :: WithError a -> WithError b -> WithError (a,b)+-- we concatenate the errors, inserting a newline between them if there are two.+pairWithError (Value a) (Value b) = Value (a,b)+pairWithError (Error e) (Value b) = Error e+pairWithError (Value a) (Error f) = Error f+pairWithError (Error e) (Error f) = Error (e++"\n"++f)++listWithError :: [WithError a] -> WithError [a]+listWithError awes =+   foldr+      (\ awe awes ->+         mapWithError+            (\ (a,as) -> a:as)+            (pairWithError awe awes)+         )+      (hasValue [])+      awes++-- coerce or raise error+coerceWithError :: WithError a -> a+coerceWithError (Value a) = a+coerceWithError (Error err) = error err++coerceWithErrorIO :: WithError a -> IO a+coerceWithErrorIO (Value a) = return a+coerceWithErrorIO (Error err) = error err++coerceWithErrorStringIO :: String -> WithError a -> IO a+coerceWithErrorStringIO _ (Value a) = return a+coerceWithErrorStringIO mess (Error err) =+   error ("coerceWithErrorString " ++ mess ++ ": " ++ err)++-- | coerce or use the supplied break function (to be used with+-- 'ExtendedPrelude.addFallOut')+-- The value is evaluated immediately.+coerceWithErrorOrBreakIO :: (String -> a) -> WithError a -> IO a+coerceWithErrorOrBreakIO = coerceWithErrorOrBreakIOPrefix ""++-- | coerce or use the supplied break function (to be used with+-- 'ExtendedPrelude.addFallOut')+--+-- The first argument is prepended to any error message.+-- The value is evaluated immediately.+coerceWithErrorOrBreakIOPrefix+   :: String -> (String -> a) -> WithError a -> IO a+coerceWithErrorOrBreakIOPrefix errorPrefix breakFn aWe =+   do+      let+         a = coerceWithErrorOrBreakPrefix errorPrefix breakFn aWe+      seq a (return a)++-- | coerce or use the supplied break function (to be used with+-- 'ExtendedPrelude.addFallOut')+coerceWithErrorOrBreak :: (String -> a) -> WithError a -> a+coerceWithErrorOrBreak = coerceWithErrorOrBreakPrefix ""+++-- | coerce or use the supplied break function (to be used with+-- 'ExtendedPrelude.addFallOut')+--+-- The first argument is prepended to any error message.+coerceWithErrorOrBreakPrefix :: String -> (String -> a) -> WithError a -> a+coerceWithErrorOrBreakPrefix errorPrefix breakFn (Value a) = a+coerceWithErrorOrBreakPrefix errorPrefix breakFn (Error s)+   = breakFn (errorPrefix ++ s)++concatWithError :: [WithError a] -> WithError [a]+concatWithError withErrors =+   foldr+      (\ wE wEsf -> mapWithError (uncurry (:)) (pairWithError wE wEsf))+      (Value [])+      withErrors++swapIOWithError :: WithError (IO a) -> IO (WithError a)+swapIOWithError (Error e) = return (Error e)+swapIOWithError (Value act) =+   do+      v <- act+      return (Value v)++exceptionToError :: (Exception -> Maybe String) -> IO a -> IO (WithError a)+exceptionToError testFn action =+   catchJust+      testFn+      (do+          val <- action+          return (hasValue val)+      )+      (\ str -> return (hasError str))++instance Functor WithError where+   fmap aToB aWE = case aWE of+      Value a -> Value (aToB a)+      Error e -> Error e++instance Monad WithError where+   return v = hasValue v+   (>>=) aWE toBWe =+      mapWithError' toBWe aWE+   fail s = hasError s++newtype MonadWithError m a = MonadWithError (m (WithError a))++instance Monad m => Monad (MonadWithError m) where+   return v = MonadWithError (return (Value v))+   (>>=) (MonadWithError act1) getAct2 =+      MonadWithError (+         do+            valWithError <- act1+            case valWithError of+               Value v ->+                  let+                     (MonadWithError act2) = getAct2 v+                  in+                     act2+               Error s -> return (Error s)+         )+   fail s = MonadWithError (return (Error s))++monadifyWithError :: Monad m => WithError a -> MonadWithError m a+monadifyWithError we = MonadWithError (return we)++toMonadWithError :: Monad m => m a -> MonadWithError m a+toMonadWithError act = MonadWithError (+   do+      a <- act+      return (hasValue a)+   )++-- --------------------------------------------------------------------------+-- Derived Control Abstractions: Iteration+-- --------------------------------------------------------------------------++foreverUntil :: Monad m => m Bool -> m ()+foreverUntil act =+   do+      stop <- act+      if stop+         then+            done+         else+            foreverUntil act++foreach :: Monad m => [a] -> (a -> m b) -> m ()+foreach el c = sequence_ (map c el)   -- mapM c el++-- --------------------------------------------------------------------------+-- Derived Control Abstractions: Selection+-- --------------------------------------------------------------------------++incase :: Maybe a -> (a -> IO b) -> IO ()+incase Nothing f = done+incase (Just a) f = do {f a; done}++-- --------------------------------------------------------------------------+-- Loops+-- --------------------------------------------------------------------------++while :: Monad m => m a -> (a -> Bool) -> m a+while c p = c >>= \x -> if (p x) then while c p else return x+++-- --------------------------------------------------------------------------+-- Configuration Options+-- --------------------------------------------------------------------------++type Config w = w -> IO w++configure :: w -> [Config w] -> IO w+configure w [] = return w+configure w (c:cl) = do {w' <- c w; configure w' cl}++config :: IO () -> Config w+config f w = f >> return w+++-- --------------------------------------------------------------------------+-- New-style configuration+-- Where HasConfig is defined you can type+--     option1  $$ option2 $$ ... $$ initial_configuration+-- --------------------------------------------------------------------------++class HasConfig option configuration where+   ($$) :: option -> configuration -> configuration++   configUsed :: option -> configuration -> Bool+   -- In some implementations (EG a text-only+   -- implementation of the GraphDisp interface)+   -- we may create default configurations in which $$ simply+   -- ignores the option.  In such cases configUsed should return+   -- False.++infixr 0 $$+-- This makes $$ have fixity like $.+
+ Util/Debug.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}++-- |+-- MODULE        : Debug+-- AUTHOR        : George Russell+-- University of Bremen+-- DATE          : 2000+-- DESCRIPTION   : This module provides a uniform interface for debugging+--              purposes.  In final versions of this module it would+--              be best to make the debug function do nothing and+--              force it to be inlined.+--+-- #########################################################################++module Util.Debug(+  debug, -- show something to log file if debugging is turned on.++  debugAct,+  -- If an action fails print out a message before+  -- propagating message.+  (@:),+  -- inline version of debugAct++  -- The following functions work whether debugging is turned on or+  -- not, and are intended to be used when the debugging facility+  -- itself is causing strange effects . . .+  alwaysDebug,+  alwaysDebugAct,++  debugString, -- Send a string to the debug file.  This differs from+     -- debug, in that debug will Haskell-escape the string and add+     -- a newline, while just writes to the file with no interpretation.+  (@@:),+++  wrapError, -- :: String -> a -> a+     -- If debugging is on, transforms value so that when evaluated, if+     -- the evaluation calls an error call, the given String is prepended+     -- to the evaluation.+  ) where+import System.IO as IO+import System.IO.Error as IO++import System.IO.Unsafe+import Control.Exception++import Util.WBFiles++openDebugFile :: IO (Maybe Handle)+openDebugFile =+   do+      debugFileName <- getDebugFileName+      IO.catch (+         do+             handle <- openFile debugFileName WriteMode+             hSetBuffering handle NoBuffering+             return (Just handle)+         )+         (\ _-> return Nothing)++debugFile = unsafePerformIO openDebugFile+debugFile :: Maybe Handle+{-# NOINLINE debugFile #-}++#ifdef DEBUG+debugString s =+               case debugFile of+                  Just f -> IO.hPutStr f s+                  Nothing -> return ()++debug s =+               case debugFile of+                  Just f  -> IO.hPutStrLn f (show s)+                  Nothing -> return ()++debugAct mess act =+               do+                  res <- Control.Exception.try act+                  case res of+                     Left error ->+                        do+                           debug ("Debug.debug caught "++mess)+                           throw error+                     Right success -> return success++#else+debugString _ = return ()++debug _ = return ()+{-# inline debug #-}++debugAct _ act = act+{-# inline debugAct #-}+#endif++-- | show something to log file if debugging is turned on.+debug :: Show a => a -> IO()++-- | Send a string to the debug file.  This differs from+-- debug, in that debug will Haskell-escape the string and add+-- a newline, while just writes to the file with no interpretation.+debugString :: String -> IO ()++-- | If an action fails print out a message before+-- propagating message.+debugAct :: String -> IO a -> IO a++(@:) :: String -> IO a -> IO a+(@:) = debugAct+++-- | always show something to the log file+alwaysDebug :: Show a => a -> IO()+alwaysDebug s =+   case debugFile of+      Just f  -> IO.hPutStrLn f (show s)+      Nothing -> return ()++-- | always print out a message if action fails.+alwaysDebugAct :: String -> IO a -> IO a+alwaysDebugAct mess act =+   do+      res <- Control.Exception.try act+      case res of+         Left error ->+            do+               alwaysDebug ("AlwaysDebug.debug caught "++mess)+               throw error+         Right success -> return success++(@@:) :: String -> IO a -> IO a+(@@:) = alwaysDebugAct++wrapError :: String -> a -> a+#ifdef DEBUG+wrapError str value = unsafePerformIO (wrapErrorIO str value)+#else+wrapError str value = value+#endif++wrapErrorIO :: String -> a -> IO a+wrapErrorIO str value =+   Control.Exception.catchJust errorCalls (value `seq` return value)+      (\ mess -> error (str++":"++mess))++
+ Util/DeepSeq.hs view
@@ -0,0 +1,67 @@+-- | Module taken from Dean Harington's post to the Haskell mailing list+-- on Fri, 17 Aug 2001.+--+-- URL is currently+-- <http://www.haskell.org/pipermail/haskell/2001-August/007712.html>+--+-- This module provides 'deepSeq' and '$!!' which correspond to 'seq' and '$!'+-- except that they try to evaluate everything in the argument.  For example,+-- if a list is provided, the whole list must be evaluated.+--+-- For purposes of Haddock, empty instance declarations with @where@+-- have had the @where@ deleted.++module Util.DeepSeq where++class  DeepSeq a  where+   deepSeq :: a -> b -> b+   deepSeq = seq                        -- default, for simple cases++infixr 0 `deepSeq`, $!!++($!!) :: (DeepSeq a) => (a -> b) -> a -> b+f $!! x = x `deepSeq` f x+++instance  DeepSeq ()++instance  (DeepSeq a) => DeepSeq [a]  where+   deepSeq [] y = y+   deepSeq (x:xs) y = deepSeq x $ deepSeq xs y++instance  (DeepSeq a,DeepSeq b) => DeepSeq (a,b)  where+   deepSeq (a,b) y = deepSeq a $ deepSeq b y++instance  (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c)  where+   deepSeq (a,b,c) y = deepSeq a $ deepSeq b $ deepSeq c y++instance  (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d)  where+   deepSeq (a,b,c,d) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d y++instance  (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e)  where+   deepSeq (a,b,c,d,e) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e y++instance  (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f) => DeepSeq (a,b,c,d,e,f)  where+   deepSeq (a,b,c,d,e,f) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f y++instance  (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f,DeepSeq g) => DeepSeq (a,b,c,d,e,f,g)  where+   deepSeq (a,b,c,d,e,f,g) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g y++instance  DeepSeq Bool++instance  DeepSeq Char++instance  (DeepSeq a) => DeepSeq (Maybe a)  where+   deepSeq Nothing y = y+   deepSeq (Just x) y = deepSeq x y++instance  (DeepSeq a, DeepSeq b) => DeepSeq (Either a b)  where+   deepSeq (Left a) y = deepSeq a y+   deepSeq (Right b) y = deepSeq b y++instance  DeepSeq Ordering++instance  DeepSeq Integer+instance  DeepSeq Int+instance  DeepSeq Float+instance  DeepSeq Double
+ Util/Delayer.hs view
@@ -0,0 +1,206 @@+-- | Delayers handle delaying of actions; the main purpose is to delay+-- graph redrawing actions during complex updates.+module Util.Delayer(+   -- Client side+   Delayer,+   newDelayer, -- :: IO Delayer+   HasDelayer(..),+      -- :: Class of things which have a delayer.+      -- Delayer itself is an instance.+   delay, -- :: HasDelayer object => object -> IO a -> IO a+      -- carry out the given action preventing the Delayer from doing anything.++   -- Producer side+   DelayedAction,+   newDelayedAction, -- :: IO () -> IO DelayedAction+   delayedAct, -- :: Delayer -> DelayedAction -> IO ()+      -- If no delay is taking place, perform the DelayedAction action+      -- immediately.  Otherwise remember to do it when are no longer inside+      -- a delay.+      -- If the same DelayedAction is queued multiple times when a Delayer+      -- is delay'd, we nevertheless only do it once.+   cancelDelayedAct, -- :: Delayer -> DelayedAction -> IO ()+      -- If this DelayedAction is queued, remove it from the queue.++   HasAddDelayer(..),+   -- Instances of HasAddDelayer are event sources to which you can attach+   --    a delayer, to indicate you are currently not interested in events.++   HasAddDelayerIO(..),+   -- Like HasAddDelayer, but allows an IO action.+   ) where++import Control.Concurrent.MVar+import Control.Exception++import qualified Data.Set as Set++import Util.Object+import Util.Computation(done)++-- ------------------------------------------------------------------------+-- Data types+-- ------------------------------------------------------------------------++data DelayedAction = DelayedAction {+   oId :: ObjectID,+   action :: IO ()+   }++data DelayerState = DelayerState {+   delayCount ::  ! Int, -- ^ 0 when not delay'd.+   delayedActions :: Set.Set DelayedAction+   }++data Delayer = Delayer (MVar DelayerState)++-- ------------------------------------------------------------------------+-- HasAddDelayer+-- ------------------------------------------------------------------------++-- | Instances of HasAddDelayer are event sources to which you can attach+--   a delayer, to indicate you are currently not interested in events.+class HasAddDelayer eventSource where+   addDelayer :: Delayer -> eventSource -> eventSource++-- | Like HasAddDelayer, but allows an IO action.+class HasAddDelayerIO eventSource where+   addDelayerIO :: Delayer -> eventSource -> IO eventSource++-- ------------------------------------------------------------------------+-- HasDelayer+-- ------------------------------------------------------------------------++class HasDelayer object where+   toDelayer :: object -> Delayer++-- ------------------------------------------------------------------------+-- Instances+-- ------------------------------------------------------------------------++instance Eq DelayedAction where+   (==) act1 act2 = (==) (oId act1) (oId act2)++instance Ord DelayedAction where+   compare act1 act2 = compare (oId act1) (oId act2)++instance HasDelayer Delayer where+   toDelayer delayer = delayer++-- ------------------------------------------------------------------------+-- Client Side+-- ------------------------------------------------------------------------++newDelayer :: IO Delayer+newDelayer =+   do+      mVar <- newMVar emptyDelayerState+      return (Delayer mVar)++-- | carry out the given action preventing the Delayer from doing anything.+delay :: HasDelayer object => object -> IO a -> IO a+delay object action =+   do+      let+         delayer = toDelayer object+      beginDelay delayer+      finally action (endDelay delayer)++beginDelay :: Delayer -> IO ()+beginDelay (Delayer mVar) =+   modifyMVar_ mVar (\ delayerState0 ->+      do+         let+            delayCount1 = delayCount delayerState0 + 1++            delayerState1 = delayerState0 {delayCount = delayCount1}++         seq delayerState1 (return delayerState1)+      )++endDelay :: Delayer -> IO ()+endDelay (Delayer mVar) =+   do+      -- to reduce the danger of deadlocks, we don't perform the actions while+      -- the MVar is empty.+      afterAct <- modifyMVar mVar (\ delayerState0 ->+         do+            let+               delayCount1 = delayCount delayerState0 - 1+            return (if delayCount1 > 0+               then+                  (delayerState0 {delayCount = delayCount1},done)+               else+                  let+                     afterAct = mapM_+                        (\ delayedAction -> action delayedAction)+                        (Set.toList (delayedActions delayerState0))+                  in+                     (emptyDelayerState,afterAct)+               )+         )+      afterAct+++emptyDelayerState :: DelayerState+emptyDelayerState = DelayerState {+   delayCount = 0,+   delayedActions = Set.empty+   }+++-- ------------------------------------------------------------------------+-- Producer side+-- ------------------------------------------------------------------------++newDelayedAction :: IO () -> IO DelayedAction+newDelayedAction action =+   do+      oId <- newObject+      let+         delayedAction = DelayedAction {+            oId = oId,+            action = action+            }++      return delayedAction++-- } If no delay is taking place, perform the DelayedAction action+-- immediately.  Otherwise remember to do it when are no longer inside+-- a delay.+-- If the same DelayedAction is queued multiple times when a Delayer+-- is delay'd, we nevertheless only do it once.+delayedAct :: Delayer -> DelayedAction -> IO ()+delayedAct (Delayer mVar) delayedAct =+   do+      afterAct <- modifyMVar mVar (\ delayerState0 ->+         return (+            if delayCount delayerState0 == 0+               then+                  (delayerState0,action delayedAct)+               else+                  let+                     delayedActions1 = Set.insert delayedAct+                        (delayedActions delayerState0)++                     delayerState1 = delayerState0 {+                        delayedActions = delayedActions1+                        }+                  in+                     (delayerState1,done)+            )+         )+      afterAct++-- | If this DelayedAction is queued, remove it from the queue.+cancelDelayedAct :: Delayer -> DelayedAction -> IO ()+cancelDelayedAct (Delayer mVar) delayedAction =+   modifyMVar_ mVar (\ delayerState0 ->+      let+         delayedActions1+            = Set.delete delayedAction (delayedActions delayerState0)++         delayerState1 = delayerState0 {delayedActions = delayedActions1}+      in+         return delayerState1+      )
+ Util/Dynamics.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}++-- | A wrapper for the new GHC (and Hugs) Dynamic module.+-- The main improvement over the original Dynamic module is+-- that we provide flavours of TypeableXXXX for kinds with+-- arguments other than *, a feature used by "DisplayView".+module Util.Dynamics (+        Typeable(..), -- inherited from Dynamic+        TypeRep, -- same as Dynamic.TypeRep+++        Dyn, -- equal to Dynamic.Dynamic+        toDyn, -- inherited from Dynamic.toDyn+        fromDynamic, -- inherited from Dynamic.fromDynamic+        fromDynamicWE, -- :: Dyn -> WithError a++        coerce, -- read Dyn or (match) error+        coerceIO, -- read Dyn or fail with typeMismatch+        typeMismatch,+        dynCast, -- Cast to another value of the same type, or+           -- error (useful for extracting from existential types).+        dynCastOpt,++        mkTypeRep,+           -- :: String -> String -> TypeRep++        -- Flavours of Typeable we need not already in Data.Typeable.+        -- The only customer for these at the moment seems to be+        -- types/DisplayView.hs+        Typeable1_1(..),+        Typeable2_11(..),+        Typeable3_111(..),+        Typeable4_0111(..),+        Typeable5_00111(..),+        Typeable6_000111(..),+        )+where++import qualified Data.Dynamic+import Data.Typeable++import Util.Computation+import Util.Debug(debug)++fromDynamic :: Typeable a => Dyn -> Maybe a+fromDynamic = Data.Dynamic.fromDynamic++-- | Like 'fromDynamic' but provides an error message indicating what+-- types are getting confused.+fromDynamicWE :: Typeable a => Dyn -> WithError a+fromDynamicWE dyn =+   case fromDynamic dyn of+      Just a -> return a+      (aOpt @ Nothing) ->+         fail ("Dynamic type error.  Looking for "+            ++ show (typeOf (typeHack aOpt))+            ++ " but found a " ++ show dyn)+   where+      typeHack :: Maybe a -> a+      typeHack _ = undefined+type Dyn = Data.Dynamic.Dynamic++toDyn :: Typeable a => a -> Dyn+toDyn = Data.Dynamic.toDyn++coerce  :: Typeable a => Dyn -> a+coerce d =+   case fromDynamic d of+      Just x -> x++coerceIO :: Typeable a => Dyn -> IO a+coerceIO d =+   case fromDynamic d of+      Nothing ->+         do+            debug "Dynamics.coerceIO failure"+            ioError typeMismatch+      (Just x) -> return x++typeMismatch :: IOError+typeMismatch =+        userError "internal type of dynamics does not match expected type"++dynCast :: (Typeable a,Typeable b) => String -> a -> b+dynCast mess value = case dynCastOpt value of+   Nothing -> error ("Dynamics.dynCast failure in "++mess)+   Just value2 -> value2++dynCastOpt :: (Typeable a,Typeable b) => a -> Maybe b+dynCastOpt = Data.Dynamic.cast++-- | Construct a TypeRep for a type or type constructor with no arguments.+-- The first string should be the module name, the second that of the type.+mkTypeRep :: String -> String -> TypeRep+mkTypeRep s1 s2 = mkTyConApp (mkTyCon (s1 ++ "." ++ s2)) []++-- ------------------------------------------------------------+-- Flavours of Typeable we need not already in Data.Typeable.+-- The only customer for these at the moment seems to be+-- types/DisplayView.hs+-- ------------------------------------------------------------++class Typeable1_1 ty where+   typeOf1_1 :: Typeable1 typeArg => ty typeArg -> TypeRep++instance (Typeable1_1 ty,Typeable1 typeArg) => Typeable (ty typeArg) where+   typeOf (x :: ty typeArg) = (typeOf1_1 x) `mkAppTy` typeOf v+      where+         v :: typeArg ()+         v = error "Dynamics.31"++class Typeable2_11 ty where+   typeOf2_11 :: (Typeable1 typeArg1,Typeable1 typeArg2)+      => ty typeArg1 typeArg2 -> TypeRep++instance (Typeable2_11 ty,Typeable1 typeArg1)+      => Typeable1_1 (ty typeArg1) where+   typeOf1_1 (x :: ty typeArg1 typeArg2) =+         (typeOf2_11 x) `mkAppTy` (typeOf1 v)+      where+         v :: typeArg1 ()+         v = error "Dynamics.23"++class Typeable3_111 ty where+   typeOf3_111 :: (Typeable1 typeArg1,Typeable1 typeArg2,Typeable1 typeArg3)+      => ty typeArg1 typeArg2 typeArg3 -> TypeRep++instance (Typeable3_111 ty,Typeable1 typeArg1)+      => Typeable2_11 (ty typeArg1) where+   typeOf2_11 (x :: ty typeArg1 typeArg2 typeArg3) =+         (typeOf3_111 x) `mkAppTy` (typeOf1 v)+      where+         v :: typeArg1 ()+         v = error "Dynamics.23"++class Typeable4_0111 ty where+   typeOf4_0111+      :: (Typeable ty1,+         Typeable1 typeArg1,Typeable1 typeArg2,Typeable1 typeArg3)+      => ty ty1 typeArg1 typeArg2 typeArg3  -> TypeRep++instance (Typeable4_0111 ty,Typeable ty1)+      => Typeable3_111 (ty ty1) where+   typeOf3_111 (x :: ty ty1 typeArg2 typeArg3 typeArg4) =+         (typeOf4_0111 x) `mkAppTy` (typeOf v)+      where+         v :: ty1+         v = error "Dynamics.23"++class Typeable5_00111 ty where+   typeOf5_00111+      :: (Typeable ty1,Typeable ty2,+         Typeable1 typeArg1,Typeable1 typeArg2,Typeable1 typeArg3)+      => ty ty1 ty2 typeArg1 typeArg2 typeArg3  -> TypeRep++instance (Typeable5_00111 ty,Typeable ty1)+      => Typeable4_0111 (ty ty1) where+   typeOf4_0111 (x :: ty ty1 ty2 typeArg1 typeArg2 typeArg3) =+         (typeOf5_00111 x) `mkAppTy` (typeOf v)+      where+         v :: ty1+         v = error "Dynamics.23"++class Typeable6_000111 ty where+   typeOf6_000111+      :: (Typeable ty1,Typeable ty2,Typeable ty3,+         Typeable1 typeArg1,Typeable1 typeArg2,Typeable1 typeArg3)+      => ty ty1 ty2 ty3 typeArg1 typeArg2 typeArg3  -> TypeRep++instance (Typeable6_000111 ty,Typeable ty1)+      => Typeable5_00111 (ty ty1) where+   typeOf5_00111 (x :: ty ty1 ty2 ty3 typeArg1 typeArg2 typeArg3) =+         (typeOf6_000111 x) `mkAppTy` (typeOf v)+      where+         v :: ty1+         v = error "Dynamics.23"+
+ Util/ExtendedPrelude.hs view
@@ -0,0 +1,794 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoMonoPatBinds #-}++-- |+-- Description : What the Prelude Forgot+--+-- Basic string-manipulation and other functions they forgot to put in+-- the standard prelude.+module Util.ExtendedPrelude (+   -- * Trimming spaces from Strings and putting them back again.+   trimTrailing,+   trimLeading,+   trimSpaces,+   padToLength,++   -- * Miscellaneous functions+   monadDot,+   simpleSplit,+   findJust,+   insertOrdLt,+   insertOrdGt,+   insertOrd,+   insertOrdAlternate,+   bottom,++   readCheck,+      -- :: (Read a) => String -> Maybe a+      -- returns Just a if we can read a, and the rest is just spaces.++   chop, -- :: Int -> [a] -> Maybe [a]+      -- removes last elements from a list+   pairList, -- :: a -> [b] -> [(a,b)]+      -- pair of elements of a list.+   lastOpt, -- :: [a] -> Maybe a+      -- gets the last element of a list, safely.++   isPrefix,+      -- :: Eq a => [a] -> [a] -> Just [a]+      -- returns remainder if the first list is a prefix of the second one.++   -- Indicates that this type allows an IO-style map.+   HasCoMapIO(..),+   HasMapIO(..),+   HasMapMonadic(..),+   mapPartialM,++   splitByChar,++   -- * Miscellaneous string and list operations+   unsplitByChar,+   unsplitByChar0,+   splitToChar,+   splitToElem,+   splitToElemGeneral,+   deleteFirst,+   deleteFirstOpt,+   deleteAndFindFirst,+   deleteAndFindFirstOpt,+   divideList,++   -- | Folding on trees+   treeFold,+   treeFoldM,++   mapEq, -- used for instancing Eq+   mapOrd, -- used for instancing Ord.++   -- * Exception-driven error mechanism.+   BreakFn,+   addFallOut,+   addFallOutWE,++   addSimpleFallOut,+   simpleFallOut,+   mkBreakFn,+   newFallOut,+   isOurFallOut, -- :: ObjectID -> Exception -> Maybe String++   addGeneralFallOut,+   GeneralBreakFn(..),GeneralCatchFn(..),+   catchOurExceps, -- :: IO a -> IO (Either String a)+   catchAllExceps, -- :: IO a -> IO (Either String a)+   errorOurExceps, -- :: IO a -> IO a+   ourExcepToMess, -- :: Exception -> Maybe String+   breakOtherExceps, -- :: BreakFn -> IO a -> IO a+   showException2, -- :: Exception -> String++   -- * Other miscellaneous functions+   EqIO(..),OrdIO(..),+   Full(..),++   uniqOrd,+   uniqOrdOrder,++   uniqOrdByKey, -- :: Ord b => (a -> b) -> [a] -> [a]+   uniqOrdByKeyOrder, -- :: Ord b => (a -> b) -> [a] -> [a]+   -- Remove duplicate elements from a list where the key function is supplied.+   allSame,+   allEq, -- :: Eq a => [a] -> Bool+   findDuplicate, -- :: Ord a => (b -> a) -> [b] -> Maybe b++   generalisedMerge,+   ) where++import Data.Char+import Control.Monad+import Data.Maybe+import qualified Data.Map as Map++import qualified Data.Set as Set+import Control.Exception+import System.IO.Unsafe++import Util.Object+import Util.Computation+import Util.Dynamics++-- ---------------------------------------------------------------------------+-- Character operations+-- ---------------------------------------------------------------------------++-- | Remove trailing spaces (We try to avoid reconstructing the string,+-- on the assumption that there aren't often spaces)+trimTrailing :: String -> String+trimTrailing str =+   case tt str of+      Nothing -> str+      Just str2 -> str2+   where+      tt [] = Nothing+      tt (str@[ch]) = if isSpace ch then Just [] else Nothing+      tt (ch:rest) =+         case tt rest of+            Nothing -> Nothing+            (j@(Just "")) -> if isSpace ch then j else Just [ch]+            Just trimmed -> Just (ch:trimmed)++-- | Remove leading spaces+trimLeading :: String -> String+trimLeading [] = []+trimLeading (str@(ch:rest)) = if isSpace ch then trimLeading rest else str++-- | Remove trailing and leading spaces+trimSpaces :: String -> String+trimSpaces = trimTrailing . trimLeading++-- | Pad a string if necessary to the given length with leading spaces.+padToLength :: Int -> String -> String+padToLength l s =+   let+      len = length s+   in+      if len < l+         then+            replicate (l - len) ' ' ++ s+         else+            s++-- | returns Just a if we can read a, and the rest is just spaces.+readCheck :: Read a => String -> Maybe a+readCheck str = case reads str of+   [(val,s)] | all isSpace s  -> Just val+   _ -> Nothing+++-- ---------------------------------------------------------------------------+-- Monad Operations+-- ---------------------------------------------------------------------------++-- | The "." operator lifted to monads.   So like ., the arguments+-- are given in the reverse order to that in which they should+-- be executed.+monadDot :: Monad m =>  (b -> m c) -> (a -> m b) -> (a -> m c)+monadDot f g x =+   do+      y <- g x+      f y++-- ---------------------------------------------------------------------------+-- Things to do with maps+-- ---------------------------------------------------------------------------++class HasMapIO option where+   mapIO :: (a -> IO b) -> option a -> option b++class HasCoMapIO option where+   coMapIO :: (a -> IO b) -> option b -> option a++class HasMapMonadic h where+   mapMonadic :: Monad m => (a -> m b) -> h a -> m (h b)++instance HasMapMonadic [] where+   mapMonadic = mapM++mapPartialM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapPartialM mapFn as =+   do+      bOpts <- mapM mapFn as+      return (catMaybes bOpts)+{-# SPECIALIZE mapPartialM :: (a -> IO (Maybe b)) -> [a] -> IO [b] #-}++-- ---------------------------------------------------------------------------+-- List Operations+-- ---------------------------------------------------------------------------++simpleSplit :: (a -> Bool) -> [a] -> [[a]]+simpleSplit p s = case dropWhile p s of+                [] -> []+                s' -> w : simpleSplit p s''+                      where (w,s'') = break p s'++findJust :: (a -> Maybe b) -> [a] -> Maybe b+findJust f [] = Nothing+findJust f (x:xs) = case f x of+   (y@ (Just _)) -> y+   Nothing -> findJust f xs++deleteFirst :: (a -> Bool) -> [a] -> [a]+deleteFirst fn [] = error "ExtendedPrelude.deleteFirst - not found"+deleteFirst fn (a:as) =+   if fn a then as else a:deleteFirst fn as++deleteFirstOpt :: (a -> Bool) -> [a] -> [a]+deleteFirstOpt fn as = case deleteAndFindFirstOpt fn as of+   Nothing -> as+   Just (_,as) -> as++deleteAndFindFirst :: (a -> Bool) -> [a] -> (a,[a])+deleteAndFindFirst fn []+   = error "ExtendedPrelude.deleteAndFindFirst - not found"+deleteAndFindFirst fn (a:as) =+   if fn a then (a,as) else+      let+         (a1,as1) = deleteAndFindFirst fn as+      in+         (a1,a:as1)++deleteAndFindFirstOpt :: (a -> Bool) -> [a] -> Maybe (a,[a])+deleteAndFindFirstOpt fn [] = Nothing+deleteAndFindFirstOpt fn (a:as) =+   if fn a then Just (a,as) else+      fmap+         (\ (a1,as1) -> (a1,a:as1))+         (deleteAndFindFirstOpt fn as)++divideList :: (a -> Either b c) -> [a] -> ([b],[c])+divideList fn [] = ([],[])+divideList fn (a:as) =+   let+      (bs,cs) = divideList fn as+   in+      case fn a of+         Left b -> (b:bs,cs)+         Right c -> (bs,c:cs)+++-- ---------------------------------------------------------------------------+-- Ordered List Operations+-- ---------------------------------------------------------------------------++insertOrdLt :: Ord a => a -> [a] -> [a]+insertOrdLt x l = insertOrd (<=) x l++insertOrdGt :: Ord a => a -> [a] -> [a]+insertOrdGt x l = insertOrd (>=) x l++insertOrd :: (a -> a -> Bool) -> a -> [a] -> [a]+insertOrd p x [] = [x]+insertOrd p x ll@(e:l) =+   if p x e+   then+      x : ll+   else+      e : (insertOrd p x l)+++-- | insertOrdAlternate is similar to insertOrd except (1) it takes an Ordering+-- argument; (2) if it finds an argument that matches, it applies the+-- given function to generate a new element, rather than inserting another.+-- The new generated element should be EQ to the old one.+insertOrdAlternate :: (a -> a -> Ordering) -> a -> (a -> a) -> [a] -> [a]+insertOrdAlternate p x merge [] = [x]+insertOrdAlternate p x merge (ll@(e:l)) =+   case p x e of+      LT -> x : ll+      EQ -> merge e : l+      GT -> e : insertOrdAlternate p x merge l++-- ---------------------------------------------------------------------------+-- bottom+-- ---------------------------------------------------------------------------++bottom :: a+bottom = error "Attempted to evaluate ExtendedPrelude.bottom"+++-- ---------------------------------------------------------------------------+-- Splitting a string up into a list of strings and unsplitting back+-- by a single character.+-- Examples:+--    splitByChar '.' "a.b.." = ["a","b","",""]+--    splitByChar '.' "" = [""]+-- unsplitByChar is the inverse function.+-- unsplitByChar0 allows the empty list.+-- ---------------------------------------------------------------------------++splitByChar :: Char -> String -> [String]+splitByChar ch s = split s+   where+      split s = case splitTo s of+         Nothing -> [s]+         Just (s1,s2) -> s1 : split s2++      splitTo [] = Nothing+      splitTo (c:cs) = if c == ch then Just ([],cs) else+         fmap+            (\ (cs1,cs2) -> (c:cs1,cs2))+            (splitTo cs)++unsplitByChar :: Char -> [String] -> String+unsplitByChar ch [] = error "unsplitByChar not defined for empty list"+unsplitByChar ch l = foldr1 (\w s -> w ++ ch:s) l++unsplitByChar0 :: Char -> [String] -> String+unsplitByChar0 ch [] = ""+unsplitByChar0 ch l = unsplitByChar ch l++-- ------------------------------------------------------------------------+-- Splitting to and after a character+-- ------------------------------------------------------------------------++-- | We split at the first occurrence of the character, returning the+-- string before and after.+splitToChar :: Char -> String -> Maybe (String,String)+splitToChar c = sTC+   where+      sTC [] = Nothing+      sTC (x:xs) =+         if x == c then Just ([],xs) else+            fmap+               (\ (xs1,xs2) -> (x:xs1,xs2))+               (sTC xs)++-- ------------------------------------------------------------------------+-- Like splitToChar, but with an arbitrary predicate.+-- ------------------------------------------------------------------------++splitToElem :: (a -> Bool) -> [a] -> Maybe ([a],[a])+splitToElem fn = sTC+   where+      sTC [] = Nothing+      sTC (x:xs) =+         if fn x then Just ([],xs) else+            fmap+               (\ (xs1,xs2) -> (x:xs1,xs2))+               (sTC xs)++-- ------------------------------------------------------------------------+-- Like splitToElem, but also return the matching element+-- ------------------------------------------------------------------------++splitToElemGeneral :: (a -> Bool) -> [a] -> Maybe ([a],a,[a])+splitToElemGeneral fn = sTC+   where+      sTC [] = Nothing+      sTC (x:xs) =+         if fn x then Just ([],x,xs) else+            fmap+               (\ (xs1,x1,xs2) -> (x:xs1,x1,xs2))+               (sTC xs)++-- ------------------------------------------------------------------------+-- Removing the last n elements from a list+-- ------------------------------------------------------------------------++chop :: Int -> [a] -> Maybe [a]+chop n list =+   let+      toTake = length list - n+   in+      if toTake >=0 then Just (take toTake list) else Nothing++-- ------------------------------------------------------------------------+-- Pair off elements of a list+-- ------------------------------------------------------------------------++pairList :: a -> [b] -> [(a,b)]+pairList a bs = fmap (\ b -> (a,b)) bs++-- ------------------------------------------------------------------------+-- Get the last element (safely)+-- ------------------------------------------------------------------------++lastOpt :: [a] -> Maybe a+lastOpt [] = Nothing+lastOpt [a] = Just a+lastOpt (_:rest) = lastOpt rest+++-- ------------------------------------------------------------------------+-- Prefix functions+-- ------------------------------------------------------------------------++++-- | returns remainder if the first list is a prefix of the second one.+isPrefix :: Eq a => [a] -> [a] -> Maybe [a]+isPrefix [] s = Just s+isPrefix (c1 : c1s) (c2 : c2s) | c1 == c2+   = isPrefix c1s c2s+isPrefix _ _ = Nothing++-- ------------------------------------------------------------------------+-- Folding a Tree+-- ------------------------------------------------------------------------++-- | node is the tree's node type.+-- state is folded through every node of the tree (and is the result).+-- We search the tree in depth-first order, applying visitNode at each+--   node to update the state.+-- The ancestorInfo information comes from the ancestors of the node.  EG+-- if we are visiting node N1 which came from N2 the ancestorInfo given to+-- visitNode for N1 will be that computed from visitNode for N2.+-- For the root node, it will be initialAncestor+treeFold ::+   (ancestorInfo -> state -> node -> (ancestorInfo,state,[node]))+   -> ancestorInfo -> state -> node+   -> state+treeFold visitNode initialAncestor initialState node =+   let+      (newAncestor,newState,children)+         = visitNode initialAncestor initialState node+   in+      foldl+         (\ state node -> treeFold visitNode newAncestor state node)+         newState+         children++-- | Like treeFold, but using monads.+treeFoldM :: Monad m =>+   (ancestorInfo -> state -> node -> m (ancestorInfo,state,[node]))+   -> ancestorInfo -> state -> node+   -> m state+treeFoldM visitNode initialAncestor initialState node =+   do+      (newAncestor,newState,children)+         <- visitNode initialAncestor initialState node+      foldM+         (\ state node -> treeFoldM visitNode newAncestor state node)+         newState+         children++-- ------------------------------------------------------------------------+-- Functions which make it easy to create new instances of Eq and Ord.+-- ------------------------------------------------------------------------++-- | Produce an equality function for b+mapEq :: Eq a => (b -> a) -> (b -> b -> Bool)+mapEq toA b1 b2 = (toA b1) == (toA b2)++-- | Produce a compare function for b+mapOrd :: Ord a => (b -> a) -> (b -> b -> Ordering)+mapOrd toA b1 b2 = compare (toA b1) (toA b2)++-- ------------------------------------------------------------------------+-- Adding fall-out actions to IO actions+-- ------------------------------------------------------------------------++-- | A function indicating we want to escape from the current computation.+type BreakFn = (forall other . String -> other)++-- |  Intended use, EG+--    addFallOut (\ break ->+--       do+--          -- blah blah (normal IO a stuff) --+--          when (break condition)+--             (break "You can't do that there ere")+--          -- more blah blah, not executed if there's an break --+--          return (value of type a)+--       )+addFallOut :: (BreakFn -> IO a) -> IO (Either String a)+addFallOut getAct =+   do+      (id,tryFn) <- newFallOut+      tryFn (getAct (mkBreakFn id))++-- | Like addFallOut, but returns a WithError object instead.+addFallOutWE :: (BreakFn -> IO a) -> IO (WithError a)+addFallOutWE toAct =+   do+      result <- addFallOut toAct+      return (toWithError result)+++simpleFallOut :: BreakFn+simpleFallOut = mkBreakFn simpleFallOutId++addSimpleFallOut :: IO a -> IO (Either String a)+simpleFallOutId :: ObjectID++(simpleFallOutId,addSimpleFallOut) = mkSimpleFallOut++mkSimpleFallOut = unsafePerformIO newFallOut+{-# NOINLINE mkSimpleFallOut #-}++data FallOutExcep = FallOutExcep {+   fallOutId :: ObjectID,+   mess :: String+   } deriving (Typeable)++mkBreakFn :: ObjectID -> BreakFn+mkBreakFn id mess = throwDyn (FallOutExcep {fallOutId = id,mess = mess})+++newFallOut :: IO (ObjectID,IO a -> IO (Either String a))+newFallOut =+   do+      id <- newObject+      let+         tryFn act = tryJust (isOurFallOut id) act++      return (id,tryFn)++isOurFallOut :: ObjectID -> Exception -> Maybe String+isOurFallOut oId exception =+   case dynExceptions exception of+      Nothing -> Nothing+         -- don't handle this as it's not even a dyn.+      Just dyn ->+         case fromDynamic dyn of+            Nothing -> Nothing -- not a fallout.+            Just fallOutExcep -> if fallOutId fallOutExcep /= oId+               then+                  Nothing+                  -- don't handle this; it's from another+                  -- addFallOut+               else+                  Just (mess fallOutExcep)+++-- ------------------------------------------------------------------------+-- More general try/catch function.+-- ------------------------------------------------------------------------++data GeneralBreakFn a = GeneralBreakFn (forall b . a -> b)+data GeneralCatchFn a = GeneralCatchFn (forall c . IO c -> IO (Either a c))++addGeneralFallOut :: Typeable a => IO (GeneralBreakFn a,GeneralCatchFn a)+addGeneralFallOut =+   do+      (objectId,catchFn) <- newGeneralFallOut+      let+         breakFn a = throwDyn (GeneralFallOutExcep {+            generalFallOutId = objectId,a=a})+      return (GeneralBreakFn breakFn,catchFn)+++data GeneralFallOutExcep a = GeneralFallOutExcep {+   generalFallOutId :: ObjectID,+   a :: a+   } deriving (Typeable)++newGeneralFallOut :: Typeable a => IO (ObjectID,GeneralCatchFn a)+newGeneralFallOut =+   do+      id <- newObject+      let+         tryFn act =+            tryJust+               (\ exception -> case dynExceptions exception of+                  Nothing -> Nothing+                     -- don't handle this as it's not even a dyn.+                  Just dyn ->+                     case fromDynamic dyn of+                        Nothing -> Nothing+                           -- not a fallout, or not the right type of a.+                        Just generalFallOutExcep ->+                              if generalFallOutId generalFallOutExcep /= id+                           then+                              Nothing+                              -- don't handle this; it's from another+                              -- addGeneralFallOut+                           else+                              Just (a generalFallOutExcep)+                  )+               act++      return (id,GeneralCatchFn tryFn)++-- ------------------------------------------------------------------------+-- General catch function for our exceptions.+-- ------------------------------------------------------------------------++ourExcepToMess :: Exception -> Maybe String+ourExcepToMess excep = case dynExceptions excep of+   Nothing -> Nothing+   Just dyn ->+      case fromDynamic dyn of+         Just fallOut -> Just ("Fall-out exception "+            ++ show (fallOutId fallOut) ++ ": " ++ mess fallOut)+         Nothing -> Just ("Mysterious dynamic exception " ++ show dyn)++showException2 :: Exception -> String+showException2 exception =+   fromMaybe (show exception) (ourExcepToMess exception)++catchOurExceps :: IO a -> IO (Either String a)+catchOurExceps act =+   tryJust ourExcepToMess act++catchAllExceps :: IO a -> IO (Either String a)+catchAllExceps act =+   do+      result <- Control.Exception.try act+      return (case result of+         Left excep -> Left (showException2 excep)+         Right a -> Right a+         )++errorOurExceps :: IO a -> IO a+errorOurExceps act =+   do+      eOrA <- catchOurExceps act+      case eOrA of+         Left mess -> error mess+         Right a -> return a++breakOtherExceps :: BreakFn -> IO a -> IO a+breakOtherExceps break act =+   catchJust+      (\ excep -> if isJust (ourExcepToMess excep)+         then+            Nothing+         else+            Just (break ("Haskell Exception: " ++ show excep))+         )+      act+      id+++++-- ------------------------------------------------------------------------+-- Miscellanous equality types+-- ------------------------------------------------------------------------++-- | indicates that an Ord or Eq instance really does need to+-- take everything into account.+newtype Full a = Full a++-- ------------------------------------------------------------------------+-- Where equality and comparing requires IO.+-- ------------------------------------------------------------------------++class EqIO v where+   eqIO :: v -> v -> IO Bool++class EqIO v => OrdIO v where+   compareIO :: v -> v -> IO Ordering++-- ------------------------------------------------------------------------+-- Eq/Ord operations+-- ------------------------------------------------------------------------+++-- | Remove duplicate elements from a list.+uniqOrd :: Ord a => [a] -> [a]+uniqOrd = Set.toList . Set.fromList++-- | Remove duplicate elements from a list where the key function is supplied.+uniqOrdByKey :: Ord b => (a -> b) -> [a] -> [a]+uniqOrdByKey (getKey :: a -> b) (as :: [a]) =+   let+      fm :: Map.Map b a+      fm = Map.fromList+         (fmap+            (\ a -> (getKey a,a))+            as+            )+  in+     fmap snd (Map.toList fm)++-- | Remove duplicate elements from a list where the key function is supplied.+-- The list order is preserved and of the duplicates, it is the first in the+-- list which is not deleted.+uniqOrdByKeyOrder :: Ord b => (a -> b) -> [a] -> [a]+uniqOrdByKeyOrder (getKey :: a -> b) =+   let+      u :: Set.Set b -> [a] -> [a]+      u visited [] = []+      u visited (a:as) =+         if Set.member key visited+            then+               u visited as+            else+               a : u (Set.insert key visited) as+         where+            key = getKey a+   in+      u Set.empty++-- | Like uniqOrd, except that we specify the output order of the list.+-- The resulting list is that obtained by deleting all duplicate elements+-- in the list, except the first, for example [1,2,3,2,1,4] will go to+-- [1,2,3,4].+uniqOrdOrder :: Ord a => [a] -> [a]+uniqOrdOrder list = mkList Set.empty list+   where+      mkList _ [] = []+      mkList set (a : as) =+         if Set.member a set+            then+               mkList set as+            else+               a : mkList (Set.insert a set) as++-- | If there are two elements of the list with the same (a), return one,+-- otherwise Nothing.+findDuplicate :: Ord a => (b -> a) -> [b] -> Maybe b+findDuplicate toA bs = fd Set.empty bs+   where+      fd _ [] = Nothing+      fd aSet0 (b:bs) =+         let+            a = toA b+         in+            if Set.member a aSet0+               then+                  Just b+               else+                  fd (Set.insert a aSet0) bs++-- | Return Just True if all the elements give True, Just False if all False,+-- Nothing otherwise (or list is empty).+allSame :: (a -> Bool) -> [a] -> Maybe Bool+allSame fn [] = Nothing+allSame fn (a : as) =+   if fn a+      then+         if all fn as+            then+               Just True+            else+               Nothing+      else+         if any fn as+            then+               Nothing+            else+               Just False++-- | If all the elements are equal, return True+allEq :: Eq a => [a] -> Bool+allEq [] = True+allEq (a:as) = all (== a) as++-- ------------------------------------------------------------------------+-- Generalised Merge+-- ------------------------------------------------------------------------++-- | A merge function for combining an input list with some new data,+-- where both are pre-sorted.+generalisedMerge :: (Monad m)+   => [a] -- ^ input list+   -> [b] -- ^ list to combine with input list+   -> (a -> b -> Ordering)+          -- ^ comparison function.  a and b should be already sorted+          -- consistently with this comparison function, and it is assumed+          -- that each list is EQ to at most one of the other.+   -> (Maybe a -> Maybe b -> m (Maybe a,Maybe c))+          -- ^ Merge function applied to each element of a and b, where+          -- we pair EQ elements together.+   -> m ([a],[c])+          -- ^ Output of merge function concatenated.+generalisedMerge as bs (compareFn :: a -> b -> Ordering)+      (mergeFn :: Maybe a -> Maybe b -> m (Maybe a,Maybe c)) =+   let+      mkAC :: [m (Maybe a,Maybe c)] -> m ([a],[c])+      mkAC mList =+        do+           (results :: [(Maybe a,Maybe c)]) <- sequence mList+           return (mapMaybe fst results,mapMaybe snd results)++      gm :: [a] -> [b] -> [m (Maybe a,Maybe c)]+      gm as [] = fmap (\ a -> mergeFn (Just a) Nothing) as+      gm [] bs = fmap (\ b -> mergeFn Nothing (Just b)) bs+      gm (as0 @ (a:as1)) (bs0 @ (b:bs1)) = case compareFn a b of+         LT -> mergeFn (Just a) Nothing : gm as1 bs0+         GT -> mergeFn Nothing (Just b) : gm as0 bs1+         EQ -> mergeFn (Just a) (Just b) : gm as1 bs1+   in+      mkAC (gm as bs)
+ Util/FileNames.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+-- | FileNames contain facilities for manipulating filenames+-- in a hopefully OS-independent manner.+module Util.FileNames(+   fileSep, -- :: Char+            -- file separator+   topDir,  -- :: String+            -- what we call the top directory.+   thisDir,  -- :: String+            -- what we call the current directory.+   trimDir, -- :: String -> String+            -- trim file separator from end of name if there.+            -- (intended for directories)+   splitName,+            -- :: String -> (String,String)+            -- Returns the directory and file part of a name.+   combineNames,+            -- :: String -> String -> String+            -- combines a directory and file name.+   breakName,+            -- :: String -> [String]+            -- breakName splits local file name completely into+            -- a sequence of file names, with the top directory+            -- first.  (If the first character is the file separator+            -- the first list element is the empty string.)+   unbreakName,+            -- :: [String] -> String+            -- unbreakName inverts breakName++   splitExtension,+            -- :: String -> Maybe (String,String)+            -- Remove the (last) extension part from a file name, returning+            -- the two parts.  For example "foo.bar" should go to (foo,bar).+   unsplitExtension,+            -- :: String -> String -> String+            -- reverse unsplitExtension.++   recordSep,+            -- :: String+            -- separator for between records.++   ) where++#ifdef WINDOWS+fileSep = '\\'+recordSep = "\r\n"+#else+fileSep = '/'+recordSep = "\n"+#endif++fileSep :: Char+recordSep :: String++topDir :: String+topDir = [fileSep]++thisDir :: String+thisDir = "."++trimDir :: String -> String+trimDir [] = []+trimDir (name@[c])+   | c==fileSep = []+   | True = name+trimDir (first:rest) = first:trimDir rest++splitName :: String -> (String,String)+splitName filePath0 =+   let+      filePath1 = trimDir filePath0+   in+      case splitName1 filePath1 of+         Nothing -> (thisDir,filePath1)+         Just ("",filePath2) -> (topDir,filePath2)+         Just simple -> simple++splitName1 :: String -> Maybe(String,String)+splitName1 [] = Nothing+splitName1 (first:remainder) =+   case splitName1 remainder of+      Nothing+         | first == fileSep -> Just([],remainder)+         | True -> Nothing+      Just (dir,name) -> Just (first:dir,name)++combineNames :: String -> String -> String+combineNames dir file = dir ++ (fileSep:file)++breakName :: String -> [String]+breakName [] = [[]]+breakName (first : rest)+   | (first == fileSep) = "":breakName rest+   | True =+      case breakName rest of+         firstName : restNames -> (first:firstName) : restNames+         [] -> error "breakName"++unbreakName :: [String] -> String+unbreakName [] = ""+unbreakName parts = foldr1 combineNames parts+++splitExtension :: String -> Maybe (String,String)+splitExtension str = case splitExtension0 str of+      Just (ne @ (name,ext)) | not (null name) && not (null ext) -> Just ne+      _ -> Nothing+   where+      splitExtension0 [] = Nothing+      splitExtension0 (c:cs) = case splitExtension0 cs of+         Just (name0,ext) -> Just (c:name0,ext)+         Nothing -> if c == '.' then Just ("",cs) else Nothing++unsplitExtension :: String -> String -> String+unsplitExtension name ext = name ++ "." ++ ext
+ Util/HostName.hs view
@@ -0,0 +1,15 @@+-- | This module contains code which (supposedly) extracts the full qualified+-- name of the machine on which it is running.  (At least it does on the+-- Linux and Solaris implementations I tested.)+module Util.HostName(+   getFullHostName,+   ) where++import Network.BSD++getFullHostName :: IO String+getFullHostName =+   do+      partialName <- getHostName+      hostEntry <- getHostByName partialName+      return (hostName hostEntry)
+ Util/Huffman.hs view
@@ -0,0 +1,83 @@+-- | This code does "Huffman" coding, using the queue implementation.  This+-- can be used for constructing Huffman encodings, or for computing factorials+-- efficiently.+module Util.Huffman(+   huffmanFold+   ) where++import Util.Queue++-- | huffmanFold op l+-- where op is associative, l is a nonempty monotonically increasing list,+-- and op has the property that (x1>=x2,y1>=y2) => (op x1 y1>=op x2 y2)+-- computes the fold of l with op, by repeatedly folding the smallest two+-- elements of the list until only one remains.+huffmanFold :: Ord a => (a -> a -> a) -> [a] -> a+huffmanFold op l =+   let+      pointedList = pointList l++      phase1 pointedList =+         case removePointed pointedList of+            Nothing -> error "huffmanFold requires a non-empty list"+            Just (a1,pointedList2) ->+               case removePointed pointedList2 of+                  Nothing -> a1 -- This is already the result of the folding+                  Just (a2,pointedList3) ->+                     case insertAndMovePointer pointedList3 (op a1 a2) of+                        Right pointedList4 -> phase1 pointedList4+                        Left queue -> phase2 queue+      phase2 queue =+         case removeQ queue of+            -- Nothing can't happen+            Just (a1,queue2) ->+               case removeQ queue2 of+                  Just (a2,queue3) ->+                     phase2 (insertQ queue3 (op a1 a2))+                  Nothing -> a1 -- we have a result!+   in+      phase1 pointedList++-- ------------------------------------------------------------------------+-- PointedList operations+-- ------------------------------------------------------------------------++-- | effectively a list with a pointer in the middle which can only be+-- moved right.  The list should always be in increasing order.+data PointedList a = PointedList (Queue a)  [a]++instance Show a => Show (PointedList a) where+   show (PointedList queue l) = show (queueToList queue, l)+-- | pointList makes a new pointed list with the pointer at the left.+pointList :: [a] -> PointedList a+pointList l = PointedList emptyQ l++-- | removePointed gets the first element of a PointedList.  If the pointer+-- is at the start of the list, it is moved to the new head.+removePointed :: PointedList a -> Maybe (a,PointedList a)+removePointed (PointedList queue list) =+   case removeQ queue of+      Nothing ->+         case list of+            [] -> Nothing+            a:list' -> Just (a,PointedList emptyQ list')+      Just (a,queue') -> Just (a,PointedList queue' list)++-- | insertAndMovePointer inserts an element to the right of the pointer,+-- and moves the pointer after it.  It does this maintaining the invariant+-- that the pointed list is ordered, and we assume that all elements to the+-- left of the pointer are not more than the inserted element.+--+-- If the pointer reaches the end of the list, we instead of returning a+-- PointedList, return a queue containing the list contents.+insertAndMovePointer :: Ord a => PointedList a -> a+   -> Either (Queue a) (PointedList a)+insertAndMovePointer (PointedList queue list) a =+   case list of+      [] -> Left (insertQ queue a)+      a2:list' ->+         if a2<a+         then insertAndMovePointer+            (PointedList (insertQ queue a2) list') a+         else+            Right (PointedList (insertQ queue a) list)
+ Util/ICStringLen.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}++-- | This module provides immutable CStrings, which additionally have+-- the property that they are automatically freed when the garbage-collector+-- forgets about them.+module Util.ICStringLen(+   ICStringLen, -- instance of AtomString and Eq.++   UTF8(..),+      -- newtype alias.  UTF8 ICStringLen is also an instance of AtomString,+      -- but we assume the characters are UTF8-encoded.+   toUTF8,+      -- :: String -> String+   fromUTF8WE,+      -- :: String -> WithError String+      -- This can be used for an error-checking UTF8 conversion.++   -- general creation and reading.+   mkICStringLen, -- :: Int -> (Ptr CChar -> IO()) -> IO ICStringLen+   mkICStringLenExtra,+      -- :: Int -> (CString -> IO extra) -> IO (ICStringLen,extra)+   withICStringLen, -- :: ICStringLen -> (Int -> Ptr CChar -> IO a) -> IO a+++   -- Conversion to/from (Bytes,Int)+   -- NB.  Once a bytes value is converted to an ICStringLen,+   -- that ICStringLen will automatically free the pointer when the+   -- ICStringLen value is garbage collected.+   bytesToICStringLen, -- :: (Bytes,Int) -> IO ICStringLen+   bytesFromICStringLen, -- :: ICStringLen -> (Bytes,Int)+   touchICStringLen, -- :: ICStringLen -> IO ()++   -- Conversion to and from other objects+   readICStringLen, -- :: HasBinary a StateBinArea => ICStringLen -> IO a+   writeToICStringLen, -- :: HasBinary a StateBinArea => a -> IO ICStringLen+++   ) where++import System.IO.Unsafe+import Foreign.C.String+import Foreign.ForeignPtr+import Foreign.Marshal.Array+import Foreign.Marshal.Alloc+import Foreign.C.Types+import Control.Monad.Trans++import Util.AtomString+import Util.Bytes+import Util.Binary+import Util.Computation+import Util.ExtendedPrelude+import Util.Dynamics+import Util.UTF8++-- ------------------------------------------------------------------+-- The datatype+-- ------------------------------------------------------------------++data ICStringLen = ICStringLen (ForeignPtr CChar) Int deriving (Typeable)++newtype UTF8 bytes = UTF8 bytes++-- ------------------------------------------------------------------+-- Creation and reading+-- ------------------------------------------------------------------++instance StringClass ICStringLen where+   fromString str = unsafePerformIO (innerFromString str)+      where+         innerFromString :: String -> IO ICStringLen+         innerFromString str =+            do+               let+                  len = length str+               mkICStringLen len+                  (\ ptr -> pokeArray ptr+                     (map castCharToCChar str)+                     )++   toString icsl = unsafePerformIO (innerToString icsl)+      where+         innerToString :: ICStringLen -> IO String+         innerToString icsl =+            withICStringLen icsl+               (\ len ptr ->+                  do+                     cchars <- peekArray len ptr+                     return (map castCCharToChar cchars)+                  )+++instance StringClass (UTF8 ICStringLen) where+   fromString str = UTF8 (fromString (toUTF8 str))+   toString (UTF8 icsl) = coerceWithError (fromUTF8WE (toString icsl))++instance Show ICStringLen where+   show = show . toString++-- -------------------------------------------------------------------+-- General functions for Creating and reading ICStringLen's.+-- -------------------------------------------------------------------++mkICStringLen :: Int -> (CString -> IO()) -> IO ICStringLen+mkICStringLen len writeFn =+   do+      ptr <- mallocArray len+      writeFn ptr+      createICStringLen ptr len++mkICStringLenExtra :: Int -> (CString -> IO extra) -> IO (ICStringLen,extra)+mkICStringLenExtra len writeFn =+   do+      ptr <- mallocArray len+      extra <- writeFn ptr+      icsl <- createICStringLen ptr len+      return (icsl,extra)++withICStringLen :: ICStringLen -> (Int -> CString -> IO a) -> IO a+withICStringLen (ICStringLen foreignPtr len) readFn =+   withForeignPtr foreignPtr (\ ptr -> readFn len ptr)++createICStringLen :: CString -> Int -> IO ICStringLen+createICStringLen ptr len =+   do+      foreignPtr <- newForeignPtr finalizerFree ptr+      return (ICStringLen foreignPtr len)+++-- -------------------------------------------------------------------+-- Converting ICStringLen directly to its components.+-- -------------------------------------------------------------------++bytesToICStringLen :: (Bytes,Int) -> IO ICStringLen+bytesToICStringLen (bytes,i) = createICStringLen (unMkBytes bytes) i++bytesFromICStringLen :: ICStringLen -> (Bytes,Int)+bytesFromICStringLen (ICStringLen foreignPtr len)+   = (mkBytes (unsafeForeignPtrToPtr foreignPtr),len)++touchICStringLen :: ICStringLen -> IO ()+touchICStringLen (ICStringLen foreignPtr _) = touchForeignPtr foreignPtr++-- -------------------------------------------------------------------+-- Instance of EqIO, OrdIO.+-- -------------------------------------------------------------------++instance OrdIO ICStringLen where+   compareIO (ICStringLen fptr1 len1) (ICStringLen fptr2 len2) =+      case compare len1 len2 of+         LT -> return LT+         GT -> return GT+         EQ -> compareBytes (mkBytes (unsafeForeignPtrToPtr fptr1))+            (mkBytes (unsafeForeignPtrToPtr fptr2)) len1++instance EqIO ICStringLen where+   eqIO icsl1 icsl2 =+      do+         ord <- compareIO icsl1 icsl2+         return (ord == EQ)++-- -------------------------------------------------------------------+-- Oh very well.  We implement Eq for ICStringLen, using unsafePerformIO.+-- -------------------------------------------------------------------++instance Eq ICStringLen where+   (==) icsl1 icsl2 = unsafePerformIO (eqIO icsl1 icsl2)++-- -------------------------------------------------------------------+-- Instance of HasBinary+-- -------------------------------------------------------------------++instance MonadIO m => HasBinary ICStringLen m where+   writeBin wb icsl =+      do+         r <- writeBin wb (bytesFromICStringLen icsl)+         seq r done+         liftIO (touchICStringLen icsl)+         return r+   readBin rb =+      do+         bl <- readBin rb+         icsl <- liftIO (bytesToICStringLen bl)+         return icsl++-- -------------------------------------------------------------------+-- Conversion to and from other objects+-- -------------------------------------------------------------------++readICStringLen :: HasBinary a StateBinArea => ICStringLen -> IO a+readICStringLen icsl =+   do+      let+         bl = bytesFromICStringLen icsl++      a <- readFromBytes bl+      touchICStringLen icsl+      return a++writeToICStringLen :: HasBinary a StateBinArea => a -> IO ICStringLen+writeToICStringLen a =+   do+      bl <- writeToBytes a+      bytesToICStringLen bl+
+ Util/IOExtras.hs view
@@ -0,0 +1,75 @@+-- | Little functions connected with IO+module Util.IOExtras(+   catchEOF, -- :: IO a -> IO (Maybe a)+   -- If successful return result.+   -- if unsuccessful because of EOF return Nothing+   -- otherwise pass on error++   catchAlreadyExists, -- :: IO a -> IO (Maybe a)+   -- If successful return results,+   -- If unsuccessful because of an isAlreadyExists error return Nothing+   -- otherwise pass on error.++   catchDoesNotExist,+      -- :: IO a -> IO (Maybe a)++   catchErrorCalls, -- :: IO a -> IO (Either String a)+   -- Catch all calls to the error function.++   hGetLineR, -- :: Read a => Handle -> IO a+   -- hGetLine and then read.++   simpleModifyIORef,+      -- :: IORef a -> (a -> (a,b)) -> IO b+      -- carry out a pure modification of an IORef.+      -- From ghc5.05 onwards, we should be able to use atomicModifyIORef+      -- for this.++   ) where++import System.IO.Error+import System.IO++import Data.IORef+import Control.Exception++catchEOF :: IO a -> IO (Maybe a)+catchEOF action = catchGeneral isEOFError action++catchAlreadyExists :: IO a -> IO (Maybe a)+catchAlreadyExists action = catchGeneral isAlreadyExistsError action++catchDoesNotExist :: IO a -> IO (Maybe a)+catchDoesNotExist action = catchGeneral isDoesNotExistError action++catchGeneral :: (IOError -> Bool) -> IO a -> IO (Maybe a)+catchGeneral discriminator action =+   do+      result <- tryJust+         (\ excep ->+            case ioErrors excep of+               Nothing -> Nothing+               Just ioError ->+                  if discriminator ioError+                     then+                        Just ()+                     else+                        Nothing+            )+         action+      case result of+         Left () -> return Nothing+         Right success -> return (Just success)++catchErrorCalls :: IO a -> IO (Either String a)+catchErrorCalls action =  tryJust errorCalls action++hGetLineR :: Read a => Handle -> IO a+hGetLineR handle =+   do+      line <- hGetLine handle+      return (read line)++simpleModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+simpleModifyIORef = atomicModifyIORef+
+ Util/IntPlus.hs view
@@ -0,0 +1,65 @@+-- | Integers augmented with Infinity.+module Util.IntPlus(+   IntPlus,+   infinity+   ) where++-- --------------------------------------------------------------------+-- The datatype+-- --------------------------------------------------------------------++-- | The Bool is a sign, with True meaning positive infinity.+data IntPlus = Infinite Bool | Finite Integer deriving Eq++-- --------------------------------------------------------------------+-- The interface+-- --------------------------------------------------------------------++infinity :: IntPlus+infinity = Infinite True++instance Ord IntPlus where+   compare i1 i2 = case (i1,i2) of+      (Infinite b1,Infinite b2) -> compare b1 b2+      (Finite _,Infinite b) -> if b then LT else GT+      (Infinite b,Finite _) -> if b then GT else LT+      (Finite i1,Finite i2) -> compare i1 i2++instance Show IntPlus where+   showsPrec _ (Infinite b) s = if b then "infinity"++s else "-infinity"++s+   showsPrec p (Finite i) s = showsPrec p i s++instance Num IntPlus where+   (+) i1 i2 = case (i1,i2) of+      (Finite i1,Finite i2) -> Finite (i1 + i2)+      (Infinite b,Finite _) -> Infinite b+      (Finite _,Infinite b) -> Infinite b+      (Infinite b1,Infinite b2) ->+         if b1 == b2 then Infinite b1 else+            error "IntPlus: attempt to subtract infinities of like sign"+   (*) i1 i2 = case (i1,i2) of+      (Finite i1,Finite i2) -> Finite (i1*i2)+      (Finite i,Infinite b) -> mul i b+      (Infinite b,Finite i) -> mul i b+      (Infinite b1,Infinite b2) -> Infinite (b1 == b2)+      where+         mul i b = case compare i 0 of+            LT -> Infinite (not b)+            EQ -> Finite 0+            GT -> Infinite b++   negate (Finite i) = Finite (negate i)+   negate (Infinite b) = Infinite (not b)++   abs (Finite i) = Finite (abs i)+   abs (Infinite _) = infinity++   signum i = case compare i 0 of+      LT -> -1+      EQ -> 0+      GT -> 1++   fromInteger i = Finite i+++
+ Util/KeyedChanges.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | This implements a SinkSource with keyed changes.+module Util.KeyedChanges(+   KeyedChanges,++   -- The idea is to keep track of changes to which a key is attached.+   -- When a new sink is attached, only the most recent changes for each+   -- key are returned.++   -- Producer's interface+   newKeyedChanges,+      -- :: Ord key => IO (KeyedChanges key delta)+   sendKeyedChanges,+      -- :: Ord key => key -> delta -> KeyedChanges key delta -> IO ()++   -- Used for sending changes which restore the situation to its default.+   -- If there is no entry for the key, nothing is done.  Otherwise the+   -- given delta is sent, and the entry is deleted.+   deleteKeyedChange,+      -- :: Ord key => key -> delta -> KeyedChanges key delta -> IO ()++   -- Consumer's interface+   -- instance Ord key => HasSource (KeyedChanges key delta) [delta] delta+   ) where++import qualified Data.Map as Map++import Util.Sources+import Util.Broadcaster++newtype KeyedChanges key delta+   = KeyedChanges (Broadcaster (Map.Map key delta) delta)++-- ------------------------------------------------------------------------+-- Producer's interface+-- ------------------------------------------------------------------------++newKeyedChanges :: Ord key => IO (KeyedChanges key delta)+newKeyedChanges =+   do+      broadcaster <- newBroadcaster Map.empty+      return (KeyedChanges broadcaster)++sendKeyedChanges :: Ord key => key -> delta -> KeyedChanges key delta -> IO ()+sendKeyedChanges key delta (KeyedChanges broadcaster) =+   applyUpdate broadcaster (\ map -> (Map.insert key delta map,[delta]))++deleteKeyedChange :: Ord key => key -> delta -> KeyedChanges key delta -> IO ()+deleteKeyedChange key delta (KeyedChanges broadcaster) =+   applyUpdate broadcaster (\ map -> case Map.lookup key map of+      Nothing -> (map,[])+      Just _ -> (Map.delete key map,[delta])+      )++-- ------------------------------------------------------------------------+-- Consumer's interface+-- ------------------------------------------------------------------------++instance Ord key => HasSource (KeyedChanges key delta) [delta] delta where+   toSource (KeyedChanges broadcaster) = map1 Map.elems (toSource broadcaster)
+ Util/LineShow.hs view
@@ -0,0 +1,32 @@+-- | The LineShow type is simply a list type except that it has+-- Read and Show instances which put the output line by line,+-- preceded by the number of lines.  This is useful for data+-- files stored by CVS and similar systems.+module Util.LineShow(+   LineShow(..)+   ) where++newtype LineShow a = LineShow [a]++instance Show a => Show (LineShow a) where+   showsPrec prec (LineShow list) acc =+      let+         showLines [] acc = acc+         showLines (h:t) acc = showLines t (showsPrec prec h ('\n':acc))+      in+         (show (length list))++('\n':showLines list acc)++instance Read a => Read (LineShow a) where+   readsPrec prec toRead =+      let+         readLines 0 acc toRead = [(LineShow acc,toRead)]+         readLines nLeft acc toRead =+            case readsPrec prec toRead of+               [(this,'\n':remainder)] ->+                  readLines (nLeft-1) (this:acc) remainder+               _ -> []+      in+         case readsPrec prec toRead of+            [(nLines,'\n':remainder)] -> readLines (nLines :: Int) [] remainder+            _ -> []+
+ Util/Maybes.hs view
@@ -0,0 +1,12 @@+-- | This file differs from the Einar original (itself automatically+-- produced by decommenting an obsolete GHC source file, apparently) with+-- nearly all the functions removed.+module Util.Maybes (+   fromMaybes, -- :: [Maybe a] -> Maybe [a]+      -- check that all the Maybes are really Just's.+   ) where++fromMaybes :: [Maybe a] -> Maybe [a]+fromMaybes [] = Just []+fromMaybes (Nothing : _) = Nothing+fromMaybes (Just a : rest) = fmap (a :) (fromMaybes rest)
+ Util/Messages.hs view
@@ -0,0 +1,234 @@+-- |+-- Description: Outputting Messages+--+-- This module contains the hooks for displaying messages to the user+-- (errors, alerts, warnings and the like) and getting yes\/no responses.+--+-- The idea is that these are by default textual, and go via+-- 'stdin', 'stdout' and 'stderr' .  However if the DialogWin function+-- 'useHTk' is invoked, windows will pop up.+module Util.Messages(+   -- Functions for displaying messages+   alertMess, -- :: String -> IO ()+   errorMess, -- :: String -> IO ()+   warningMess, -- :: String -> IO ()+   confirmMess, -- :: String -> IO Bool+   messageMess, -- :: String -> IO ()++   -- Miscellaneous+   htkPresent,+      -- :: IO Bool+      -- If True, indicates that the flag corresponding to a graphical mode+      -- has been set.  This is used occasionally for deciding whether to+      -- ask the user something on stdout, stdin or via a window.++   textQuery,+      -- :: String -> IO String+      -- queries the user on stdout getting the answer from stdin.+      -- Leading and trailing spaces are trimmed from the result.++   errorMess2,+      -- :: String -> IO ()+      -- Attempt to reduce the number of error messages displayed by the+      -- imports stuff.++   -- Interface used by HTk for setting a graphical mode++   MessFns(..),  -- versions of the above functions+   setMessFns, -- :: MessFns -> IO ()+   ) where++import System.IO+import Data.Char+import qualified Data.List as List++import qualified Data.Set as Set+import Control.Concurrent.MVar+import System.IO.Unsafe++import Util.Computation(done)+import Util.ExtendedPrelude++-- ------------------------------------------------------------------------+-- Displaying Messages & Miscellaneous+-- ------------------------------------------------------------------------++-- | Display an alert+alertMess :: String -> IO ()+alertMess = getMessFn alertFn++-- | Display an error+errorMess :: String -> IO ()+errorMess = getMessFn errorFn++-- | Display a warning message+warningMess :: String -> IO ()+warningMess = getMessFn warningFn++-- | Confirm something with the user.+confirmMess :: String -> IO Bool+confirmMess = getMessFn confirmFn++-- | Display some informational message.+messageMess :: String -> IO ()+messageMess = getMessFn messageFn++-- | If True, indicates that the flag corresponding to a graphical mode+-- has been set.  This is used occasionally for deciding whether to+-- ask the user something on stdout, stdin or via a window.+htkPresent :: IO Bool+htkPresent = getMessValue htkPres++-- | queries the user on stdout getting the answer from stdin.+-- Leading and trailing spaces are trimmed from the result.+textQuery :: String -> IO String+textQuery query =+   do+      putStrLn query+      reply <- getLine+      return (trimSpaces reply)++-- ------------------------------------------------------------------------+-- MessFns+-- ------------------------------------------------------------------------++data MessFns = MessFns {+   alertFn :: String -> IO (),+   errorFn :: String -> IO (),+   warningFn :: String -> IO (),+   confirmFn :: String -> IO Bool,+   messageFn :: String -> IO (),+   htkPres :: Bool+   }++messFnsMVar :: MVar MessFns+messFnsMVar = unsafePerformIO (newMVar defaultMessFns)+{-# NOINLINE messFnsMVar #-}++setMessFns :: MessFns -> IO ()+setMessFns messFns =+   do+      takeMVar messFnsMVar+      putMVar messFnsMVar messFns++getMessFn :: (MessFns -> (String -> IO a)) -> (String -> IO a)+getMessFn toFn str =+   do+      messFns <- getMessValue id+      (toFn messFns) str++getMessValue :: (MessFns -> a) -> IO a+getMessValue toA =+   do+      messFns <- readMVar messFnsMVar+      return (toA messFns)++-- ------------------------------------------------------------------------+-- The default messFns+-- ------------------------------------------------------------------------++defaultMessFns :: MessFns+defaultMessFns = MessFns {+   alertFn = defaultAlert,+   errorFn = defaultError,+   warningFn = defaultWarning,+   confirmFn = defaultConfirm,+   messageFn = defaultMessage,+   htkPres = False+   }++defaultAlert :: String -> IO ()+defaultAlert str = putStrLn ("Alert: " ++ str)++defaultError :: String -> IO ()+defaultError str = hPutStrLn stderr ("Error: " ++ str)++defaultWarning :: String -> IO ()+defaultWarning str = putStrLn ("Warning: " ++ str)++defaultConfirm :: String -> IO Bool+defaultConfirm str =+   do+      putStrLn str+      putStrLn ("O[K] or C[ancel]?")+      let+         getOC :: IO Bool+         getOC =+            do+               oc <- readOC+               case oc of+                  Just c -> return c+                  Nothing ->+                     do+                        putStrLn ("Type O (or some prefix of OK) or C "+                           ++ "(or some prefix of CANCEL)")+                        getOC++         readOC :: IO (Maybe Bool)+         readOC =+            do+               result0 <- getLine+               let+                  result1 = fmap toUpper (trimSpaces result0)++               case (result1,isPrefix result1 "OK",isPrefix result1 "CANCEL")+                     of+                  ("",_,_) -> return Nothing+                  (_,Just _,_) -> return (Just True)+                  (_,_,Just _) -> return (Just False)+                  (_,Nothing,Nothing) -> return Nothing+      getOC++defaultMessage :: String -> IO ()+defaultMessage = putStrLn++-- ------------------------------------------------------------------------+-- Reducing the number of error messages.+-- ------------------------------------------------------------------------++pendingErrorMessagesMVar :: MVar [String]+pendingErrorMessagesMVar = unsafePerformIO (newMVar [])+{-# NOINLINE pendingErrorMessagesMVar #-}++-- | Display a series of one-line messages, separated by newline characters,+-- attempting to combine them together and eliminate duplicates as much as+-- possible.  If other identical messages come in while the error message+-- is being delayed, we throw them away.+errorMess2 :: String -> IO ()+errorMess2 message0 =+   do+      let+         messages1 = reverse (lines message0)++      modifyMVar_ pendingErrorMessagesMVar+         (\ messages -> return (messages1 ++ messages))+      clearPendingErrorMessages++clearPendingErrorMessages :: IO ()+clearPendingErrorMessages = cpe Set.empty+   where+      cpe :: Set.Set String -> IO ()+      cpe alreadyDisplayedSet0 =+         do+            messages0 <- readMVar pendingErrorMessagesMVar+            putStrLn (show (messages0,Set.toList alreadyDisplayedSet0))+            let+               messages1 = List.filter+                  (\ message -> not (Set.member message alreadyDisplayedSet0))+                  messages0++               messages2 = uniqOrdOrder messages1++            case messages2 of+               [] -> done+               _ ->+                  do+                     errorMess (unlines (reverse messages2))++                     let+                        alreadyDisplayedSet1 =+                           Set.union alreadyDisplayedSet0+                                  (Set.fromList messages2)++                     cpe alreadyDisplayedSet1+
+ Util/Myers.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Implementation of the Myers algorithm, from "An O(ND) Difference Algorithm+-- and Its Variations", by Eugene Myers page 6 (figure 2).+--+-- Specification: if+--+--    f1 (InBoth v) = Just v+--    f1 (InFirst v) = Just v+--    f1 (InSecond v) = Nothing+--+-- and+--+--    f2 (InBoth v) = Just v+--    f2 (InFirst v) = Nothing+--    f2 (InSecond v) = Just v+--+-- then+--+--    mapPartial f1 (diff l1 l2) == l1+--+-- and+--+--    mapPartial f2 (diff l1 l2) == l2+module Util.Myers(+   diff,+   diff2,+   DiffElement(..),+   ) where+++import Data.Array++import Control.Monad.ST+import Data.Array.ST++import Util.ExtendedPrelude++-- -----------------------------------------------------------------------+-- Datatypes+-- -----------------------------------------------------------------------++data DiffElement v =+      InBoth [v]+   |  InFirst [v]+   |  InSecond [v] deriving (Show)++-- -----------------------------------------------------------------------+-- The implementation.  The whole function, apart from the body of diff+-- itself, is taken from a message from Andrew Bromage+-- -----------------------------------------------------------------------++diff :: (Eq a) => [a] -> [a] -> [DiffElement a]+diff l1 l2 =+   let+      common = lcss l1 l2++      addFirst :: [a] -> [DiffElement a] -> [DiffElement a]+      addFirst [] de0 = de0+      addFirst l1 de0 = InFirst l1 : de0++      addSecond :: [a] -> [DiffElement a] -> [DiffElement a]+      addSecond [] de0 = de0+      addSecond l1 de0 = InSecond l1 : de0++      doCommon :: Eq a => [a] -> [a] -> [a] -> [DiffElement a]+      doCommon [] l1 l2 = (addFirst l1) . (addSecond l2) $ []+      doCommon (c:cs) l10 l20 =+         let+            Just (l1A,l11) = splitToElem (== c) l10+            Just (l2A,l21) = splitToElem (== c) l20+            de0 = doCommon cs l11 l21+            de1 = case de0 of+               (InBoth cs:rest) -> InBoth (c:cs):rest+               _ -> InBoth [c] : de0+         in+             (addFirst l1A) . (addSecond l2A) $ de1+   in+      doCommon common l1 l2++-- stolen from message from Andrew Bromage+algb :: (Eq a) => [a] -> [a] -> [Int]+algb xs ys+  = 0 : algb1 xs [ (y,0) | y <- ys ]+  where+    algb1 [] ys' = map snd ys'+    algb1 (x:xs) ys'+      = algb1 xs (algb2 0 0 ys')+      where+        algb2 _ _ [] = []+        algb2 k0j1 k1j1 ((y,k0j):ys)+          = let kjcurr = if x == y then k0j1+1 else max k1j1 k0j+            in (y,kjcurr) : algb2 k0j kjcurr ys++algc :: (Eq a) => Int -> Int -> [a] -> [a] -> [a] -> [a]+algc m n xs []  = id+algc m n [x] ys = if x `elem` ys then (x:) else id+algc m n xs ys+  = algc m2 k xs1 (take k ys) . algc (m-m2) (n-k) xs2 (drop k ys)+  where+    m2 = m `div` 2++    xs1 = take m2 xs+    xs2 = drop m2 xs++    l1 = algb xs1 ys+    l2 = reverse (algb (reverse xs2) (reverse ys))++    k = findk 0 0 (-1) (zip l1 l2)++    findk k km m [] = km+    findk k km m ((x,y):xys)+      | x+y >= m  = findk (k+1) k  (x+y) xys+      | otherwise = findk (k+1) km m     xys++lcss :: (Eq a) => [a] -> [a] -> [a]+lcss xs ys = algc (length xs) (length ys) xs ys []+++{- Here, as an appendix, is my slow inefficient version -}+diff2 :: Eq v => [v] -> [v] -> [DiffElement v]+diff2 [] [] = []+diff2 a b = runST (diffST2 a b)++-- NB. diffST does not work if both arguments are null, so that+-- case should be handled separately.+diffST2 :: forall v s . Eq v => [v] -> [v] -> ST s [DiffElement v]+diffST2 a b =+   do+      let+         m = length a+         (aArr :: Array Int v) = listArray (1,m) a++         n = length b+         (bArr :: Array Int v) = listArray (1,n) b++         match :: Int -> Int -> Bool+         match x y = (aArr ! x) == (bArr ! y)++         -- Given (x,y) return the highest (x+k,y+k) such that (x+1,y+1),+         -- (x+2,y+2)...(x+k,y+k) match.+         scan :: Int -> Int -> (Int,Int)+         scan x y =+            if x < m && y < n+               then+                  let+                     x' = x+1+                     y' = y+1+                  in+                     if match x' y' then scan x' y' else (x,y)+               else+                  (x,y)++         max = m+n+      -- We do the computation using an STArray for V+      -- We arrange that there is always a -1 on either side of the+      -- existing range, to simplify handling of the end-cases.+      (v :: STUArray s Int Int) <- newArray (-max-1,max+1) (-1)+      writeArray v 1 0++      -- The w array contains a list of integers (x,y) such that the snakes+      -- starting from the elements (x+1,y+1) together make up all the snakes+      -- needed in the optimal solution.+      --+      -- The idea is that storage for w should not get too big, either if a+      -- and b are much the same, or if they are completely different.  Thus+      -- in most cases quadratic behaviour *should* be avoided.+      (w :: STArray s Int [(Int,Int)]) <- newArray (-max,max) []++      let+         -- step carries out the algorithm for a given (d,k), returning+         -- the appropriate w-list.+         step :: Int -> Int -> ST s [(Int,Int)]+         step d k =+            if k > d+               then+                  innerStep (d+1) (-(d+1))+               else+                  innerStep d k++         innerStep :: Int -> Int -> ST s [(Int,Int)]+         innerStep d k =+            do+               vkplus <- readArray v (k+1)+               vkminus <- readArray v (k-1)+               (x,l0) <- if vkminus < vkplus+                  then+                     do+                        l0 <- readArray w (k+1)+                        return (vkplus,l0)+                  else+                     do+                        l <- readArray w (k-1)+                        return (vkminus+1,l)+               let+                  y = x - k++                  (x',_) = scan x y++                  l1 =+                     if x' == x+                        then+                           l0+                        else+                           (x,y) : l0++               -- Can we finish now?+               if x' >= m && (y + (x' - x)) >= n+                  then+                     return l1+                  else+                     do+                        writeArray v k x'+                        writeArray w k l1+                        step d (k+2)++      snakes <- step 0 0++      let+         -- The task is now to reassemble snakes to produce a list.  Since+         -- the snakes are given in reverse order, we may as well produce the+         -- elements in that order and work backwards.++         addSnake :: (Int,Int) -> (Int,Int)+            -> [DiffElement v] -> [DiffElement v]+         addSnake (lastX,lastY) (x,y) l0 =+            -- We assume that elements a[lastX+1...] and b[lastY+1...] have+            -- been dealt with, and we now add on a segment starting with a+            -- snake which begins at (x+1,y+1).+            let+               -- Compute the end of the snake+               (x',y') = scan x y++               -- Add on elements b[y'+1..lastY]+               l1 = (InSecond (map (\ index -> bArr ! index)+                       [y'+1..lastY])) : l0+               -- Add on elements a[x'+1..lastX]+               l2 = (InFirst (map (\ index -> aArr ! index)+                       [x'+1..lastX])) : l1+               -- Add on snake+               l3 = (InBoth (map (\ index -> aArr ! index)+                       [x+1..x'])) : l2+            in+               l3++         doSnakes :: (Int,Int) -> [(Int,Int)] -> [DiffElement v]+            -> [DiffElement v]+         doSnakes last [] l0 =+            -- we pretend there's a zero-length snake starting at (1,1).+            if last /= (0,0) then addSnake last (0,0) l0 else l0+         doSnakes last (s:ss) l0 =+            let+               l1 = addSnake last s l0+            in+               doSnakes s ss l1++         result0 = doSnakes (m,n) snakes []++         result1 = filter+            -- Filter out null elements+            (\ de -> case de of+               InFirst [] -> False+               InSecond [] -> False+               InBoth [] -> False+               _ -> True+               )+            result0++      return result1+{- -}+++-- | This version was posted to the Haskell mailing list by Gertjan Kamsteeg+-- on Sun, 15 Dec 2002.+-- But it seems to be slightly slower than the others.+{-++data In a = F a | S a | B a deriving Show++diff xs ys = steps ([(0,0,[],xs,ys)],[]) where+  steps (((_,_,ws,[],[]):_),_) = reverse ws+  steps d                      = steps (step d) where+    step (ps,qs) = let (us,vs) = h1 ps in (h3 qs (h2 us),vs) where+      h1 []     = ([],[])+      h1 (p:ps) = let (rs,ss) = next p; (us,vs) = h1 ps in (rs++us,ss++vs)+         where+            next (k,n,ws,(x:xs),[])           = ([(k+1,n+1,F x:ws,xs,[])],[])+            next (k,n,ws,[],(y:ys))           = ([(k-1,n+1,S y:ws,[],ys)],[])+            next (k,n,ws,xs@(x:us),ys@(y:vs))+              | x == y    = ([],[(k,n+1,B x:ws,us,vs)])+              | otherwise = ([(k+1,n+1,F x:ws,us,ys),(k-1,n+1,S y:ws,xs,vs)],[])+      h2 []                                   = []+      h2 ps@[_]                               = ps+      h2 (p@(k1,n1,_,_,_):ps@(q@(k2,n2,_,_,_):us))+        | k1 == k2  = if n1 <= n2 then p:h2 us else q:h2 us+        | otherwise = p:h2 ps+      h3 ps [] = ps+      h3 [] qs = qs+      h3 (ps@(p@(k1,n1,_,_,_):us)) (qs@(q@(k2,n2,_,_,_):vs))+        | k1 > k2   = p:h3 us qs+        | k1 == k2  = if n1 <= n2 then p:h3 us vs else q:h3 us vs+        | otherwise = q:h3 ps vs+-}
+ Util/NameMangle.hs view
@@ -0,0 +1,54 @@+-- | Module for generating unique names which correspond to given names+-- (of type ref).+module Util.NameMangle(+   NameMangler,+   newNameMangler, -- :: IO (NameMangler ref)+   MangledName, -- synonym for String.  MangledNames are generated by+      -- UniqueString.+   newMangledName, -- :: NameMangler ref -> ref -> IO MangledName+   readMangledName, -- :: NameMangler ref -> MangledName -> IO ref+   ) where++import Util.Registry+import Util.UniqueString++-- ---------------------------------------------------------------------+-- Data types+-- ---------------------------------------------------------------------++type MangledName = String++-- | For now we just do this naively, with a Registry.  Since the names are+-- generated sequentially a dynamic array would be more efficient, perhaps.+data NameMangler ref = NameMangler {+   nameSource :: UniqueStringSource,+   fromMangledName :: Registry MangledName ref+   }++-- ---------------------------------------------------------------------+-- Functions+-- ---------------------------------------------------------------------++newNameMangler :: IO (NameMangler ref)+newNameMangler =+   do+      nameSource <- newUniqueStringSource+      fromMangledName <- newRegistry+      return (NameMangler {nameSource = nameSource,+         fromMangledName = fromMangledName})++newMangledName :: NameMangler ref -> ref -> IO MangledName+newMangledName (NameMangler {nameSource = nameSource,+      fromMangledName = fromMangledName}) str =+   do+      name <- newUniqueString nameSource+      setValue fromMangledName name str+      return name++readMangledName :: NameMangler ref -> MangledName -> IO ref+readMangledName (NameMangler {fromMangledName = fromMangledName}) name =+   do+      refOpt <- getValueOpt fromMangledName name+      case refOpt of+         Nothing -> error ("NameMangle: couldn't retrieve "++name)+         Just ref -> return ref
+ Util/Object.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Module which generates globally unique 'ObjectID's.+module Util.Object (+   ObjectID(..),+   Object(..),+   newObject, -- generates a unique object+   staticObject,+      -- generates a not-necessarily unique object given a+      -- postive integer.  But at least it will be different from all those+      -- generated by newObject, or with a different integer.+   newInt -- generates a unique integer.+   ) where++-- --------------------------------------------------------------------------+-- Class Object+-- --------------------------------------------------------------------------++newtype ObjectID = ObjectID Int deriving (Eq,Ord)++class Object o where+   objectID :: o -> ObjectID++instance Show ObjectID where+   showsPrec d (ObjectID n) r = showsPrec d n r++instance Read ObjectID where+   readsPrec p b =+      case reads b of+         [] -> []+         ((v,xs):_) ->[(ObjectID v,xs)]++-- --------------------------------------------------------------------------+-- New Object Identifier+-- --------------------------------------------------------------------------++foreign import ccall unsafe "new_object.h next_object_id" newInt :: IO Int++newObject :: IO ObjectID+newObject =+   do+      nextInt <- newInt+      return(ObjectID nextInt)++staticObject :: Int -> ObjectID+staticObject i+   | i>0 = ObjectID (-i)+   | True = error "staticObject not given positive integer"
+ Util/Queue.hs view
@@ -0,0 +1,119 @@+-- | This is an implementation of queues inspired by the paper in+-- Software Practice & Experience, ...+-- The queue is divided into two sequences. The first sequence+-- holds the elements in a LIFO order, the second in a FIFO order.+-- The LIFO sequence is the one where elements are added, the FIFO+-- the one from which elements are removed. When the remove operation+-- is called and the FIFO sequence is empty, the LIFO sequence is+-- turned into a FIFO sequence by reversing the order of its elements.+--+-- Note from GER - as far as I know, we only need the values+--    emptyQ :: Queue a -- new empty queue+--    singletonQ :: a -> Queue a -- new singleton queue+--    insertQ :: Queue a -> a -> Queue a -- add to queue+--    removeQ :: Queue a -> Maybe (a,Queue a) -- pop from queue.+--    insertAtEndQ :: Queue a -> a -> Queue a+--    -- undo the effect of the previous removeQ.+--    isEmptyQ :: Queue a -> Bool+--    queueToList :: Queue a -> [a]+module Util.Queue (+        Queue,++        emptyQ,+        singletonQ,+        isEmptyQ,+        insertQ,+        removeQ,+        insertAtEndQ,++        listToQueue,+        queueToList,+        ) where++-- --------------------------------------------------------------------------+-- Data Type+-- --------------------------------------------------------------------------++data Queue a = Queue [a] [a]+++-- --------------------------------------------------------------------------+-- Instances+-- --------------------------------------------------------------------------++instance Eq a => Eq (Queue a) where+        (Queue f1 r1) == (Queue f2 r2) =+                (f1 ++ reverse r1) == (f2 ++ reverse r2)++instance Functor Queue where+        fmap f (Queue l1 l2) = Queue (map f l1) (map f l2)++-- --------------------------------------------------------------------------+-- Operations+-- --------------------------------------------------------------------------++emptyQ :: Queue a+emptyQ =  Queue [] []+++singletonQ :: a -> Queue a+singletonQ e =  Queue [] [e]+++isEmptyQ :: Queue a -> Bool+isEmptyQ (Queue [] []) = True+isEmptyQ _ = False++++insertQ :: Queue a -> a -> Queue a+insertQ (Queue fl rl) e = Queue (e:fl) rl++++{-++lengthQ :: Queue a -> Int+lengthQ (Queue fl rl) = length fl + length rl++headQ :: Queue a -> a+headQ (Queue fl []) = (head (reverse fl))+headQ (Queue _ rl) = (head rl)++tailQ :: Queue a -> Queue a+tailQ (Queue fl [] ) = Queue [] tl where (_ : tl) = reverse fl+tailQ (Queue fl rl ) = Queue fl (tail rl)+++frontQ :: Queue a -> Maybe a+frontQ (Queue [] []) = Nothing+frontQ (Queue fl []) = Just (head (reverse fl))+frontQ (Queue _ rl) = Just (head rl)++-}++removeQ :: Queue a -> Maybe (a, Queue a)+removeQ (Queue [] [] ) = Nothing+-- This function used to return+-- error "removeQ: Queue is empty" where above we have "Nothing".+-- Heaven knows why.  Anyway it's only used in Selective.hs and a+-- test case, so I think I can safely change it.  (GER, 10/2/2000)+removeQ (Queue fl [] ) = Just (x, Queue [] tl) where (x : tl) = reverse fl+removeQ (Queue fl rl ) = Just (head rl, Queue fl (tail rl))++insertAtEndQ :: Queue a -> a -> Queue a+insertAtEndQ (Queue fl rl) next = Queue fl (next:rl)++-- --------------------------------------------------------------------------+-- Converting to and from lists+-- --------------------------------------------------------------------------+++-- | Converts a list to a queue with the first element of the list the+-- first element of the queue.+listToQueue :: [a] -> Queue a+listToQueue xs = foldl insertQ emptyQ xs++-- | Inverts listToQueue+queueToList :: Queue a -> [a]+queueToList (Queue fl rl) = rl ++ reverse fl
+ Util/QuickReadShow.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | QuickReadShow is designed for the rapid manufacture of read/show+-- instances.  To create such an instance you need to (a) instance+-- quickRead; (b) instance Read/Show using a particular template.+-- (Before April 2004 (b) was not part of the code; it now has to+-- be added to deal with tougher GHC restrictions on overlapping instances.)+module Util.QuickReadShow(+   WrapRead(WrapRead),+   QuickRead(quickRead),+   qRead,++   WrapShow(WrapShow),+   QuickShow(quickShow),+   qShow+   ) where++data WrapRead toRead = forall read . Read read => WrapRead (read -> toRead)++class QuickRead toRead where+   quickRead :: WrapRead toRead++mkReadsPrec :: WrapRead toRead -> Int -> ReadS toRead+mkReadsPrec (WrapRead convFn) prec str =+   let+      parses = readsPrec prec str+   in+      map+         (\ (result,rest) -> (convFn result,rest))+         parses++qRead :: QuickRead toRead => Int -> String -> [(toRead, String)]+qRead = mkReadsPrec quickRead++{- Example instance++instance Read ExampleType where+   readsPrec = qRead+   -}++data WrapShow toShow = forall show . Show show => WrapShow (toShow -> show)++class QuickShow toShow where+   quickShow :: WrapShow toShow++mkShowsPrec :: WrapShow toShow -> Int -> toShow -> ShowS+mkShowsPrec (WrapShow convFn) prec value acc =+   showsPrec prec (convFn value) acc++qShow :: QuickShow toShow => Int -> toShow -> String -> String+qShow = mkShowsPrec quickShow++{- Example instance++instance Show ExampleType where+   showsPrec = qShow+   -}
+ Util/ReferenceCount.hs view
@@ -0,0 +1,40 @@+-- | A simple reference counter+module Util.ReferenceCount(+   RefCount,++   newRefCount, -- :: IO RefCount+      -- new ref count with no links.+   newLinkedRefCount, -- :: IO RefCount+      -- new ref count with one link (that being what is normally wanted).+   addRef, -- :: RefCount -> IO ()+   remRef, -- :: RefCount -> IO Bool+      -- returns True if we reach 0.+   ) where++import Control.Concurrent.MVar++newtype RefCount = RefCount (MVar Int)+++newRefCount :: IO RefCount+newRefCount =+   do+      mVar <- newMVar 0+      return (RefCount mVar)++newLinkedRefCount :: IO RefCount+newLinkedRefCount =+   do+      mVar <- newMVar 1+      return (RefCount mVar)++addRef :: RefCount -> IO ()+addRef (RefCount mVar) = modifyMVar_ mVar (return . (+1))++remRef :: RefCount -> IO Bool+remRef (RefCount mVar) = modifyMVar mVar (\ count0 ->+   let+      count1 = count0 - 1+   in+      return (count1,count1 == 0)+   )
+ Util/Registry.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoMonoPatBinds #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Description: Store information by key.+--+-- A Registry is a mapping from ordered values.  For the Registry+-- type itself, all target values have the same type.  For the+-- UntypedRegistry type, the values+-- can have any Typeable type.+module Util.Registry(+   Registry, -- A "Registry from to" maps from values to to values.+   UntypedRegistry, -- An "UntypedRegistry from" maps from values to+                -- any Typeable values.+   LockedRegistry, -- A "LockedRegistry from to" is like a+      -- "Registry from to" but with finer locking.+   UntypedLockedRegistry, -- An "UntypedLockedRegistry from" is+      -- like an "UntypedRegistry from" but with finer locking.+   Untyped, -- Type constructor for registries with untyped contents.++   -- Unsafe/UnsafeRegistry are equivalent to Untyped/UntypedRegistry except+   -- for the additional functionality of causing a core-dump if misused,+   -- and not requiring Typeable.  THIS WILL GO IN GHC6.04+   Unsafe,+   UnsafeRegistry,++   NewRegistry(..),+   GetSetRegistry(..),+   GetSetRegistryDyn(..), -- direct access to dynamic values in+      -- Untyped's.+   KeyOpsRegistry(..),+      -- These classes describe access operations for registries.+   ListRegistryContents(..),+      -- extra block functions for typed registries.++   -- other specific operations+   changeKey,+      -- :: Ord from => Registry from to -> from -> from -> IO ()++   -- Operation for getting values directly from a Registry+   getRegistryValue,+      -- :: Ord from => Registry from to -> from -> IO to+      -- (This can be used to get a value without having to put+      -- a type annotation on it.)++   getValueDefault, -- :: ... => to -> registry -> from -> IO to++   lockedRegistryCheck, -- :: IO a -> IO (Either String a)+      -- For operations involving LockedRegistry's, catches the exception+      -- raised when we attempt to access a value inside a transformValue+      -- operation.+++   getValue',+      -- Function to be used instead of getValue for debugging purposes.+   getValueSafe,+      -- alias for that (useful in combination with CPP).+   getRegistryValueSafe,+      -- :: Ord from => String -> Registry from to -> from -> IO to+      -- corresponds to getValueSafe and getRegistryValue+   ) where++import Data.Maybe++import Control.Monad.Trans+import System.IO.Unsafe+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Concurrent+import Control.Exception+import GHC.Prim(unsafeCoerce#)+   -- Ouch.  Will go with ghc6++import Util.ExtendedPrelude(newFallOut,mkBreakFn)+import Util.Dynamics+import Util.BinaryAll+import Util.CompileFlags+import Util.Object(ObjectID)+++-- ----------------------------------------------------------------------+-- Classes, which describe the implementation.+-- ----------------------------------------------------------------------++class NewRegistry registry where+   newRegistry :: IO registry+   emptyRegistry :: registry -> IO ()++class GetSetRegistry registry from to where+   transformValue :: registry -> from -> (Maybe to -> IO (Maybe to,extra))+      -> IO extra+      -- transform a value, where "Nothing" means "value is not in+      -- the registry.  Locking is important, but depends on the+      -- implementation.+      -- Only this function has to be defined.+   getValueOpt :: registry -> from -> IO (Maybe to)+      -- returns Nothing if the value is not defined or+      -- has the wrong type.+   getValueOpt registry from = transformValue registry from+      (\ valueOpt -> return (valueOpt,valueOpt))++   getValue :: registry -> from -> IO to+      -- should raise an IO error if the value is not defined or-+      -- (for Untyped) has the wrong type.+   getValue registry from =+      do+         valueOpt <- getValueOpt registry from+         case valueOpt of+            Nothing -> error "Registry.getValue  - value undefined"+            Just value -> return value++   setValue :: registry -> from -> to -> IO ()+   setValue registry from to =+      transformValue registry from (\ _ -> return (Just to,()))+++-- | ListRegistryContents will not be implemented for the untyped registries.+class ListRegistryContents registry from to where+   listRegistryContents :: registry from to -> IO [(from,to)]++   listRegistryContentsAndEmptyRegistry :: registry from to -> IO [(from,to)]+      -- ^ this is atomic.++   listToNewRegistry :: [(from,to)] -> IO (registry from to)++getValueDefault :: GetSetRegistry registry from to+   => to -> registry -> from -> IO to+getValueDefault defTo registry from =+   do+      toOpt <- getValueOpt registry from+      case toOpt of+         Nothing -> return defTo+         Just to -> return to++class KeyOpsRegistry registry from where+   deleteFromRegistryBool :: registry -> from -> IO Bool+   -- deleteFromRegistryBool returns True if the element was in+   -- the registry and deletes it, otherwise False (and does nothing).+   deleteFromRegistry :: registry -> from -> IO ()+   -- This should fail silently if the key does not+   -- exist in the map.+   deleteFromRegistry registry from =+      do+         deleteFromRegistryBool registry from+         return ()++   listKeys :: registry -> IO [from]++-- ----------------------------------------------------------------------+-- Typed registries+-- The locking here for transformValue is not so clever and just locks the+-- whole map while the fallback action runs.+-- ----------------------------------------------------------------------++newtype Ord from => Registry from to = Registry (MVar (Map.Map from to))+   deriving (Typeable)++instance Ord from => NewRegistry (Registry from to) where+   newRegistry =+      do+         mVar <- newMVar Map.empty+         return (Registry mVar)+   emptyRegistry (Registry mVar) =+      do+         takeMVar mVar+         putMVar mVar Map.empty++instance Ord from => GetSetRegistry (Registry from to) from to where+   getValue registry from =+      do+         valueOpt <- getValueOpt registry from+         case valueOpt of+            Nothing ->+               ioError(userError "Registry.getValue - value not found")+            Just value -> return value++   getValueOpt (Registry mVar) from =+      do+         map <- readMVar mVar+         return (Map.lookup from map)++   transformValue (Registry mVar) from transformer =+      modifyMVar mVar+         (\ map ->+            do+               (newSetting,extra) <- transformer (Map.lookup from map)+               newMap <- case newSetting of+                  Just newTo -> return (Map.insert from newTo map)+                  Nothing -> return (Map.delete from map)+               return (newMap,extra)+            )++   setValue (Registry mVar) from to =+      do+         map <- takeMVar mVar+         putMVar mVar (Map.insert from to map)+++getRegistryValue :: Ord from => Registry from to -> from -> IO to+getRegistryValue registry from = getValue registry from+++getRegistryValueSafe :: Ord from => String -> Registry from to -> from -> IO to+getRegistryValueSafe label registry from = getValueSafe label registry from++instance Ord from => KeyOpsRegistry (Registry from to) from where+   deleteFromRegistryBool (Registry mVar) from =+      do+         map <- takeMVar mVar+         if Map.member from map+            then+               do+                  putMVar mVar (Map.delete from map)+                  return True+            else+               do+                  putMVar mVar map+                  return False++   deleteFromRegistry (Registry mVar) from =+      do+         map <- takeMVar mVar+         putMVar mVar (Map.delete from map)+   listKeys (Registry mVar) =+      do+         map <- readMVar mVar+         return (Map.keys map)++instance Ord from => ListRegistryContents Registry from to where+   listRegistryContents (Registry mVar) =+      do+         fm <- readMVar mVar+         return (Map.toList fm)++   listRegistryContentsAndEmptyRegistry (Registry mVar) =+      modifyMVar mVar (\ fm ->+         return (Map.empty,Map.toList fm)+         )++   listToNewRegistry contents =+      do+         let map = Map.fromList contents+         mVar <- newMVar map+         return (Registry mVar)++-- | look up the element given by the first key, and if it exists+-- delete it, replacing it with the element given by the second key.+changeKey :: Ord from => Registry from to -> from -> from -> IO ()+changeKey (Registry mVar) oldKey newKey =+   modifyMVar_ mVar (\ fmap0 -> return (case Map.lookup oldKey fmap0 of+      Nothing -> fmap0+      Just elt ->+         let+            fmap1 = Map.delete oldKey fmap0+            fmap2 = Map.insert newKey elt fmap1+         in+            fmap2+         )+      )++-- ----------------------------------------------------------------------+-- Untyped Registries+-- ----------------------------------------------------------------------++-- We abbreviate a common case:+type UntypedRegistry from = Untyped Registry from++newtype Untyped registry from = Untyped (registry from Dyn)++instance NewRegistry (registry from Dyn)+   => NewRegistry (Untyped registry from) where+   newRegistry =+      do+         registry <- newRegistry+         return (Untyped registry)+   emptyRegistry (Untyped registry) = emptyRegistry registry++fromDynamicMessage :: Typeable to => String -> Dyn -> to+fromDynamicMessage fName dyn =+   case fromDynamic dyn of+      Just to -> to+      Nothing -> error ("Registry."++fName++" - value has wrong type")++instance (Typeable to,GetSetRegistry (registry from Dyn) from Dyn)+   => GetSetRegistry (Untyped registry from) from to where+   transformValue (Untyped registry) from transformer =+      do+         let+            valMapIn = fromDynamicMessage "transformValue"+            valMapOut val = toDyn val+            transformerDyn dynInOpt =+               do+                  let valInOpt = (fmap valMapIn) dynInOpt+                  (valOutOpt,extra) <- transformer valInOpt+                  let dynOutOpt = (fmap valMapOut) valOutOpt+                  return (dynOutOpt,extra)+         transformValue registry from transformerDyn++instance KeyOpsRegistry (registry from Dyn) from+   => KeyOpsRegistry (Untyped registry from) from where+   deleteFromRegistryBool (Untyped registry) from =+      deleteFromRegistryBool registry from+   deleteFromRegistry (Untyped registry) from =+      deleteFromRegistry registry from+   listKeys (Untyped registry) = listKeys registry++-- We also provide direct setting/unsetting of Dyn values.+class GetSetRegistryDyn registry from where+   setValueAsDyn :: registry -> from -> Dyn -> IO ()+   getValueAsDyn :: registry -> from -> IO Dyn++instance GetSetRegistry (registry from Dyn) from Dyn+   => GetSetRegistryDyn (Untyped registry from) from where++   setValueAsDyn (Untyped registry) from dyn =+      setValue registry from dyn+   getValueAsDyn (Untyped registry) from =+      getValue registry from++-- ----------------------------------------------------------------------+-- Unsafe Registries+-- To be used only in dire emergency where GHC's obscure multi-parameter+-- type rules aren't able to infer Typeable, these will cause core dumps+-- if the types are wrong.+-- ----------------------------------------------------------------------++type UnsafeRegistry from = Unsafe Registry from++data Obj = Obj+ -- to hold the value, which may be of any type.++toObj :: a -> Obj+toObj = unsafeCoerce#++fromObj :: Obj -> a+fromObj = unsafeCoerce#++newtype Unsafe registry from = Unsafe (registry from Obj)++instance NewRegistry (registry from Obj)+   => NewRegistry (Unsafe registry from) where+   newRegistry =+      do+         registry <- newRegistry+         return (Unsafe registry)+   emptyRegistry (Unsafe registry) = emptyRegistry registry++instance (GetSetRegistry (registry from Obj) from Obj)+   => GetSetRegistry (Unsafe registry from) from to where+   transformValue (Unsafe registry) from transformer =+      do+         let+            transformerObj objInOpt =+               do+                  let valInOpt = (fmap fromObj) objInOpt+                  (valOutOpt,extra) <- transformer valInOpt+                  let objOutOpt = (fmap toObj) valOutOpt+                  return (objOutOpt,extra)+         transformValue registry from transformerObj++instance KeyOpsRegistry (registry from Obj) from+   => KeyOpsRegistry (Unsafe registry from) from where+   deleteFromRegistryBool (Unsafe registry) from =+      deleteFromRegistryBool registry from+   deleteFromRegistry (Unsafe registry) from =+      deleteFromRegistry registry from+   listKeys (Unsafe registry) = listKeys registry++-- ----------------------------------------------------------------------+-- Locked registries.  These improve on the previous model in+-- that transformValue actions do not lock the whole registry,+-- but only the key whose value is being transformed.+--+-- They also catch cases where an locked registry function is used+-- inside a transformValue, and throw an appropriate exception, which+-- can be caught using lockedRegistryCheck.+-- ----------------------------------------------------------------------++newtype LockedRegistry from to+   = Locked (Registry from (MVar (Maybe to),Set.Set ThreadId))+   deriving (Typeable)++type UntypedLockedRegistry from = Untyped LockedRegistry from++instance Ord from => NewRegistry (LockedRegistry from to) where+   newRegistry =+      do+         registry <- newRegistry+         return (Locked registry)+   emptyRegistry (Locked registry) = emptyRegistry registry++-- utility functions transformValue will need+takeVal :: Ord from => LockedRegistry from to -> from -> IO (Maybe to)+takeVal (Locked registry) from =+   do+      mVar <-+         transformValue registry from+            (\ dataOpt ->+               do+                  threadId <- myThreadId+                  case dataOpt  of+                     Nothing ->+                        do+                           mVar <- newMVar Nothing+                           return (Just (mVar,Set.singleton threadId),mVar)+                     Just (mVar,set0) ->+                        if Set.member threadId set0+                           then -- error+                              mkBreakFn lockedFallOutId+                                 ("Circular transformValue detected in "+                                    ++ "Registry.LockedRegistry")+                           else+                              return (Just (mVar,Set.insert threadId set0),mVar)+               )+      takeMVar mVar+++putVal :: Ord from => LockedRegistry from to -> from -> Maybe to -> IO ()+putVal (Locked registry) from toOpt =+   transformValue registry from+      (\ dataOpt ->+         do+            threadId <- myThreadId+            case dataOpt of+               Nothing -> error "Registry: unmatched putVal"+               Just (mVar,set0) ->+                  do+                     let+                        set1 = Set.delete threadId set0+                     if Set.null set1 && not (isJust toOpt)+                        then+                           return (Nothing,())+                        else+                           do+                              putMVar mVar toOpt+                              return (Just (mVar,set1),())+         )++++lockedRegistryCheck :: IO a -> IO (Either String a)++lockedFallOutId :: ObjectID+(lockedFallOutId,lockedRegistryCheck) = lockedCheckBreak++lockedCheckBreak :: (ObjectID,IO a -> IO (Either String a))+lockedCheckBreak = unsafePerformIO newFallOut+{-# NOINLINE lockedCheckBreak #-}++instance Ord from => GetSetRegistry (LockedRegistry from to) from to where+   transformValue lockedRegistry from transformer =+      do+         valInOpt <- takeVal lockedRegistry from+         resultOrError <- Control.Exception.try (transformer valInOpt)+         case resultOrError of+            Left error ->+               do+                  putVal lockedRegistry from valInOpt+                  Control.Exception.throw error+            Right (valOutOpt,extra) ->+               do+                  putVal lockedRegistry from valOutOpt+                  return extra++instance Ord from => KeyOpsRegistry (LockedRegistry from to) from where+   deleteFromRegistryBool lockedRegistry from =+      do+         toOpt <- takeVal lockedRegistry from+         putVal lockedRegistry from Nothing+         return (isJust toOpt)+   listKeys (Locked registry) = listKeys registry+++-- ----------------------------------------------------------------------+-- Function to be preferred to getValue when it is not absolutely certain+-- if a value is there, since it prints the label if things go wrong.+-- ----------------------------------------------------------------------++getValueSafe :: GetSetRegistry registry from to+   => String -> registry -> from -> IO to+getValueSafe = getValue'+++getValue' :: GetSetRegistry registry from to+   => String -> registry -> from -> IO to+getValue' =+   if isDebug+      then+         (\ label registry from ->+            do+               toOpt <- getValueOpt registry from+               case toOpt of+                  Nothing -> error ("Registry.getValue' - failed with "+                     ++ label)+                  Just to -> return to+            )+      else+         (\ label -> getValue)++++-- ----------------------------------------------------------------------+-- Instance of HasBinary for monads which have IO.+-- ----------------------------------------------------------------------++instance (HasBinary (from,to) m,Ord from,MonadIO m)+   => HasBinary (Registry from to) m where++   writeBin = mapWriteIO listRegistryContents+   readBin = mapReadIO listToNewRegistry
+ Util/Sink.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | Very primitive concurrency, this implements a sink, which passes messages+-- along until the receiver is no longer interested.+module Util.Sink(+   HasInvalidate(..),++   SinkID,+   newSinkID,++   Sink,+   newSink,+   newSinkGeneral,+   newParallelSink,+   newParallelDelayedSink,++   putSink,+   putSinkMultiple,+   coMapSink,+   coMapSink',+   coMapIOSink',++   CanAddSinks(..),+   addNewAction,++   ParallelExec,+   newParallelExec,+   parallelExec,+   parallelExecVSem,+   ) where++import Control.Concurrent+import Control.Exception (try)+import System.IO.Unsafe+import Data.IORef++import Util.Object+import Util.ExtendedPrelude+import Util.Thread+import Util.Computation (done)+import Util.VSem++-- -------------------------------------------------------------------------+-- The HasInvalidate+-- -------------------------------------------------------------------------++-- | The HasInvalidate class represents information sources which can be told+-- \"No more, I\'m not interested.\"+class HasInvalidate source where+   invalidate :: source -> IO ()++-- -------------------------------------------------------------------------+-- SinkID+-- -------------------------------------------------------------------------++--+-- A SinkID identifies the consumer and whether the consumer is still+-- interested.+data SinkID = SinkID {+   oID :: ObjectID,+   interested :: IORef Bool+   }++newSinkID :: IO SinkID+newSinkID =+   do+      oID <- newObject+      interested <- newIORef True+      return (SinkID {+         oID = oID,+         interested = interested+         })++-- | Returns True if sink is still interested+isInterested :: SinkID -> IO Bool+isInterested sinkID = readIORef (interested sinkID)++instance HasInvalidate SinkID where+   invalidate sinkID = writeIORef (interested sinkID) False++instance Eq SinkID where+   (==) sinkID1 sinkID2 = (oID sinkID1) == (oID sinkID2)++instance Ord SinkID where+   compare sinkID1 sinkID2 = compare (oID sinkID1) (oID sinkID2)+++-- -------------------------------------------------------------------------+-- Sinks+-- -------------------------------------------------------------------------++data Sink x = Sink {+   sinkID :: SinkID,+   action :: x -> IO ()+   }++-- -------------------------------------------------------------------------+-- The consumer's interface+-- -------------------------------------------------------------------------++-- | Creates a new sink with its own SinkID+newSink :: (x -> IO ()) -> IO (Sink x)+newSink action =+   do+      sinkID <- newSinkID+      newSinkGeneral sinkID action++-- | Creates a new sink with a given SinkID.  This allows us to+-- invalidate lots of sinks just by invalidating one sinkID.+newSinkGeneral :: SinkID -> (x -> IO ()) -> IO (Sink x)+newSinkGeneral sinkID action = return (Sink {sinkID = sinkID,action = action})++-- | Or we can do so with HasInvalidate+instance HasInvalidate (Sink x) where+   invalidate sink = invalidate (sinkID sink)++-- -------------------------------------------------------------------------+-- The provider's interface+-- -------------------------------------------------------------------------++-- | Put a value into the sink, returning False if the sink id has been+-- invalidated.+putSink :: Sink x -> x -> IO Bool+putSink sink x =+   do+      interested <- isInterested (sinkID sink)+      if interested then (action sink x) else done+      return interested+-- | Put a list of values into the sink, returning False if the sink id has been+-- invalidated+putSinkMultiple :: Sink x -> [x] -> IO Bool+putSinkMultiple sink [] = return True+putSinkMultiple sink (x:xs) =+   do+      interested <- putSink sink x+      if interested+         then+            putSinkMultiple sink xs+         else+            return interested++-- | Convert a sink from one type to another+coMapSink :: (y -> x) -> Sink x -> Sink y+coMapSink fn (Sink {sinkID = sinkID,action = action}) =+   Sink {sinkID = sinkID,action = action . fn}++-- | Another version which allows a transformation function to filter+-- certain elements+coMapSink' :: (y -> Maybe x) -> Sink x -> Sink y+coMapSink' fn (Sink {sinkID = sinkID,action = action}) =+   let+      action' y = case fn y of+         Nothing -> done+         Just x -> action x+   in+      Sink {sinkID = sinkID,action = action'}++-- | A version which allows an IO action, which had better not take too long.+coMapIOSink' :: (y -> IO (Maybe x)) -> Sink x -> Sink y+coMapIOSink' actFn (Sink {sinkID = sinkID,action = action}) =+    let+       action' y =+          do+             xOpt <- actFn y+             case xOpt of+                Nothing -> done+                Just x -> action x+    in+       Sink {sinkID = sinkID,action = action'}++-- -------------------------------------------------------------------------+-- The CanAddSinks class.+-- -------------------------------------------------------------------------++-- | A class for things (in particular Source and SimpleSource) that can+-- output via sinks.  Each sink source is supposed to have a unique+-- x, containing a representation of the current value, and delta,+-- containing the (incremental) updates which are put in the sink.+-- Only the addOrdSink function must be defined by instances.+class CanAddSinks sinkSource x delta | sinkSource -> x,sinkSource -> delta+      where+   ---+   -- Create and add a new sink containing the given action.+   addNewSink :: sinkSource -> (delta -> IO ()) -> IO (x,Sink delta)+   addNewSink sinkSource action =+      do+         parallelX <- newParallelExec+         addNewQuickSink sinkSource+            (\ delta -> parallelExec parallelX (action delta))++   ---+   -- Like addNewSink, but use the supplied SinkID+   addNewSinkGeneral :: sinkSource -> (delta -> IO ()) -> SinkID+      -> IO (x,Sink delta)+   addNewSinkGeneral sinkSource action sinkID =+      do+         parallelX <- newParallelExec+         addNewSinkVeryGeneral sinkSource action sinkID parallelX++   ---+   -- Like addNewQuickSink, but use the supplied ParallelExec as well+   addNewSinkVeryGeneral :: sinkSource -> (delta -> IO ()) -> SinkID+      -> ParallelExec -> IO (x,Sink delta)+   addNewSinkVeryGeneral sinkSource action sinkID parallelX =+      addNewQuickSinkGeneral+         sinkSource+         (\ delta -> parallelExec parallelX (+            do+               -- add an extra check here to prevent surplus queued actions+               -- being performed after the sink has been invalidated.+               interested <- isInterested sinkID+               if interested then action delta else done+            ))+         sinkID++   ---+   -- Like addNewSinkVeryGeneral, but compute an action from the x value which+   -- is performed in the parallelExec thread first of all.+   addNewSinkWithInitial :: sinkSource -> (x -> IO ()) -> (delta -> IO ())+      -> SinkID -> ParallelExec -> IO (x,Sink delta)+   addNewSinkWithInitial sinkSource xAction deltaAction sinkID parallelX =+      do+         mVar <- newEmptyMVar+         let+            firstAct =+               do+                  x <- takeMVar mVar+                  xAction x+         parallelExec parallelX firstAct+         (returnValue @ (x,sink))+            <- addNewSinkVeryGeneral sinkSource deltaAction sinkID parallelX+         putMVar mVar x+         return returnValue++   ---+   -- Like addNewSink, but the action is guaranteed to terminate quickly+   -- and normally.+   addNewQuickSink :: sinkSource -> (delta -> IO ()) -> IO (x,Sink delta)+   addNewQuickSink sinkSource action =+      do+         sink <- newSink action+         x <- addOldSink sinkSource sink+         return (x,sink)++   ---+   -- Like addNewQuickSink, but use the supplied SinkID+   addNewQuickSinkGeneral :: sinkSource -> (delta -> IO ()) -> SinkID+      -> IO (x,Sink delta)+   addNewQuickSinkGeneral sinkSource action sinkID =+      do+         sink <- newSinkGeneral sinkID action+         x <- addOldSink sinkSource sink+         return (x,sink)++   ---+   -- Adds a pre-existing sink.+   addOldSink :: sinkSource -> Sink delta -> IO x++-- | Add an action to a sinkSource which is performed until the action returns+-- False.+addNewAction :: CanAddSinks sinkSource x delta+   => sinkSource -> (delta -> IO Bool) -> IO x+addNewAction sinkSource action =+   do+      sinkMVar <- newEmptyMVar+      let+         deltaAct delta =+            do+               continue <- action delta+               if continue+                  then+                     done+                  else+                     do+                        sink <- takeMVar sinkMVar+                        invalidate sink+                        simpleFallOut ""++      (x,sink) <- addNewSink sinkSource deltaAct+      putMVar sinkMVar sink+      return x++-- -------------------------------------------------------------------------+-- A ParallelExec executes actions concurrently in a separate thread+--+-- Apart from (probably) being cheaper than forking off a new thread+-- each time, it also guarantees the order of the actions.+--+-- The Thread can be stopped with simpleFallOut.+--+-- We also provide a VSem which is locked locally when a parallelExec action+-- is pending.+-- -------------------------------------------------------------------------++newtype ParallelExec = ParallelExec (Chan (IO ()))++parallelExecVSem :: VSem+parallelExecVSem = unsafePerformIO newVSem+{-# NOINLINE parallelExecVSem #-}++newParallelExec :: IO ParallelExec+newParallelExec =+   do+      chan <- newChan+      let+         parallelExecThread0 =+            do+               act <- readChan chan+               result <- try act+               case result of+                  Left excep -> putStrLn ("Exception detected: "+                     ++ showException2 excep)+                  Right () -> done+               releaseLocal parallelExecVSem++               parallelExecThread0++         parallelExecThread =+            do+               addSimpleFallOut parallelExecThread0+               done++      forkIODebug parallelExecThread+      return (ParallelExec chan)++parallelExec :: ParallelExec -> IO () -> IO ()+parallelExec (ParallelExec chan) act =+   do+      acquireLocal parallelExecVSem+      writeChan chan act++-- | Creates a new sink which executes actions in a parallelExec thread.+newParallelSink :: (x -> IO ()) -> IO (Sink x)+newParallelSink action =+   do+      parallelX <- newParallelExec+      sinkID <- newSinkID+      newSinkGeneral sinkID (\ delta -> parallelExec parallelX (+         do+            interested <- isInterested sinkID+            if interested then action delta else done+         ))++-- | Creates a new sink which executes actions in a parallelExec thread,+-- but allow the function generating these actions to be specified later,+-- via the returned command.+newParallelDelayedSink :: IO (Sink x,(x -> IO ()) -> IO ())+newParallelDelayedSink =+   do+      actionMVar <- newEmptyMVar+      parallelX <- newParallelExec+      sinkID <- newSinkID++      sink <- newSinkGeneral sinkID (\ delta -> parallelExec parallelX (+         do+            interested <- isInterested sinkID+            if interested+               then+                  do+                     action <- readMVar actionMVar+                     action delta+               else+                  done+         ))++      return (sink,putMVar actionMVar)+
+ Util/Sources.hs view
@@ -0,0 +1,990 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Description: Simple Events+--+-- We implement the Source type and combinators for it.+module Util.Sources(+   Source,+      -- A Source x d represents something that stores a value of+      -- type x and sends change messages of type d.++      -- We instance CanAddSinks (Source x d) x d++   Client,+      -- A Client d is something that consumes change messages of type d.++   -- Producer side+   staticSource, -- :: x -> Source x d+      -- returns a source which never changes++   staticSourceIO, -- :: IO x -> Source x d+      -- returns a source which never changes but gets its initial value+      -- from an IO action.++   variableSource, -- :: x -> IO (Source x d,(x -> (x,[d])) -> IO ())+      -- returns a source which can change.  The supplied action+      -- changes it.++   variableGeneralSource,+      -- :: x -> IO (Source x d,Updater x d)+      -- Like variableSource, but allows the provider of new values to+      -- get out an extra value.  For this it is necessary to go+      -- via the Updater type.++   Updater,+   applyToUpdater, -- :: Updater x d -> (x -> (x,[d],extra)) -> IO extra++   -- Client side+   attachClient, -- :: Client d -> Source x d -> IO x++   -- Transformers+   map1,+      -- :: (x1 -> x2) -> Source x1 d -> Source x2 d++   map1IO,+      -- :: (x1 -> IO x2) -> Source x1 d -> Source x2 d++   map2,+      -- :: (d1 -> d2) -> Source x d1 -> Source x d2+   filter2,+      -- :: (d1 -> Maybe d2) -> Source x d1 -> Source x d2++   filter2IO,+      -- :: (d1 -> IO (Maybe d2)) -> Source x d1 -> Source x d2+      -- To be used with care, since the IO action ties up the source.++   foldSource,+      -- :: (x -> state) -> (state -> d1 -> (state,d2))+      --    -> Source x d1 -> Source (state,x) d2++   foldSourceIO,+      -- :: (x1 -> IO (state,x2)) -> (state -> d1 -> IO (state,d2))+      -- -> Source x1 d1 -> Source (state,x2) d2++   stepSource,+      -- :: (x -> d2) -> (d1 -> d2) -> Source x d1 -> Source x d2+      -- This modifies the source so that whenever we attempt to read from it,+      -- the current "x" value is BOTH returned AND converted to an instant+      -- update (via the first function).++   -- Combinators+   choose,+      -- :: Source x1 d1 -> Source x2 d2 -> Source (x1,x2) (Either d1 d2)+   seqSource,+      -- :: Source x1 x1 -> (x1 -> Source x2 x2) -> Source x2 x2+   flattenSource,+      -- :: Source x [d] -> Source x d+      -- A Source combinator which "flattens" lists of updates.++   -- Monadic Sources+   SimpleSource(..),+      -- newtype for Source x x+      -- Instance of Functor and Monad++   staticSimpleSource, -- :: x -> SimpleSource x++   staticSimpleSourceIO, -- :: IO x -> SimpleSource x++   -- We also instance CanAddSinks (SimpleSource x) x x.+   -- This is done via the following class+   HasSource(..),+   HasSimpleSource(..),++   readContents,+      -- :: HasSource source x d => source -> IO x+      -- Get the current contents of the source, but don't specify any other+      -- action.++   -- miscellaneous handy utilities,+   mkHistorySource, -- :: (x -> d) -> Source x d -> Source x (d,d)+   mkHistorySimpleSource, -- :: x -> SimpleSource x -> SimpleSource (x,x)+   uniqSimpleSource, -- :: Eq x => SimpleSource x -> SimpleSource x++   pairSimpleSources,+      -- :: SimpleSource x1 -> SimpleSource x2 -> SimpleSource (x1,x2)+      -- Pair two SimpleSource's.  This is probably better than using >>=,+      -- since it does not require reregistering with the second SimpleSource++   sequenceSimpleSource, -- :: [SimpleSource x] -> SimpleSource [x]+   -- Does a similar job to pairSimpleSources, so that the sources run+   -- parallel.++   change1, -- :: SimpleSource x -> x -> SimpleSource x+   -- replaces the first value of the SimpleSource.++   mapIOSeq,+      -- :: SimpleSource a -> (a -> IO (SimpleSource b)) -> SimpleSource b+      -- allow us to sequence a SimpleSource where the continuation function+      -- uses an IO action.++   addNewSourceActions,+      -- :: Source x d -> (x -> IO ()) -> (d -> IO ())+      -- -> SinkID -> ParallelExec -> IO x+   -- Run the specified actions for the source, using the given SinkID and+   -- in the ParallelExec thread.+   -- The x -> IO () action is guaranteed to be performed before any of the+   -- d -> IO () actions.++   traceSimpleSource,+      -- :: (a -> String) -> SimpleSource a -> SimpleSource a+      -- Outputs information about what comes through the source, turning+      -- it into a String with the supplied function.  (This is done once+      -- for each active client.)++   traceSource,+      -- :: (a -> String) -> (d -> String) -> Source a d -> Source a d+      -- Like traceSimpleSource but for Source's.++   noLoopSimpleSource,+      -- :: TSem -> ([String] -> a) -> SimpleSource a -> SimpleSource a+      -- Used when we are worried that a SimpleSource recursively constructed+      -- by mapIOSeq, >>= and friends may actually try to call itself, and+      -- so loop forever.   The Strings identify the SimpleSource,+      -- and so the [String] is effectively a backtrace of the TSems,+      -- revealing what chain of simple sources might have caused the loop.++   mkIOSimpleSource,+      -- :: IO (SimpleSource a) -> SimpleSource a++   foldSimpleSourceIO,+      -- :: (x1 -> IO (state,x2)) -> (state -> x1 -> IO (state,x2))+      -- -> SimpleSource x1 -> SimpleSource x2++   ) where++import Data.Maybe++import Control.Concurrent+import Data.IORef++import Util.ExtendedPrelude(HasMapIO(..))+import Util.Sink+import Util.TSem+import Util.Debug(debug)++-- -----------------------------------------------------------------+-- Datatypes+-- -----------------------------------------------------------------++newtype Source x d = Source (Client d -> IO x)++newtype Client d = Client (d -> IO (Maybe (Client d)))++data SourceData x d = SourceData {+   x :: x,+   client :: Maybe (Client d)+   }++-- -----------------------------------------------------------------+-- Producer side+-- -----------------------------------------------------------------++staticSource :: x -> Source x d+staticSource x = Source (\ _ -> return x)+++staticSourceIO :: IO x -> Source x d+staticSourceIO action = Source (\ _ -> action)++variableSource :: x -> IO (Source x d,(x -> (x,[d])) -> IO ())+variableSource x =+   do+      mVar <- newMVar (SourceData {+         x = x,+         client = Nothing+         })+      let+         update updateFn =+            do+               (SourceData {x = x1,client = clientOpt}) <- takeMVar mVar+               let+                  (x2,ds) = updateFn x1++                  sendUpdates (Just (Client clientFn)) (d:ds) =+                     do+                        newClientOpt <- clientFn d+                        sendUpdates newClientOpt ds+                  sendUpdates clientOpt _ = return clientOpt++               newClientOpt <- sendUpdates clientOpt ds+               putMVar mVar (SourceData {x = x2,client = newClientOpt})+         addClient newClient =+            do+               (SourceData {x = x,client = oldClientOpt}) <- takeMVar mVar+               let+                  fullNewClient = case oldClientOpt of+                     Nothing -> newClient+                     Just oldClient -> combineClients oldClient newClient+               putMVar mVar (SourceData {x = x,client = Just fullNewClient})+               return x+      return (Source addClient,update)+++newtype Updater x d = Updater (forall extra . (x -> (x,[d],extra)) -> IO extra)++applyToUpdater :: Updater x d -> (x -> (x,[d],extra)) -> IO extra+applyToUpdater (Updater update) updateAct = update updateAct++variableGeneralSource :: x -> IO (Source x d,Updater x d)+variableGeneralSource x =+   do+      mVar <- newMVar (SourceData {+         x = x,+         client = Nothing+         })+      let+         update updateFn =+            do+               (SourceData {x = x1,client = clientOpt}) <- takeMVar mVar++               let+                  (x2,ds,extra) = updateFn x1+                  sendUpdates (Just (Client clientFn)) (d:ds) =+                     do+                        newClientOpt <- clientFn d+                        sendUpdates newClientOpt ds+                  sendUpdates clientOpt _ = return clientOpt++               newClientOpt <- sendUpdates clientOpt ds+               putMVar mVar (SourceData {x = x2,client = newClientOpt})+               return extra+         addClient newClient =+            do+               (SourceData {x = x,client = oldClientOpt}) <- takeMVar mVar+               let+                  fullNewClient = case oldClientOpt of+                     Nothing -> newClient+                     Just oldClient -> combineClients oldClient newClient+               putMVar mVar (SourceData {x = x,client = Just fullNewClient})+               return x+      return (Source addClient,Updater update)++combineClients :: Client d -> Client d -> Client d+combineClients (Client clientFn1) (Client clientFn2) =+   let+      clientFn d =+         do+            newClient1Opt <- clientFn1 d+            newClient2Opt <- clientFn2 d+            case (newClient1Opt,newClient2Opt) of+               (Nothing,Nothing) -> return Nothing+               (Just newClient1,Nothing) -> return (Just newClient1)+               (Nothing,Just newClient2) -> return (Just newClient2)+               (Just newClient1,Just newClient2)+                  -> return (Just (combineClients newClient1 newClient2))+   in+      Client clientFn++-- -----------------------------------------------------------------+-- Client side+-- -----------------------------------------------------------------++attachClient :: Client d -> Source x d -> IO x+attachClient client (Source addClient) = addClient client++-- | attachClientTemporary is like attach, but additionally returns an+-- IO action which can be used to prevent any client being run after that+-- IO action is called.+attachClientTemporary :: Client d -> Source x d -> IO (x,IO ())+attachClientTemporary client source =+   do+      (newClient,terminator) <- mkTemporaryClient client+      x <- attachClient newClient source+      return (x,terminator)++-- | mkTemporaryClient is used to map the client by attachClientTemporary.+mkTemporaryClient :: Client d -> IO (Client d,IO ())+mkTemporaryClient client =+   do+      ioRef <- newIORef True -- write False to this to stop the client.+      let+         newClient client = Client (newClientFn client)++         newClientFn (Client oldClientFn) d  =+            do+               goAhead <- readIORef ioRef+               if goAhead+                  then+                     do+                        newClientOpt <- oldClientFn d+                        return (fmap newClient newClientOpt)+                  else+                     return Nothing+      return (newClient client,writeIORef ioRef False)++-- | mkComputedClient computes a client using a value to be supplied via the+-- returned function.  (Hopefully soon after, because of course the source+-- will block until it is.)+mkComputedClient :: (x -> Client d) -> IO (Client d,x -> IO ())+mkComputedClient getClient =+   do+      mVar <- newEmptyMVar+      let+         client = Client clientFn++         clientFn d =+            do+               x <- takeMVar mVar+               let+                  (Client realClientFn) = getClient x+               realClientFn d+      return (client,putMVar mVar)++-- | mkComputedClient is like mkComputedClient, but still more dangerously+-- allows an IO action to compute the client.+--+-- It also allows the supplied function to provide Nothing, indicating no+-- client.+mkComputedClientIO :: (x -> IO (Maybe (Client d))) -> IO (Client d,x -> IO ())+mkComputedClientIO getClient =+   do+      mVar <- newEmptyMVar+      let+         client = Client clientFn++         clientFn d =+            do+               x <- takeMVar mVar+               clientOpt <- getClient x+               case clientOpt of+                  Nothing -> return Nothing+                  Just (Client realClientFn) -> realClientFn d+      return (client,putMVar mVar)++-- | mkStaticClient is used by various functions to create from a client+-- a single static client which tracks its state using an MVar.+mkStaticClient :: Client d -> IO (Client d)+mkStaticClient client =+   do+      (newClient,_) <- mkStaticClientGeneral client+      return newClient++-- | mkStaticClientGeneral is like mkStaticClient except that it also returns+-- an action which determines if the client is still running.+mkStaticClientGeneral :: Client d -> IO (Client d,IO Bool)+mkStaticClientGeneral (client :: Client d) =+   do+      mVar <- newMVar (Just client)+      let+         client = Client clientFn++         clientFn d =+            do+               clientOpt <- takeMVar mVar+               case clientOpt of+                  Nothing -> do+                     putMVar mVar clientOpt+                     return Nothing+                  Just (Client clientFnInner) ->+                     do+                        newClientOpt <- clientFnInner d+                        putMVar mVar newClientOpt+                        return (Just client)++         clientRunning =+            do+               clientOpt <- readMVar mVar+               return (isJust clientOpt)++      return (client,clientRunning)++-- -----------------------------------------------------------------+-- Transformers+-- -----------------------------------------------------------------++map1 :: (x1 -> x2) -> Source x1 d -> Source x2 d+map1 mapFn (Source addClient1) =+   let+      addClient2 d =+         do+            x1 <- addClient1 d+            return (mapFn x1)+   in+      Source addClient2++map1IO :: (x1 -> IO x2) -> Source x1 d -> Source x2 d+map1IO mapFn (Source addClient1) =+   let+      addClient2 d =+         do+            x1 <- addClient1 d+            mapFn x1+   in+      Source addClient2++map2 :: (d1 -> d2) -> Source x d1 -> Source x d2+map2 mapFn (Source addClient1) =+   let+      addClient2 newClient1 = addClient1 (coMapClient mapFn newClient1)+   in+      Source addClient2++coMapClient :: (d1 -> d2) -> Client d2 -> Client d1+coMapClient mapFn (Client clientFn2) =+   let+      client1 = Client clientFn1++      clientFn1 d1 =+         do+            let+               d2 = mapFn d1+            newClient2Opt <- clientFn2 d2+            return (fmap+               (coMapClient mapFn)+               newClient2Opt+               )+   in+      client1++filter2 :: (d1 -> Maybe d2) -> Source x d1 -> Source x d2+filter2 filterFn (Source addClient1) =+   let+      addClient2 newClient1 = addClient1 (filterClient filterFn newClient1)+   in+      Source addClient2++filterClient :: (d1 -> Maybe d2) -> Client d2 -> Client d1+filterClient filterFn (Client clientFn2) =+   let+      client1 = Client clientFn1++      clientFn1 d1 =+         let+            d2Opt = filterFn d1+         in+            case d2Opt of+               Nothing -> return (Just client1)+               Just d2 ->+                  do+                     newClient2Opt <- clientFn2 d2+                     return (fmap+                        (filterClient filterFn)+                        newClient2Opt+                        )+   in+      client1++filter2IO :: (d1 -> IO (Maybe d2)) -> Source x d1 -> Source x d2+filter2IO filterFn (Source addClient1) =+   let+      addClient2 newClient1 = addClient1 (filterClientIO filterFn newClient1)+   in+      Source addClient2++filterClientIO :: (d1 -> IO (Maybe d2)) -> Client d2 -> Client d1+filterClientIO filterFn (Client clientFn2) =+   let+      client1 = Client clientFn1++      clientFn1 d1 =+         do+            d2Opt <- filterFn d1+            case d2Opt of+               Nothing -> return (Just client1)+               Just d2 ->+                  do+                     newClient2Opt <- clientFn2 d2+                     return (fmap+                        (filterClientIO filterFn)+                        newClient2Opt+                        )+   in+      client1++foldSource :: (x -> state) -> (state -> d1 -> (state,d2))+   -> Source x d1 -> Source (state,x) d2+foldSource xFn foldFn =+   let+      xFnIO x = return (xFn x,x)+      foldFnIO state d = return (foldFn state d)+   in+      foldSourceIO xFnIO foldFnIO++-- | Fold a Source so that it can carry state around.+foldSourceIO :: (x1 -> IO (state,x2)) -> (state -> d1 -> IO (state,d2))+   -> Source x1 d1 -> Source (state,x2) d2+foldSourceIO (xFnIO :: x1 -> IO (state,x2))+      (foldFnIO :: state -> d1 -> IO (state,d2))+      ((Source addClient1) :: Source x1 d1) =+   let+      addClient2 :: Client d2 -> IO (state,x2)+      addClient2 client2 =+         do+            let+               createClient :: state -> Client d1+               createClient state = foldClientIO state foldFnIO client2+            (computedClient,writeState) <- mkComputedClient createClient+            x1 <- addClient1 computedClient++            (state,x2) <- xFnIO x1+            writeState state+            return (state,x2)+   in+      Source addClient2++foldClientIO+   :: state -> (state -> d1 -> IO (state,d2)) -> Client d2 -> Client d1+foldClientIO state1 foldFnIO (Client clientFn2) =+   let+      clientFn1 d1 =+         do+            (state2,d2) <- foldFnIO state1 d1+            (newClient2Opt) <- clientFn2 d2+            return (fmap+               (foldClientIO state2 foldFnIO)+               newClient2Opt+               )+   in+      Client clientFn1++stepSource :: (x -> d2) -> (d1 -> d2) -> Source x d1 -> Source x d2+stepSource fromX fromD (Source addClient1) =+   let+      addClient2 (Client clientFn2) =+         do+            (computedClient,writeClientOpt) <- mkComputedClientIO return+            x <- addClient1 ((coMapClient fromD) computedClient)+            clientOpt <- clientFn2 (fromX x)+            writeClientOpt clientOpt+            return x+   in+      Source addClient2++-- | A Source combinator which \"flattens\" lists of updates.+flattenSource :: Source x [d] -> Source x d+flattenSource (Source addClient1) =+   let+      addClient2 client1 = addClient1 (flattenClient client1)+   in+      (Source addClient2)++flattenClient :: Client d -> Client [d]+flattenClient client0 = Client (mkClientFn client0)+   where+      mkClientFn :: Client d -> [d] -> IO (Maybe (Client [d]))+      mkClientFn client0 [] = return (Just (flattenClient client0))+      mkClientFn (Client clientFn1) (d:ds) =+         do+            client1Opt <- clientFn1 d+            case client1Opt of+               Nothing -> return Nothing+               Just client2 -> mkClientFn client2 ds++-- -----------------------------------------------------------------+-- Combinators+-- -----------------------------------------------------------------++-- Combinators+choose :: Source x1 d1 -> Source x2 d2 -> Source (x1,x2) (Either d1 d2)+choose ((Source addClient1) :: Source x1 d1)+       ((Source addClient2) :: Source x2 d2) =+   let+      addClient (client :: Client (Either d1 d2)) =+         do+            (Client staticClientFn) <- mkStaticClient client+            let+               client1 = Client clientFn1++               clientFn1 d1 =+                  do+                     continue <- staticClientFn (Left d1)+                     return (fmap (\ _ -> client1) continue)++               client2 = Client clientFn2++               clientFn2 d2 =+                  do+                     continue <- staticClientFn (Right d2)+                     return (fmap (\ _ -> client2) continue)++            x1 <- addClient1 client1+            x2 <- addClient2 client2+            return (x1,x2)+   in+      Source addClient++seqSource :: Source x1 x1 -> (x1 -> Source x2 x2) -> Source x2 x2+seqSource source getSource = seqSourceIO source (\ x1 -> return (getSource x1))++seqSourceIO :: Source x1 x1 -> (x1 -> (IO (Source x2 x2))) -> Source x2 x2+seqSourceIO (source1 :: Source x1 x1) (getSource2 :: x1 -> IO (Source x2 x2)) =+   let+      addClient client2 =+         do+            (staticClient2 @ (Client staticClientFn),clientRunning)+               <- mkStaticClientGeneral client2++            let+               getClient1 :: (IO (),x1) -> Client x1+               getClient1 (oldTerminator,x1) =+                  let+                     client1 terminator = Client (clientFn1 terminator)++                     clientFn1 oldTerminator x1 =+                        do+                           source2 <- getSource2 x1++                           oldTerminator+                           continue <- clientRunning+                           if continue+                              then+                                 do+                                    (staticClient2',write)+                                       <- mkComputedClient+                                          (const staticClient2)++                                    (x2,newTerminator)+                                       <- attachClientTemporary+                                             staticClient2' source2+                                    staticClientFn x2+                                    write ()+                                    return (Just (client1 newTerminator))+                              else+                                 return Nothing+                  in+                     client1 oldTerminator++            (client1',write) <- mkComputedClient getClient1+            x1 <- attachClient client1' source1++            source2 <- getSource2 x1++            (x2,firstTerminator) <- attachClientTemporary staticClient2 source2+            write (firstTerminator,x1)+            return x2+   in+      Source addClient++-- -----------------------------------------------------------------+-- SimpleSource+-- -----------------------------------------------------------------++newtype SimpleSource x = SimpleSource (Source x x)++staticSimpleSource :: x -> SimpleSource x+staticSimpleSource x = SimpleSource (staticSource x)++staticSimpleSourceIO :: IO x -> SimpleSource x+staticSimpleSourceIO act = SimpleSource (staticSourceIO act)++instance Functor SimpleSource where+   fmap mapFn (SimpleSource source) =+      SimpleSource ( (map1 mapFn) . (map2 mapFn) $ source)++instance HasMapIO SimpleSource where+   mapIO mapFn (SimpleSource source) =+      SimpleSource (+         (map1IO mapFn)+         . (filter2IO+            (\ x ->+               do+                  y <- mapFn x+                  return (Just y)+               )+            )+         $ source+         )+++mapIOSeq :: SimpleSource a -> (a -> IO (SimpleSource b)) -> SimpleSource b+mapIOSeq (SimpleSource (source1 :: Source a a))+      (getSimpleSource :: (a -> IO (SimpleSource b))) =+   let+      getSource :: a -> IO (Source b b)+      getSource a =+         do+            (SimpleSource source) <- getSimpleSource a+            return source++      source2 :: Source b b+      source2 = seqSourceIO source1 getSource+   in+      SimpleSource source2++instance Monad SimpleSource where+   return x = SimpleSource (staticSource x)+   (>>=) (SimpleSource source1) getSimpleSource2 =+      let+         getSource2 x =+            let+               (SimpleSource source2) = getSimpleSource2 x+            in+               source2+      in+         SimpleSource (seqSource source1 getSource2)++-- -----------------------------------------------------------------+-- The HasSource and HasSimpleSource classes and their instances+-- -----------------------------------------------------------------++class HasSource hasSource x d | hasSource -> x,hasSource -> d where+   toSource :: hasSource -> Source x d++class HasSimpleSource hasSource x | hasSource -> x where+   toSimpleSource :: hasSource -> SimpleSource x++instance HasSource (Source x d) x d where+   toSource source = source++instance HasSimpleSource (SimpleSource x) x where+   toSimpleSource simpleSource = simpleSource++instance HasSource (SimpleSource x) x x where+   toSource (SimpleSource source) = source++-- -----------------------------------------------------------------+-- The readContents function+-- -----------------------------------------------------------------++-- | Get the current contents of the source, but don\'t specify any other+-- action.+readContents :: HasSource source x d => source -> IO x+readContents hasSource =+   let+      trivialClient = Client (\ _ -> return Nothing)+   in+      attachClient trivialClient (toSource hasSource)++-- -----------------------------------------------------------------+-- Instance of CanAddSinks+-- -----------------------------------------------------------------++instance HasSource hasSource x d => CanAddSinks hasSource x d where+   addOldSink hasSource sink =+      do+         let+            client = Client clientFn++            clientFn d =+               do+                  continue <- putSink sink d+                  return (if continue+                     then+                        Just client+                     else+                        Nothing+                     )+         attachClient client (toSource hasSource)++-- -----------------------------------------------------------------+-- Other handy utilities+-- -----------------------------------------------------------------++-- | Pair two SimpleSource\'s.  This is probably better than using >>=, since it+-- does not require reregistering with the second SimpleSource+pairSimpleSources :: SimpleSource x1 -> SimpleSource x2 -> SimpleSource (x1,x2)+pairSimpleSources (SimpleSource source1) (SimpleSource source2) =+   let+      sourceChoose = choose source1 source2+      source =+         foldSource+            id+            (\ (x1,x2) change ->+               let+                  new = case change of+                     Left newX1 -> (newX1,x2)+                     Right newX2 -> (x1,newX2)+               in+                  (new,new)+               )+            sourceChoose+   in+      SimpleSource (map1 fst source)++-- | Does a similar job to pairSimpleSources, so that the sources run+-- parallel.+sequenceSimpleSource :: [SimpleSource x] -> SimpleSource [x]+sequenceSimpleSource [] = return []+sequenceSimpleSource (first:rest) =+   fmap (uncurry (:)) (pairSimpleSources first (sequenceSimpleSource rest))++-- | For each update d, pairs it with its predecessor (given first).+-- For the very first update, a value is given based on the initial x,+-- mapped by the given function.+mkHistorySource :: (x -> d) -> Source x d -> Source x (d,d)+mkHistorySource getD source =+   map1 (\ (d,x) -> x) (foldSource getD (\ lastD d -> (d,(lastD,d))) source)++-- | Like mkHistorySource but for SimpleSource\'s; the x returns the initial+-- value to compare with.+mkHistorySimpleSource :: x -> SimpleSource x -> SimpleSource (x,x)+mkHistorySimpleSource lastX (SimpleSource source) =+   SimpleSource (map1 (\ x -> (lastX,x)) (mkHistorySource id source))++-- | filter out consecutive duplicates+uniqSimpleSource :: Eq x => SimpleSource x -> SimpleSource x+uniqSimpleSource (SimpleSource source0) =+   let+      source1 = mkHistorySource id source0+      source2 = filter2 (\ (lastD,d) -> if lastD == d then Nothing else Just d)+         source1+   in+      SimpleSource source2+++-- | Fold a Simple Source, so that it carries state.+-- The state is recomputed for each client.+foldSimpleSourceIO :: (x1 -> IO (state,x2)) -> (state -> x1 -> IO (state,x2))+   -> SimpleSource x1 -> SimpleSource x2+foldSimpleSourceIO (getStateIO :: x1 -> IO (state,x2)) updateStateIO+      (SimpleSource (source :: Source x1 x1)) =+   let+      source1 :: Source (state,x2) x2+      source1 = foldSourceIO getStateIO updateStateIO source+   in+      SimpleSource (map1 snd source1)++-- | replaces the first value of the SimpleSource.+change1 :: SimpleSource x -> x -> SimpleSource x+change1 (SimpleSource source) x = SimpleSource (map1 (\ _ -> x) source)++-- | Run the specified actions for the source, using the given SinkID and+-- in the ParallelExec thread.+-- The x -> IO () action is guaranteed to be performed before any of the+-- d -> IO () actions.+addNewSourceActions :: Source x d -> (x -> IO ()) -> (d -> IO ())+   -> SinkID -> ParallelExec -> IO x+addNewSourceActions (source1 :: Source x d) actionX actionD sinkID parallelX =+   do+      mVar <- newEmptyMVar -- used to return the first x value+      let+         actionX' x =+            do+               putMVar mVar x+               actionX x++         (source2 :: Source x (IO ())) = stepSource actionX' actionD source1+      addNewQuickSinkGeneral+         source2+         (\ action -> parallelExec parallelX action)+         sinkID+      takeMVar mVar++-- -----------------------------------------------------------------+-- Trace functions+-- -----------------------------------------------------------------++-- | Outputs information about what comes through the source, turning+-- it into a String with the supplied function.  (This is done once+-- for each active client.)+traceSimpleSource :: (a -> String) -> SimpleSource a -> SimpleSource a+traceSimpleSource toS (SimpleSource source) =+   SimpleSource (+      (map1IO+         (\ a ->+            do+               putStrLn ("Initialising "++toS a)+               return a+            )+         )+      .+      (filter2IO+         (\ a ->+            do+               putStrLn ("Updating "++toS a)+               return (Just a)+            )+         )+      $+      source+      )++-- | Outputs information about what comes through the source, turning+-- it into a String with the supplied function.  (This is done once+-- for each active client.)+traceSource :: (a -> String) -> (d -> String) -> Source a d -> Source a d+traceSource toS1 toS2 source =+   (map1IO+      (\ a ->+         do+            putStrLn ("Initialising "++toS1 a)+            return a+         )+      )+   .+   (filter2IO+      (\ d ->+         do+            putStrLn ("Updating "++toS2 d)+            return (Just d)+         )+      )+   $+   source++-- -----------------------------------------------------------------+-- noLoop functions.  (Only noLoopSimpleSource is exported, for now.)+-- -----------------------------------------------------------------++noLoopSource :: TSem -> ([String] -> x) -> ([String] -> d)+   -> Source x d -> Source x d+noLoopSource tSem toX toD (Source addClient0 :: Source x d) =+   let+      mkClient :: Client d -> Client d+      mkClient client = Client (mkClientFn client)++      mkClientFn :: Client d -> d -> IO (Maybe (Client d))+      mkClientFn (client @ (Client clientFn0)) d =+         do+            (looped :: Either [String] (Maybe (Client d)))+               <- synchronizeTSem tSem (clientFn0 d)+            case looped of+               Left strings ->+                  do+                     debug ("mkClientFn loop caught " ++ show strings)+                     -- repeat with the artificial d (which had better+                     -- not cause a loop).+                     mkClientFn client (toD strings)+               Right clientOpt -> return (fmap mkClient clientOpt)++      addClient1 :: Client d -> IO x+      addClient1 client =+         do+            stringsOrX <- synchronizeTSem tSem+               (addClient0 (mkClient client))+            case stringsOrX of+               Left strings -> return (toX strings)+               Right x -> return x+   in+      Source addClient1++-- | Used when we are worried that a SimpleSource recursively constructed+-- by mapIOSeq, >>= and friends may actually try to call itself, and+-- so loop forever.   The Strings identify the SimpleSource,+-- and so the [String] is effectively a backtrace of the TSems, revealing what+-- chain of simple sources might have caused the loop.+noLoopSimpleSource :: TSem -> ([String] -> a) -> SimpleSource a+   -> SimpleSource a+noLoopSimpleSource tSem toA (SimpleSource source0) =+   let+      source1 = noLoopSource tSem toA toA source0+   in+      SimpleSource source1++-- ---------------------------------------------------------------------------+-- mkIOSource and mkIOSimpleSource+-- ---------------------------------------------------------------------------++mkIOSource :: IO (Source x d) -> Source x d+mkIOSource act =+   let+      addClient client =+         do+            (Source addClient1) <- act+            addClient1 client+   in+      Source addClient++mkIOSimpleSource :: IO (SimpleSource a) -> SimpleSource a+mkIOSimpleSource act =+   SimpleSource (mkIOSource (+      do+         simpleSource <- act+         return (toSource simpleSource)+      ))
+ Util/Store.hs view
@@ -0,0 +1,31 @@+-- | A Store a contains an (a) value which is only to be computed once,+-- when it is first needed.+--+-- Perhaps we should use laziness and unsafePerformIO?+module Util.Store(+   Store,+   newStore, -- :: IO (Store a)+   takeStore, -- :: IO a -> Store a -> IO a+   ) where++import Control.Concurrent.MVar++newtype Store a = Store (MVar (Maybe a))++newStore :: IO (Store a)+newStore =+   do+      mVar <- newMVar Nothing+      return (Store mVar)++takeStore :: IO a -> Store a -> IO a+takeStore getA (Store mVar) =+   modifyMVar+      mVar+      (\ aOpt -> case aOpt of+         Just a -> return (aOpt,a)+         Nothing ->+            do+               a <- getA+               return (Just a,a)+         )
+ Util/TSem.hs view
@@ -0,0 +1,101 @@+-- | A TSem is an unusual sort of lock in that it only protects the same thread+-- from acquiring it twice.  Different threads may acquire the same TSem+-- without problems.+--+-- The purpose of this is to allow computations which potentially would+-- loop forever by calling themselves to instead fail gracefully.  To+-- aid in this process, we also include in each TSem a String.  When we+-- attempt to acquire a TSem which is already acquired, we instead return+-- the String for this TSem and the TSems acquired within this one.+module Util.TSem(+   TSem,+   newTSem, -- :: IO String -> IO TSem+   synchronizeTSem, -- TSem -> IO a -> IO (Either [String] a)+   ) where++import System.IO.Unsafe+import Control.Exception++import Util.Object+import Util.ExtendedPrelude++import Util.ThreadDict++-- ---------------------------------------------------------------------------+-- Datatypes+-- ---------------------------------------------------------------------------++data TSem = TSem {+   oId :: ObjectID,+   label :: IO String+   }++newtype ThreadInfo = ThreadInfo [TSem]+   -- Information we keep per thread.++-- ---------------------------------------------------------------------------+-- The global dictionary of ThreadInfo+-- ---------------------------------------------------------------------------++threadInfoDict :: ThreadDict ThreadInfo+threadInfoDict = unsafePerformIO newThreadDict+{-# NOINLINE threadInfoDict #-}++-- ---------------------------------------------------------------------------+-- The functions+-- ---------------------------------------------------------------------------++newTSem :: IO String -> IO TSem+newTSem label =+   do+      oId <- newObject+      return (TSem {oId = oId,label = label})++synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)+synchronizeTSem tSem act =+   do+      strActsOpt <- tryAcquire tSem+      case strActsOpt of+         Nothing -> finally+            (do+                a <- act+                return (Right a)+            )+            (release tSem)+         Just strActs ->+            do+               strs <- mapM id strActs+               return (Left strs)++tryAcquire :: TSem -> IO (Maybe [IO String])+-- if unsuccessful return the labels of all TSems held by this thread.+tryAcquire tSem =+   modifyThreadDict threadInfoDict+      (\ threadInfoOpt ->+         return (case threadInfoOpt of+            Nothing -> (Just (ThreadInfo [tSem]),Nothing)+            Just (ThreadInfo tSems) ->+               case splitToElem (\ tSem2 -> oId tSem2 == oId tSem) tSems+                     of+                  Nothing -> -- not already locked+                     (Just (ThreadInfo (tSem : tSems)),Nothing)+                  Just (tSems,_) -> -- already locked+                     (threadInfoOpt,Just (map label (tSem : reverse tSems)))+            )+         )++release :: TSem -> IO ()+release tSem =+   modifyThreadDict threadInfoDict+      (\ threadInfoOpt ->+         case threadInfoOpt of+            (Just (ThreadInfo (tSem2 : tSems)))+               | oId tSem2 == oId tSem+               ->+               return (+                  case tSems of+                     [] -> Nothing+                     _ -> Just (ThreadInfo tSems)+                  , ())+            _ -> error "TSem -- improperly nested release"+         )
+ Util/TempFile.hs view
@@ -0,0 +1,45 @@+-- | The TempFile module allocates temporary files+module Util.TempFile(+   newTempFile, -- :: IO FilePath+   ) where+++import System.Directory++import Control.Concurrent+import System.IO.Unsafe++import Util.IOExtras+import Util.WBFiles+import Util.UniqueFile+import Util.FileNames++data TempFileSource = TempFileSource {+   fileStore :: UniqueFileStore,+   fileSource :: MVar UniqueFileCounter+   }++tempFileSource :: TempFileSource+tempFileSource = unsafePerformIO (+   do+      workingDir <- getWorkingDir+      let directory = combineNames workingDir "#"+      catchAlreadyExists (createDirectory workingDir)+      catchAlreadyExists (createDirectory directory)+      fileStore <- newUniqueFileStore directory createDirectory+      fileSource <- newMVar initialUniqueFileCounter+      return (TempFileSource {fileStore = fileStore,fileSource = fileSource})+   )+{-# NOINLINE tempFileSource #-}++newTempFile :: IO FilePath+newTempFile =+   do+      let+         TempFileSource {fileStore = fileStore,fileSource = fileSource} =+            tempFileSource+      fileCounter <- takeMVar fileSource+      let (newName,nextFileCounter) = stepUniqueFileCounter fileCounter+      putMVar fileSource nextFileCounter+      ensureDirectories fileStore newName+      return (getFilePath fileStore newName)
+ Util/Thread.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnliftedFFITypes #-}++-- | Basic Thread operations.+module Util.Thread (++   ThreadId,++   hashThreadId, -- :: ThreadId -> Int32++   -- thread creation++   forkIODebug, -- :: IO () -> IO ThreadId+      -- Try to be more helpful about catching exceptions.+++   forkIOquiet,+      -- ALMOST identical with standard action.+      -- The differences are (a) that it takes an extra string argument+      -- (which goes first); (b) if the thread fails because of+      -- "BlockedOnDeadMVar" nothing is printed, but we output a+      -- message to "debug" which includes the label.+      -- NB.  This function no longer seems to be necessary in recent+      -- versions of GHC (current is 6.02.1) so please don't use it.+   goesQuietly,+   -- :: IO () -> IO ()+   -- This wraps an action so that if killed nothing is printed and it+   -- just returns.  This is useful for Expect and other things which+   -- get rid of a redundant thread by killing it.+   -- Now changed so that it also prints nothing for BlockedOnDeadMVar+++   -- delay thread execution+   Duration,+   mins,+   secs,+   msecs,+   usecs,+   delay,+   after,+   every,++   mapMConcurrent,+   mapMConcurrent_,+      -- evaluate a list of IO actions concurrently.+   mapMConcurrentExcep,+      -- evaluate a list of IO actions concurrently, also propagating+      -- exceptions properly.+   )+where++import qualified GHC.Conc+import qualified GHC.Base++import Control.Exception+import Control.Concurrent+import Control.Monad+import Data.HashTable+import Data.Int++import Util.Computation++import Util.Debug(debug)+import Util.ExtendedPrelude++-- --------------------------------------------------------------------------+-- Delay Thread Execution+-- --------------------------------------------------------------------------++type Duration = Int -- time in microseconds++delay :: Duration -> IO ()+delay d =+   if d<0+      then+         debug("Thread.delay - delay time of " ++ show d)+      else+         threadDelay d+{-# INLINE delay #-}++after :: Duration -> IO a -> IO a+after d c = do {delay d; c}++every :: Duration -> IO a -> IO ()+every d c = forever (after d c)++mins  :: Double -> Duration+secs  :: Double -> Duration+msecs :: Double -> Duration+usecs :: Double -> Duration++usecs x = round(x)+msecs x = round(x*1000.0)+secs x  = round(x*1000000.0)+mins x  = round(x*60000000.0)++-- --------------------------------------------------------------------------+-- goesQuietly+-- --------------------------------------------------------------------------++goesQuietly :: IO () -> IO ()+goesQuietly action =+   do+      result <-+         tryJust+            (\ exception -> case exception of+               AsyncException ThreadKilled -> Just ()+               BlockedOnDeadMVar -> Just ()+               _ -> Nothing+               )+            action+      case result of+         Left () -> return ()+         Right () -> return ()++-- --------------------------------------------------------------------------+-- forkIOSafe+-- --------------------------------------------------------------------------++forkIODebug :: IO () -> IO ThreadId+forkIODebug = forkIO . errorOurExceps++-- --------------------------------------------------------------------------+-- forkIOquiet+-- --------------------------------------------------------------------------++forkIOquiet :: String -> IO () -> IO ThreadId+forkIOquiet label action =+   do+      let+         newAction =+            do+               error <- tryJust+                  (\ exception -> case exception of+                     BlockedOnDeadMVar -> Just ()+                     _ -> Nothing+                     )+                  action+               case error of+                  Right () -> done -- success+                  Left () ->+                     do+                        debug ("Thread.forkIOquiet: "++label)+      forkIO newAction+++-- --------------------------------------------------------------------------+-- mapMConcurrent+-- --------------------------------------------------------------------------++mapMConcurrent :: (a -> IO b) -> [a] -> IO [b]+mapMConcurrent mapFn [] = return []+mapMConcurrent mapFn [a] =+   do+      b <- mapFn a+      return [b]+mapMConcurrent mapFn as =+   do+      (mVars :: [MVar b]) <- mapM+         (\ a ->+            do+               mVar <- newEmptyMVar+               let+                  act =+                     do+                        b <- mapFn a+                        putMVar mVar b+               forkIO act+               return mVar+            )+         as+      mapM takeMVar mVars++-- this version is careful to propagate exceptions, at a slight cost.+mapMConcurrentExcep :: (a -> IO b) -> [a] -> IO [b]+mapMConcurrentExcep mapFn [] = return []+mapMConcurrentExcep mapFn [a] =+   do+      b <- mapFn a+      return [b]+mapMConcurrentExcep mapFn as =+   do+      (mVars :: [MVar (Either Exception b)]) <- mapM+         (\ a ->+            do+               mVar <- newEmptyMVar+               let+                  act =+                     do+                        bAnswer <- Control.Exception.try (mapFn a)+                        putMVar mVar bAnswer+               forkIO act+               return mVar+            )+         as+      mapM+         (\ mVar ->+            do+               bAnswer <- takeMVar mVar+               propagate bAnswer+            )+         mVars++++mapMConcurrent_ :: (a -> IO ()) -> [a] -> IO ()+mapMConcurrent_ mapFn as = mapM_ (\ a -> forkIO (mapFn a)) as+++-- --------------------------------------------------------------------------+-- hashThreadId+-- --------------------------------------------------------------------------++hashThreadId :: ThreadId -> Int32+-- Currently implemented by a horrible hack requiring access to GHC internals.+hashThreadId (GHC.Conc.ThreadId ti) = hashInt (getThreadId ti)++foreign import ccall unsafe "rts_getThreadId" getThreadId+   :: GHC.Base.ThreadId# -> Int
+ Util/ThreadDict.hs view
@@ -0,0 +1,52 @@+-- | This module implements per-thread variables+module Util.ThreadDict(+   ThreadDict, -- contains all the thread variables+   newThreadDict, -- :: IO (ThreadDict a)+   writeThreadDict, -- :: ThreadDict a -> a -> IO ()+   readThreadDict, -- :: ThreadDict a -> IO (Maybe a)+   modifyThreadDict, -- :: ThreadDict a -> (Maybe a -> IO (Maybe a,b)) -> IO b+   ) where++import Data.HashTable+import Control.Concurrent++import Util.Thread++-- -------------------------------------------------------------------------+-- Data types+-- -------------------------------------------------------------------------++newtype ThreadDict a = ThreadDict (HashTable ThreadId a)++-- -------------------------------------------------------------------------+-- Functions+-- -------------------------------------------------------------------------++newThreadDict :: IO (ThreadDict a)+newThreadDict =+   do+      table <- new (==) hashThreadId+      return (ThreadDict table)++writeThreadDict :: ThreadDict a -> a -> IO ()+writeThreadDict (ThreadDict table) a =+   do+      ti <- myThreadId+      insert table ti a++readThreadDict :: ThreadDict a -> IO (Maybe a)+readThreadDict (ThreadDict table) =+   do+      ti <- myThreadId+      Data.HashTable.lookup table ti++modifyThreadDict :: ThreadDict a -> (Maybe a -> IO (Maybe a,b)) -> IO b+modifyThreadDict (ThreadDict table) updateFn =+   do+      ti <- myThreadId+      aOpt0 <- Data.HashTable.lookup table ti+      (aOpt1,b) <- updateFn aOpt0+      case aOpt1 of+         Nothing -> delete table ti+         Just a -> insert table ti a+      return b
+ Util/UTF8.hs view
@@ -0,0 +1,169 @@+-- | This module contains functions for converting to and from the UTF8+-- representations for Strings.+module Util.UTF8(+   toUTF8,+      -- :: String -> String+      -- Converts a String (whose characters must all have codes <2^31) into+      -- its UTF8 representation.+   fromUTF8WE,+      -- :: Monad m => String -> m String+      -- Converts a UTF8 representation of a String back into the String,+      -- catching all possible format errors.+      --+      -- Example: With the Haskell module Control.Monad.Error, you can+      -- instance this as+      -- (fromUTF8WE :: String -> Either String String)+      -- to get a conversion function which either succeeds (Right) or+      -- returns an error message (Left).+   ) where++import Data.Char+import Data.List++import Data.Bits+import Data.Word+import Control.Monad.Error () -- needed for instance Monad (Either String)++import Util.Computation++-- --------------------------------------------------------------------------+-- Encoding+-- --------------------------------------------------------------------------++-- | Converts a String into its UTF8 representation.+toUTF8 :: Enum byte => String -> [byte]+toUTF8 [] = []+toUTF8 (x:xs) =+   let+      xs1 = toUTF8 xs+      ox = ord x++      mkUTF8 x0 xs0 xmask0 xmax0 =+         let+            xbot = 0x80 .|. (x0 .&. 0x3f)+            x1 = x0 `shiftR` 6+            xs1 = toEnum xbot : xs0+         in+            if x1 < xmax0+              then+                 toEnum (xmask0 .|. x1) : xs1+              else+                 let+                    xmask1 = xmask0 .|. xmax0+                    xmax1 = xmax0 `shiftR` 1+                 in+                    mkUTF8 x1 xs1 xmask1 xmax1+   in+      if ox <= 0x7f+         then+            toEnum ox : xs1+         else+           if ox `shiftR` 31 /= 0+              then+                 error ("Huge character with code " ++ show ox +++                    " detected in string being converted to UTF8.")+              else+                 mkUTF8 ox xs1 0xc0 0x20++{-# SPECIALIZE toUTF8 :: String -> [Char] #-}+{-# SPECIALIZE toUTF8 :: String -> [Word8] #-}++-- | Converts a UTF8 representation of a String back into the String,+-- catching all possible format errors.+--+-- Example: With the Haskell module Control.Monad.Error, you can+-- instance this as+-- (fromUTF8WE :: String -> Either String String)+-- to get a conversion function which either succeeds (Right) or+-- returns an error message (Left).+fromUTF8WE :: (Enum byte,Monad m) => [byte] -> m String+fromUTF8WE [] = return []+fromUTF8WE (x0 : xs0) =+   let+      ox = fromEnum x0+   in+      case topZero8 ox of+         7 ->+            do+               xs1 <- fromUTF8WE xs0+               return (chr ox : xs1)+         6 ->+            fail "UTF8 escape sequence starts 10xxxxxx"+         0 ->+            fail "UTF8 escape sequence starts 11111110"+         -1 ->+            fail "UTF8 escape sequence starts 11111111"+         n ->+            let+               r = 6 - n -- number of 6-bit pieces+               xtop = ox .&. ones n++               minx =+                  bit (+                     if r == 1+                        then+                           7+                        else+                           5*r + 1+                     )++               mkx [] _ _ =+                  fail "UTF8 string ends in middle of escape sequence"+               mkx (ch : xs1) x0 count0 =+                  do+                     let+                        och = fromEnum ch+                     if och .&. 0x80 /= 0x80+                        then+                           fail ("UTF8 escape sequence contains continuing "+                              ++ "character not of form 10xxxxxx")+                        else+                           return ()+                     let+                        xbot = och .&. 0x3f+                        x1 = (x0 `shiftL` 6) .|. xbot+                        count1 = count0 - 1+                     if count1 == 0+                        then+                           return (x1,xs1)+                        else+                           mkx xs1 x1 count1+            in+               do+                  (x,xs1) <- mkx xs0 xtop r+                  if x < minx+                     then+                        fail ("UTF8 escape sequence contains character not "+                           ++ "optimally encoded")+                     else+                        do+                           xs2 <- fromUTF8WE xs1+                           return (toEnum x : xs2)++{-# SPECIALIZE fromUTF8WE :: String -> WithError String #-}+{-# SPECIALIZE fromUTF8WE :: [Word8] -> WithError String #-}+{-# SPECIALIZE fromUTF8WE :: String -> Either String String #-}+{-# SPECIALIZE fromUTF8WE :: [Word8] -> Either String String #-}+++-- --------------------------------------------------------------------------+-- Binary utilities+-- --------------------------------------------------------------------------++-- | return the number of the top bit which is zero, or -1 if they+-- are all zero, for a number between 0 and 255.+topZero8 :: Int -> Int+topZero8 i =+   case+      (findIndex not+         (map+            (\ bn -> testBit i bn)+            [7,6..0]+            ))+      of+         Just n -> 7 - n+         Nothing -> -1++-- | (ones i) is number with binary representation 1 written i times.+ones :: Int -> Int+ones i = bit i - 1
+ Util/UnionFind.hs view
@@ -0,0 +1,115 @@+-- | Union-Find algorithm.+module Util.UnionFind(+   -- NB.  The functions in this module are not guaranteed thread-safe.+++   UnionFind, -- :: type with parameter.  Instance of Eq.+   newElement, -- :: a -> IO (UnionFind a)+   toValue, -- :: UnionFind a -> a++   union, -- :: UnionFind a -> UnionFind a -> IO ()+   isSame, -- :: UnionFind a -> UnionFind a -> IO Bool+   sameElements, -- :: UnionFind a -> IO [UnionFind a]+   ) where++import Data.IORef++import Util.Computation(done)+import Util.ExtendedPrelude++-- -------------------------------------------------------------------+-- The datatype and instance of Eq+-- -------------------------------------------------------------------++data UnionFind a = UnionFind {+   value :: a,+   contentsRef :: IORef [UnionFind a],+      -- All items union'd with this one.+      -- Thus these contents form a tree-structure.+   headRef :: IORef (Maybe (UnionFind a))+      -- If Just, an item with which this one is union'd, possibly+      -- indirectly.+      --+      -- To avoid spending lots of time chasing up long chains of+      -- head pointers, we in each case replace the head with the eventual+      -- parent.  I think this is Tarjan's algorithm and makes the operations+      -- almost linear (amortized time), but can't be bothered to chase up+      -- the reference.+   }++instance Eq (UnionFind a) where+   (==) = mapEq contentsRef++-- -------------------------------------------------------------------+-- The external functions+-- -------------------------------------------------------------------++newElement :: a -> IO (UnionFind a)+newElement value =+   do+      contentsRef <- newIORef []+      headRef <- newIORef Nothing+      let+         unionFind = UnionFind {+            value = value,+            contentsRef = contentsRef,+            headRef = headRef+            }+      return unionFind++toValue :: UnionFind a -> a+toValue = value++union :: UnionFind a -> UnionFind a -> IO ()+union uf1 uf2 =+   do+      head1 <- getHead uf1+      head2 <- getHead uf2+      if head1 == head2+         then+            done+         else+            do+               writeIORef (headRef head2) (Just head1)++               contents0 <- readIORef (contentsRef head1)+               writeIORef (contentsRef head1) (head2 : contents0)++isSame :: UnionFind a -> UnionFind a -> IO Bool+isSame uf1 uf2 =+   do+      head1 <- getHead uf1+      head2 <- getHead uf2+      return (head1 == head2)++sameElements :: UnionFind a -> IO [UnionFind a]+sameElements uf =+   do+      head <- getHead uf+      allContents head+   where+      allContents :: UnionFind a -> IO [UnionFind a]+      allContents uf =+         do+            contents <- readIORef (contentsRef uf)+            innerContents <- mapM allContents contents+            return (uf : concat innerContents)++-- -------------------------------------------------------------------+-- Retrieving the head (the most important operation).+-- -------------------------------------------------------------------++getHead :: UnionFind a -> IO (UnionFind a)+getHead unionFind =+   do+      thisHeadOpt <- readIORef (headRef unionFind)+      case thisHeadOpt of+         Nothing -> return unionFind+         Just unionFind2 ->+            do+               thisHead <- getHead unionFind2+               writeIORef (headRef unionFind) (Just thisHead)+               return thisHead+++
+ Util/UniqueFile.hs view
@@ -0,0 +1,181 @@+-- | UniqueFile is used for allocating names for temporary files in a directory.+-- To avoid large numbers of files in the same directory, we create sub-+-- directories where necessary.+module Util.UniqueFile(+   UniqueFileCounter,+      -- This represents the state, which needs to be single-threaded.+      -- Instance of Read,Show so it can be transmitted.+   initialUniqueFileCounter, -- :: UniqueFileCounter+      -- This is how you start+   stepUniqueFileCounter, -- :: UniqueFileCounter -> (String,UniqueFileCounter)+      -- And this is how you get a String out.++   -- Here are some independent functions for actually managing the+   -- subdirectories.  We don't require that the file names be generated+   -- from a UniqueFileCounter.+   UniqueFileStore, -- This represents a location on disk where the+      -- unique files are actually stored.  NB - it is not expected that+      -- all files got from the unique file++   newUniqueFileStore,+      -- :: FilePath -> (FilePath -> IO ()) -> IO UniqueFileStore+      -- This creates a new file store.+      -- The FilePath should point do a directory, which must already+      -- exist.+      -- The user should specify the create-directory function in the+      -- second argument, which is assumed to work.  This is given+      -- the name relative to the top directory, not the full name.++   ensureDirectories,+      -- :: UniqueFileStore -> String -> IO ()+   -- ensureDirectories is given the relative location of a+   -- file inside the file store (../. characters not permitted!) and+   -- creates directories appropriately.++   getFilePath, -- :: UniqueFileStore -> String -> FilePath+   -- Get full name of a file in the unique file store.+   ) where++import System.Directory+import Data.Char++import Util.IOExtras+import Util.Registry+import Util.FileNames+import Util.Computation(done)++-- --------------------------------------------------------------+-- UniqueFileCounter+-- --------------------------------------------------------------++{-+   Strategy: each file name has the form+   [char]/[char]/.../[char]+   The [char] is chosen from the 64-character set:++   lower case and upper case letters (52)+   digits (10)+   @+++   Thus each char corresponds to a number between 0 and 63.+   The characters are divided into those with numbers <22+   and those with numbers >=22.  Characters with numbers >=22+   correspond to bits of the directory entry of the file name.+   The ones with numbers <22 correspond to the file name part.+   Thus the file names can get arbitrarily long.  The reason+   for choosing 22 is that it maximises the number of possibilities+   when there are up to three parts, which is 39754.+   -}++newtype UniqueFileCounter = UniqueFileCounter [Int] deriving (Show,Read)++initialUniqueFileCounter :: UniqueFileCounter+initialUniqueFileCounter = UniqueFileCounter [0]++stepUniqueFileCounter :: UniqueFileCounter -> (String,UniqueFileCounter)+stepUniqueFileCounter (UniqueFileCounter ilist) =+      (toString ilist,UniqueFileCounter (increment ilist))+   where+      toString :: [Int] -> String+      toString [] = error "UniqueFile.toString"+      toString (first:rest) = tS [encodeChar first] rest+         where+            tS :: String -> [Int] -> String+            tS acc [] = acc+            tS acc (first:rest) = tS ((encodeChar first):fileSep:acc) rest++      encodeChar :: Int -> Char+      encodeChar i=+         if i<26 then+            chr(ord 'a' + i)+         else if i<52 then+            chr((ord 'A'-26)+i)+         else if i<62 then+            chr((ord '0'-52)+i)+         else case i of+            62 -> '@'+            63 -> '+'+            _ -> error "UniqueFile.encodeChar"++      increment :: [Int] -> [Int]+      increment (file:rest) =+         if file==(divider-1)+            then+               0:(incrementDirs rest)+            else+               (file+1):rest+         where+            incrementDirs :: [Int] -> [Int]+            incrementDirs [] = [divider]+            incrementDirs (first:rest) =+               if first==(nChars-1)+                  then+                     divider:(incrementDirs rest)+                  else+                     (first+1):rest+++      divider :: Int+      divider = 22++      nChars :: Int+      nChars = 64++-- --------------------------------------------------------------+-- UniqueFileStore+-- --------------------------------------------------------------++data UniqueFileStore = UniqueFileStore {+   directory :: FilePath, -- We trim a trailing slash, if any.+   alreadyExistsRegistry :: LockedRegistry String (),+      -- This is a cache of subdirectories already known to exist.+      -- Using a locked registry allows ensureDirectories to+      -- be run in several threads simultanesouly, without running concurrently+      -- on the same sub-directory.+   createDirAct :: FilePath -> IO ()+      -- function passed in by newUniqueFileStore+   }++newUniqueFileStore :: FilePath -> (FilePath -> IO ()) -> IO UniqueFileStore+newUniqueFileStore directory createDirAct =+   do+      exists <- doesDirectoryExist directory+      if exists+         then+            done+         else+            error "UniqueFile.newUniqueFileStore: directory must alreay exist"+      alreadyExistsRegistry <- newRegistry++      return (UniqueFileStore {+         directory = trimDir directory,+         createDirAct = createDirAct,+         alreadyExistsRegistry = alreadyExistsRegistry+         })++ensureDirectories :: UniqueFileStore -> String -> IO ()+ensureDirectories (uniqueFileStore @ UniqueFileStore {directory = directory,+      createDirAct = createDirAct,+      alreadyExistsRegistry = alreadyExistsRegistry}) fullName =+   case splitName fullName of+      (subDir,rest)+         | subDir == thisDir -> done -- no subdirectories required.+         | True ->+            transformValue alreadyExistsRegistry subDir+               (\ existsOpt ->+                  do+                     case existsOpt of+                        Just () -> -- no action required+                           done+                        Nothing ->+                           do+                              ensureDirectories uniqueFileStore subDir+                              catchAlreadyExists (createDirAct subDir)+                              done+                     return (Just (),())+                  )+++getFilePath :: UniqueFileStore -> String -> FilePath+getFilePath (UniqueFileStore {directory = directory}) file =+   combineNames directory file
+ Util/UniqueString.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Description : Generate Unique Strings+--+-- This module generates short non-empty unique printable strings (IE without+-- funny characters).  Quotes and backslashes are not included, so printing+-- should not be too hard.  Periods are also not included, for the+-- benefit of NewNames.hs.+module Util.UniqueString(+   UniqueStringSource, -- A source of unique strings.  Instance of Typeable+   newUniqueStringSource, -- :: IO UniqueStringSource+   newUniqueString, -- :: UniqueStringSource -> IO String+++   maxUniqueStringSources, -- :: [UniqueStringSource] -> IO UniqueStringSource++   -- Here is a "pure" interface.+   UniqueStringCounter,++   firstUniqueStringCounter, -- :: UniqueStringCounter+      -- This is what you start with+   stepUniqueStringCounter, -- :: UniqueStringCounter+      -- -> (String,UniqueStringCounter)+      -- and this is how you get a new String out.+++   -- read/createUniqueStringSource are used by types/CodedValue+   -- to import and export string sources.+   readUniqueStringSource, -- :: UniqueStringSource -> IO [Int]+   createUniqueStringSource, -- :: [Int] -> IO UniqueStringSource++   -- Create non-conflicting string which cannot be produced by+   -- newUniqueString.  This is useful for exceptional cases.+   newNonUnique, -- :: String -> String++   -- The first string generated by newUniqueString or stepUniqueStringCounter+   firstUniqueString, -- :: String+   ) where++import Data.Array++import Control.Concurrent++import Util.ExtendedPrelude+import Util.Dynamics++-- The list of "printable" characters that may occur in one of these+-- strings.+--+-- 20.9.02.  {} characters eliminated because daVinci doesn't like them.+printableCharsStr :: String+printableCharsStr =+   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()"+   ++ "-_+=|~[];:,<>/?"++-- The same, as an array and length.+printableCharsLen :: Int+printableCharsLen = length printableCharsStr++printableCharsArr :: Array Int Char+printableCharsArr = listArray (0,printableCharsLen-1) printableCharsStr++-- -------------------------------------------------------------------+-- The impure interface.+-- -------------------------------------------------------------------++newtype UniqueStringSource = UniqueStringSource (MVar UniqueStringCounter)+   deriving (Typeable)++newUniqueStringSource :: IO UniqueStringSource+newUniqueStringSource =+   do+      mVar <- newMVar firstUniqueStringCounter+      return (UniqueStringSource mVar)++newUniqueString :: UniqueStringSource -> IO String+newUniqueString (UniqueStringSource mVar) =+   do+      uniqueStringCounter <- takeMVar mVar+      let+         (str,nextUniqueStringCounter) =+            stepUniqueStringCounter uniqueStringCounter+      putMVar mVar nextUniqueStringCounter+      return str++-- | readUniqueStringSource is used by types\/CodedValue.hs to export values.+readUniqueStringSource :: UniqueStringSource -> IO [Int]+readUniqueStringSource (UniqueStringSource mVar) =+   do+      (UniqueStringCounter l) <- readMVar mVar+      return l++-- | createUniqueStringSource is the inverse of readUniqueStringSource.+createUniqueStringSource :: [Int] -> IO UniqueStringSource+createUniqueStringSource l =+   do+      mVar <- newMVar (UniqueStringCounter l)+      return (UniqueStringSource mVar)+++{- unused+compareUniqueStringSource :: UniqueStringSource -> UniqueStringSource+   -> IO Ordering+compareUniqueStringSource (UniqueStringSource mVar1) (UniqueStringSource mVar2)+      =+   do+      c1 <- readMVar mVar1+      c2 <- readMVar mVar2+      return (compare c1 c2)+-}++maxUniqueStringSources :: [UniqueStringSource] -> IO UniqueStringSource+maxUniqueStringSources stringSources =+   do+      stringCounters <- mapM+         (\ (UniqueStringSource mVar) -> readMVar mVar)+         stringSources+      let+         maxCounter = foldl max firstUniqueStringCounter stringCounters+      mVar <- newMVar maxCounter+      return (UniqueStringSource mVar)++-- -------------------------------------------------------------------+-- The pure interface.+-- -------------------------------------------------------------------+++-- UniqueStringCounter is a list of numbers from 0 to printableCharsLen-1.+-- The last number is at least 1.+newtype UniqueStringCounter = UniqueStringCounter [Int]++firstUniqueStringCounter :: UniqueStringCounter+firstUniqueStringCounter = UniqueStringCounter [0]++stepUniqueStringCounter :: UniqueStringCounter -> (String,UniqueStringCounter)+stepUniqueStringCounter (uniqueStringCounter @ (UniqueStringCounter ilist)) =+      (toStringUniqueStringCounter uniqueStringCounter,+         UniqueStringCounter (step ilist))+   where+      step [] = [1]+      step (first:rest) =+         if first == printableCharsLen -1+            then+               0:step rest+            else+               (first+1):rest++toStringUniqueStringCounter :: UniqueStringCounter -> String+toStringUniqueStringCounter (UniqueStringCounter ilist) =+   map (\ i -> printableCharsArr ! i) ilist++instance Eq UniqueStringCounter where+   (==) = mapEq (\ (UniqueStringCounter l) -> l)++instance Ord UniqueStringCounter where+   compare (UniqueStringCounter l1) (UniqueStringCounter l2)+         = comp l1 l2+      where+         comp [] [] = EQ+         comp (_:_) [] = GT+         comp [] (_:_) = LT+         comp (c1:cs1) (c2:cs2) = case comp cs1 cs2 of+            EQ -> compare c1 c2+            other -> other++-- -------------------------------------------------------------------+-- firstUniqueString+-- -------------------------------------------------------------------++firstUniqueString :: String+firstUniqueString =+   let+      (s,_) = stepUniqueStringCounter firstUniqueStringCounter+   in+      s++-- -------------------------------------------------------------------+-- newNonUnique+-- -------------------------------------------------------------------++-- | Create non-conflicting string which cannot be produced by+-- newUniqueString.  This is useful for exceptional cases.+-- We add this by adding a character with integer value 0 at the end.+newNonUnique :: String -> String+newNonUnique str = str ++ [printableCharsArr ! 0]
+ Util/VSem.hs view
@@ -0,0 +1,173 @@+-- | | Implements locks which can be locked "globally" or "locally".+--   A global lock prevents any other lock; a local lock allows other local+--   locks.+--+--   There are some subtle decisions to be made about when to give preference+--   to local, and when to global, locks.  There are two important cases:+--   (1) When we free a global lock, and there is another queued global lock,+--       we take that global lock (or the earliest for which someone is+--       waiting, if there's a choice), irrespective of whether anyone is+--       waiting for a local lock.+--   (2) When at least one local lock is held, we allow people to acquire+--       further local locks, even if there are queued global locks.+--+--   A bad consequence of (2) is that a global lock can be indefinitely not+--   satisfied by a carefully-timed sequence of finite local locks:+--+--   local locks : --- --- --- --- . . .+--                   --- --- ---   . . .+--   no global lock can be acquired at all.+--+--   However the alternative, of not permitting any fresh local locks when+--   a global lock is queued, is worse (in my opinion), since if a thread+--   attempts to acquire two local locks, one inside the other, and another+--   attempts to acquire a global lock, the whole thing can deadlock.+--+--   Thread 1  : acquire local lock                    attempt to acquire second local lock => DEADLOCK.+--   Thread 2  :                   wait for global lock+--+--   We could deal with this partially by allowing local locks for free+--   to a thread which already holds one, but this is more complicated and+--   I suspect theoretically dodgy.+--+--   A consequence of this decision is that threads should avoid creating+--   automated repeated sequences of local locks on the same VSem.+module Util.VSem(+   VSem,+   newVSem,++   synchronizeLocal,+   synchronizeGlobal,++   acquireLocal, -- :: VSem -> IO ()+   releaseLocal, -- :: VSem -> IO ()+   ) where++import Control.Concurrent+import Control.Exception++import Util.Computation+import Util.Queue++data VSemState = VSemState {+   queuedGlobals :: Queue (MVar ()),+   queuedLocals :: [MVar ()],+   nLocalLocks :: Int+      -- ^ -1 if the vSem is globally locked, otherwise the number of local+      -- locks.+   }++-- | A lock which can be globally or locally locked.+-- At any time, a @VSem@ is either globally locked once, or locally locked+-- zero or more times.  Global locks always take priority over local locks.+newtype VSem = VSem (MVar VSemState)++-- | Creates a 'VSem'.+newVSem :: IO VSem+newVSem =+   do+      mVar <- newMVar (VSemState {+         queuedGlobals = emptyQ,+         queuedLocals = [],+         nLocalLocks = 0+         })+      return (VSem mVar)++-- | Perform an action while locking a 'VSem' locally.+synchronizeLocal :: VSem -> IO b -> IO b+synchronizeLocal vSem act =+   do+      acquireLocal vSem+      finally act (releaseLocal vSem)++-- | Perform an action while locking a 'VSem' globally.+synchronizeGlobal :: VSem -> IO b -> IO b+synchronizeGlobal vSem act =+   do+      acquireGlobal vSem+      finally act (releaseGlobal vSem)++vSemAct :: VSem -> (VSemState -> IO (VSemState,b)) -> IO b+vSemAct (VSem mVar) update =+   modifyMVar mVar update++-- | Acquire a local lock on a 'VSem'+acquireLocal :: VSem -> IO ()+acquireLocal vSem =+   do+      act <- vSemAct vSem (\ vSemState ->+         if nLocalLocks vSemState <0+            then+               do+                  mVar <- newEmptyMVar+                  return (vSemState {+                     queuedLocals = mVar : queuedLocals vSemState},+                     takeMVar mVar+                     )+            else+               return (vSemState {+                  nLocalLocks = nLocalLocks vSemState + 1},+                  done)+         )+      act+++-- | Release a local lock on a 'VSem'+releaseLocal :: VSem -> IO ()+releaseLocal vSem =+   vSemAct vSem (\ vSemState ->+      do+         let+            nLocalLocks0 = nLocalLocks vSemState+            nLocalLocks1 = nLocalLocks0 - 1+         case (nLocalLocks1,removeQ (queuedGlobals vSemState)) of+            (0,Just (mVar,queuedGlobals1)) ->+               do+                  putMVar mVar ()+                  return (vSemState {nLocalLocks = -1,+                     queuedGlobals = queuedGlobals1+                     },())+            _ -> return (vSemState {nLocalLocks = nLocalLocks1},())+      )+++-- | Acquire a global lock on a 'VSem'+acquireGlobal :: VSem -> IO ()+acquireGlobal vSem =+   do+      act <- vSemAct vSem (\ vSemState ->+         do+            let+               nLocalLocks0 = nLocalLocks vSemState+            if nLocalLocks0 == 0+               then+                  return (vSemState {nLocalLocks = -1},done)+               else+                  do+                     mVar <- newEmptyMVar+                     return (vSemState {+                        queuedGlobals+                           = insertQ (queuedGlobals vSemState) mVar},+                        takeMVar mVar+                        )+         )+      act+++-- | Release a global lock on a 'VSem'+releaseGlobal :: VSem -> IO ()+releaseGlobal vSem =+   vSemAct vSem (\ vSemState ->+      case (removeQ (queuedGlobals vSemState),queuedLocals vSemState) of+         (Just (mVar,queuedGlobals1),_) ->+            do+              putMVar mVar ()+              return (vSemState {queuedGlobals = queuedGlobals1},())+         (Nothing,queuedLocals0) ->+            do+              mapM_ (\ mVar -> putMVar mVar ()) queuedLocals0+              return (vSemState {queuedLocals = [],+                 nLocalLocks = length queuedLocals0},())+      )++
+ Util/VariableList.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Util.VariableList(+   newVariableListFromSet, -- :: Ord a => VariableSetSource a -> VariableList a+   newVariableListFromList, -- :: Ord a => SimpleSource [a] -> VariableList a+   emptyVariableList, -- :: VariableList a+   singletonList, -- :: a -> VariableList a+   VariableList,+   ListDrawer(..),+   attachListOp, -- :: VariableList a -> ListDrawer a -> IO (IO ())+   coMapListDrawer, -- :: (a -> b) -> ListDrawer b pos -> ListDrawer a pos+   map2ListDrawer, -- :: (pos1 -> pos2) -> (pos2 -> pos2) ->+      -- ListDrawer b pos1 -> ListDrawer b pos2++   catVariableLists, -- :: VariableList a -> VariableList a -> VariableList a++   ) where++import Data.Maybe++import Data.IORef++import Util.Computation+import Util.Registry+import Util.Sources+import Util.Sink+import Util.VariableSet+import Util.Delayer+import Util.Myers++-- -----------------------------------------------------------------------+-- The types+-- -----------------------------------------------------------------------++data ListDrawer a pos = ListDrawer {+   -- A drawn list consists of a list of positions of type "pos", each of+   -- which optionally has a value of type "a" attached to it.  The value+   -- of type "a" is mutable.++   newPos :: Maybe pos -> Maybe a -> IO pos,+      -- newPos posOpt aOpt creates a new position.  If posOpt is+      -- Nothing this is at the beginning of the list, otherwise it is+      -- after the given position. aOpt specifies the value.+   setPos :: pos -> Maybe a -> IO (),+      -- Alter the value at pos.+   delPos :: pos -> IO (),+      -- Remove pos.  After this, pos should not be used.++   redraw :: IO ()+      -- This should be done after every group of updates, to ensure they+      -- physically happen.+   }++-- | Return the close action.+-- attachListOp :: ParallelExec -> VariableList a -> ListDrawer a -> IO (IO ())++data VariableList a = VariableList {+   attachListOp :: forall pos . ParallelExec -> ListDrawer a pos -> IO (IO ())+   }++-- -----------------------------------------------------------------------+-- The instances+-- -----------------------------------------------------------------------++instance Functor VariableList where+   fmap fn (VariableList {attachListOp = attachListOp0}) =+      let+         attachListOp1 parallelEx listDrawer =+            attachListOp0 parallelEx (coMapListDrawer fn listDrawer)+      in+         VariableList attachListOp1++coMapListDrawer :: (a -> b) -> ListDrawer b pos -> ListDrawer a pos+coMapListDrawer fn (ListDrawer {+      newPos = newPos0,setPos = setPos0,delPos = delPos0,redraw = redraw0}) =+   let+      newPos1 posOpt aOpt = newPos0 posOpt (fmap fn aOpt)+      setPos1 pos aOpt = setPos0 pos (fmap fn aOpt)+      delPos1 = delPos0+      redraw1 = redraw0+   in+      ListDrawer {+         newPos = newPos1,setPos = setPos1,delPos = delPos1,redraw = redraw1}++map2ListDrawer :: (pos1 -> pos2) -> (pos2 -> pos1) ->+      ListDrawer b pos1 -> ListDrawer b pos2+map2ListDrawer toPos2 toPos1 (ListDrawer {+      newPos = newPos1,setPos = setPos1,delPos = delPos1,redraw = redraw1}) =+   let+      newPos2 pos2Opt aOpt =+         do+            pos1 <- newPos1 (fmap toPos1 pos2Opt) aOpt+            return (toPos2 pos1)+      setPos2 pos2 aOpt = setPos1 (toPos1 pos2) aOpt+      delPos2 pos2 = delPos1 (toPos1 pos2)+      redraw2 = redraw1+   in+      ListDrawer {+         newPos = newPos2,setPos = setPos2,delPos = delPos2,redraw = redraw2}++instance HasAddDelayer (VariableList a) where+   addDelayer delayer (VariableList attachListOp0) =+      let+         attachListOp1 parallelX listDrawer0 =+            do+               listDrawer1 <- addDelayerIO delayer listDrawer0+               attachListOp0 parallelX listDrawer1+      in+         VariableList attachListOp1++instance HasAddDelayerIO (ListDrawer a pos) where+   addDelayerIO delayer listDrawer0 =+      do+         delayedAction <- newDelayedAction (redraw listDrawer0)+         let+            redraw1 = delayedAct delayer delayedAction++            listDrawer1 = listDrawer0 {redraw = redraw1}+         return listDrawer1++-- -----------------------------------------------------------------------+-- Constructing VariableList's from other things.+-- -----------------------------------------------------------------------++emptyVariableList :: VariableList a+emptyVariableList =+   let+      attachListOp _ _ = return done+   in+      VariableList attachListOp++singletonList :: forall a . a -> VariableList a+singletonList a =+   let+      attachListOp :: forall pos . ParallelExec -> ListDrawer a pos+        -> IO (IO ())+      attachListOp parallelX listDrawer =+         do+            parallelExec parallelX (+               do+                  newPos listDrawer Nothing (Just a)+                  done+               )+            return done+   in+      VariableList attachListOp++newVariableListFromSet :: forall a . Ord a => VariableSetSource a+    -> VariableList a+newVariableListFromSet (variableSetSource :: VariableSetSource a) =+   let+      attachListOp :: forall pos . ParallelExec -> ListDrawer a pos+        -> IO (IO ())+      attachListOp parallelX listDrawer =+         do+            (posRegistry :: Registry a pos) <- newRegistry++            groupingCount <- newIORef 0++            let+               updateFn :: VariableSetUpdate a -> IO ()+               updateFn (AddElement a) =+                  do+                     addElement a+                     groupCount <- readIORef groupingCount+                     when (groupCount == 0) (redraw listDrawer)+               updateFn (DelElement a) =+                  do+                     delElement a+                     groupCount <- readIORef groupingCount+                     when (groupCount == 0) (redraw listDrawer)+               updateFn BeginGroup = modifyIORef groupingCount (+1)+               updateFn EndGroup =+                  do+                     groupCount0 <- readIORef groupingCount+                     let+                        groupCount1 = groupCount0 - 1+                     writeIORef groupingCount groupCount1+                     when (groupCount1 == 0) (redraw listDrawer)++               initialElements :: [a] -> IO ()+               initialElements as =+                  do+                     mapM_ addElement as+                     redraw listDrawer++               addElement :: a -> IO ()+               addElement a =+                  do+                     pos <- newPos listDrawer Nothing (Just a)+                     setValue posRegistry a pos++               delElement :: a -> IO ()+               delElement a =+                  transformValue posRegistry a (\ posOpt -> case posOpt of+                     Just pos ->+                        do+                           delPos listDrawer pos+                           return (Nothing,())+                     )++            sinkID <- newSinkID++            (x,sink) <- addNewSinkWithInitial variableSetSource+               initialElements updateFn sinkID parallelX++            return (invalidate sinkID)+   in+      VariableList attachListOp++newVariableListFromList :: forall a . Ord a => SimpleSource [a]+    -> VariableList a+newVariableListFromList (simpleSource :: SimpleSource [a]) =+   let+      attachListOp :: forall pos . ParallelExec -> ListDrawer a pos+        -> IO (IO ())+      attachListOp parallelX listDrawer =+         do+            -- state stores the current a values and a list of the same length+            -- containing their pos values.+            (state :: IORef ([a],[pos])) <- newIORef ([],[])++            let+               updateList :: [a] -> IO ()+               updateList newAs =+                  do+                     (oldAs,oldPos) <- readIORef state+                     let+                        changes = diff2 oldAs newAs++                        oldAsPlus :: [(a,Bool)]+                           -- True means that it is in both lists+                        oldAsPlus = concat (map+                           (\ diffElement -> case diffElement of+                              InSecond _ -> []+                              InFirst l -> map (\ a -> (a,False)) l+                              InBoth l -> map (\ a -> (a,True)) l+                              )+                           changes+                           )++                        newAsPlus :: [(a,Bool)]+                           -- True means that it is in both lists+                        newAsPlus = concat (map+                           (\ diffElement -> case diffElement of+                              InFirst _ -> []+                              InSecond l -> map (\ a -> (a,False)) l+                              InBoth l -> map (\ a -> (a,True)) l+                              )+                           changes+                           )++                        -- (1) compute the delete actions+                        deleteAct = sequence_ (zipWith+                           (\ (oldA,isCommon) oldPos ->+                              if isCommon then done else+                                 delPos listDrawer oldPos+                              )+                           oldAsPlus oldPos+                           )++                        -- (2) compute the positions which are common+                        commonPos = catMaybes+                           (zipWith+                              (\ (oldA,isCommon) oldPos ->+                                 if isCommon+                                    then+                                       Just oldPos+                                    else+                                       Nothing+                                 )+                              oldAsPlus oldPos+                              )++                        -- (3) compute pairs (Maybe pos,[a]) where (Maybe pos)+                        -- is the last position before an insertion, [a] is+                        -- the insertion.+                        mkPairs :: Maybe pos -> [pos] -> [(a,Bool)]+                           -> [(Maybe pos,[a])] -> [(Maybe pos,[a])]+                        mkPairs lastPosOpt [] [] acc0 = acc0+                        mkPairs lastPosOpt poss0+                              (xs0@((a,isCommon):rest)) acc0 =+                           if isCommon+                              then+                                 case poss0 of+                                    pos:poss1 ->+                                       mkPairs (Just pos) poss1 rest acc0+                              else+                                 -- scan to next common element or end+                                 let+                                    getInsertion :: [(a,Bool)]+                                       -> ([a],[(a,Bool)])+                                    getInsertion [] = ([],[])+                                    getInsertion (xs@((_,True):_)) = ([],xs)+                                    getInsertion (((a,False):xs0)) =+                                       let+                                          (as,xs1) = getInsertion xs0+                                       in+                                          (a:as,xs1)++                                    (as,xs1) = getInsertion xs0+                                    acc1 = (lastPosOpt,as) : acc0+                                in+                                    case (poss0,xs1) of+                                       ([],[]) -> acc1+                                       (pos:pos1,((_,True):xs2)) ->+                                          mkPairs (Just pos) pos1 xs2 acc1++                        -- NB.  pairs is in reverse order.+                        pairs :: [(Maybe pos,[a])]+                        pairs = mkPairs Nothing commonPos newAsPlus []++                        -- (4) The add action, which also the+                        -- new positions.  The lists are all in reverse order.+                        addAct :: IO [[pos]]+                        addAct = mapM+                           (\ (posOpt,as) ->+                              mapM+                                 (\ a -> newPos listDrawer posOpt (Just a))+                                 (reverse as)+                              )+                           pairs++                     -- (5) Do the additions and deletions.+                     (newPosss0 :: [[pos]]) <- addAct+                     deleteAct+                     redraw listDrawer++                     let+                        -- (6) Compute all the new positions given the new+                        -- list + old common and new positions.+                        mkNewPos :: [(a,Bool)] -> [pos] -> [pos] -> [pos]+                           -> [pos]+                        mkNewPos [] [] [] posAcc = posAcc+                        mkNewPos ((_,isCommon):xs0) posOld posNew posAcc =+                           if isCommon+                              then+                                 case posOld of+                                    pos:posOld1 ->+                                       mkNewPos xs0 posOld1 posNew (pos:posAcc)+                              else+                                 case posNew of+                                    pos:posNew1 ->+                                       mkNewPos xs0 posOld posNew1 (pos:posAcc)++                        newPos =  mkNewPos newAsPlus commonPos+                           (reverse (concat newPosss0)) []++                     writeIORef state (newAs,reverse newPos)++            sinkID <- newSinkID++            addNewSinkWithInitial simpleSource updateList updateList sinkID+               parallelX++            return (invalidate sinkID)+   in+      VariableList attachListOp++-- -----------------------------------------------------------------------+-- Combinators+-- -----------------------------------------------------------------------++catVariableLists :: VariableList a -> VariableList a -> VariableList a+catVariableLists (VariableList attachListOp1) (VariableList attachListOp2) =+   let+      attachListOp parallelX listDrawer =+         do+            -- Separate the two using an unused position in the middle.+            middlePos <- newPos listDrawer Nothing Nothing+            let+               listDrawer1 = listDrawer++               newPos2 posOpt aOpt =+                  let+                     pos = fromMaybe middlePos posOpt+                  in+                     newPos listDrawer (Just pos) aOpt++               listDrawer2 = listDrawer {newPos = newPos2}++            destroy1 <- attachListOp1 parallelX listDrawer1+            destroy2 <- attachListOp2 parallelX listDrawer2+            return (destroy1 >> destroy2)+   in+      VariableList attachListOp
+ Util/VariableMap.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | VariableMap is analagous to VariableSet and provides a mutable map ordered+-- by key whose changes can be tracked.+module Util.VariableMap(+   VariableMapData,+   VariableMapUpdate(..),+   VariableMap,+   newEmptyVariableMap,+   newVariableMap,+   newVariableMapFromFM,+   updateMap,+   lookupMap,+   lookupWithDefaultMap,+   mapToList,+   mapToFM,+   mapToVariableSetSource,++   addToVariableMap,+   delFromVariableMap,+   variableMapToList,+   lookupVariableMap,+   getVariableMapByKey,+   ) where++import Data.Maybe++import qualified Data.Map as Map++import Util.Dynamics+import Util.Broadcaster+import Util.VariableSet+import Util.Sources++-- --------------------------------------------------------------------+-- The datatype+-- --------------------------------------------------------------------++-- | Describes a map update.  For DelUpdate, the second parameter (the one+-- of type elt) is irrelevant and may be undefined.+newtype VariableMapData key elt = VariableMapData (Map.Map key elt)++-- | We recycle the VariableSetUpdate type for this.+newtype VariableMapUpdate key elt =+   VariableMapUpdate (VariableSetUpdate (key,elt))++-- | The Bool indicates whether the operation was successfully carried out.+-- We block updating a value which is already in the map, or+-- deleting one that isn\'t.+update :: Ord key+   => VariableMapUpdate key elt -> VariableMapData key elt+   -> (VariableMapData key elt,[VariableMapUpdate key elt],Bool)+update (variableUpdate @ (VariableMapUpdate update))+       (variableMap @ (VariableMapData map)) =+   case update of+      AddElement (key,elt) ->+         if member key+            then+               (variableMap,[],False)+            else+               (VariableMapData (Map.insert key elt map),[variableUpdate],True)+      DelElement (key,_) ->+         -- we ignore the element, allowing delFromVariable map to put an+         -- error there.+         case Map.lookup key map of+            Just elt ->+               (VariableMapData (Map.delete key map),+                  [VariableMapUpdate (DelElement (key,elt))],True)+            Nothing -> (variableMap,[],False)+      BeginGroup -> (variableMap,[variableUpdate],True)+      EndGroup -> (variableMap,[variableUpdate],True)+   where+      member key = isJust (Map.lookup key map)++newtype VariableMap key elt =+   VariableMap (GeneralBroadcaster (VariableMapData key elt)+      (VariableMapUpdate key elt))+   deriving (Typeable)++-- --------------------------------------------------------------------+-- The provider's interface+-- --------------------------------------------------------------------++-- | Create a new empty variable map.+newEmptyVariableMap :: Ord key => IO (VariableMap key elt)+newEmptyVariableMap =+   do+      broadcaster <- newGeneralBroadcaster (VariableMapData Map.empty)+      return (VariableMap broadcaster)++-- | Create a new variable map with given contents+newVariableMap :: Ord key => [(key,elt)] -> IO (VariableMap key elt)+newVariableMap contents = newVariableMapFromFM (Map.fromList contents)++newVariableMapFromFM :: Ord key+   => Map.Map key elt -> IO (VariableMap key elt)+newVariableMapFromFM fmap =+   do+      broadcaster <- newGeneralBroadcaster (VariableMapData fmap)+      return (VariableMap broadcaster)+++-- | Update a variable map in some way.  Returns True if the update was+-- sucessful (so for insertions, the object is not already there; for+-- deletions the object is not there).+updateMap :: Ord key => VariableMap key elt -> VariableMapUpdate key elt+   -> IO Bool+updateMap (VariableMap broadcaster) mapUpdate =+   applyGeneralUpdate broadcaster (update mapUpdate)+++-- --------------------------------------------------------------------+-- The client's interface+-- --------------------------------------------------------------------+++-- | Unlike VariableSet, the contents of a variable map are not returned in+-- concrete form but as the abstract data type VariableMapData.  We provide+-- functions for querying this.+instance Ord key => HasSource (VariableMap key elt)+      (VariableMapData key elt) (VariableMapUpdate key elt)+      where+   toSource (VariableMap broadcaster) = toSource broadcaster++lookupMap :: Ord key => VariableMapData key elt -> key -> Maybe elt+lookupMap (VariableMapData map) key = Map.lookup key map++lookupWithDefaultMap :: Ord key => VariableMapData key elt -> elt -> key -> elt+lookupWithDefaultMap (VariableMapData map) def key+   = Map.findWithDefault def key map++mapToList :: Ord key => VariableMapData key elt -> [(key,elt)]+mapToList = Map.toList . mapToFM++mapToFM :: Ord key => VariableMapData key elt -> Map.Map key elt+mapToFM (VariableMapData map) = map++-- --------------------------------------------------------------------+-- An interface to a VariableMap which makes it look like a variable+-- set source.+-- --------------------------------------------------------------------++data VariableMapSet key elt element = VariableMapSet {+   variableMap :: VariableMap key elt,+   mkElement :: key -> elt -> element+   }++-- | Given a variable map and conversion function, produce a VariableSetSource+mapToVariableSetSource :: Ord key => (key -> elt -> element)+   -> VariableMap key elt -> VariableSetSource element+mapToVariableSetSource mkElement variableMap = toSource (VariableMapSet+      {variableMap = variableMap,mkElement = mkElement})++instance Ord key => HasSource (VariableMapSet key elt element) [element]+     (VariableSetUpdate element)+   where+      toSource (VariableMapSet+         {variableMap = variableMap,mkElement = mkElement}) =+            (map1+               (\ (VariableMapData contents) ->+                  map (uncurry mkElement) (Map.toList contents)+                  )+               )+            .+            (map2+               (\ (VariableMapUpdate update) ->+                  fmap (\ (key,elt) -> mkElement key elt) update+                  )+               )+            $+            (toSource variableMap)++-- --------------------------------------------------------------------+-- A couple of simple access functions+-- NB.  We don't follow the Registry interface because, without altering+-- the design, it would be difficult to implement some Registry functions.+-- --------------------------------------------------------------------++addToVariableMap :: Ord key => VariableMap key elt -> key -> elt -> IO Bool+addToVariableMap variableMap key elt =+   updateMap variableMap (VariableMapUpdate (AddElement (key,elt)))++delFromVariableMap :: Ord key => VariableMap key elt -> key -> IO Bool+delFromVariableMap variableMap key =+   updateMap variableMap (VariableMapUpdate (DelElement (key,+      error ("VariableMap.delFromVariableMap"))))++variableMapToList :: Ord key => VariableMap key elt -> IO [(key,elt)]+variableMapToList (VariableMap broadcaster) =+   do+      contents <- readContents broadcaster+      return (mapToList contents)++lookupVariableMap :: Ord key => VariableMap key elt -> key -> IO (Maybe elt)+lookupVariableMap (VariableMap broadcaster) key =+   do+      (VariableMapData finiteMap) <- readContents broadcaster+      return (Map.lookup key finiteMap)++-- --------------------------------------------------------------------+-- Returns current value of key (if any) in variable map+-- NB.  This implementation is very inefficient and it is in an inner loop+-- in types/LinkManager.  However it could be made much better by changing+-- the type.+-- --------------------------------------------------------------------++getVariableMapByKey :: Ord key => VariableMap key elt -> key+   -> SimpleSource (Maybe elt)+getVariableMapByKey variableMap key =+   let+      source1 = toSource variableMap+      source2 =+         (map1+            (\ (VariableMapData fmap) -> Map.lookup key fmap)+            )+         .+         (filter2+            (\ (VariableMapUpdate update) -> case update of+               AddElement (key2,elt)+                  | key2 == key -> Just (Just elt)+               DelElement (key2,elt)+                  | key2 == key -> Just Nothing+               _ -> Nothing+               )+            )+         $+         source1+   in+      SimpleSource source2
+ Util/VariableSet.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}++-- | VariableSet allow us to track changes to an unordered mutable set.+-- The elements of the set are keyed by instancing HasKey with some Ord+-- instance; this allows us to set up a special HasKey instance for this+-- module without committing us to that Ord instance everywhere.+module Util.VariableSet(+   HasKey(..),+   Keyed(..),+   VariableSetUpdate(..),+   VariableSet(..),++   newEmptyVariableSet,+   newVariableSet,+   updateSet,+   setVariableSet,++   VariableSetSource,+   emptyVariableSetSource,++   mapVariableSetSourceIO',+   concatVariableSetSource,++   mapVariableSetSource,+   singletonSetSource,+   listToSetSource,+   ) where++import Data.Maybe+import qualified Data.List as List++import qualified Data.Set as Set++import Util.Dynamics+import Util.Sources+import Util.Broadcaster++-- --------------------------------------------------------------------+-- The HasKey and Keyed types+-- --------------------------------------------------------------------++class Ord key => HasKey x key | x -> key where+   toKey :: x -> key+++newtype Keyed x = Keyed x++unKey :: Keyed x -> x+unKey (Keyed x) = x++lift :: (HasKey x1 key1,HasKey x2 key2)+   => (key1 -> key2 -> a) -> (Keyed x1 -> Keyed x2 -> a)+lift f x1 x2 = f (toKey . unKey $ x1) (toKey . unKey $ x2)+++-- | HasKey specifies the ordering to use (without committing us to+-- a particular Ord instance elsewhere).+instance HasKey x key => Eq (Keyed x) where+   (==) = lift (==)+   (/=) = lift (/=)++instance HasKey x key => Ord (Keyed x) where+   compare = lift compare+   (<=) = lift (<=)+   (>=) = lift (>=)+   (<) = lift (<)+   (>) = lift (>)++-- --------------------------------------------------------------------+-- The datatype+-- --------------------------------------------------------------------++newtype VariableSetData x = VariableSetData (Set.Set (Keyed x))++-- | Encodes the updates to a variable set.+-- BeginGroup does not actually alter the set itself, but+-- indicate that a group of updates is about to begin, terminated by EndGroup.+-- This prevents the client from trying to recalculate the state after every single+-- update.+--+-- BeginGroup\/EndGroup may be nested (though I don\'t have any application for that+-- yet).+data VariableSetUpdate x =+      AddElement x+   |  DelElement x+   |  BeginGroup+   |  EndGroup++update :: HasKey x key+   => VariableSetUpdate x -> VariableSetData x+   -> (VariableSetData x,[VariableSetUpdate x])+update setUpdate (variableSet @ (VariableSetData set)) =+   let+      noop = (variableSet,[])+      grouper = (variableSet,[setUpdate])+      oneop newSet = (VariableSetData newSet,[setUpdate])+   in+      case setUpdate of+         AddElement x ->+            let+               kx = Keyed x+               isElement = Set.member kx set+            in+               if isElement then noop else oneop (Set.insert kx set)+         DelElement x ->+            let+               kx = Keyed x+               isElement = Set.member kx set+            in+               if isElement then oneop (Set.delete kx set)+                  else noop+         BeginGroup -> grouper+         EndGroup -> grouper++newtype VariableSet x+   = VariableSet (Broadcaster (VariableSetData x) (VariableSetUpdate x))+   deriving (Typeable)++-- --------------------------------------------------------------------+-- The provider's interface+-- --------------------------------------------------------------------++-- | Create a new empty variable set.+newEmptyVariableSet :: HasKey x key => IO (VariableSet x)+newEmptyVariableSet =+   do+      broadcaster <- newBroadcaster (VariableSetData Set.empty)+      return (VariableSet broadcaster)++-- | Create a new variable set with given contents+newVariableSet :: HasKey x key => [x] -> IO (VariableSet x)+newVariableSet contents =+   do+      broadcaster+         <- newBroadcaster (VariableSetData (Set.fromList (fmap Keyed contents)))+      return (VariableSet broadcaster)++-- | Update a variable set in some way.+updateSet :: HasKey x key => VariableSet x -> VariableSetUpdate x -> IO ()+updateSet (VariableSet broadcaster) setUpdate+   = applyUpdate broadcaster (update setUpdate)++-- | Set the elements of the variable set.+setVariableSet :: HasKey x key => VariableSet x -> [x] -> IO ()+setVariableSet (VariableSet broadcaster) newList =+   do+     let+        newSet = Set.fromList (fmap Keyed newList)++        updateFn (VariableSetData oldSet) =+           let+              toAddList+                 = List.filter+                    (\ el -> not (Set.member (Keyed el) oldSet)) newList+              toDeleteList = fmap unKey (Set.toList (Set.difference oldSet newSet))+              updates =+                 [BeginGroup] ++ (fmap AddElement toAddList)+                    ++ (fmap DelElement toDeleteList) ++ [EndGroup]+           in+              (VariableSetData newSet,updates)++     applyUpdate broadcaster updateFn++-- --------------------------------------------------------------------+-- The client's interface+-- --------------------------------------------------------------------++instance HasKey x key => HasSource (VariableSet x) [x] (VariableSetUpdate x)+      where+   toSource (VariableSet broadcaster) =+      map1+         (\ (VariableSetData set) -> fmap unKey (Set.toList set))+         (toSource broadcaster)++-- --------------------------------------------------------------------+-- Type with the clients interface to a variable set (but which may be+-- otherwise implemented)+-- --------------------------------------------------------------------++type VariableSetSource x = Source [x] (VariableSetUpdate x)++emptyVariableSetSource :: VariableSetSource x+emptyVariableSetSource = staticSource []++-- --------------------------------------------------------------------+-- Combinators for VariableSetSource+-- --------------------------------------------------------------------++mapVariableSetSourceIO' :: (x -> IO (Maybe y)) -> VariableSetSource x+   -> VariableSetSource y+mapVariableSetSourceIO' mapFn=+   (map1IO+      (\ currentEls ->+         do+            newEls <- mapM mapFn currentEls+            return (catMaybes newEls)+         )+      )+   .+   (filter2IO+      (\ change ->+         case change of+            AddElement x ->+               do+                  yOpt <- mapFn x+                  case yOpt of+                     Nothing -> return Nothing+                     Just y -> return (Just (AddElement y))+            DelElement x ->+               do+                  yOpt <- mapFn x+                  case yOpt of+                     Nothing -> return Nothing+                     Just y -> return (Just (DelElement y))+            BeginGroup -> return (Just BeginGroup)+            EndGroup -> return (Just EndGroup)+         )+      )++concatVariableSetSource :: VariableSetSource x -> VariableSetSource x+   -> VariableSetSource x+concatVariableSetSource (source1 :: VariableSetSource x) source2 =+   let+      pair :: Source ([x],[x])+         (Either (VariableSetUpdate x) (VariableSetUpdate x))+      pair = choose source1 source2++      res :: Source [x] (VariableSetUpdate x)+      res =+         (map1 (\ (x1,x2) -> x1 ++ x2))+         .+         (map2+            (\ xlr -> case xlr of+               Left x -> x+               Right x -> x+               )+            )+         $+         pair+   in+      res++-- --------------------------------------------------------------------+-- VariableSetUpdate is an instance of Functor.+-- mapVariableSetSource is functor-like for VariableSetSource.+-- --------------------------------------------------------------------++instance Functor VariableSetUpdate where+   fmap fn (AddElement x) = AddElement (fn x)+   fmap fn (DelElement x) = DelElement (fn x)+   fmap fn BeginGroup = BeginGroup+   fmap fn EndGroup = EndGroup++mapVariableSetSource :: (x -> y) -> VariableSetSource x -> VariableSetSource y+mapVariableSetSource fn source =+   (map1 (fmap fn)) .+   (map2 (fmap fn)) $+   source++-- --------------------------------------------------------------------+-- singletonSetSource creates a VariableSet with a single element+-- --------------------------------------------------------------------++singletonSetSource :: SimpleSource x -> VariableSetSource x+singletonSetSource (source0 :: SimpleSource x) =+   let+      (source1 :: Source x x) = toSource source0+      (source2 :: Source x (x,x)) = mkHistorySource id source1+      (source3 :: Source [x] [VariableSetUpdate x]) =+         (map1+            (\ x -> [x])+            )+         .+         (map2+            (\ (x1,x2) -> [BeginGroup,AddElement x2,DelElement x1,EndGroup])+            )+         $+         source2+      (source4 :: VariableSetSource x) = flattenSource source3+   in+      source4++-- | Creates a VariableSetSource whose elements are the same as those of the+-- corresponding list.+listToSetSource :: Ord x => SimpleSource [x] -> VariableSetSource x+listToSetSource (simpleSource :: SimpleSource [x]) =+   let+      source1 :: Source [x] [x]+      source1 = toSource simpleSource++      source2 :: Source (Set.Set x,[x]) [VariableSetUpdate x]+      source2 = foldSource+         (\ list -> Set.fromList list)+         (\ oldSet newList ->+            let+               newSet = Set.fromList newList++               toAdd = Set.difference newSet oldSet+               adds = fmap AddElement (Set.toList toAdd)++               toDelete = Set.difference oldSet newSet+               deletes = fmap DelElement (Set.toList toDelete)+            in+               (newSet,adds ++ deletes)+            )+         source1++      source3 :: Source [x] [VariableSetUpdate x]+      source3 = map1 snd source2++      source4 :: Source [x] (VariableSetUpdate x)+      source4 = flattenSource source3+   in+      source4+++
+ Util/VariableSetBlocker.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Blockers are used to implement variable set sources which can be+-- turned on and off.  They are indexed by a BlockID.+module Util.VariableSetBlocker(+   Blocker,+   BlockID,+   newBlocker, -- :: HasKey a key => VariableSetSource a -> IO (Blocker a)+   newBlockID, -- :: IO BlockID++   openBlocker, -- :: HasKey a key => Blocker a -> BlockID -> IO ()+   closeBlocker, -- :: HasKey a key => Blocker a -> BlockID -> IO ()+   blockVariableSet,+      -- :: HasKey a key => Blocker a -> BlockID -> VariableSetSource a+++   newBlockerWithPreAction+      -- :: HasKey a key => VariableSetSource a -> ([a] -> IO ())+      -- -> IO (Blocker a)+      --+      -- newBlockerWithPreAction creates a blocker that additionally permits+      -- an action that is performed the very first time the blocker is+      -- opened.+      -- The arguments to the action are the contents of the variable set+      -- at about the time of the opening.+   ) where++import System.IO.Unsafe+import Control.Concurrent++import Util.Object+import Util.Registry+import Util.Sink+import Util.Sources+import Util.VariableSet+++-- --------------------------------------------------------------------+-- The types+-- --------------------------------------------------------------------++data Blocker a = Blocker {+   registry :: Registry BlockID (VariableSetSource a,Bool -> IO ()),+      -- For each blockID, the corresponding VariableSetSource and an+      -- action which blocks it, with True meaning "blocked".+   setSource :: VariableSetSource a+   }++newtype BlockID = BlockID ObjectID deriving (Eq,Ord)++-- --------------------------------------------------------------------+-- The functions+-- --------------------------------------------------------------------++newBlocker :: HasKey a key => VariableSetSource a -> IO (Blocker a)+newBlocker setSource =+   do+      registry <- newRegistry+      let+         blocker = Blocker {+            registry = registry,+            setSource = setSource+            }+      return blocker++newBlockerWithPreAction+   :: HasKey a key => VariableSetSource a -> ([a] -> IO ()) -> IO (Blocker a)+newBlockerWithPreAction setSource0 preAction =+   let+      action =+         do+            list <- readContents setSource0+            preAction list+      setSource1 = (unsafePerformIO action) `seq` setSource0+   in+      newBlocker setSource1++newBlockID :: IO BlockID+newBlockID =+   do+      objectID <- newObject+      return (BlockID objectID)++openBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()+openBlocker blocker blockID =+   do+      (_,blockFn) <- getBlockEntry blocker blockID+      blockFn False++closeBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()+closeBlocker blocker blockID =+   do+      (_,blockFn) <- getBlockEntry blocker blockID+      blockFn True++blockVariableSet :: HasKey a key+   => Blocker a -> BlockID -> IO (VariableSetSource a)+blockVariableSet blocker blockID =+   do+      (setSource,_) <- getBlockEntry blocker blockID+      return setSource++-- --------------------------------------------------------------------+-- The primitive functions+-- --------------------------------------------------------------------++getBlockEntry :: HasKey a key+   => Blocker a -> BlockID -> IO (VariableSetSource a,Bool -> IO ())+getBlockEntry blocker blockID =+   transformValue (registry blocker) blockID (\ entryOpt ->+      case entryOpt of+         Just entry -> return (entryOpt,entry)+         Nothing ->+            do+               entry <- blockableVariableSet (setSource blocker)+               return (Just entry,entry)+         )++-- | (setSource2,block) \<- blockableVariableSet setSource1+-- returns a setSource2 which is in one of two states.  In one state it is+-- blocked, and empty.  In the other, it is unblocked, and its contents are+-- the same as those of setSource1.  Initially it is blocked.  To switch+-- from one to the other the block function is used.  \"block True\" blocks+-- the set source; \"block False\" unblocks it.   Blocking if we are already+-- blocked, or unblocking if we are already unblocked, is harmless and does+-- nothing.+--+-- This somewhat baroque function is required for arc sets from folders.+-- I have wasted a couple of days trying to think of a more elegant way of+-- doing this ...+blockableVariableSet :: HasKey a key+   => VariableSetSource a -> IO (VariableSetSource a,Bool -> IO ())+blockableVariableSet (setSource1 :: VariableSetSource a) =+   do+      (mVar :: MVar (Maybe (IO ()))) <- newMVar Nothing+         -- If we are not blocked, contains the terminator action.+      set2 <- newEmptyVariableSet -- contains the contents of setSource2+      parallelX <- newParallelExec+         -- used to execute updates to set2.  This helps make sure they+         -- happen in the right order.+      let+         block doBlock = modifyMVar_ mVar (\ terminatorOpt ->+            do+               case (doBlock,terminatorOpt) of+                  (True,Just terminator) -> -- block+                     do+                        parallelExec parallelX (+                           do+                              terminator -- stop any more updates.+                              setVariableSet set2 [] -- empty this set.+                           )+                        return Nothing+                  (False,Nothing) -> -- unblock+                     do+                        sinkID <- newSinkID++                        let+                           doContents :: [a] -> IO ()+                           doContents contents = setVariableSet set2 contents++                           doUpdate :: VariableSetUpdate a -> IO ()+                           doUpdate update = updateSet set2 update++                        addNewSinkWithInitial setSource1 doContents doUpdate+                           sinkID parallelX+                        return (Just (invalidate sinkID))+                  _ -> return terminatorOpt+                  )++      return (toSource set2,block)
+ Util/VisitedSet.hs view
@@ -0,0 +1,31 @@+module Util.VisitedSet(+   VisitedSet,+   newVisitedSet, -- :: Ord key => IO (VisitedSet key)+   isVisited,+      -- :: Ord key => VisitedSet key -> key -> IO Bool+      -- return True if the element has already been visited, otherwise+      -- visit it.+   ) where++import Control.Concurrent+import qualified Data.Set as Set++newtype VisitedSet key = VisitedSet (MVar (Set.Set key))++newVisitedSet :: Ord key => IO (VisitedSet key)+newVisitedSet =+   do+      mVar <- newMVar Set.empty+      return (VisitedSet mVar)++isVisited :: Ord key => VisitedSet key -> key -> IO Bool+isVisited (VisitedSet mVar) key =+   modifyMVar mVar+      (\ set ->+         return (if Set.member key set+            then+               (set,True)+            else+               (Set.insert key set,False)+            )+         )
+ Util/WBFiles.hs view
@@ -0,0 +1,881 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- |+-- Description : Option processing+--+-- The WBFiles module is in charge of decoding information from the command+-- line and making it available to the rest of the UniForM workbench.+--+-- All UniForM options have names beginning with "--uni".  It is hoped+-- that this won't be a problem for programs that use the UniForM workbench.+-- However, if it is, the function+--    setAlternateArgs+-- should be called before any of the functions in the UniForM workbench,+-- as this will prevent the program arguments being read by UniForM.+--+-- The+-- @+--    --uni+-- @+-- option prints a help message, as do other options beginning with+-- --uni which are not understood.+--+-- The+-- @+--    --uni-parameters+-- @+-- option prints the parameters at the given position on the command+-- line.+--+-- The+-- @+--    --uni-version+-- @+-- option prints the current version of uni.+--+-- @+-- --uni-<option-name>:<option-value>+-- @+-- or equivalently+-- @+-- --uni-<option-name>=<option-value>+-- @+--+-- All options can also be overridden by environment variables.+-- The environment variable corresponding to <option-name> has the+-- name @UNI<OPTION-NAME>@+-- where @<OPTION-NAME>@ is the capitalised name of the option.+--+-- The default set of options are as follows:+--+-- option-name   explanation+--+-- wish          The filename of the wish program+-- daVinci       The filename of daVinci+-- gnuclient     The filename of gnuclient+-- editor        A command to execute the text editor.+--               This uses the CommandStringSub format, with defined+--               substitutions %F => where the file is to be found and+--               %N => what the user-visible name (for example, of the+--               buffer) should be.+-- top           The directory in which UniForM is installed+--+-- daVinciIcons  The directory containing daVinci icons+--+-- workingDir    The directory used for temporary files.+--+-- server        The host name of the server+-- user          The user-id to use connecting to the server+-- password      The password to use connecting to the server+-- port          The port on the server to connect to+-- xmlPort       The port for the XML server (which has a different default)+--+-- debug         Where Debug.debug messages should go+--+-- serverDir     Where Server stores its files+-- serverId      The unique identifier of the server.+--               Since this really does have to be globally unique,+--               it is by default constructed from a combination+--               of the machine's hostname and the server port.+--               You had better not change it unless you know what+--               you are doing.+--+-- MMiSSDTD      Location of DTD file for MMiSS.+--+-- hosts         Location of hosts file.+--+-- toolTimeOut   Time-out waiting for responses from a tool when+--               it starts up and we are doing challenge-response+--               verification.+-- windowsTick   (Windows only) time in microseconds we wait between+--               polling Wish.+--+-- The options wish, daVinci, daVinciIcons, top+-- should all be set automatically by the configure procedure.+-- The configure procedure constructs a variable DEFAULTOPTIONS+-- and writes it into the file default_options.c.+--+-- returns a string with exactly the same syntax as the command line+-- so a typical one might be+--    @+--    --uni-wish:/usr/bin/wish --uni-daVinci:/usr/bin/daVinci+--    @+--    ... (and so on)+--+-- However one difference is that options which are not understood+-- in the default_options string are simply ignored.+module Util.WBFiles (+   -- Functions for reading the results of initialising WBFiles.+   -- Values for which we provide defaults either here or in the+   -- configuration file can be accessed without Maybe.+   getWishPath, -- :: IO String+      -- gets the path for wish+   getDaVinciPath,+      -- ditto daVinci+   getGnuClientPath,+      -- ditto gnuclient.++   getToolTimeOut, -- :: IO Int+      -- gets tool time out.+   getTOP, --  :: IO String+      -- Get the location of the top directory.+   getTOPPath,+      -- :: [String] -> IO String+      -- Get a path within the top directory.+   getEditorString, -- :: IO (Maybe String)+      -- returns editor string, if set.+   getMMiSSDTD, -- :: IO (Maybe String)+      -- returns location of MMiSSDTD, if set.+   getMMiSSAPIDTD, -- :: IO (Maybe String)+      -- returns location of DTD for API requests, if set.+      -- (does not correspond to an option at present, we get it from TOP)++   getHosts, -- :: IO String+      -- returns location of hosts file.++   getPort, -- IO Int++   getXMLPort, -- IO Int++   getCouplingPort, -- IO Int++   -- getWorkingDir trims a right-file-separator from its argument, if any.+   getWorkingDir, -- :: IO String++   getCouplingDir, -- :: IO String++   -- getDebugFileName returns the name of the debug file.+   getDebugFileName, -- IO String++   -- values for which we don't are:+   getDaVinciIcons, -- :: IO (Maybe String)+   getServer, -- ditto+   getUser, -- ditto+   getPassword, -- ditto++   -- Store options.+   getServerFile, -- :: String -> IO String+      -- Get a file for the use of the server.+   getServerDir, --  :: IO String+      -- Get the server's private directory.+   getServerId, -- :: IO (Maybe String)+      -- Return a (globally unique) id for this server.++   -- Access to other options.+   getArgString, -- :: String -> IO (Maybe String)+   getArgBool, -- :: String -> IO (Maybe Bool)+   getArgInt, -- :: String -> IO (Maybe Int)++   -- Functions for initialising WBFiles.  If they detect an error+   -- in the parse, they immediately do System.exitWith (ExitFailure 4).+   -- If the --uni option is used, they do System.exitWith (ExitSuccess)+   -- (after displaying a help message).+   -- If none of these functions are used, the arguments are parsed when+   -- we first try to access them, with the same effect as parseArguments+   -- except that we don't exit if there's a problem.+   --+   parseArguments, -- :: IO ()+       -- equivalent to parseTheseArguments usualProgramArguments.+       -- parseArguments is done by default+   parseArgumentsRequiring, -- :: [String] -> IO ()+       -- equivalent to parseTheseArgumentsRequiring usualProgramArguments.++   ArgType(..), -- represents type arguments can have.+   ArgValue(..), -- represents values arguments can have.++   ProgramArgument(..), -- data corresponding to a single sort of argument.++   usualProgramArguments,+      -- :: [ProgramArgument]+      -- corresponds to the usual program arguments.++   parseTheseArguments, -- :: [ProgramArgument] -> IO ()+   -- parseTheseArguments args = parseTheseArgumentsRequiring args []++   parseTheseArgumentsRequiring, -- :: [ProgramArgument] -> [String] -> IO ()+   -- parseTheseArgumentsRequiring+   -- parses the arguments, using the supplied list of allowed arguments.+   -- It is an error if any of the options with names in the second argument+   -- are not defined.++   setAlternateArgs, -- :: [String] -> IO ()+   -- specify the given strings as arguments to be used by the parse+   -- functions.++   ) where++import Data.Char+import Util.CompileFlags+import System.IO+import System.IO.Error+import Data.List+import Control.Monad+import qualified System.Environment as System+import System.Exit(exitWith,ExitCode(..))++import Control.Concurrent+import qualified Data.Map as Map+import System.IO.Unsafe+import Foreign.C.String++import Util.FileNames++------------------------------------------------------------------------+-- Specific access functions.+------------------------------------------------------------------------++valOf :: String -> IO (Maybe a) -> IO a+valOf optionName action =+   do+      valueOpt <- action+      case valueOpt of+         Just a -> return a+         Nothing ->+            error ("option --uni-" ++ optionName ++ " is surprisingly unset")++getWishPath :: IO String+getWishPath = valOf "wish" (getArgString "wish")++getEditorString :: IO (Maybe String)+getEditorString = getArgString "editor"++getMMiSSDTD :: IO (Maybe String)+getMMiSSDTD =+   do+      mmissDTDOpt <- getArgString "MMiSSDTD"+      case mmissDTDOpt of+         Just mmissDTD -> return mmissDTDOpt+         Nothing ->+            do+               path <- getTOPPath ["mmiss","MMiSS.dtd"]+               return (Just path)++getMMiSSAPIDTD :: IO (Maybe String)+getMMiSSAPIDTD =+   do+      path <- getTOPPath ["mmiss","api","MMiSSRequest.dtd"]+      return (Just path)++      -- returns location of DTD for API requests, if set.++getHosts :: IO String+getHosts =+   do+      hostsOpt <- getArgString "Hosts"+      case hostsOpt of+         Just hosts -> return hosts+         Nothing ->+            getTOPPath ["server","Hosts.xml"]+++getDaVinciPath :: IO String+getDaVinciPath = valOf "daVinci" (getArgString "daVinci")++getGnuClientPath :: IO String+getGnuClientPath = valOf "gnuclient" (getArgString "gnuclient")++getToolTimeOut :: IO Int+getToolTimeOut = valOf "toolTimeOut" (getArgInt "toolTimeOut")++getTOP :: IO String+getTOP = valOf "top" (getArgString "top")++-- | Get a path within the top directory.+getTOPPath :: [String] -> IO String+getTOPPath names =+   do+      top <- getTOP+      return (unbreakName (trimDir top:names))++getPort :: IO Int+getPort = valOf "port" (getArgInt "port")++getXMLPort :: IO Int+getXMLPort = valOf "xmlPort" (getArgInt "xmlPort")++getWorkingDir :: IO String+getWorkingDir =+   do+      workingDir' <- valOf "workingDir" (getArgString "workingDir")+      return (trimDir workingDir')++getDebugFileName :: IO String+getDebugFileName = valOf "debug" (getArgString "debug")++getServerFile :: String -> IO String+getServerFile innerName =+   do+      serverDir <- getServerDir+      return (combineNames (trimDir serverDir) innerName)++getServerDir :: IO String+getServerDir =+   do+      serverDirOpt <- getArgString "serverDir"+      case serverDirOpt of+         Nothing ->+            error (+               "UNISERVERDIR environment variable or --uni-serverDir"+               ++ " must be set for server programs")+         Just serverDir -> return serverDir++getServerId :: IO (Maybe String)+getServerId = getArgString "serverId"+++getDaVinciIcons :: IO (Maybe String)+getDaVinciIcons = getArgString "daVinciIcons"++getServer :: IO (Maybe String)+getServer = getArgString "server"++getUser :: IO (Maybe String)+getUser = getArgString "user"++getPassword :: IO (Maybe String)+getPassword = getArgString "password"++getCouplingPort :: IO Int+getCouplingPort = valOf "couplingPort" (getArgInt "couplingPort")++getCouplingDir ::  IO String+getCouplingDir = valOf "couplingDir" (getArgString "couplingDir")+++------------------------------------------------------------------------+-- ProgramArgument and usualProgramArguments.+------------------------------------------------------------------------++data ProgramArgument = ProgramArgument {+   optionName :: String, -- the option name+   optionHelp :: String, -- Help text displayed by --uni option.+   defaultVal :: Maybe ArgValue, -- default value+   argType :: ArgType+   }++usualProgramArguments :: [ProgramArgument]+usualProgramArguments = [+   ProgramArgument{+      optionName = "wish",+      optionHelp = "path to the wish program",+      defaultVal = Just (StringValue "/usr/bin/wish"),+      argType = STRING+      },+   ProgramArgument{+      optionName = "daVinci",+      optionHelp = "path to the daVinci program",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "daVinciIcons",+      optionHelp = "directory containing daVinci icons",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "gnuclient",+      optionHelp = "path to the gnuclient program",+      defaultVal = Just (StringValue "gnuclient"),+      argType = STRING+      },+   ProgramArgument{+      optionName = "toolTimeOut",+      optionHelp = "time-out when tools start up in milliseconds",+      defaultVal = Just (IntValue 10000),+      argType = INT+      },+   ProgramArgument{+      optionName = "windowsTick",+      optionHelp = "interval in microseconds for polling wish (Windows only).",+      defaultVal = Just (IntValue 10000),+      argType = INT+      },+   ProgramArgument{+      optionName = "editor",+      optionHelp = "text editor cmd; %F => filename; %N => user-visible name",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      -- We make getMMiSSDTD return a default of TOP/mmiss/MMiSS.dtd if+      -- nothing is set.+      optionName = "MMiSSDTD",+      optionHelp = "Filename for MMiSS's DTD",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      -- We make getHosts return a default of TOP/server/Hosts.xml if+      -- Nothing is set.+      optionName = "Hosts",+      optionHelp = "File containing list of hosts",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "top",+      optionHelp = "path where UniForM was installed",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "serverDir",+      optionHelp = "where server stores its files",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "serverId",+      optionHelp = "globally unique server identifier (EXPERTS ONLY)",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "workingDir",+      optionHelp = "directory used for temporary files",+      defaultVal = Just (StringValue "/tmp"),+      argType = STRING+      },+   ProgramArgument{+      optionName = "server",+      optionHelp = "machine where the server runs",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "user",+      optionHelp = "Your identifier on the server",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "password",+      optionHelp = "Your password on the server",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "port",+      optionHelp = "port for the server",+      defaultVal = Just (IntValue defaultPort),+      argType = INT+      },+   ProgramArgument{+      optionName = "xmlPort",+      optionHelp = "port for the MMiSS-XML server",+      defaultVal = Just (IntValue defaultXMLPort),+      argType = INT+      },+   ProgramArgument{+      optionName = "couplingPort",+      optionHelp = "port for the coupling server",+      defaultVal = Just (IntValue defaultCouplingPort),+      argType = INT+      },+   ProgramArgument{+      optionName = "couplingDir",+      optionHelp = "directory where the coupling server finds the working copy of foreign repository",+      defaultVal = Nothing,+      argType = STRING+      },+   ProgramArgument{+      optionName = "debug",+      optionHelp = "file for debug output",+      defaultVal = Just (StringValue "/tmp/uniform.DEBUG"),+      argType = STRING+      }+   ]++defaultPort :: Int+defaultPort = 11393+++defaultXMLPort :: Int+defaultXMLPort = 11396++defaultCouplingPort :: Int+defaultCouplingPort = 11391++------------------------------------------------------------------------+-- Argument Types+------------------------------------------------------------------------++data ArgType = STRING | INT | BOOL++showArgType :: ArgType -> String+showArgType STRING = "string"+showArgType INT = "int"+showArgType BOOL = "bool"++data ArgValue = StringValue String | IntValue Int | BoolValue Bool++parseArgValue :: ArgType -> String -> Maybe ArgValue+parseArgValue STRING str = Just (StringValue str)+parseArgValue INT str =+   case readsPrec 0 str of+      [(val,"")] -> Just (IntValue val)+      _ -> Nothing+parseArgValue BOOL str =+   let+      true = Just (BoolValue True)+      false = Just (BoolValue False)+   in+      case str of+         "" -> true+         "True" -> true+         "False" -> false+         "+" -> true+         "-" -> false+         "yes" -> true+         "no" -> false+         _ -> Nothing++showArgValue :: ArgValue -> String+showArgValue (StringValue str) = str+showArgValue (IntValue i) = show i+showArgValue (BoolValue b) = if b then "+" else "-"++------------------------------------------------------------------------+-- Parsed Arguments+------------------------------------------------------------------------++newtype ParsedArguments =+   ParsedArguments (MVar (Maybe (Map.Map String ArgValue)))++makeParsedArguments :: IO ParsedArguments+makeParsedArguments =+   do+      mVar <- newMVar Nothing+      return (ParsedArguments mVar)+{-# NOINLINE makeParsedArguments #-}+-- the NOINLINE should, we hope, mean that there is only one copy of+-- the parsedArguments mVar.++parsedArguments :: ParsedArguments+-- the unique set of parsed arguments+parsedArguments = unsafePerformIO makeParsedArguments+{-# NOINLINE parsedArguments #-}++getArgValue :: String -> IO (Maybe ArgValue)+getArgValue optionName =+   do+      map <- forceParseArguments+      return (Map.lookup optionName map)++mismatch :: String -> a+mismatch optionName =+   error ("WBFiles.mismatch - type mismatch for "++optionName)+   -- If this happens, it means a bug in this file or else+   -- a default value for a program argument does not have the right type,+   -- or an attempt to use a getArg* function for an option with the wrong+   -- type.+{-# NOINLINE mismatch #-}++getArgString :: String -> IO (Maybe String)+getArgString optionName =+   do+      valOpt <- getArgValue optionName+      case valOpt of+         Just (StringValue str) -> return (Just str)+         Just _ -> mismatch optionName+         Nothing -> return Nothing++getArgInt :: String -> IO (Maybe Int)+getArgInt optionName =+   do+      valOpt <- getArgValue optionName+      case valOpt of+         Just (IntValue i) -> return (Just i)+         Just _ -> mismatch optionName+         Nothing -> return Nothing+++getArgBool :: String -> IO (Maybe Bool)+getArgBool optionName =+   do+      valOpt <- getArgValue optionName+      case valOpt of+         Just (BoolValue b) -> return (Just b)+         Just _ -> mismatch optionName+         Nothing -> return Nothing+++-- forceParseArguments is used to force a parse of the arguments+-- when no parse function has been called before.+forceParseArguments :: IO (Map.Map String ArgValue)+forceParseArguments =+   do+      let ParsedArguments mVar = parsedArguments+      mapOpt <- takeMVar mVar+      case mapOpt of+         Nothing ->+            do+               (exitCode,newMap) <-+                  parseTheseArgumentsRequiring' usualProgramArguments []+               putMVar mVar (Just newMap)+               return newMap+         Just map ->+            do+               putMVar mVar (Just map)+               return map++------------------------------------------------------------------------+-- setAlternateArgs+------------------------------------------------------------------------++alternateArgs :: MVar [String]++newAlternateArgs :: IO (MVar [String])+newAlternateArgs = newEmptyMVar+{-# NOINLINE newAlternateArgs #-}++alternateArgs = unsafePerformIO newAlternateArgs++setAlternateArgs :: [String] -> IO ()+setAlternateArgs newArgs =+   do+      isEmpty <- isEmptyMVar alternateArgs+      if isEmpty+         then+            putMVar alternateArgs newArgs+         else+            error "setAlternateArgs called twice or after getArgs"++getArgs :: IO [String]+getArgs =+   do+      isEmpty <- isEmptyMVar alternateArgs+      args <- if isEmpty+         then+            System.getArgs+         else+            takeMVar alternateArgs+      putMVar alternateArgs args+      return args++------------------------------------------------------------------------+-- Parsing Arguments+------------------------------------------------------------------------++parseArguments :: IO ()+parseArguments = parseTheseArguments usualProgramArguments++parseArgumentsRequiring :: [String] -> IO ()+parseArgumentsRequiring required =+   parseTheseArgumentsRequiring usualProgramArguments required++parseTheseArguments :: [ProgramArgument] -> IO ()+parseTheseArguments arguments = parseTheseArgumentsRequiring arguments []++parseTheseArgumentsRequiring :: [ProgramArgument] -> [String] -> IO ()+parseTheseArgumentsRequiring arguments required =+   do+      let ParsedArguments mVar = parsedArguments+      mapOpt <- takeMVar mVar+      case mapOpt of+         Just _ ->+            do+               putMVar mVar mapOpt+               printToErr+                  ("WBFiles.parseTheseArgumentsRequiring: " +++                     "attempt to parse arguments too late")+         Nothing ->+            do+               (result,newMap) <-+                  parseTheseArgumentsRequiring' arguments required+               putMVar mVar (Just newMap)+               case result of+                  Nothing -> return ()+                  Just exitCode -> exitWith exitCode+++type ParseState = (Maybe ExitCode,Map.Map String ArgValue)++parseTheseArgumentsRequiring' :: [ProgramArgument] -> [String] ->+  IO ParseState+-- is the most general argument parsing function, in terms of which+-- all the others are defined.+-- It returns a map representing the parsed arguments, plus an exit+-- code if an exit is indicated.+parseTheseArgumentsRequiring' arguments required =+   do+      let+         initialMap =+            foldl+               (\ map argument ->+                  case (defaultVal argument) of+                     Nothing -> map+                     Just value -> Map.insert (optionName argument) value map+                  )+               Map.empty+               arguments++         initial = (Nothing, initialMap) :: ParseState++      defaultOptionsStr <- peekCString defaultOptions+      afterDefault <- foldM (handleParameter False) initial+         (words defaultOptionsStr)++      parameters <- getArgs++      afterParms <- foldM (handleParameter True) afterDefault parameters++      afterEnvs <- foldM handleEnv afterParms arguments++      foldM checkReq afterEnvs required+   where+      handleParameter :: Bool -> ParseState -> String -> IO ParseState+      -- handles a single command line parameter.  If the Bool is true+      -- it modifies the exit code accordingly.+      handleParameter noticeErrors prev@(prevExit,prevMap) parameter =+         let+            newExit exitCode = upgradeError noticeErrors exitCode prevExit+            cantParse =+               do+                  printToErr ("Can't parse "++parameter)+                  displayHelp+                  return (newExit (ExitFailure 4),prevMap)+         in+            case parameter of+               "--uni" ->+                  do+                     displayHelp+                     return (newExit ExitSuccess,prevMap)+               "--uni-version" ->+                     do+                        printToErr ("uni's version is "++uniVersion)+                        -- The MMiSS installer relies on the exact text of+                        -- this message.+                        return (newExit ExitSuccess,prevMap)+               "--uni-parameters" ->+                  do+                     displayState prevMap+                     return (newExit ExitSuccess,prevMap)+               '-':'-':'u':'n':'i':'-':setParm ->+                  case splitSetPart setParm of+                     Nothing -> cantParse+                     Just (option,value) ->+                        case find (\ arg -> optionName arg == option)+                              arguments of+                           Nothing ->+                              do+                                 if noticeErrors+                                    then+                                       do+                                          displayHelp+                                          printToErr ("Option '"++option+++                                             "' not recognised")+                                    else+                                       return ()+                                 return (newExit (ExitFailure 4),prevMap)+                           Just arg ->+                              tryToAddValue (argType arg) option value prev+               '-':'-':'u':'n':'i':_ -> cantParse+               _ -> return prev++      tryToAddValue :: ArgType -> String -> String -> ParseState ->+         IO ParseState+      tryToAddValue argType option value prev@(prevExit,prevMap) =+         case parseArgValue argType value of+            Nothing ->+               do+                  printToErr("For --uni-"++ option ++ ", "++(show value)+++                     " isn't "++ (showArgType argType))+                  return+                     (upgradeError True (ExitFailure 4) prevExit,prevMap)+                     -- we always take notice of this error, since it+                     -- shouldn't occur in the default list either.+            Just argValue ->+               return (prevExit,Map.insert option argValue prevMap)++      splitSetPart :: String -> Maybe (String,String)+      -- splitSetPart splits the string at its first : or = and returns+      -- the result+      splitSetPart "" = Nothing+      splitSetPart (':':rest) = Just ("",rest)+      splitSetPart ('=':rest) = Just ("",rest)+      splitSetPart (first:rest) =+         case splitSetPart rest of+            Nothing -> Nothing+            Just (left,right) -> Just (first:left,right)++      displayHelp :: IO ()+      -- display a help message+      displayHelp =+         do+            printToErr "Command-line options:"+            printToErr "--uni displays this message"+            printToErr "--uni-version displays the current version"+            printToErr "--uni-parameters displays option settings"+            sequence_+               (map+                  (\ (ProgramArgument{optionName = optionName,+                     optionHelp = optionHelp,argType = argType}) ->+                     printToErr (+                        "--uni-"++optionName++"=["++showArgType argType +++                        "] sets "++optionHelp+                        )+                     )+                  arguments+                  )++      displayState :: Map.Map String ArgValue -> IO ()+      -- displays the current options+      displayState fmap =+         do+            let optionValues = Map.toList fmap+            printToErr "Parameter settings:"+            sequence_+               (map+                  (\ (option,argValue) ->+                     printToErr ("--uni-"++option++"="+++                        (showArgValue argValue))+                     )+                  optionValues+                  )++      handleEnv :: ParseState -> ProgramArgument -> IO ParseState+      -- look up the environment variable for the program argument and+      -- adjust state appropriately+      handleEnv prev@(prevExit,prevMap) arg =+         do+            let+               option = optionName arg+               envVar = "UNI"++(map toUpper option)+            valueOpt <- try (System.getEnv envVar)+            case valueOpt of+               Left error -> return prev+               Right newValue ->+                  tryToAddValue (argType arg) option newValue prev++      checkReq :: ParseState -> String -> IO ParseState+      -- check that the provided option value is set+      checkReq prev@(prevExit,prevMap) option =+         case Map.lookup option prevMap of+            Just _ -> return prev+            Nothing ->+               do+                  printToErr ("Option "++option++" is not set.")+                  return (upgradeError True (ExitFailure 4) prevExit,prevMap)++      upgradeError :: Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode+      -- takes notice of an error, if the first argument is set.+      upgradeError False _ soFar = soFar+      upgradeError True exitCode Nothing = Just exitCode+      upgradeError True exitCode (Just ExitSuccess) = Just exitCode+      upgradeError True ExitSuccess (Just exitCode) = Just exitCode+      upgradeError True (ExitFailure level1) (Just (ExitFailure level2)) =+         Just (ExitFailure (max level1 level2))++foreign import ccall  "default_options.h & default_options"+   defaultOptions :: CString++------------------------------------------------------------------------+-- Printing to stderr.+------------------------------------------------------------------------++printToErr :: String -> IO ()+printToErr message =+   do+      hPutStrLn stderr message
+ default_options.c view
@@ -0,0 +1,9 @@+/* default_options is a string representing the default+   options to be compiled into UniForM. */+/* This is a version to be compiled into uni when exported, at least until+   we have a better way of doing things.   What we can't guess, we leave+   blank. */+#include "default_options.h"++const char default_options[] =+"--uni-wish:wish --uni-daVinci:uDrawGraph";
+ include/default_options.h view
@@ -0,0 +1,9 @@+#ifndef DEFAULT_OPTIONS_H+#define DEFAULT_OPTIONS_H++/* default_options is a string representing the default+   options to be compiled into UniForM. */++extern const char default_options[];++#endif
+ include/new_object.h view
@@ -0,0 +1,15 @@+#ifndef NEW_OBJECT_H+#define NEW_OBJECT_H++/* This C function returns a unique int each time it is called.+   (Up to a limit of 2^32 iterations).++   Limitations: +      1) not thread-safe+      2) not unique between machines.+      3) could conceivably overflow.+   */++int next_object_id();++#endif
+ new_object.c view
@@ -0,0 +1,15 @@+/* This C function returns a unique int each time it is called.+   (Up to a limit of 2^32 iterations).++   Limitations: +      1) not thread-safe+      2) not unique between machines.+      3) could conceivably overflow+   */+#include "new_object.h"++static int object_id_source=0;++int next_object_id() {+   return object_id_source++;+   }
+ uni-util.cabal view
@@ -0,0 +1,63 @@+name:           uni-util+version:        2.2.0.0+build-type:     Simple+license:        LGPL+license-file:   LICENSE+author:         uniform@informatik.uni-bremen.de+maintainer:     Christian.Maeder@dfki.de+homepage:       http://www.informatik.uni-bremen.de/uniform/wb/+category:       Uniform+synopsis:       Utilities for the uniform workbench+description:+ This package contains various miscellaneous utilities used for the+ old HTk- und uDrawGraph bindings as well as for the MMiSS Workbench.+ They are kept for compatibility reason and put on hackage to ease+ installation.+cabal-version:  >= 1.4+Tested-With:    GHC==6.8.3, GHC==6.10.4, GHC==6.12.3++extra-source-files: include/new_object.h include/default_options.h++flag base4++flag debug+  description: add debug traces+  default: False++library+ exposed-modules:+  Util.Huffman, Util.CompileFlags, Util.Queue,+  Util.ExtendedPrelude, Util.Computation, Util.Dynamics, Util.WBFiles,+  Util.Object, Util.Debug, Util.Maybes, Util.LineShow, Util.Cache,+  Util.FileNames, Util.IOExtras, Util.QuickReadShow, Util.AtomString,+  Util.Registry,+  Util.Thread, Util.UniqueString, Util.UniqueFile, Util.TempFile, Util.Sink,+  Util.VariableSet, Util.VariableMap, Util.CommandStringSub,+  Util.DeepSeq, Util.NameMangle,+  Util.KeyedChanges, Util.Sources, Util.Broadcaster, Util.ReferenceCount,+  Util.Delayer, Util.VariableList, Util.Myers, Util.VariableSetBlocker,+  Util.IntPlus, Util.UnionFind, Util.ICStringLen, Util.VisitedSet,+  Util.HostName, Util.Bytes, Util.Binary, Util.BinaryUtils,+  Util.BinaryInstances, Util.BinaryExtras, Util.BinaryAll,+  Util.ThreadDict, Util.TSem, Util.Store, Util.Messages,+  Util.ClockTimeToString, Util.UTF8, Util.VSem++ include-dirs: include+ c-sources: new_object.c, default_options.c++ build-depends: base >= 3 && < 4, parsec < 3, mtl, directory,+  network, containers, bytestring, array, old-time++ if flag(base4)+   build-depends: ghc-prim++ if flag(debug)+   cpp-options: -DDEBUG++ if os(windows)+   cpp-options: -DWINDOWS++ if impl(ghc < 6.10)+   extensions: PatternSignatures+ else+   ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations