diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Util/AtomString.hs b/Util/AtomString.hs new file mode 100644 --- /dev/null +++ b/Util/AtomString.hs @@ -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)) diff --git a/Util/Binary.hs b/Util/Binary.hs new file mode 100644 --- /dev/null +++ b/Util/Binary.hs @@ -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} + diff --git a/Util/BinaryAll.hs b/Util/BinaryAll.hs new file mode 100644 --- /dev/null +++ b/Util/BinaryAll.hs @@ -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 + diff --git a/Util/BinaryExtras.hs b/Util/BinaryExtras.hs new file mode 100644 --- /dev/null +++ b/Util/BinaryExtras.hs @@ -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 + diff --git a/Util/BinaryInstances.hs b/Util/BinaryInstances.hs new file mode 100644 --- /dev/null +++ b/Util/BinaryInstances.hs @@ -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)) diff --git a/Util/BinaryUtils.hs b/Util/BinaryUtils.hs new file mode 100644 --- /dev/null +++ b/Util/BinaryUtils.hs @@ -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" diff --git a/Util/Broadcaster.hs b/Util/Broadcaster.hs new file mode 100644 --- /dev/null +++ b/Util/Broadcaster.hs @@ -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) diff --git a/Util/Bytes.hs b/Util/Bytes.hs new file mode 100644 --- /dev/null +++ b/Util/Bytes.hs @@ -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 diff --git a/Util/Cache.hs b/Util/Cache.hs new file mode 100644 --- /dev/null +++ b/Util/Cache.hs @@ -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 + + diff --git a/Util/ClockTimeToString.hs b/Util/ClockTimeToString.hs new file mode 100644 --- /dev/null +++ b/Util/ClockTimeToString.hs @@ -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 +-- \\+\ +-- 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" diff --git a/Util/CommandStringSub.hs b/Util/CommandStringSub.hs new file mode 100644 --- /dev/null +++ b/Util/CommandStringSub.hs @@ -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 diff --git a/Util/CompileFlags.hs b/Util/CompileFlags.hs new file mode 100644 --- /dev/null +++ b/Util/CompileFlags.hs @@ -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" diff --git a/Util/Computation.hs b/Util/Computation.hs new file mode 100644 --- /dev/null +++ b/Util/Computation.hs @@ -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 $. + diff --git a/Util/Debug.hs b/Util/Debug.hs new file mode 100644 --- /dev/null +++ b/Util/Debug.hs @@ -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)) + + diff --git a/Util/DeepSeq.hs b/Util/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/Util/DeepSeq.hs @@ -0,0 +1,67 @@ +-- | Module taken from Dean Harington's post to the Haskell mailing list +-- on Fri, 17 Aug 2001. +-- +-- URL is currently +-- +-- +-- 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 diff --git a/Util/Delayer.hs b/Util/Delayer.hs new file mode 100644 --- /dev/null +++ b/Util/Delayer.hs @@ -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 + ) diff --git a/Util/Dynamics.hs b/Util/Dynamics.hs new file mode 100644 --- /dev/null +++ b/Util/Dynamics.hs @@ -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" + diff --git a/Util/ExtendedPrelude.hs b/Util/ExtendedPrelude.hs new file mode 100644 --- /dev/null +++ b/Util/ExtendedPrelude.hs @@ -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) diff --git a/Util/FileNames.hs b/Util/FileNames.hs new file mode 100644 --- /dev/null +++ b/Util/FileNames.hs @@ -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 diff --git a/Util/HostName.hs b/Util/HostName.hs new file mode 100644 --- /dev/null +++ b/Util/HostName.hs @@ -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) diff --git a/Util/Huffman.hs b/Util/Huffman.hs new file mode 100644 --- /dev/null +++ b/Util/Huffman.hs @@ -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 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 + diff --git a/Util/IOExtras.hs b/Util/IOExtras.hs new file mode 100644 --- /dev/null +++ b/Util/IOExtras.hs @@ -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 + diff --git a/Util/IntPlus.hs b/Util/IntPlus.hs new file mode 100644 --- /dev/null +++ b/Util/IntPlus.hs @@ -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 + + + diff --git a/Util/KeyedChanges.hs b/Util/KeyedChanges.hs new file mode 100644 --- /dev/null +++ b/Util/KeyedChanges.hs @@ -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) diff --git a/Util/LineShow.hs b/Util/LineShow.hs new file mode 100644 --- /dev/null +++ b/Util/LineShow.hs @@ -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 + _ -> [] + diff --git a/Util/Maybes.hs b/Util/Maybes.hs new file mode 100644 --- /dev/null +++ b/Util/Maybes.hs @@ -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) diff --git a/Util/Messages.hs b/Util/Messages.hs new file mode 100644 --- /dev/null +++ b/Util/Messages.hs @@ -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 + diff --git a/Util/Myers.hs b/Util/Myers.hs new file mode 100644 --- /dev/null +++ b/Util/Myers.hs @@ -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 +-} diff --git a/Util/NameMangle.hs b/Util/NameMangle.hs new file mode 100644 --- /dev/null +++ b/Util/NameMangle.hs @@ -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 diff --git a/Util/Object.hs b/Util/Object.hs new file mode 100644 --- /dev/null +++ b/Util/Object.hs @@ -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" diff --git a/Util/Queue.hs b/Util/Queue.hs new file mode 100644 --- /dev/null +++ b/Util/Queue.hs @@ -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 diff --git a/Util/QuickReadShow.hs b/Util/QuickReadShow.hs new file mode 100644 --- /dev/null +++ b/Util/QuickReadShow.hs @@ -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 + -} diff --git a/Util/ReferenceCount.hs b/Util/ReferenceCount.hs new file mode 100644 --- /dev/null +++ b/Util/ReferenceCount.hs @@ -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) + ) diff --git a/Util/Registry.hs b/Util/Registry.hs new file mode 100644 --- /dev/null +++ b/Util/Registry.hs @@ -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 diff --git a/Util/Sink.hs b/Util/Sink.hs new file mode 100644 --- /dev/null +++ b/Util/Sink.hs @@ -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) + diff --git a/Util/Sources.hs b/Util/Sources.hs new file mode 100644 --- /dev/null +++ b/Util/Sources.hs @@ -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) + )) diff --git a/Util/Store.hs b/Util/Store.hs new file mode 100644 --- /dev/null +++ b/Util/Store.hs @@ -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) + ) diff --git a/Util/TSem.hs b/Util/TSem.hs new file mode 100644 --- /dev/null +++ b/Util/TSem.hs @@ -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" + ) diff --git a/Util/TempFile.hs b/Util/TempFile.hs new file mode 100644 --- /dev/null +++ b/Util/TempFile.hs @@ -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) diff --git a/Util/Thread.hs b/Util/Thread.hs new file mode 100644 --- /dev/null +++ b/Util/Thread.hs @@ -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 diff --git a/Util/ThreadDict.hs b/Util/ThreadDict.hs new file mode 100644 --- /dev/null +++ b/Util/ThreadDict.hs @@ -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 diff --git a/Util/UTF8.hs b/Util/UTF8.hs new file mode 100644 --- /dev/null +++ b/Util/UTF8.hs @@ -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 diff --git a/Util/UnionFind.hs b/Util/UnionFind.hs new file mode 100644 --- /dev/null +++ b/Util/UnionFind.hs @@ -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 + + + diff --git a/Util/UniqueFile.hs b/Util/UniqueFile.hs new file mode 100644 --- /dev/null +++ b/Util/UniqueFile.hs @@ -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 diff --git a/Util/UniqueString.hs b/Util/UniqueString.hs new file mode 100644 --- /dev/null +++ b/Util/UniqueString.hs @@ -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] diff --git a/Util/VSem.hs b/Util/VSem.hs new file mode 100644 --- /dev/null +++ b/Util/VSem.hs @@ -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},()) + ) + + diff --git a/Util/VariableList.hs b/Util/VariableList.hs new file mode 100644 --- /dev/null +++ b/Util/VariableList.hs @@ -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 diff --git a/Util/VariableMap.hs b/Util/VariableMap.hs new file mode 100644 --- /dev/null +++ b/Util/VariableMap.hs @@ -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 diff --git a/Util/VariableSet.hs b/Util/VariableSet.hs new file mode 100644 --- /dev/null +++ b/Util/VariableSet.hs @@ -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 + + + diff --git a/Util/VariableSetBlocker.hs b/Util/VariableSetBlocker.hs new file mode 100644 --- /dev/null +++ b/Util/VariableSetBlocker.hs @@ -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) diff --git a/Util/VisitedSet.hs b/Util/VisitedSet.hs new file mode 100644 --- /dev/null +++ b/Util/VisitedSet.hs @@ -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) + ) + ) diff --git a/Util/WBFiles.hs b/Util/WBFiles.hs new file mode 100644 --- /dev/null +++ b/Util/WBFiles.hs @@ -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-: +-- @ +-- or equivalently +-- @ +-- --uni-= +-- @ +-- +-- All options can also be overridden by environment variables. +-- The environment variable corresponding to has the +-- name @UNI@ +-- where @@ 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 diff --git a/default_options.c b/default_options.c new file mode 100644 --- /dev/null +++ b/default_options.c @@ -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"; diff --git a/include/default_options.h b/include/default_options.h new file mode 100644 --- /dev/null +++ b/include/default_options.h @@ -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 diff --git a/include/new_object.h b/include/new_object.h new file mode 100644 --- /dev/null +++ b/include/new_object.h @@ -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 diff --git a/new_object.c b/new_object.c new file mode 100644 --- /dev/null +++ b/new_object.c @@ -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++; + } diff --git a/uni-util.cabal b/uni-util.cabal new file mode 100644 --- /dev/null +++ b/uni-util.cabal @@ -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