diff --git a/c2hs/base/errors/Errors.hs b/c2hs/base/errors/Errors.hs --- a/c2hs/base/errors/Errors.hs +++ b/c2hs/base/errors/Errors.hs @@ -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 -- --- :: (column ) [] +-- :: (column ) [] -- >>> -- -- ... @@ -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:\ diff --git a/c2hs/base/general/Binary.hs b/c2hs/base/general/Binary.hs --- a/c2hs/base/general/Binary.hs +++ b/c2hs/base/general/Binary.hs @@ -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) -} diff --git a/c2hs/base/general/FNameOps.hs b/c2hs/base/general/FNameOps.hs --- a/c2hs/base/general/FNameOps.hs +++ b/c2hs/base/general/FNameOps.hs @@ -39,7 +39,7 @@ -- eg, ../lib/libc.so -> libc -- basename :: FilePath -> FilePath -basename = takeBaseName +basename = takeBaseName -- strip basename and suffix (EXPORTED) -- diff --git a/c2hs/base/general/FileOps.hs b/c2hs/base/general/FileOps.hs --- a/c2hs/base/general/FileOps.hs +++ b/c2hs/base/general/FileOps.hs @@ -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 -- diff --git a/c2hs/base/general/Position.hs b/c2hs/base/general/Position.hs --- a/c2hs/base/general/Position.hs +++ b/c2hs/base/general/Position.hs @@ -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 diff --git a/c2hs/base/general/UNames.hs b/c2hs/base/general/UNames.hs --- a/c2hs/base/general/UNames.hs +++ b/c2hs/base/general/UNames.hs @@ -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) diff --git a/c2hs/base/state/CIO.hs b/c2hs/base/state/CIO.hs --- a/c2hs/base/state/CIO.hs +++ b/c2hs/base/state/CIO.hs @@ -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' -- diff --git a/c2hs/base/state/State.hs b/c2hs/base/state/State.hs --- a/c2hs/base/state/State.hs +++ b/c2hs/base/state/State.hs @@ -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) ) diff --git a/c2hs/base/state/StateBase.hs b/c2hs/base/state/StateBase.hs --- a/c2hs/base/state/StateBase.hs +++ b/c2hs/base/state/StateBase.hs @@ -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 diff --git a/c2hs/base/state/StateTrans.hs b/c2hs/base/state/StateTrans.hs --- a/c2hs/base/state/StateTrans.hs +++ b/c2hs/base/state/StateTrans.hs @@ -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 diff --git a/c2hs/base/syms/Attributes.hs b/c2hs/base/syms/Attributes.hs --- a/c2hs/base/syms/Attributes.hs +++ b/c2hs/base/syms/Attributes.hs @@ -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 diff --git a/c2hs/base/syms/Idents.hs b/c2hs/base/syms/Idents.hs --- a/c2hs/base/syms/Idents.hs +++ b/c2hs/base/syms/Idents.hs @@ -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 !-} diff --git a/c2hs/base/syms/NameSpaces.hs b/c2hs/base/syms/NameSpaces.hs --- a/c2hs/base/syms/NameSpaces.hs +++ b/c2hs/base/syms/NameSpaces.hs @@ -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 diff --git a/c2hs/toplevel/Version.hs b/c2hs/toplevel/Version.hs --- a/c2hs/toplevel/Version.hs +++ b/c2hs/toplevel/Version.hs @@ -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 diff --git a/callbackGen/Signal.chs.template b/callbackGen/Signal.chs.template --- a/callbackGen/Signal.chs.template +++ b/callbackGen/Signal.chs.template @@ -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 diff --git a/gtk2hs-buildtools.cabal b/gtk2hs-buildtools.cabal --- a/gtk2hs-buildtools.cabal +++ b/gtk2hs-buildtools.cabal @@ -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 diff --git a/hierarchyGen/Hierarchy.chs.template b/hierarchyGen/Hierarchy.chs.template --- a/hierarchyGen/Hierarchy.chs.template +++ b/hierarchyGen/Hierarchy.chs.template @@ -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