gtk2hs-buildtools 0.13.0.2 → 0.13.0.3
raw patch · 17 files changed
+183/−181 lines, 17 files
Files
- c2hs/base/errors/Errors.hs +14/−14
- c2hs/base/general/Binary.hs +31/−31
- c2hs/base/general/FNameOps.hs +1/−1
- c2hs/base/general/FileOps.hs +3/−3
- c2hs/base/general/Position.hs +3/−3
- c2hs/base/general/UNames.hs +8/−8
- c2hs/base/state/CIO.hs +7/−7
- c2hs/base/state/State.hs +16/−16
- c2hs/base/state/StateBase.hs +8/−8
- c2hs/base/state/StateTrans.hs +26/−26
- c2hs/base/syms/Attributes.hs +28/−28
- c2hs/base/syms/Idents.hs +29/−29
- c2hs/base/syms/NameSpaces.hs +4/−4
- c2hs/toplevel/Version.hs +1/−1
- callbackGen/Signal.chs.template +1/−0
- gtk2hs-buildtools.cabal +2/−2
- hierarchyGen/Hierarchy.chs.template +1/−0
c2hs/base/errors/Errors.hs view
@@ -25,7 +25,7 @@ -- -- language: Haskell 98 ----- * the single lines of error messages shouldn't be to long as file name +-- * the single lines of error messages shouldn't be to long as file name -- and position are prepended at each line -- --- TODO ----------------------------------------------------------------------@@ -50,16 +50,16 @@ -- raise a fatal internal error; message may have multiple lines (EXPORTED) -- interr :: String -> a-interr msg = error ("INTERNAL COMPILER ERROR:\n" - ++ indentMultilineString 2 msg +interr msg = error ("INTERNAL COMPILER ERROR:\n"+ ++ indentMultilineString 2 msg ++ "\n") -- raise a error due to a implementation restriction; message may have multiple--- lines (EXPORTED) +-- lines (EXPORTED) -- todo :: String -> a todo msg = error ("Feature not yet implemented:\n"- ++ indentMultilineString 2 msg + ++ indentMultilineString 2 msg ++ "\n") @@ -83,13 +83,13 @@ -- instance Eq Error where (Error lvl1 pos1 _) == (Error lvl2 pos2 _) = lvl1 == lvl2 && pos1 == pos2- + instance Ord Error where (Error lvl1 pos1 _) < (Error lvl2 pos2 _) = pos1 < pos2 || (pos1 == pos2 && lvl1 < lvl2) e1 <= e2 = e1 < e2 || e1 == e2- + -- produce an `Error', given its level, position, and a list of lines of -- the error message that must not be empty (EXPORTED) --@@ -107,7 +107,7 @@ -- -- * the format is ----- <fname>:<row>: (column <col>) [<err lvl>] +-- <fname>:<row>: (column <col>) [<err lvl>] -- >>> <line_1> -- <line_2> -- ...@@ -123,22 +123,22 @@ -- showError :: Error -> String showError (Error _ pos (l:ls)) | isInternalPos pos =- "INTERNAL ERROR!\n" + "INTERNAL ERROR!\n" ++ " >>> " ++ l ++ "\n"- ++ (indentMultilineString 2 . unlines) ls + ++ (indentMultilineString 2 . unlines) ls showError (Error lvl (Position fname row col) (l:ls)) = let prefix = fname ++ ":" ++ show (row::Int) ++ ": "- ++ "(column " - ++ show (col::Int) - ++ ") [" + ++ "(column "+ ++ show (col::Int)+ ++ ") [" ++ showErrorLvl lvl ++ "] " showErrorLvl WarningErr = "WARNING" showErrorLvl ErrorErr = "ERROR" showErrorLvl FatalErr = "FATAL" in- prefix ++ "\n" + prefix ++ "\n" ++ " >>> " ++ l ++ "\n" ++ (indentMultilineString 2 . unlines) ls showError (Error _ _ [] ) = interr "Errors: showError:\
c2hs/base/general/Binary.hs view
@@ -135,7 +135,7 @@ -- Bin --------------------------------------------------------------- -newtype Bin a = BinPtr Int +newtype Bin a = BinPtr Int deriving (Eq, Ord, Show, Bounded) castBin :: Bin a -> Bin b@@ -163,7 +163,7 @@ getAt bh p = do seekBin bh p; get bh openBinIO_ :: IO.Handle -> IO BinHandle-openBinIO_ h = openBinIO h +openBinIO_ h = openBinIO h openBinIO :: IO.Handle -> IO BinHandle openBinIO h = do@@ -188,7 +188,7 @@ tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) seekBin :: BinHandle -> Bin a -> IO ()-seekBin (BinIO _ ix_r h) (BinPtr p) = do +seekBin (BinIO _ ix_r h) (BinPtr p) = do writeFastMutInt ix_r p hSeek h AbsoluteSeek (fromIntegral p) seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do@@ -259,7 +259,7 @@ ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r -- double the size of the array if it overflows- if (ix >= sz) + if (ix >= sz) then do expandBin h ix putWord8 h w else do arr <- readIORef arr_r@@ -322,9 +322,9 @@ w2 <- getWord8 h w3 <- getWord8 h w4 <- getWord8 h- return $! ((fromIntegral w1 `shiftL` 24) .|. - (fromIntegral w2 `shiftL` 16) .|. - (fromIntegral w3 `shiftL` 8) .|. + return $! ((fromIntegral w1 `shiftL` 24) .|.+ (fromIntegral w2 `shiftL` 16) .|.+ (fromIntegral w3 `shiftL` 8) .|. (fromIntegral w4)) @@ -347,13 +347,13 @@ w6 <- getWord8 h w7 <- getWord8 h w8 <- getWord8 h- return $! ((fromIntegral w1 `shiftL` 56) .|. - (fromIntegral w2 `shiftL` 48) .|. - (fromIntegral w3 `shiftL` 40) .|. - (fromIntegral w4 `shiftL` 32) .|. - (fromIntegral w5 `shiftL` 24) .|. - (fromIntegral w6 `shiftL` 16) .|. - (fromIntegral w7 `shiftL` 8) .|. + return $! ((fromIntegral w1 `shiftL` 56) .|.+ (fromIntegral w2 `shiftL` 48) .|.+ (fromIntegral w3 `shiftL` 40) .|.+ (fromIntegral w4 `shiftL` 32) .|.+ (fromIntegral w5 `shiftL` 24) .|.+ (fromIntegral w6 `shiftL` 16) .|.+ (fromIntegral w7 `shiftL` 8) .|. (fromIntegral w8)) -- -----------------------------------------------------------------------------@@ -495,8 +495,8 @@ let sz# = sizeofByteArray# a# -- in *bytes* put_ bh (I# sz#) -- in *bytes* putByteArray bh a# sz#- - get bh = do ++ get bh = do b <- getByte bh case b of 0 -> do (I# i#) <- get bh@@ -508,7 +508,7 @@ putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () putByteArray bh a s# = loop 0#- where loop n# + where loop n# | n# ==# s# = return () | otherwise = do putByte bh (indexByteArray a n#)@@ -516,11 +516,11 @@ getByteArray :: BinHandle -> Int -> IO ByteArray getByteArray bh (I# sz) = do- (MBA arr) <- newByteArray sz + (MBA arr) <- newByteArray sz let loop n | n ==# sz = return () | otherwise = do- w <- getByte bh + w <- getByte bh writeByteArray arr n w loop (n +# 1#) loop 0#@@ -544,7 +544,7 @@ #if __GLASGOW_HASKELL__ < 503 writeByteArray arr i w8 = IO $ \s ->- case word8ToWord w8 of { W# w# -> + case word8ToWord w8 of { W# w# -> case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> (# s , () #) }} #else@@ -623,7 +623,7 @@ -- -------------------------------------------------------------- -- Main wrappers: getBinFileWithDict, putBinFileWithDict ----- This layer is built on top of the stuff above, +-- This layer is built on top of the stuff above, -- and should not know anything about BinHandles -- -------------------------------------------------------------- @@ -635,7 +635,7 @@ bh <- Binary.readBinMem file_path -- Read the magic number to check that this really is a GHC .hi file- -- (This magic number does not change when we change + -- (This magic number does not change when we change -- GHC interface file format) magic <- get bh when (magic /= binaryInterfaceMagic) $@@ -653,7 +653,7 @@ -- Initialise the user-data field of bh let bh' = setUserData bh (initReadState dict) - -- At last, get the thing + -- At last, get the thing get bh' putBinFileWithDict :: Binary a => FilePath -> a -> IO ()@@ -670,7 +670,7 @@ -- Make some intial state usr_state <- newWriteState - -- Put the main thing, + -- Put the main thing, put_ (setUserData bh usr_state) the_thing -- Get the final-state@@ -692,12 +692,12 @@ -- And send the result to the file writeBinMem bh file_path -- hClose hnd- + -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- -data UserData = +data UserData = UserData { -- This field is used only when reading ud_dict :: Dictionary, @@ -741,7 +741,7 @@ undef s = error ("Binary.UserData: no " ++ s) ------------------------------------------------------------ The Dictionary +-- The Dictionary --------------------------------------------------------- type Dictionary = Array Int String -- The dictionary@@ -753,7 +753,7 @@ mapM_ (put_ bh) (elems dict) getDictionary :: BinHandle -> IO Dictionary-getDictionary bh = do +getDictionary bh = do sz <- get bh elems <- sequence (take sz (repeat (get bh))) return (listArray (0,sz-1) elems)@@ -804,7 +804,7 @@ -- Note: the length of the FastString is *not* the same as -- the size of the ByteArray: the latter is rounded up to a -- multiple of the word size.- + {- -- possible faster version, not quite there yet: getFS bh@BinMem{} = do (I# l) <- get bh@@ -819,7 +819,7 @@ instance Binary FastString where put_ bh f@(FastString id l ba) =- case getUserData bh of { + case getUserData bh of { UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f@@ -833,7 +833,7 @@ } put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) - get bh = do + get bh = do j <- get bh return $! (ud_dict (getUserData bh) ! j) -}
c2hs/base/general/FNameOps.hs view
@@ -39,7 +39,7 @@ -- eg, ../lib/libc.so -> libc -- basename :: FilePath -> FilePath-basename = takeBaseName +basename = takeBaseName -- strip basename and suffix (EXPORTED) --
c2hs/base/general/FileOps.hs view
@@ -56,7 +56,7 @@ "" `fileFindIn` paths = fail "Empty file name" file `fileFindIn` paths = do- let (paths', file') = if head file == '/' + let (paths', file') = if head file == '/' then (dirname file : paths, stripDirname file) else (paths, file) files = map (`addPath` file') paths'@@ -74,7 +74,7 @@ -- -- * Default permissions are used, which might not be optimal, but -- unfortunately the Haskell standard libs don't support proper permission--- management. +-- management. -- -- * We make 100 attempts on getting a unique filename before giving up. --@@ -97,7 +97,7 @@ handler attempts rs' _ = createLoop (attempts - 1) rs' sixChars :: [Int] -> ([Int], String)- sixChars is = + sixChars is = let (sixInts, is') = splitAt 6 is --
c2hs/base/general/Position.hs view
@@ -20,7 +20,7 @@ --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides some definitions used throughout all modules of a--- compiler. +-- compiler. -- --- DOCU ---------------------------------------------------------------------- --@@ -30,7 +30,7 @@ -- --- TODO ---------------------------------------------------------------------- --- + module Position ( -- -- source text positions@@ -47,7 +47,7 @@ -- uniform representation of source file positions; the order of the arguments -- is important as it leads to the desired ordering of source positions--- (EXPORTED) +-- (EXPORTED) -- data Position = Position String -- file name {-# UNPACK #-} !Int -- row
c2hs/base/general/UNames.hs view
@@ -23,7 +23,7 @@ -- & D. Synek ``Functional pearl: On generating unique names'', Journal of -- Functional Programming 4(1), pp 117-123, 1994. ----- WARNING: DON'T tinker with the implementation! It uses UNSAFE low-level +-- WARNING: DON'T tinker with the implementation! It uses UNSAFE low-level -- operations! -- --- DOCU ----------------------------------------------------------------------@@ -35,10 +35,10 @@ -- are generated from the name space. Furthermore, names are instances of -- `Ix' to allow to use them as indicies. ----- * A supply should be used *at most* once to *either* split it or extract a +-- * A supply should be used *at most* once to *either* split it or extract a -- stream of names. A supply used repeatedly will always generate the same -- set of names (otherwise, the whole thing wouldn't be referential--- transparent). +-- transparent). -- -- * If you ignored the warning below, looked at the implementation, and lost -- faith, consider that laziness means call-by-need *and* sharing, and that@@ -84,7 +84,7 @@ show (Name i) = show i --- *** DON'T TOUCH THE FOLLOWING *** +-- *** DON'T TOUCH THE FOLLOWING *** -- and if you believe in the lambda calculus better also don't look at it -- ! here lives the daemon of unordered destructive updates ! @@ -103,14 +103,14 @@ -- names :: NameSupply -> [Name] ----- The recursion of `theNames' where `s' is passed as an argument is crucial, +-- The recursion of `theNames' where `s' is passed as an argument is crucial, -- as it forces the creation of a new closure for `unsafeReadAndIncIntRef s' -- in each recursion step. Sharing a single closure or building a cyclic -- graph for a nullary `theNames' would always result in the same name! If -- the compiler ever gets clever enough to optimize this, we have to prevent -- it from doing so. ---names (NameSupply s) = +names (NameSupply s) = theNames s where theNames s = Name (unsafeReadAndIncIntRef s) : theNames s@@ -129,7 +129,7 @@ return (Name val) restoreRootNameSupply :: Name -> IO ()-restoreRootNameSupply (Name val) = +restoreRootNameSupply (Name val) = case rootSupply of NameSupply ref -> do prev <- readIORef ref@@ -153,7 +153,7 @@ -- world. And if you believe into the lambda calculus, you don't -- want to know about this other world. ----- *** DON'T TOUCH NOR USE THIS STUFF *** +-- *** DON'T TOUCH NOR USE THIS STUFF *** -- (unless you really know what you are doing!) -- UNSAFELY create a mutable integer (EXPORTED)
c2hs/base/state/CIO.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -cpp #-}--- Compiler Toolkit: Compiler I/O +-- Compiler Toolkit: Compiler I/O -- -- Author : Manuel M T Chakravarty -- Created: 2 November 95@@ -28,7 +28,7 @@ -- -- language: Haskell 98 ----- * the usage of the `...CIO' functions is exactly as that of the +-- * the usage of the `...CIO' functions is exactly as that of the -- corresponding `...' functions from the Haskell 98 prelude and library -- -- * error handling can be found in the module `StateTrans' and `State'@@ -42,10 +42,10 @@ module CIO (-- (verbatim) re-exports -- Handle, HandlePosn, IOMode(..), BufferMode(..), SeekMode(..),- stdin, stdout, stderr, + stdin, stdout, stderr, isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, isFullError, isEOFError, isIllegalOperation, isPermissionError,- isUserError, + isUserError, ioeGetErrorString, ioeGetHandle, ioeGetFileName, -- -- file handling@@ -56,12 +56,12 @@ -- putCharCIO, putStrCIO, hPutStrCIO, hPutStrLnCIO, writeFileCIO, readFileCIO, printCIO, getCharCIO, hFlushCIO, hPutCharCIO,- hGetContentsCIO, hSetBufferingCIO, hGetBufferingCIO, - newlineCIO, + hGetContentsCIO, hSetBufferingCIO, hGetBufferingCIO,+ newlineCIO, -- -- `Directory' --- doesFileExistCIO, removeFileCIO, + doesFileExistCIO, removeFileCIO, -- -- `System' --
c2hs/base/state/State.hs view
@@ -23,7 +23,7 @@ -- used by all modules that are not directly involved in implementing the -- state base. It provides a state transformer that is capable of doing I/O -- and provides facilities such as error handling and compiler switch--- management. +-- management. -- --- DOCU ---------------------------------------------------------------------- --@@ -42,7 +42,7 @@ PreCST, -- reexport ABSTRACT nop, yield, (+>=), (+>), fixCST, -- reexport throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted- readCST, writeCST, transCST, run, runCST, + readCST, writeCST, transCST, run, runCST, StateTrans.MVar, -- reexport newMV, readMV, assignMV, -- reexport lifted --@@ -81,7 +81,7 @@ import StateTrans (STB, readBase, transBase, runSTB) import qualified- StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy, + StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy, MVar, newMV, readMV, assignMV) import StateBase (PreCST(..), ErrorState(..), BaseState(..), nop, yield, (+>=), (+>), fixCST,@@ -94,7 +94,7 @@ -- state used in the whole compiler -- -------------------------------- --- initialization +-- initialization -- -- * it gets the version information and the initial extra state as arguments --@@ -102,7 +102,7 @@ initialBaseState vcd es = BaseState { idTKBS = (version, copyright, disclaimer), idBS = vcd,- errorsBS = initialErrorState, + errorsBS = initialErrorState, suppliesBS = splitSupply rootSupply, extraBS = es }@@ -131,7 +131,7 @@ -- -- the generic state of the enclosing PreCST is preserved while the -- computation of the PreCST passed as an argument is interleaved in the--- execution of the enclosing one +-- execution of the enclosing one -- runCST :: PreCST e s a -> s -> PreCST e s' a runCST m s = CST $ StateTrans.interleave (unpackCST m) s@@ -161,8 +161,8 @@ -- semantics is the only reasonable when it should be possible to use -- updating for maintaining the state) ---catchExc :: PreCST e s a - -> (String, String -> PreCST e s a) +catchExc :: PreCST e s a+ -> (String, String -> PreCST e s a) -> PreCST e s a catchExc m (s, h) = CST $ StateTrans.catchExc (unpackCST m) (s, unpackCST . h) @@ -203,7 +203,7 @@ -- read identification information (EXPORT) -- getId :: PreCST e s (String, String, String)-getId = CST $ +getId = CST $ readBase (idBS) @@ -268,7 +268,7 @@ noOfErrs <- CST $ transBase doRaise when (noOfErrs >= errorLimit) $ do errmsgs <- showErrors- fatal ("Error limit of " ++ show errorLimit + fatal ("Error limit of " ++ show errorLimit ++ " errors has been reached.\n" ++ errmsgs) where doRaise :: BaseState e -> (BaseState e, Int)@@ -284,7 +284,7 @@ -- yield a string containing the collected error messages (EXPORTED) ----- * the error state is reset in this process +-- * the error state is reset in this process -- showErrors :: PreCST e s String showErrors = CST $ do@@ -292,7 +292,7 @@ return $ foldr (.) id (map showString (errsToStrs errs)) "" where extractErrs :: BaseState e -> (BaseState e, ErrorState)- extractErrs bs = (bs {errorsBS = initialErrorState}, + extractErrs bs = (bs {errorsBS = initialErrorState}, errorsBS bs) errsToStrs :: [Error] -> [String]@@ -302,7 +302,7 @@ -- (EXPORTED) -- errorsPresent :: PreCST e s Bool-errorsPresent = CST $ do +errorsPresent = CST $ do ErrorState wlvl no _ <- readBase errorsBS return $ wlvl >= ErrorErr @@ -311,7 +311,7 @@ -- ---------------------------- -- apply a reader function to the extra state and yield the reader's result--- (EXPORTED) +-- (EXPORTED) -- readExtra :: (e -> a) -> PreCST e s a readExtra rf = CST $ readBase (\bs ->@@ -324,7 +324,7 @@ updExtra uf = CST $ transBase (\bs -> let es = extraBS bs- in + in (bs {extraBS = uf es}, ()) ) @@ -338,6 +338,6 @@ getNameSupply = CST $ transBase (\bs -> let supply : supplies = suppliesBS bs- in + in (bs {suppliesBS = supplies}, supply) )
c2hs/base/state/StateBase.hs view
@@ -42,11 +42,11 @@ -- * The following state components are maintained: -- -- + idBS (triple of strings) -- version, copyright, and disclaimer--- + errorsBS (type `ErrorState') -- keeps track of raised errors +-- + errorsBS (type `ErrorState') -- keeps track of raised errors -- + namesBS (type `NameSupply') -- provides unique names--- + extraBS (generic type) -- extra compiler-dependent state +-- + extraBS (generic type) -- extra compiler-dependent state -- information, e.g., for compiler--- switches +-- switches -- --- TODO ---------------------------------------------------------------------- --@@ -61,10 +61,10 @@ import Position (Position) import UNames (NameSupply)-import StateTrans (STB, +import StateTrans (STB, fixSTB, readGeneric, writeGeneric, transGeneric, readBase, transBase)-import qualified +import qualified StateTrans (liftIO) import Errors (ErrorLvl(..), Error) @@ -88,13 +88,13 @@ data BaseState e = BaseState { idTKBS :: (String, String, String), -- toolkit id idBS :: (String, String, String), -- compiler id- errorsBS :: ErrorState, + errorsBS :: ErrorState, suppliesBS :: [NameSupply], extraBS :: e -- extra state } -- the compiler state transformer (EXPORTED)--- +-- newtype PreCST e s a = CST (STB (BaseState e) s a) @@ -160,7 +160,7 @@ writeCST s' = CST $ writeGeneric s' -- given a transformer function for the state, wrap it into an CST monad--- (EXPORTED) +-- (EXPORTED) -- transCST :: (s -> (s, a)) -> PreCST e s a transCST f = CST $ transGeneric f
c2hs/base/state/StateTrans.hs view
@@ -25,7 +25,7 @@ -- the intention to use the first one for the omnipresent compiler state -- consisting of the accumulated error messages etc. and to use the second as -- a generic component that can be used in different ways by the different--- phases of the compiler. +-- phases of the compiler. -- -- The module also supports the use of exceptions and fatal errors. --@@ -68,11 +68,11 @@ -- monad specific operations -- readBase, writeBase, transBase, readGeneric, writeGeneric,- transGeneric, liftIO, runSTB, interleave, + transGeneric, liftIO, runSTB, interleave, -- -- exception handling and fatal errors --- throwExc, fatal, catchExc, fatalsHandledBy, + throwExc, fatal, catchExc, fatalsHandledBy, -- -- mutable variables and arrays --@@ -92,7 +92,7 @@ infixr 1 +>=, +> --- BEWARE! You enter monad country. Read any of Wadler's or +-- BEWARE! You enter monad country. Read any of Wadler's or -- Launchbury/Peyton-Jones' texts before entering. Otherwise, -- your mental health my be in danger. You have been warned! @@ -162,10 +162,10 @@ -- future overall result wrapped into a closure with the function extracting -- the user-level result component is used to build the cycle ---fixSTB m = STB $ \bs gs - -> fixIO (\future -> let - STB m' = m (extractResult future) - in +fixSTB m = STB $ \bs gs+ -> fixIO (\future -> let+ STB m' = m (extractResult future)+ in m' bs gs) where extractResult (_, _, Right r) = r@@ -213,7 +213,7 @@ writeGeneric gs' = STB $ \bs _ -> return (bs, gs', Right ()) -- given a transformer function for the generic state, wrap it into an STB--- monad +-- monad -- transGeneric :: (gs -> (gs, a)) -> STB bs gs a transGeneric f = STB $ \bs gs -> let@@ -239,15 +239,15 @@ runSTB :: STB bs gs a -> bs -> gs -> IO a runSTB m bs gs = let STB m' = m- in - m' bs gs >>= \(_, _, res) -> + in+ m' bs gs >>= \(_, _, res) -> case res of Left (tag, msg) -> let- err = userError ("Exception `" + err = userError ("Exception `" ++ tag ++ "': " ++ msg) in- ioError err + ioError err Right a -> return a -- interleave the (complete) execution of an `STB' with another generic state@@ -256,8 +256,8 @@ interleave :: STB bs gs' a -> gs' -> STB bs gs a interleave m gs' = STB $ let STB m' = m- in - \bs gs + in+ \bs gs -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a)) @@ -266,7 +266,7 @@ -- * we exploit the `UserError' component of `IOError' for fatal errors ----- * we distinguish exceptions and user-defined fatal errors +-- * we distinguish exceptions and user-defined fatal errors -- -- - exceptions are meant to be caught in order to recover the currently -- executed operation; they turn into fatal errors if they are not caught;@@ -303,20 +303,20 @@ -- thrown (this semantics is the only reasonable when it should be possible -- to use updating for maintaining the state) ---catchExc :: STB bs gs a - -> (String, String -> STB bs gs a) +catchExc :: STB bs gs a+ -> (String, String -> STB bs gs a) -> STB bs gs a-catchExc m (tag, handler) = - STB $ \bs gs - -> let +catchExc m (tag, handler) =+ STB $ \bs gs+ -> let STB m' = m- in + in m' bs gs >>= \state@(bs', gs', res) -> case res of Left (tag', msg) -> if (tag == tag') -- exception with... then let- STB handler' = handler msg + STB handler' = handler msg in handler' bs' gs' -- correct tag, catch else@@ -334,15 +334,15 @@ -- to `catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a-fatalsHandledBy m handler = - STB $ \bs gs +fatalsHandledBy m handler =+ STB $ \bs gs -> (let STB m' = m in m' bs gs >>= \state@(gs', bs', res) -> case res of Left (tag, msg) -> let- err = userError ("Exception `" ++ tag + err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err
c2hs/base/syms/Attributes.hs view
@@ -24,7 +24,7 @@ -- single node of the structure tree is referenced via an attributes -- identifier. This is basically a reference into so-called attribute tables, -- which manage attributes of one type and may use different representations.--- There is also a position attribute managed via the attribute identifier +-- There is also a position attribute managed via the attribute identifier -- without needing a further table (it is already fixed on construction of -- the structure tree). --@@ -62,7 +62,7 @@ -- realized via hash table---depending on the type of attribute table, we -- may even allow them to be soft. ----- NOTE: Currently, if assertions are switched on, on freezing a table, its +-- NOTE: Currently, if assertions are switched on, on freezing a table, its -- density is calculate and, if it is below 33%, an internal error is -- raised (only if there are more than 1000 entries in the table). --@@ -85,12 +85,12 @@ copyAttr, freezeAttrTable, softenAttrTable, StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr, isUndefStdAttr, setStdAttr, updStdAttr,- getGenAttr, setGenAttr, updGenAttr) + getGenAttr, setGenAttr, updGenAttr) where import Data.Array import Control.Exception (assert)-import Position (Position, Pos(posOf), nopos, isNopos, dontCarePos, +import Position (Position, Pos(posOf), nopos, isNopos, dontCarePos, isDontCarePos) import Errors (interr) import UNames (NameSupply, Name,@@ -120,14 +120,14 @@ -- instance Eq Attrs where (Attrs _ id1) == (Attrs _ id2) = id1 == id2- _ == _ = + _ == _ = interr "Attributes: Attempt to compare `OnlyPos' attributes!" -- attribute ordering is also lifted to objects (EXPORTED) -- instance Ord Attrs where (Attrs _ id1) <= (Attrs _ id2) = id1 <= id2- _ <= _ = + _ <= _ = interr "Attributes: Attempt to compare `OnlyPos' attributes!" -- a class for convenient access to the attributes of an attributed object@@ -167,8 +167,8 @@ -- the type class `Attr' determines which types may be used as attributes -- (EXPORTED)--- --- * such types have to provide values representing an undefined and a don't +--+-- * such types have to provide values representing an undefined and a don't -- care state, together with two functions to test for these values -- -- * an attribute in an attribute table is initially set to `undef' (before@@ -203,8 +203,8 @@ -- * the table description string is used to emit better error messages (for -- internal errors) ---data Attr a => - AttrTable a = -- for all attribute identifiers not contained in the +data Attr a =>+ AttrTable a = -- for all attribute identifiers not contained in the -- finite map the value is `undef' -- SoftTable (Map Name a) -- updated attr.s@@ -212,14 +212,14 @@ -- the array contains `undef' attributes for the undefined -- attributes; for all attribute identifiers outside the- -- bounds, the value is also `undef'; + -- bounds, the value is also `undef'; -- | FrozenTable (Array Name a) -- attribute values String -- desc of the table - + --- create an attribute table, where all attributes are `undef' (EXPORTED) +-- create an attribute table, where all attributes are `undef' (EXPORTED) -- -- the description string is used to identify the table in error messages -- (internal errors); a table is initially soft@@ -231,7 +231,7 @@ -- getAttr :: Attr a => AttrTable a -> Attrs -> a getAttr at (OnlyPos pos ) = onlyPosErr "getAttr" at pos-getAttr at (Attrs _ aid) = +getAttr at (Attrs _ aid) = case at of (SoftTable fm _) -> Map.findWithDefault undef aid fm (FrozenTable arr _) -> let (lbd, ubd) = bounds arr@@ -243,11 +243,11 @@ -- setAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a setAttr at (OnlyPos pos ) av = onlyPosErr "setAttr" at pos-setAttr at (Attrs pos aid) av = +setAttr at (Attrs pos aid) av = case at of (SoftTable fm desc) -> assert (isUndef (Map.findWithDefault undef aid fm)) $ SoftTable (Map.insert aid av fm) desc- (FrozenTable arr _) -> interr frozenErr + (FrozenTable arr _) -> interr frozenErr where frozenErr = "Attributes.setAttr: Tried to write frozen attribute in\n" ++ errLoc at pos@@ -256,7 +256,7 @@ -- updAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a updAttr at (OnlyPos pos ) av = onlyPosErr "updAttr" at pos-updAttr at (Attrs pos aid) av = +updAttr at (Attrs pos aid) av = case at of (SoftTable fm desc) -> SoftTable (Map.insert aid av fm) desc (FrozenTable arr _) -> interr $ "Attributes.updAttr: Tried to\@@ -268,7 +268,7 @@ -- * undefined attributes are not copied, to avoid filling the table -- copyAttr :: Attr a => AttrTable a -> Attrs -> Attrs -> AttrTable a-copyAttr at ats ats' +copyAttr at ats ats' | isUndef av = assert (isUndef (getAttr at ats')) at | otherwise = updAttr at ats' av@@ -278,7 +278,7 @@ -- auxiliary functions for error messages -- onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b-onlyPosErr fctName at pos = +onlyPosErr fctName at pos = interr $ "Attributes." ++ fctName ++ ": No attribute identifier in\n" ++ errLoc at pos --@@ -293,7 +293,7 @@ -- table is softened again (EXPORTED) -- freezeAttrTable :: Attr a => AttrTable a -> AttrTable a-freezeAttrTable (SoftTable fm desc) = +freezeAttrTable (SoftTable fm desc) = let contents = Map.toList fm keys = map fst contents lbd = minimum keys@@ -301,7 +301,7 @@ in assert (length keys < 1000 || (length . range) (lbd, ubd) > 3 * length keys) (FrozenTable (array (lbd, ubd) contents) desc)-freezeAttrTable (FrozenTable arr desc) = +freezeAttrTable (FrozenTable arr desc) = interr ("Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\ \ table `" ++ desc ++ "'!") @@ -309,10 +309,10 @@ -- table is frozen again (EXPORTED) -- softenAttrTable :: Attr a => AttrTable a -> AttrTable a-softenAttrTable (SoftTable fm desc) = +softenAttrTable (SoftTable fm desc) = interr ("Attributes.softenAttrTable: Attempt to soften the already \ \softened\n table `" ++ desc ++ "'!")-softenAttrTable (FrozenTable arr desc) = +softenAttrTable (FrozenTable arr desc) = SoftTable (Map.fromList . assocs $ arr) desc @@ -344,18 +344,18 @@ getStdAttr :: AttrTable (StdAttr a) -> Attrs -> a getStdAttr atab at = getStdAttrDft atab at err where- err = interr $ "Attributes.getStdAttr: Don't care in\n" + err = interr $ "Attributes.getStdAttr: Don't care in\n" ++ errLoc atab (posOf at) -- get an attribute value from a standard attribute table, where a default is -- substituted if the table is don't care (EXPORTED) -- getStdAttrDft :: AttrTable (StdAttr a) -> Attrs -> a -> a-getStdAttrDft atab at dft = +getStdAttrDft atab at dft = case getAttr atab at of DontCareStdAttr -> dft JustStdAttr av -> av- UndefStdAttr -> interr $ "Attributes.getStdAttrDft: Undefined in\n" + UndefStdAttr -> interr $ "Attributes.getStdAttrDft: Undefined in\n" ++ errLoc atab (posOf at) -- check if the attribue value is marked as "don't care" (EXPORTED)@@ -387,11 +387,11 @@ getGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a getGenAttr atab at = getAttr atab (attrsOf at) -setGenAttr :: (Attr a, Attributed obj) +setGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a setGenAttr atab at av = setAttr atab (attrsOf at) av -updGenAttr :: (Attr a, Attributed obj) +updGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a -> AttrTable a updGenAttr atab at av = updAttr atab (attrsOf at) av
c2hs/base/syms/Idents.hs view
@@ -46,7 +46,7 @@ -- * Attributes may be associated to identifiers, except with `OnlyPos' -- identifiers, which have a position as their only attribute (they do not -- carry an attribute identifier, which can be used to index attribute--- tables). +-- tables). -- -- * Internal identifiers that are forming a completely unique name space are -- supported. But note, they do not have a proper lexeme, i.e., they are not@@ -60,7 +60,7 @@ module Idents (Ident, noARNum, isLegalIdent, lexemeToIdent, internalIdent, onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple, isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum,- getIdentAttrs, dumpIdent) + getIdentAttrs, dumpIdent) where import Data.Char@@ -74,7 +74,7 @@ -- simple identifier representation (EXPORTED) ----- identifiers without an ambiguousness resolving number get `noARNum' as +-- identifiers without an ambiguousness resolving number get `noARNum' as -- number -- data Ident = Ident String -- lexeme@@ -87,14 +87,14 @@ -- equality test, by comparing the lexemes only if the two numbers are equal -- instance Eq Ident where- (Ident s k id _) == (Ident s' k' id' _) = (k == k') - && (id == id') + (Ident s k id _) == (Ident s' k' id' _) = (k == k')+ && (id == id') && (s == s') -- this does *not* follow the alphanumerical ordering of the lexemes -- instance Ord Ident where- (Ident s k id _) < (Ident s' k' id' _) = (k < k') + (Ident s k id _) < (Ident s' k' id' _) = (k < k') || ((k == k') && (id < id')) || ((k == k') && (id == id') && (s < s'))@@ -119,15 +119,15 @@ -- identifiers lexeme and store it in the identifiers representation -- hash function from the dragon book pp437; assumes 7 bit characters and needs--- the (nearly) full range of values guaranteed for `Int' by the Haskell --- language definition; can handle 8 bit characters provided we have 29 bit +-- the (nearly) full range of values guaranteed for `Int' by the Haskell+-- language definition; can handle 8 bit characters provided we have 29 bit -- for the `Int's without sign -- quad :: String -> Int quad (c1:c2:c3:c4:s) = ((ord c4 * bits21- + ord c3 * bits14 + + ord c3 * bits14 + ord c2 * bits7- + ord c1) + + ord c1) `mod` bits28) + (quad s `mod` bits28) quad (c1:c2:c3:[] ) = ord c3 * bits14 + ord c2 * bits7 + ord c1@@ -140,7 +140,7 @@ bits21 = 2^21 bits28 = 2^28 --- used as a substitute for the ambiguousness resolving number if it is not +-- used as a substitute for the ambiguousness resolving number if it is not -- present (EXPORTED) -- noARNum :: Int@@ -160,7 +160,7 @@ -- isLegalIdent :: String -> Bool isLegalIdent [] = False-isLegalIdent (c:cs) = if c == '`' then isQualIdent cs +isLegalIdent (c:cs) = if c == '`' then isQualIdent cs else (isAlpha c || c == '_') && isIdent (c:cs) where isIdent = checkTail . (dropWhile isAlphaNumOrUS)@@ -176,9 +176,9 @@ isNum c = c `elem` ['0'..'9'] isQualIdent cs = let- cs' = skip cs - in - (not . null) cs' + cs' = skip cs+ in+ (not . null) cs' && (checkTail . tail) cs' skip [] = []@@ -197,7 +197,7 @@ -- * only minimal error checking, e.g., the characters of the identifier are -- not checked for being alphanumerical only; the correct lexis of the -- identifier should be ensured by the caller, e.g., the scanner or--- `isLegalIdent' +-- `isLegalIdent' -- -- * for reasons of simplicity the complete lexeme is hashed (with `quad') --@@ -223,15 +223,15 @@ -- Extract the name and ambiguousness resolving number from a lexeme. -- parseIdent :: Position -> String -> (String, Int)-parseIdent pos l - = if (null l) - then +parseIdent pos l+ = if (null l)+ then interr $ "Idents: lexemeToIdent: Empty lexeme! " ++ show pos- else - if (head l == '\'') + else+ if (head l == '\'') then parseQuoted (tail l)- else + else parseNorm l where -- parse lexeme without quotes@@ -292,7 +292,7 @@ in (chr (100*d1 + 10*d2 + d3) :cs', k)- parseSpecial (c:cs) + parseSpecial (c:cs) | c == '\\' = ('\\':cs', k) | c == '\"' = ('\"':cs', k) | c == '\'' = ('\'':cs', k)@@ -307,7 +307,7 @@ -- attributes (EXPORTED) -- cloneIdent :: Ident -> Name -> Ident-cloneIdent (Ident s k idnum at) name = +cloneIdent (Ident s k idnum at) name = Ident s k idnum (newAttrs (posOf at) name) -- given an abstract identifier, yield its lexeme (EXPORTED)@@ -315,8 +315,8 @@ identToLexeme :: Ident -> String identToLexeme (Ident s k _ _) = s ++ suffix where- suffix = if (k == noARNum) - then "" + suffix = if (k == noARNum)+ then "" else if (k == primARNum) then "##" else if (k == internARNum)@@ -339,7 +339,7 @@ -- NOTE: The new identifier will not be equal (==) to the old one! -- stripIdentARNum :: Ident -> Ident-stripIdentARNum (Ident s k id at) +stripIdentARNum (Ident s k id at) | k == primARNum || k == internARNum = interr "Idents: stripIdentARNum: \ \Not allowed!" | otherwise = Ident s noARNum id at@@ -357,7 +357,7 @@ -- NOTE: The new identifier will not be equal (==) to the old one! -- newIdentARNum :: Ident -> Int -> Ident-newIdentARNum (Ident s k id at) k' +newIdentARNum (Ident s k id at) k' | k' < 0 = interr "Idents: newIdentARNum: \ \Negative number!" | k == primARNum || k == internARNum = interr "Idents: newIdentARNum: \@@ -373,7 +373,7 @@ -- (EXPORTED) -- dumpIdent :: Ident -> String-dumpIdent ide = identToLexeme ide ++ " at " ++ show (posOf ide) +dumpIdent ide = identToLexeme ide ++ " at " ++ show (posOf ide) {-! for Ident derive : GhcBinary !-}
c2hs/base/syms/NameSpaces.hs view
@@ -76,7 +76,7 @@ -- add global definition (EXPORTED) ----- * returns the modfied name space +-- * returns the modfied name space -- -- * if the identfier is already declared, the resulting name space contains -- the new binding and the second component of the result contains the@@ -84,7 +84,7 @@ -- name space anymore) -- defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a)-defGlobal (NameSpace gs lss) id def = (NameSpace (Map.insert id def gs) lss, +defGlobal (NameSpace gs lss) id def = (NameSpace (Map.insert id def gs) lss, Map.lookup id gs) -- add new range (EXPORTED)@@ -101,7 +101,7 @@ -- add local definition (EXPORTED) ----- * returns the modfied name space +-- * returns the modfied name space -- -- * if there is no local range, the definition is entered globally --@@ -112,7 +112,7 @@ -- defLocal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defLocal ns@(NameSpace gs [] ) id def = defGlobal ns id def-defLocal (NameSpace gs (ls:lss)) id def = +defLocal (NameSpace gs (ls:lss)) id def = (NameSpace gs (((id, def):ls):lss), lookup ls) where
c2hs/toplevel/Version.hs view
@@ -6,7 +6,7 @@ -- idstr = "$Id: Version.hs,v 1.1 2012/05/27 16:49:07 dmwit Exp $" name = "C->Haskell Compiler"-versnum = "0.13.11 (gtk2hs branch)"+versnum = "0.13.12 (gtk2hs branch)" versnick = "\"Bin IO\"" date = "27 May 2012" version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date
callbackGen/Signal.chs.template view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- -*-haskell-*- -- -------------------- automatically generated file - do not edit ------------ -- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell
gtk2hs-buildtools.cabal view
@@ -1,5 +1,5 @@ Name: gtk2hs-buildtools-Version: 0.13.0.2+Version: 0.13.0.3 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team@@ -55,7 +55,7 @@ build-depends: base >= 4 && < 5, process, directory, array, containers, pretty, filepath, random- build-tools: alex, happy+ build-tools: alex >= 3.0.1, happy >= 1.18.9 other-modules: BaseVersion Config Errors
hierarchyGen/Hierarchy.chs.template view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- -*-haskell-*- -- -------------------- automatically generated file - do not edit ---------- -- Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell