gtk2hs-buildtools 0.13.0.4 → 0.13.0.5
raw patch · 39 files changed
+4485/−4488 lines, 39 filesdep ~base
Dependency ranges changed: base
Files
- COPYING +15/−18
- c2hs/base/admin/BaseVersion.hs +4/−4
- c2hs/base/admin/Config.hs +6/−6
- c2hs/base/errors/Errors.hs +19/−19
- c2hs/base/general/Binary.hs +148/−148
- c2hs/base/general/FastMutInt.hs +2/−2
- c2hs/base/general/FileOps.hs +19/−19
- c2hs/base/general/Position.hs +5/−5
- c2hs/base/general/UNames.hs +12/−12
- c2hs/base/state/CIO.hs +32/−32
- c2hs/base/state/State.hs +93/−93
- c2hs/base/state/StateBase.hs +15/−15
- c2hs/base/state/StateTrans.hs +86/−86
- c2hs/base/syms/Attributes.hs +59/−59
- c2hs/base/syms/Idents.hs +132/−132
- c2hs/base/syms/NameSpaces.hs +17/−17
- c2hs/base/syntax/Lexers.hs +1/−1
- c2hs/c/C.hs +83/−83
- c2hs/c/CAST.hs +232/−232
- c2hs/c/CAttrs.hs +79/−79
- c2hs/c/CLexer.x +1/−1
- c2hs/c/CNames.hs +42/−42
- c2hs/c/CParserMonad.hs +11/−11
- c2hs/c/CTokens.hs +126/−126
- c2hs/c/CTrav.hs +130/−130
- c2hs/chs/CHS.hs +322/−322
- c2hs/chs/CHSLexer.hs +217/−217
- c2hs/gen/CInfo.hs +23/−23
- c2hs/gen/GBMonad.hs +109/−109
- c2hs/gen/GenBind.hs +1972/−1972
- c2hs/gen/GenHeader.hs +67/−67
- c2hs/state/C2HSState.hs +15/−15
- c2hs/state/Switches.hs +38/−38
- c2hs/toplevel/C2HSConfig.hs +1/−1
- c2hs/toplevel/Main.hs +148/−148
- c2hs/toplevel/Version.hs +4/−4
- callbackGen/HookGenerator.hs +135/−135
- gtk2hs-buildtools.cabal +1/−1
- hierarchyGen/TypeGen.hs +64/−64
COPYING view
@@ -1,15 +1,13 @@-This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or+This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your option) any later version. -- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 - Copyright (C) 1989, 1991 Free Software Foundation, Inc.- 675 Mass Ave, Cambridge, MA 02139, USA+ Copyright (C) 1989, 1991 Free Software Foundation, Inc., <http://fsf.org/>+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @@ -22,7 +20,7 @@ General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by-the GNU Library General Public License instead.) You can apply it to+the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not@@ -286,7 +284,7 @@ END OF TERMS AND CONDITIONS - Appendix: How to Apply These Terms to Your New Programs+ How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it@@ -297,8 +295,8 @@ convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. - <one line to give the program's name and a brief idea of what it does.>- Copyright (C) 19yy <name of author>+ {description}+ Copyright (C) {year} {fullname} This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by@@ -310,16 +308,16 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.+ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: - Gnomovision version 69, Copyright (C) 19yy name of author+ Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details.@@ -336,12 +334,11 @@ Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. - <signature of Ty Coon>, 1 April 1989+ {signature of Ty Coon}, 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the-library. If this is what you want to do, use the GNU Library General+library. If this is what you want to do, use the GNU Lesser General Public License instead of this License.-
c2hs/base/admin/BaseVersion.hs view
@@ -7,10 +7,10 @@ idstr = "$Id: BaseVersion.hs,v 1.1.1.1 2004/11/13 16:42:44 duncan_coutts Exp $" name = "Compiler Toolkit" versnum = "0.26.0"-date = "19 Oct 2003"+date = "19 Oct 2003" version = name ++ ", version " ++ versnum ++ ", " ++ date copyright = "Copyright (c) [1995..2003] Manuel M T Chakravarty" disclaimer = "This software is distributed under the \- \terms of the GNU Public Licence.\n\- \NO WARRANTY WHATSOEVER IS PROVIDED. \- \See the details in the documentation."+ \terms of the GNU Public Licence.\n\+ \NO WARRANTY WHATSOEVER IS PROVIDED. \+ \See the details in the documentation."
c2hs/base/admin/Config.hs view
@@ -31,12 +31,12 @@ -- module Config (-- limits- --- errorLimit,- --- -- debuging- --- assertEnabled)+ --+ errorLimit,+ --+ -- debuging+ --+ assertEnabled) where -- compilation aborts with a fatal error, when the given number of errors
c2hs/base/errors/Errors.hs view
@@ -51,16 +51,16 @@ -- interr :: String -> a interr msg = error ("INTERNAL COMPILER ERROR:\n"- ++ indentMultilineString 2 msg- ++ "\n")+ ++ indentMultilineString 2 msg+ ++ "\n") -- raise a error due to a implementation restriction; message may have multiple -- lines (EXPORTED) -- todo :: String -> a todo msg = error ("Feature not yet implemented:\n"- ++ indentMultilineString 2 msg- ++ "\n")+ ++ indentMultilineString 2 msg+ ++ "\n") -- errors in the compiled program@@ -68,10 +68,10 @@ -- the higher the level of an error, the more critical it is (EXPORTED) ---data ErrorLvl = WarningErr -- does not affect compilation- | ErrorErr -- cannot generate code- | FatalErr -- abort immediately- deriving (Eq, Ord)+data ErrorLvl = WarningErr -- does not affect compilation+ | ErrorErr -- cannot generate code+ | FatalErr -- abort immediately+ deriving (Eq, Ord) data Error = Error ErrorLvl Position [String] -- (EXPORTED ABSTRACTLY) @@ -86,8 +86,8 @@ instance Ord Error where (Error lvl1 pos1 _) < (Error lvl2 pos2 _) = pos1 < pos2- || (pos1 == pos2 && lvl1 < lvl2)- e1 <= e2 = e1 < e2 || e1 == e2+ || (pos1 == pos2 && lvl1 < lvl2)+ e1 <= e2 = e1 < e2 || e1 == e2 -- produce an `Error', given its level, position, and a list of lines of@@ -111,7 +111,7 @@ -- >>> <line_1> -- <line_2> -- ...--- <line_n>+-- <line_n> -- -- * internal errors (identified by a special position value) are formatted as --@@ -119,7 +119,7 @@ -- >>> <line_1> -- <line_2> -- ...--- <line_n>+-- <line_n> -- showError :: Error -> String showError (Error _ pos (l:ls)) | isInternalPos pos =@@ -129,11 +129,11 @@ showError (Error lvl (Position fname row col) (l:ls)) = let prefix = fname ++ ":" ++ show (row::Int) ++ ": "- ++ "(column "- ++ show (col::Int)- ++ ") ["- ++ showErrorLvl lvl- ++ "] "+ ++ "(column "+ ++ show (col::Int)+ ++ ") ["+ ++ showErrorLvl lvl+ ++ "] " showErrorLvl WarningErr = "WARNING" showErrorLvl ErrorErr = "ERROR" showErrorLvl FatalErr = "FATAL"@@ -142,7 +142,7 @@ ++ " >>> " ++ l ++ "\n" ++ (indentMultilineString 2 . unlines) ls showError (Error _ _ [] ) = interr "Errors: showError:\- \ Empty error message!"+ \ Empty error message!" errorAtPos :: Position -> [String] -> a errorAtPos pos msg = (error . showError . makeError ErrorErr pos) msg@@ -152,4 +152,4 @@ indentMultilineString :: Int -> String -> String indentMultilineString n = unlines . (map (spaces++)) . lines where- spaces = take n (repeat ' ')+ spaces = take n (repeat ' ')
c2hs/base/general/Binary.hs view
@@ -45,8 +45,8 @@ putByteArray, #endif - getBinFileWithDict, -- :: Binary a => FilePath -> IO a- putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO ()+ getBinFileWithDict, -- :: Binary a => FilePath -> IO a+ putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where @@ -76,22 +76,22 @@ import Data.Int import Data.Word import Data.IORef-import Data.Char ( ord, chr )-import Data.Array.Base ( unsafeRead, unsafeWrite )-import Control.Monad ( when, liftM )+import Data.Char ( ord, chr )+import Data.Array.Base ( unsafeRead, unsafeWrite )+import Control.Monad ( when, liftM ) import System.IO as IO-import System.IO.Unsafe ( unsafeInterleaveIO )-import System.IO.Error ( mkIOError, eofErrorType )-import GHC.Real ( Ratio(..) )+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO.Error ( mkIOError, eofErrorType )+import GHC.Real ( Ratio(..) ) import GHC.Exts # if __GLASGOW_HASKELL__>=612 import GHC.IO (IO(IO)) #else import GHC.IOBase (IO(IO)) #endif-import GHC.Word ( Word8(..) )+import GHC.Word ( Word8(..) ) # if __GLASGOW_HASKELL__<602-import GHC.Handle ( hSetBinaryMode )+import GHC.Handle ( hSetBinaryMode ) # endif -- for debug import System.CPUTime (getCPUTime)@@ -102,27 +102,27 @@ type BinArray = IOUArray Int Word8 ------------------------------------------------------------------ BinHandle+-- BinHandle --------------------------------------------------------------- data BinHandle- = BinMem { -- binary data stored in an unboxed array- bh_usr :: UserData, -- sigh, need parameterized modules :-)- off_r :: !FastMutInt, -- the current offset- sz_r :: !FastMutInt, -- size of the array (cached)- arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))+ = BinMem { -- binary data stored in an unboxed array+ bh_usr :: UserData, -- sigh, need parameterized modules :-)+ off_r :: !FastMutInt, -- the current offset+ sz_r :: !FastMutInt, -- size of the array (cached)+ arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) }- -- XXX: should really store a "high water mark" for dumping out- -- the binary data to a file.+ -- XXX: should really store a "high water mark" for dumping out+ -- the binary data to a file. - | BinIO { -- binary data stored in a file+ | BinIO { -- binary data stored in a file bh_usr :: UserData,- off_r :: !FastMutInt, -- the current offset (cached)- hdl :: !IO.Handle -- the file handle (must be seekable)+ off_r :: !FastMutInt, -- the current offset (cached)+ hdl :: !IO.Handle -- the file handle (must be seekable) }- -- cache the file ptr in BinIO; using hTell is too expensive- -- to call repeatedly. If anyone else is modifying this Handle- -- at the same time, we'll be screwed.+ -- cache the file ptr in BinIO; using hTell is too expensive+ -- to call repeatedly. If anyone else is modifying this Handle+ -- at the same time, we'll be screwed. getUserData :: BinHandle -> UserData getUserData bh = bh_usr bh@@ -132,7 +132,7 @@ ------------------------------------------------------------------ Bin+-- Bin --------------------------------------------------------------- newtype Bin a = BinPtr Int@@ -142,7 +142,7 @@ castBin (BinPtr i) = BinPtr i ------------------------------------------------------------------ class Binary+-- class Binary --------------------------------------------------------------- class Binary a where@@ -194,8 +194,8 @@ seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do sz <- readFastMutInt sz_r if (p >= sz)- then do expandBin h p; writeFastMutInt ix_r p- else writeFastMutInt ix_r p+ then do expandBin h p; writeFastMutInt ix_r p+ else writeFastMutInt ix_r p isEOFBin :: BinHandle -> IO Bool isEOFBin (BinMem _ ix_r sz_r a) = do@@ -224,7 +224,7 @@ arr <- newArray_ (0,filesize-1) count <- hGetArray h arr filesize when (count /= filesize)- (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))+ (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) hClose h arr_r <- newIORef arr ix_r <- newFastMutInt@@ -241,7 +241,7 @@ arr <- readIORef arr_r arr' <- newArray_ (0,sz'-1) sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i- | i <- [ 0 .. sz-1 ] ]+ | i <- [ 0 .. sz-1 ] ] writeFastMutInt sz_r sz' writeIORef arr_r arr' #ifdef DEBUG@@ -249,7 +249,7 @@ #endif return () expandBin (BinIO _ _ _) _ = return ()- -- no need to expand a file, we'll assume they expand by themselves.+ -- no need to expand a file, we'll assume they expand by themselves. -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes@@ -258,17 +258,17 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r- -- double the size of the array if it overflows+ -- double the size of the array if it overflows if (ix >= sz)- then do expandBin h ix- putWord8 h w- else do arr <- readIORef arr_r- unsafeWrite arr ix w- writeFastMutInt ix_r (ix+1)- return ()+ then do expandBin h ix+ putWord8 h w+ else do arr <- readIORef arr_r+ unsafeWrite arr ix w+ writeFastMutInt ix_r (ix+1)+ return () putWord8 (BinIO _ ix_r h) w = do ix <- readFastMutInt ix_r- hPutChar h (chr (fromIntegral w)) -- XXX not really correct+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct writeFastMutInt ix_r (ix+1) return () @@ -277,7 +277,7 @@ ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r when (ix >= sz) $- ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) arr <- readIORef arr_r w <- unsafeRead arr ix writeFastMutInt ix_r (ix+1)@@ -286,7 +286,7 @@ ix <- readFastMutInt ix_r c <- hGetChar h writeFastMutInt ix_r (ix+1)- return $! (fromIntegral (ord c)) -- XXX not really correct+ return $! (fromIntegral (ord c)) -- XXX not really correct putByte :: BinHandle -> Word8 -> IO () putByte bh w = put_ bh w@@ -323,9 +323,9 @@ w3 <- getWord8 h w4 <- getWord8 h return $! ((fromIntegral w1 `shiftL` 24) .|.- (fromIntegral w2 `shiftL` 16) .|.- (fromIntegral w3 `shiftL` 8) .|.- (fromIntegral w4))+ (fromIntegral w2 `shiftL` 16) .|.+ (fromIntegral w3 `shiftL` 8) .|.+ (fromIntegral w4)) instance Binary Word64 where@@ -348,13 +348,13 @@ 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) .|.- (fromIntegral w8))+ (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)) -- ----------------------------------------------------------------------------- -- Primitve Int writes@@ -397,13 +397,13 @@ #if SIZEOF_HSINT == 4 put_ bh i = put_ bh (fromIntegral i :: Int32) get bh = do- x <- get bh- return $! (fromIntegral (x :: Int32))+ x <- get bh+ return $! (fromIntegral (x :: Int32)) #elif SIZEOF_HSINT == 8 put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do- x <- get bh- return $! (fromIntegral (x :: Int64))+ x <- get bh+ return $! (fromIntegral (x :: Int64)) #else #error "unsupported sizeof(HsInt)" #endif@@ -490,39 +490,39 @@ instance Binary Integer where put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do- p <- putByte bh 1;- put_ bh (I# s#)- let sz# = sizeofByteArray# a# -- in *bytes*- put_ bh (I# sz#) -- in *bytes*- putByteArray bh a# sz#+ p <- putByte bh 1;+ put_ bh (I# s#)+ let sz# = sizeofByteArray# a# -- in *bytes*+ put_ bh (I# sz#) -- in *bytes*+ putByteArray bh a# sz# get bh = do- b <- getByte bh- case b of- 0 -> do (I# i#) <- get bh- return (S# i#)- _ -> do (I# s#) <- get bh- sz <- get bh- (BA a#) <- getByteArray bh sz- return (J# s# a#)+ b <- getByte bh+ case b of+ 0 -> do (I# i#) <- get bh+ return (S# i#)+ _ -> do (I# s#) <- get bh+ sz <- get bh+ (BA a#) <- getByteArray bh sz+ return (J# s# a#) putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () putByteArray bh a s# = loop 0# where loop n#- | n# ==# s# = return ()- | otherwise = do- putByte bh (indexByteArray a n#)- loop (n# +# 1#)+ | n# ==# s# = return ()+ | otherwise = do+ putByte bh (indexByteArray a n#)+ loop (n# +# 1#) getByteArray :: BinHandle -> Int -> IO ByteArray getByteArray bh (I# sz) = do (MBA arr) <- newByteArray sz let loop n- | n ==# sz = return ()- | otherwise = do- w <- getByte bh- writeByteArray arr n w- loop (n +# 1#)+ | n ==# sz = return ()+ | otherwise = do+ w <- getByte bh+ writeByteArray arr n w+ loop (n +# 1#) loop 0# freezeByteArray arr @@ -604,27 +604,27 @@ lazyPut :: Binary a => BinHandle -> a -> IO () lazyPut bh a = do- -- output the obj with a ptr to skip over it:+ -- output the obj with a ptr to skip over it: pre_a <- tellBin bh- put_ bh pre_a -- save a slot for the ptr- put_ bh a -- dump the object- q <- tellBin bh -- q = ptr to after object- putAt bh pre_a q -- fill in slot before a with ptr to q- seekBin bh q -- finally carry on writing at q+ put_ bh pre_a -- save a slot for the ptr+ put_ bh a -- dump the object+ q <- tellBin bh -- q = ptr to after object+ putAt bh pre_a q -- fill in slot before a with ptr to q+ seekBin bh q -- finally carry on writing at q lazyGet :: Binary a => BinHandle -> IO a lazyGet bh = do- p <- get bh -- a BinPtr+ p <- get bh -- a BinPtr p_a <- tellBin bh a <- unsafeInterleaveIO (getAt bh p_a) seekBin bh p -- skip over the object for now return a -- ----------------------------------------------------------------- Main wrappers: getBinFileWithDict, putBinFileWithDict+-- Main wrappers: getBinFileWithDict, putBinFileWithDict ----- This layer is built on top of the stuff above,--- and should not know anything about BinHandles+-- This layer is built on top of the stuff above,+-- and should not know anything about BinHandles -- -------------------------------------------------------------- initBinMemSize = (1024*1024) :: Int@@ -634,26 +634,26 @@ getBinFileWithDict file_path = do 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- -- GHC interface file format)+ -- Read the magic number to check that this really is a GHC .hi file+ -- (This magic number does not change when we change+ -- GHC interface file format) magic <- get bh when (magic /= binaryInterfaceMagic) $- error "magic number mismatch: old/corrupt interface file?"+ error "magic number mismatch: old/corrupt interface file?" - -- Read the dictionary- -- The next word in the file is a pointer to where the dictionary is- -- (probably at the end of the file)- dict_p <- Binary.get bh -- Get the dictionary ptr- data_p <- tellBin bh -- Remember where we are now+ -- Read the dictionary+ -- The next word in the file is a pointer to where the dictionary is+ -- (probably at the end of the file)+ dict_p <- Binary.get bh -- Get the dictionary ptr+ data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh- seekBin bh data_p -- Back to where we were before+ seekBin bh data_p -- Back to where we were before - -- Initialise the user-data field of bh+ -- 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 ()@@ -663,33 +663,33 @@ bh <- openBinMem initBinMemSize put_ bh binaryInterfaceMagic - -- Remember where the dictionary pointer will go+ -- Remember where the dictionary pointer will go dict_p_p <- tellBin bh- put_ bh dict_p_p -- Placeholder for ptr to dictionary+ put_ bh dict_p_p -- Placeholder for ptr to dictionary - -- Make some intial state+ -- 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+ -- Get the final-state j <- readIORef (ud_next usr_state) #if __GLASGOW_HASKELL__>=602 fm <- HashTable.toList (ud_map usr_state) #else fm <- liftM Map.toList $ readIORef (ud_map usr_state) #endif- dict_p <- tellBin bh -- This is where the dictionary will start+ dict_p <- tellBin bh -- This is where the dictionary will start - -- Write the dictionary pointer at the fornt of the file- putAt bh dict_p_p dict_p -- Fill in the placeholder- seekBin bh dict_p -- Seek back to the end of the file+ -- Write the dictionary pointer at the fornt of the file+ putAt bh dict_p_p dict_p -- Fill in the placeholder+ seekBin bh dict_p -- Seek back to the end of the file - -- Write the dictionary itself+ -- Write the dictionary itself putDictionary bh j (constructDictionary j fm) - -- And send the result to the file+ -- And send the result to the file writeBinMem bh file_path -- hClose hnd @@ -698,28 +698,28 @@ -- ----------------------------------------------------------------------------- data UserData =- UserData { -- This field is used only when reading- ud_dict :: Dictionary,+ UserData { -- This field is used only when reading+ ud_dict :: Dictionary, - -- The next two fields are only used when writing- ud_next :: IORef Int, -- The next index to use+ -- The next two fields are only used when writing+ ud_next :: IORef Int, -- The next index to use #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707- ud_map :: BasicHashTable String Int -- The index of each string+ ud_map :: BasicHashTable String Int -- The index of each string # else- ud_map :: HashTable String Int -- The index of each string+ ud_map :: HashTable String Int -- The index of each string # endif #else- ud_map :: IORef (Map String Int)+ ud_map :: IORef (Map String Int) #endif- }+ } noUserData = error "Binary.UserData: no user data" initReadState :: Dictionary -> UserData initReadState dict = UserData{ ud_dict = dict,- ud_next = undef "next",- ud_map = undef "map" }+ ud_next = undef "next",+ ud_map = undef "map" } newWriteState :: IO UserData newWriteState = do@@ -734,18 +734,18 @@ out_r <- newIORef Map.empty #endif return (UserData { ud_dict = error "dict",- ud_next = j_r,- ud_map = out_r })+ ud_next = j_r,+ ud_map = out_r }) undef s = error ("Binary.UserData: no " ++ s) ------------------------------------------------------------ The Dictionary+-- The Dictionary --------------------------------------------------------- -type Dictionary = Array Int String -- The dictionary- -- Should be 0-indexed+type Dictionary = Array Int String -- The dictionary+ -- Should be 0-indexed putDictionary :: BinHandle -> Int -> Dictionary -> IO () putDictionary bh sz dict = do@@ -776,34 +776,34 @@ let entry = Map.lookup str fm #endif case entry of- Just j -> put_ bh j- Nothing -> do- j <- readIORef j_r- put_ bh j- writeIORef j_r (j+1)+ Just j -> put_ bh j+ Nothing -> do+ j <- readIORef j_r+ put_ bh j+ writeIORef j_r (j+1) #if __GLASGOW_HASKELL__>=602- HashTable.insert out_r str j+ HashTable.insert out_r str j #else- modifyIORef out_r (\fm -> Map.insert str j fm)+ modifyIORef out_r (\fm -> Map.insert str j fm) #endif getSharedString :: BinHandle -> IO String getSharedString bh = do- j <- get bh- return $! (ud_dict (getUserData bh) ! j)+ j <- get bh+ return $! (ud_dict (getUserData bh) ! j) {- ------------------------------------------------------------ Reading and writing FastStrings+-- Reading and writing FastStrings --------------------------------------------------------- putFS bh (FastString id l ba) = do put_ bh (I# l) putByteArray bh ba l putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)- -- 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.+ -- 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@@ -820,22 +820,22 @@ instance Binary FastString where put_ bh f@(FastString id l ba) = case getUserData bh of {- UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do+ UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f case lookupUFM out uniq of- Just (j,f) -> put_ bh j- Nothing -> do- j <- readIORef j_r- put_ bh j- writeIORef j_r (j+1)- writeIORef out_r (addToUFM out uniq (j,f))+ Just (j,f) -> put_ bh j+ Nothing -> do+ j <- readIORef j_r+ put_ bh j+ writeIORef j_r (j+1)+ writeIORef out_r (addToUFM out uniq (j,f)) } put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) get bh = do- j <- get bh- return $! (ud_dict (getUserData bh) ! j)+ j <- get bh+ return $! (ud_dict (getUserData bh) ! j) -} printElapsedTime :: String -> IO ()
c2hs/base/general/FastMutInt.hs view
@@ -5,8 +5,8 @@ -- Unboxed mutable Ints module FastMutInt(- FastMutInt, newFastMutInt,- readFastMutInt, writeFastMutInt+ FastMutInt, newFastMutInt,+ readFastMutInt, writeFastMutInt ) where #define SIZEOF_HSINT 4
c2hs/base/general/FileOps.hs view
@@ -35,8 +35,8 @@ -- standard libs import Data.Char (chr, ord) import System.Directory (doesFileExist)-import System.IO (Handle, IOMode(..), openFile)-import Control.Monad (liftM)+import System.IO (Handle, IOMode(..), openFile)+import Control.Monad (liftM) import Control.Exception (catch, SomeException) import System.Random (newStdGen, randomRs) @@ -57,8 +57,8 @@ file `fileFindIn` paths = do let (paths', file') = if head file == '/'- then (dirname file : paths, stripDirname file)- else (paths, file)+ then (dirname file : paths, stripDirname file)+ else (paths, file) files = map (`addPath` file') paths' existsFlags <- mapM doesFileExist files let existingFiles = [file | (file, flag) <- zip files existsFlags, flag]@@ -82,16 +82,16 @@ mktemp pre post = do rs <- liftM (randomRs (0, 61)) newStdGen- -- range for lower and upper case letters plus digits+ -- range for lower and upper case letters plus digits createLoop 100 rs where createLoop 0 _ = fail "mktemp: failed 100 times" createLoop attempts rs = let- (rs', fname) = nextName rs- in do- h <- openFile fname ReadWriteMode- return (h, fname)- `catch` handler attempts rs'+ (rs', fname) = nextName rs+ in do+ h <- openFile fname ReadWriteMode+ return (h, fname)+ `catch` handler attempts rs' -- handler :: Int -> [Int] -> SomeException -> IO (Handle,FilePath) handler attempts rs' _ = createLoop (attempts - 1) rs'@@ -100,15 +100,15 @@ sixChars is = let (sixInts, is') = splitAt 6 is- --- toChar i | i < 10 = chr . (ord '0' +) $ i- | i < 36 = chr . (ord 'A' +) . (subtract 10) $ i- | otherwise = chr . (ord 'a' +) . (subtract 36) $ i- in- (is', map toChar sixInts)+ --+ toChar i | i < 10 = chr . (ord '0' +) $ i+ | i < 36 = chr . (ord 'A' +) . (subtract 10) $ i+ | otherwise = chr . (ord 'a' +) . (subtract 36) $ i+ in+ (is', map toChar sixInts) -- nextName :: [Int] -> ([Int], String) nextName is = let- (is', rndChars) = sixChars is- in- (is', pre ++ rndChars ++ post)+ (is', rndChars) = sixChars is+ in+ (is', pre ++ rndChars ++ post)
c2hs/base/general/Position.hs view
@@ -49,9 +49,9 @@ -- is important as it leads to the desired ordering of source positions -- (EXPORTED) ---data Position = Position String -- file name- {-# UNPACK #-} !Int -- row- {-# UNPACK #-} !Int -- column+data Position = Position String -- file name+ {-# UNPACK #-} !Int -- row+ {-# UNPACK #-} !Int -- column deriving (Eq, Ord) instance Show Position where@@ -62,7 +62,7 @@ nopos :: Position nopos = Position "<no file>" (-1) (-1) -isNopos :: Position -> Bool+isNopos :: Position -> Bool isNopos (Position _ (-1) (-1)) = True isNopos _ = False @@ -73,7 +73,7 @@ isDontCarePos :: Position -> Bool isDontCarePos (Position _ (-2) (-2)) = True-isDontCarePos _ = False+isDontCarePos _ = False -- position attached to objects that are hard-coded into the toolkit (EXPORTED) --
c2hs/base/general/UNames.hs view
@@ -24,7 +24,7 @@ -- Functional Programming 4(1), pp 117-123, 1994. -- -- WARNING: DON'T tinker with the implementation! It uses UNSAFE low-level--- operations!+-- operations! -- --- DOCU ---------------------------------------------------------------------- --@@ -51,8 +51,8 @@ -- module UNames (NameSupply, Name,- rootSupply, splitSupply, names,- saveRootNameSupply, restoreRootNameSupply)+ rootSupply, splitSupply, names,+ saveRootNameSupply, restoreRootNameSupply) where import Control.Monad (when)@@ -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 ! @@ -150,10 +150,10 @@ -- ------------------------ -- WARNING: The following does not exist, or at least, it belongs to another--- world. And if you believe into the lambda calculus, you don't--- want to know about this other world.+-- 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)@@ -166,8 +166,8 @@ -- unsafeReadAndIncIntRef :: IORef Int -> Int unsafeReadAndIncIntRef mv = unsafePerformIO $ do- v <- readIORef mv- when (v<1) $- error "UName: root name supply used after saving"- writeIORef mv (v + 1)- return v+ v <- readIORef mv+ when (v<1) $+ error "UName: root name supply used after saving"+ writeIORef mv (v + 1)+ return v
c2hs/base/state/CIO.hs view
@@ -40,36 +40,36 @@ -- module CIO (-- (verbatim) re-exports- --- Handle, HandlePosn, IOMode(..), BufferMode(..), SeekMode(..),- stdin, stdout, stderr,- isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,- isFullError, isEOFError, isIllegalOperation, isPermissionError,- isUserError,- ioeGetErrorString, ioeGetHandle, ioeGetFileName,- --- -- file handling- --- openFileCIO, hCloseCIO,- --- -- text I/O- --- putCharCIO, putStrCIO, hPutStrCIO, hPutStrLnCIO, writeFileCIO,- readFileCIO, printCIO, getCharCIO, hFlushCIO, hPutCharCIO,- hGetContentsCIO, hSetBufferingCIO, hGetBufferingCIO,- newlineCIO,- --- -- `Directory'- --- doesFileExistCIO, removeFileCIO,- --- -- `System'- --- ExitCode(..), exitWithCIO, getArgsCIO, getProgNameCIO,- --- -- CTK general stuff- --- fileFindInCIO, mktempCIO)+ --+ Handle, HandlePosn, IOMode(..), BufferMode(..), SeekMode(..),+ stdin, stdout, stderr,+ isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,+ isFullError, isEOFError, isIllegalOperation, isPermissionError,+ isUserError,+ ioeGetErrorString, ioeGetHandle, ioeGetFileName,+ --+ -- file handling+ --+ openFileCIO, hCloseCIO,+ --+ -- text I/O+ --+ putCharCIO, putStrCIO, hPutStrCIO, hPutStrLnCIO, writeFileCIO,+ readFileCIO, printCIO, getCharCIO, hFlushCIO, hPutCharCIO,+ hGetContentsCIO, hSetBufferingCIO, hGetBufferingCIO,+ newlineCIO,+ --+ -- `Directory'+ --+ doesFileExistCIO, removeFileCIO,+ --+ -- `System'+ --+ ExitCode(..), exitWithCIO, getArgsCIO, getProgNameCIO,+ --+ -- CTK general stuff+ --+ fileFindInCIO, mktempCIO) where import System.IO@@ -82,7 +82,7 @@ import System.IO (hSetEncoding, latin1) #endif -import FileOps (fileFindIn, mktemp)+import FileOps (fileFindIn, mktemp) import StateBase (PreCST, liftIO) @@ -115,7 +115,7 @@ hPutStrLnCIO :: Handle -> String -> PreCST e s () hPutStrLnCIO h s = liftIO (hPutStrLn h s) -writeFileCIO :: FilePath -> String -> PreCST e s ()+writeFileCIO :: FilePath -> String -> PreCST e s () writeFileCIO fname contents = do hnd <- openFileCIO fname WriteMode hPutStrCIO hnd contents
c2hs/base/state/State.hs view
@@ -38,35 +38,35 @@ -- module State (-- the PreCST monad- --- PreCST, -- reexport ABSTRACT- nop, yield, (+>=), (+>), fixCST, -- reexport- throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted- readCST, writeCST, transCST, run, runCST,- StateTrans.MVar, -- reexport- newMV, readMV, assignMV, -- reexport lifted- --- -- reexport compiler I/O- --- module CIO,- liftIO,- --- -- identification- --- getId,- --- -- error management- --- raise, raiseWarning, raiseError, raiseFatal, showErrors,- errorsPresent,- --- -- extra state management- --- readExtra, updExtra,- --- -- name supplies- --- getNameSupply)+ --+ PreCST, -- reexport ABSTRACT+ nop, yield, (+>=), (+>), fixCST, -- reexport+ throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted+ readCST, writeCST, transCST, run, runCST,+ StateTrans.MVar, -- reexport+ newMV, readMV, assignMV, -- reexport lifted+ --+ -- reexport compiler I/O+ --+ module CIO,+ liftIO,+ --+ -- identification+ --+ getId,+ --+ -- error management+ --+ raise, raiseWarning, raiseError, raiseFatal, showErrors,+ errorsPresent,+ --+ -- extra state management+ --+ readExtra, updExtra,+ --+ -- name supplies+ --+ getNameSupply) where import Data.Ix@@ -74,19 +74,19 @@ import Data.List (sort) import BaseVersion (version, copyright, disclaimer)-import Config (errorLimit)+import Config (errorLimit) import Position (Position) import UNames (NameSupply,- rootSupply, splitSupply)+ rootSupply, splitSupply) import StateTrans (STB,- readBase, transBase, runSTB)+ readBase, transBase, runSTB) import qualified StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy,- MVar, newMV, readMV, assignMV)+ MVar, newMV, readMV, assignMV) import StateBase (PreCST(..), ErrorState(..), BaseState(..),- nop, yield, (+>=), (+>), fixCST,- unpackCST, readCST, writeCST, transCST,- liftIO)+ nop, yield, (+>=), (+>), fixCST,+ unpackCST, readCST, writeCST, transCST,+ liftIO) import CIO import Errors (ErrorLvl(..), Error, makeError, errorLvl, showError) @@ -100,12 +100,12 @@ -- initialBaseState :: (String, String, String) -> e -> BaseState e initialBaseState vcd es = BaseState {- idTKBS = (version, copyright, disclaimer),- idBS = vcd,- errorsBS = initialErrorState,- suppliesBS = splitSupply rootSupply,- extraBS = es- }+ idTKBS = (version, copyright, disclaimer),+ idBS = vcd,+ errorsBS = initialErrorState,+ suppliesBS = splitSupply rootSupply,+ extraBS = es+ } -- executing state transformers@@ -121,11 +121,11 @@ run vcd es cst = runSTB m (initialBaseState vcd es) () where m = unpackCST (- cst- `fatalsHandledBy` \err ->- putStrCIO ("Uncaught fatal error: " ++ show err) >>- exitWithCIO (ExitFailure 1)- )+ cst+ `fatalsHandledBy` \err ->+ putStrCIO ("Uncaught fatal error: " ++ show err) >>+ exitWithCIO (ExitFailure 1)+ ) -- run a PreCST in the context of another PreCST (EXPORTED) --@@ -162,8 +162,8 @@ -- updating for maintaining the state) -- catchExc :: PreCST e s a- -> (String, String -> PreCST e s a)- -> 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) -- given a state transformer that may raise fatal errors and an error handler@@ -178,9 +178,9 @@ -- fatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a fatalsHandledBy m h = CST $ StateTrans.fatalsHandledBy m' h'- where- m' = unpackCST m- h' = unpackCST . h+ where+ m' = unpackCST m+ h' = unpackCST . h -- mutable variables -- -----------------@@ -222,9 +222,9 @@ -- raise :: Error -> PreCST e s () raise err = case errorLvl err of- WarningErr -> raise0 err- ErrorErr -> raise0 err- FatalErr -> raiseFatal0 "Generic fatal error." err+ WarningErr -> raise0 err+ ErrorErr -> raise0 err+ FatalErr -> raiseFatal0 "Generic fatal error." err -- raise a warning (see `raiseErr') (EXPORTED) --@@ -254,9 +254,9 @@ -- raiseFatal0 :: String -> Error -> PreCST e s a raiseFatal0 short err = do- raise0 err- errmsgs <- showErrors- fatal (short ++ "\n\n" ++ errmsgs)+ raise0 err+ errmsgs <- showErrors+ fatal (short ++ "\n\n" ++ errmsgs) -- raise an error; internal version, doesn't check whether the error is fatal --@@ -265,22 +265,22 @@ -- raise0 :: Error -> PreCST e s () raise0 err = do- noOfErrs <- CST $ transBase doRaise- when (noOfErrs >= errorLimit) $ do- errmsgs <- showErrors- fatal ("Error limit of " ++ show errorLimit- ++ " errors has been reached.\n" ++ errmsgs)+ noOfErrs <- CST $ transBase doRaise+ when (noOfErrs >= errorLimit) $ do+ errmsgs <- showErrors+ fatal ("Error limit of " ++ show errorLimit+ ++ " errors has been reached.\n" ++ errmsgs) where doRaise :: BaseState e -> (BaseState e, Int) doRaise bs = let- lvl = errorLvl err- ErrorState wlvl no errs = errorsBS bs- wlvl' = max wlvl lvl- no' = no + if lvl > WarningErr- then 1 else 0- errs' = err : errs- in- (bs {errorsBS = (ErrorState wlvl' no' errs')}, no')+ lvl = errorLvl err+ ErrorState wlvl no errs = errorsBS bs+ wlvl' = max wlvl lvl+ no' = no + if lvl > WarningErr+ then 1 else 0+ errs' = err : errs+ in+ (bs {errorsBS = (ErrorState wlvl' no' errs')}, no') -- yield a string containing the collected error messages (EXPORTED) --@@ -288,23 +288,23 @@ -- showErrors :: PreCST e s String showErrors = CST $ do- ErrorState wlvl no errs <- transBase extractErrs- return $ foldr (.) id (map showString (errsToStrs errs)) ""- where- extractErrs :: BaseState e -> (BaseState e, ErrorState)- extractErrs bs = (bs {errorsBS = initialErrorState},- errorsBS bs)+ ErrorState wlvl no errs <- transBase extractErrs+ return $ foldr (.) id (map showString (errsToStrs errs)) ""+ where+ extractErrs :: BaseState e -> (BaseState e, ErrorState)+ extractErrs bs = (bs {errorsBS = initialErrorState},+ errorsBS bs) - errsToStrs :: [Error] -> [String]- errsToStrs errs = (map showError . sort) errs+ errsToStrs :: [Error] -> [String]+ errsToStrs errs = (map showError . sort) errs -- inquire if there was already an error of at least level `ErrorErr' raised -- (EXPORTED) -- errorsPresent :: PreCST e s Bool errorsPresent = CST $ do- ErrorState wlvl no _ <- readBase errorsBS- return $ wlvl >= ErrorErr+ ErrorState wlvl no _ <- readBase errorsBS+ return $ wlvl >= ErrorErr -- manipulating the extra state@@ -315,18 +315,18 @@ -- readExtra :: (e -> a) -> PreCST e s a readExtra rf = CST $ readBase (\bs ->- (rf . extraBS) bs- )+ (rf . extraBS) bs+ ) -- apply an update function to the extra state (EXPORTED) -- updExtra :: (e -> e) -> PreCST e s () updExtra uf = CST $ transBase (\bs ->- let- es = extraBS bs- in- (bs {extraBS = uf es}, ())- )+ let+ es = extraBS bs+ in+ (bs {extraBS = uf es}, ())+ ) -- name supplies@@ -336,8 +336,8 @@ -- getNameSupply :: PreCST e s NameSupply getNameSupply = CST $ transBase (\bs ->- let- supply : supplies = suppliesBS bs- in- (bs {suppliesBS = supplies}, supply)- )+ let+ supply : supplies = suppliesBS bs+ in+ (bs {suppliesBS = supplies}, supply)+ )
c2hs/base/state/StateBase.hs view
@@ -44,16 +44,16 @@ -- + idBS (triple of strings) -- version, copyright, and disclaimer -- + errorsBS (type `ErrorState') -- keeps track of raised errors -- + namesBS (type `NameSupply') -- provides unique names--- + extraBS (generic type) -- extra compiler-dependent state--- information, e.g., for compiler--- switches+-- + extraBS (generic type) -- extra compiler-dependent state+-- information, e.g., for compiler+-- switches -- --- TODO ---------------------------------------------------------------------- -- module StateBase (PreCST(..), ErrorState(..), BaseState(..),- nop, yield, (+>=), (+>), fixCST,- unpackCST, readCST, writeCST, transCST, liftIO)+ nop, yield, (+>=), (+>), fixCST,+ unpackCST, readCST, writeCST, transCST, liftIO) where import Control.Applicative (Applicative(..))@@ -62,8 +62,8 @@ import Position (Position) import UNames (NameSupply) import StateTrans (STB,- fixSTB, readGeneric, writeGeneric, transGeneric, readBase,- transBase)+ fixSTB, readGeneric, writeGeneric, transGeneric, readBase,+ transBase) import qualified StateTrans (liftIO) import Errors (ErrorLvl(..), Error)@@ -80,18 +80,18 @@ -- * when no error was raised yet, the error level is the lowest possible one -- data ErrorState = ErrorState ErrorLvl -- worst error level that was raised- Int -- number of errors (excl warnings)- [Error] -- already raised errors+ Int -- number of errors (excl warnings)+ [Error] -- already raised errors -- base state (EXPORTED) -- data BaseState e = BaseState {- idTKBS :: (String, String, String), -- toolkit id- idBS :: (String, String, String), -- compiler id- errorsBS :: ErrorState,- suppliesBS :: [NameSupply],- extraBS :: e -- extra state- }+ idTKBS :: (String, String, String), -- toolkit id+ idBS :: (String, String, String), -- compiler id+ errorsBS :: ErrorState,+ suppliesBS :: [NameSupply],+ extraBS :: e -- extra state+ } -- the compiler state transformer (EXPORTED) --
c2hs/base/state/StateTrans.hs view
@@ -62,21 +62,21 @@ -- module StateTrans (-- the monad and the generic operations- --- STB, fixSTB,- --- -- monad specific operations- --- readBase, writeBase, transBase, readGeneric, writeGeneric,- transGeneric, liftIO, runSTB, interleave,- --- -- exception handling and fatal errors- --- throwExc, fatal, catchExc, fatalsHandledBy,- --- -- mutable variables and arrays- --- MVar, newMV, readMV, assignMV)+ --+ STB, fixSTB,+ --+ -- monad specific operations+ --+ readBase, writeBase, transBase, readGeneric, writeGeneric,+ transGeneric, liftIO, runSTB, interleave,+ --+ -- exception handling and fatal errors+ --+ throwExc, fatal, catchExc, fatalsHandledBy,+ --+ -- mutable variables and arrays+ --+ MVar, newMV, readMV, assignMV) where import Prelude hiding (catch)@@ -110,7 +110,7 @@ -- successful computations where -- -- `Left (tag, msg)' -- stands for an exception identified by `tag' with--- error message `msg', and+-- error message `msg', and -- `Right a' -- is a successfully delivered result -- @@ -139,15 +139,15 @@ -- (+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b m +>= k = let- STB m' = m- in- STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) ->- case res of- Left exc -> return (bs', gs', Left exc) -- prop exc- Right a -> let- STB k' = k a- in- k' bs' gs' -- cont+ STB m' = m+ in+ STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) ->+ case res of+ Left exc -> return (bs', gs', Left exc) -- prop exc+ Right a -> let+ STB k' = k a+ in+ k' bs' gs' -- cont -- bind dropping the result of the first state transfomer --@@ -163,16 +163,16 @@ -- 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- m' bs gs)+ -> fixIO (\future -> let+ STB m' = m (extractResult future)+ in+ m' bs gs) where- extractResult (_, _, Right r) = r- extractResult (_, _, Left _ ) = interr "StateTrans: fixSTB: \- \Tried to access result \- \of unsuccessful \- \recursive computation!"+ extractResult (_, _, Right r) = r+ extractResult (_, _, Left _ ) = interr "StateTrans: fixSTB: \+ \Tried to access result \+ \of unsuccessful \+ \recursive computation!" -- generic state manipulation@@ -195,9 +195,9 @@ -- transBase :: (bs -> (bs, a)) -> STB bs gs a transBase f = STB $ \bs gs -> let- (bs', a) = f bs- in- return (bs', gs, Right a)+ (bs', a) = f bs+ in+ return (bs', gs, Right a) -- generic state: --@@ -217,9 +217,9 @@ -- transGeneric :: (gs -> (gs, a)) -> STB bs gs a transGeneric f = STB $ \bs gs -> let- (gs', a) = f gs- in- return (bs, gs', Right a)+ (gs', a) = f gs+ in+ return (bs, gs', Right a) -- interaction with the encapsulated `IO' monad@@ -238,27 +238,27 @@ -- runSTB :: STB bs gs a -> bs -> gs -> IO a runSTB m bs gs = let- STB m' = m- in- m' bs gs >>= \(_, _, res) ->- case res of- Left (tag, msg) -> let- err = userError ("Exception `"- ++ tag ++ "': "- ++ msg)- in- ioError err- Right a -> return a+ STB m' = m+ in+ m' bs gs >>= \(_, _, res) ->+ case res of+ Left (tag, msg) -> let+ err = userError ("Exception `"+ ++ tag ++ "': "+ ++ msg)+ in+ ioError err+ Right a -> return a -- interleave the (complete) execution of an `STB' with another generic state -- component into an `STB' -- interleave :: STB bs gs' a -> gs' -> STB bs gs a interleave m gs' = STB $ let- STB m' = m- in- \bs gs- -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a))+ STB m' = m+ in+ \bs gs+ -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a)) -- error and exception handling@@ -304,24 +304,24 @@ -- to use updating for maintaining the state) -- catchExc :: STB bs gs a- -> (String, String -> STB bs gs a)- -> STB bs gs a+ -> (String, String -> STB bs gs a)+ -> STB bs gs a catchExc m (tag, handler) = STB $ \bs gs- -> let- STB m' = m- 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- in- handler' bs' gs' -- correct tag, catch- else- return state -- wrong tag, rethrow- Right _ -> return state -- no exception+ -> let+ STB m' = m+ 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+ in+ handler' bs' gs' -- correct tag, catch+ else+ return state -- wrong tag, rethrow+ Right _ -> return state -- no exception -- given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler@@ -337,21 +337,21 @@ 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- ++ "': " ++ msg)- in- ioError err- Right a -> return state- )- `catch` (\err -> let- STB handler' = handler err- in- handler' bs gs)+ STB m' = m+ in+ m' bs gs >>= \state@(gs', bs', res) ->+ case res of+ Left (tag, msg) -> let+ err = userError ("Exception `" ++ tag+ ++ "': " ++ msg)+ in+ ioError err+ Right a -> return state+ )+ `catch` (\err -> let+ STB handler' = handler err+ in+ handler' bs gs) -- list mutable variables and arrays stuff into `STB'; all (EXPORTED)
c2hs/base/syms/Attributes.hs view
@@ -63,8 +63,8 @@ -- may even allow them to be soft. -- -- 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).+-- 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). -- -- * check whether it would increase the performance significantly if we use -- a mixed finite map/array representation for soft tables (all attributes@@ -74,30 +74,30 @@ -- module Attributes (-- attribute management- --- Attrs, newAttrsOnlyPos, newAttrs,- Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf,- --- -- attributes and attribute tables- --- Attr(undef, isUndef, dontCare, isDontCare),- AttrTable, newAttrTable, getAttr, setAttr, updAttr,- copyAttr, freezeAttrTable, softenAttrTable,- StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr,- isUndefStdAttr, setStdAttr, updStdAttr,- getGenAttr, setGenAttr, updGenAttr)+ --+ Attrs, newAttrsOnlyPos, newAttrs,+ Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf,+ --+ -- attributes and attribute tables+ --+ Attr(undef, isUndef, dontCare, isDontCare),+ AttrTable, newAttrTable, getAttr, setAttr, updAttr,+ copyAttr, freezeAttrTable, softenAttrTable,+ StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr,+ isUndefStdAttr, setStdAttr, updStdAttr,+ getGenAttr, setGenAttr, updGenAttr) where import Data.Array import Control.Exception (assert) import Position (Position, Pos(posOf), nopos, isNopos, dontCarePos,- isDontCarePos)+ isDontCarePos) import Errors (interr)-import UNames (NameSupply, Name,- rootSupply, splitSupply, names)+import UNames (NameSupply, Name,+ rootSupply, splitSupply, names) import Map (Map) import qualified Map as Map (fromList, toList, insert,- findWithDefault, empty)+ findWithDefault, empty) import Binary (Binary(..), putByte, getByte) @@ -107,8 +107,8 @@ -- abstract data structure used in the structure tree to represent the -- attribute identifier and the position (EXPORTED) ---data Attrs = OnlyPos Position -- only pos (for internal stuff only)- | Attrs Position Name -- pos and unique name+data Attrs = OnlyPos Position -- only pos (for internal stuff only)+ | Attrs Position Name -- pos and unique name -- get the position associated with an attribute identifier (EXPORTED) --@@ -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@@ -185,11 +185,11 @@ isDontCare :: a -> Bool undef = interr "Attributes: Undefined `undef' method in `Attr' class!" isUndef = interr "Attributes: Undefined `isUndef' method in `Attr' \- \class!"+ \class!" dontCare = interr "Attributes: Undefined `dontCare' method in `Attr' \- \class!"+ \class!" isDontCare = interr "Attributes: Undefined `isDontCare' method in `Attr' \- \class!"+ \class!" -- attribute tables map attribute identifiers to attribute values -- (EXPORTED ABSTRACT)@@ -205,24 +205,24 @@ -- 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- String -- desc of the table+ -- finite map the value is `undef'+ --+ SoftTable (Map Name a) -- updated attr.s+ String -- desc of the table - -- the array contains `undef' attributes for the undefined- -- attributes; for all attribute identifiers outside the- -- bounds, the value is also `undef';- --- | FrozenTable (Array Name a) -- attribute values- String -- desc of the table+ -- the array contains `undef' attributes for the undefined+ -- attributes; for all attribute identifiers outside the+ -- 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) -- -- the description string is used to identify the table in error messages--- (internal errors); a table is initially soft+-- (internal errors); a table is initially soft -- newAttrTable :: Attr a => String -> AttrTable a newAttrTable desc = SoftTable Map.empty desc@@ -235,8 +235,8 @@ case at of (SoftTable fm _) -> Map.findWithDefault undef aid fm (FrozenTable arr _) -> let (lbd, ubd) = bounds arr- in- if (aid < lbd || aid > ubd) then undef else arr!aid+ in+ if (aid < lbd || aid > ubd) then undef else arr!aid -- set the value of an, up to now, undefined attribute from the given -- attribute table (EXPORTED)@@ -246,11 +246,11 @@ 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+ SoftTable (Map.insert aid av fm) desc (FrozenTable arr _) -> interr frozenErr where frozenErr = "Attributes.setAttr: Tried to write frozen attribute in\n"- ++ errLoc at pos+ ++ errLoc at pos -- update the value of an attribute from the given attribute table (EXPORTED) --@@ -260,8 +260,8 @@ case at of (SoftTable fm desc) -> SoftTable (Map.insert aid av fm) desc (FrozenTable arr _) -> interr $ "Attributes.updAttr: Tried to\- \ update frozen attribute in\n"- ++ errLoc at pos+ \ update frozen attribute in\n"+ ++ errLoc at pos -- copy the value of an attribute to another one (EXPORTED) --@@ -270,21 +270,21 @@ copyAttr :: Attr a => AttrTable a -> Attrs -> Attrs -> AttrTable a copyAttr at ats ats' | isUndef av = assert (isUndef (getAttr at ats'))- at+ at | otherwise = updAttr at ats' av where av = getAttr at ats -- auxiliary functions for error messages ---onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b+onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b onlyPosErr fctName at pos = interr $ "Attributes." ++ fctName ++ ": No attribute identifier in\n"- ++ errLoc at pos+ ++ errLoc at pos -- errLoc :: Attr a => AttrTable a -> Position -> String errLoc at pos = " table `" ++ tableDesc at ++ "' for construct at\n\- \ position " ++ show pos ++ "!"+ \ position " ++ show pos ++ "!" where tableDesc (SoftTable _ desc) = desc tableDesc (FrozenTable _ desc) = desc@@ -292,7 +292,7 @@ -- freeze a soft table; afterwards no more changes are possible until the -- table is softened again (EXPORTED) ---freezeAttrTable :: Attr a => AttrTable a -> AttrTable a+freezeAttrTable :: Attr a => AttrTable a -> AttrTable a freezeAttrTable (SoftTable fm desc) = let contents = Map.toList fm keys = map fst contents@@ -303,15 +303,15 @@ (FrozenTable (array (lbd, ubd) contents) desc) freezeAttrTable (FrozenTable arr desc) = interr ("Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\- \ table `" ++ desc ++ "'!")+ \ table `" ++ desc ++ "'!") -- soften a frozen table; afterwards changes are possible until the -- table is frozen again (EXPORTED) ---softenAttrTable :: Attr a => AttrTable a -> AttrTable a+softenAttrTable :: Attr a => AttrTable a -> AttrTable a softenAttrTable (SoftTable fm desc) = interr ("Attributes.softenAttrTable: Attempt to soften the already \- \softened\n table `" ++ desc ++ "'!")+ \softened\n table `" ++ desc ++ "'!") softenAttrTable (FrozenTable arr desc) = SoftTable (Map.fromList . assocs $ arr) desc @@ -322,19 +322,19 @@ -- standard attribute variants (EXPORTED) -- data StdAttr a = UndefStdAttr- | DontCareStdAttr- | JustStdAttr a+ | DontCareStdAttr+ | JustStdAttr a instance Attr (StdAttr a) where undef = UndefStdAttr isUndef UndefStdAttr = True- isUndef _ = False+ isUndef _ = False dontCare = DontCareStdAttr isDontCare DontCareStdAttr = True- isDontCare _ = False+ isDontCare _ = False -- get an attribute value from a standard attribute table (EXPORTED) --@@ -345,7 +345,7 @@ getStdAttr atab at = getStdAttrDft atab at err where err = interr $ "Attributes.getStdAttr: Don't care in\n"- ++ errLoc atab (posOf at)+ ++ 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)@@ -356,7 +356,7 @@ DontCareStdAttr -> dft JustStdAttr av -> av UndefStdAttr -> interr $ "Attributes.getStdAttrDft: Undefined in\n"- ++ errLoc atab (posOf at)+ ++ errLoc atab (posOf at) -- check if the attribue value is marked as "don't care" (EXPORTED) --@@ -388,11 +388,11 @@ getGenAttr atab at = getAttr atab (attrsOf at) setGenAttr :: (Attr a, Attributed obj)- => AttrTable a -> obj -> a -> AttrTable a+ => AttrTable a -> obj -> a -> AttrTable a setGenAttr atab at av = setAttr atab (attrsOf at) av updGenAttr :: (Attr a, Attributed obj)- => AttrTable a -> obj -> a -> AttrTable a+ => AttrTable a -> obj -> a -> AttrTable a updGenAttr atab at av = updAttr atab (attrsOf at) av
c2hs/base/syms/Idents.hs view
@@ -58,9 +58,9 @@ -- module Idents (Ident, noARNum, isLegalIdent, lexemeToIdent, internalIdent,- onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple,- isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum,- getIdentAttrs, dumpIdent)+ onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple,+ isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum,+ getIdentAttrs, dumpIdent) where import Data.Char@@ -68,7 +68,7 @@ import UNames (Name) import Errors (interr) import Attributes (Attrs, newAttrsOnlyPos, newAttrs,- Attributed(attrsOf), posOfAttrsOf)+ Attributed(attrsOf), posOfAttrsOf) import Binary (Binary(..), putSharedString, getSharedString) @@ -77,10 +77,10 @@ -- identifiers without an ambiguousness resolving number get `noARNum' as -- number ---data Ident = Ident String -- lexeme- !Int -- ambiguousness resolving number- !Int -- id. number to speed up equality check- !Attrs -- attributes of this ident. incl. position+data Ident = Ident String -- lexeme+ !Int -- ambiguousness resolving number+ !Int -- id. number to speed up equality check+ !Attrs -- attributes of this ident. incl. position -- the definition of the equality allows identifiers to be equal that are -- defined at different source text positions, and aims at speeding up the@@ -88,16 +88,16 @@ -- instance Eq Ident where (Ident s k id _) == (Ident s' k' id' _) = (k == k')- && (id == id')- && (s == s')+ && (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')- || ((k == k') && (id < id'))- || ((k == k') && (id == id')- && (s < s'))+ || ((k == k') && (id < id'))+ || ((k == k') && (id == id')+ && (s < s')) id1 <= id2 = (id1 < id2) || (id1 == id2) -- for displaying identifiers@@ -125,11 +125,11 @@ -- quad :: String -> Int quad (c1:c2:c3:c4:s) = ((ord c4 * bits21- + ord c3 * bits14- + ord c2 * bits7- + ord c1)- `mod` bits28)- + (quad s `mod` bits28)+ + ord c3 * bits14+ + ord c2 * bits7+ + ord c1)+ `mod` bits28)+ + (quad s `mod` bits28) quad (c1:c2:c3:[] ) = ord c3 * bits14 + ord c2 * bits7 + ord c1 quad (c1:c2:[] ) = ord c2 * bits7 + ord c1 quad (c1:[] ) = ord c1@@ -161,33 +161,33 @@ isLegalIdent :: String -> Bool isLegalIdent [] = False isLegalIdent (c:cs) = if c == '`' then isQualIdent cs- else (isAlpha c || c == '_') && isIdent (c:cs)- where- isIdent = checkTail . (dropWhile isAlphaNumOrUS)+ else (isAlpha c || c == '_') && isIdent (c:cs)+ where+ isIdent = checkTail . (dropWhile isAlphaNumOrUS) - checkTail [] = True- checkTail ("##") = True- checkTail ('#':cs') = all isDigit cs'- checkTail _ = False+ checkTail [] = True+ checkTail ("##") = True+ checkTail ('#':cs') = all isDigit cs'+ checkTail _ = False - isAlphaNumOrUS c = isAlphaNum c || (c == '_')- isAlphaNum c = isAlpha c || isNum c- isAlpha c = c `elem` ['a'..'z'] ++ ['A'..'Z']- isNum c = c `elem` ['0'..'9']+ isAlphaNumOrUS c = isAlphaNum c || (c == '_')+ isAlphaNum c = isAlpha c || isNum c+ isAlpha c = c `elem` ['a'..'z'] ++ ['A'..'Z']+ isNum c = c `elem` ['0'..'9'] - isQualIdent cs = let- cs' = skip cs- in- (not . null) cs'- && (checkTail . tail) cs'+ isQualIdent cs = let+ cs' = skip cs+ in+ (not . null) cs'+ && (checkTail . tail) cs' - skip [] = []- skip ('\'':cs) = '\'':cs- skip ('\\':cs) = case cs of- ('\'':cs') -> skip cs'- ('\\':cs') -> skip cs'- _ -> skip cs- skip (c :cs) = skip cs+ skip [] = []+ skip ('\'':cs) = '\'':cs+ skip ('\\':cs) = case cs of+ ('\'':cs') -> skip cs'+ ('\\':cs') -> skip cs'+ _ -> skip cs+ skip (c :cs) = skip cs -- given the lexeme of an identifier, yield the abstract identifier (EXPORTED) --@@ -203,8 +203,8 @@ -- lexemeToIdent :: Position -> String -> Name -> Ident lexemeToIdent pos l name = Ident s k (quad s) (newAttrs pos name)- where- (s, k) = parseIdent pos l+ where+ (s, k) = parseIdent pos l -- generate an internal identifier (has no position and cannot be asccociated -- with attributes) (EXPORTED)@@ -217,91 +217,91 @@ -- onlyPosIdent :: Position -> String -> Ident onlyPosIdent pos l = Ident s k (quad s) (newAttrsOnlyPos pos)- where- (s, k) = parseIdent pos l+ where+ (s, k) = parseIdent pos l -- Extract the name and ambiguousness resolving number from a lexeme. -- parseIdent :: Position -> String -> (String, Int) parseIdent pos l- = if (null l)- then- interr $ "Idents: lexemeToIdent: Empty lexeme! " ++ show pos- else- if (head l == '\'')- then- parseQuoted (tail l)- else- parseNorm l- where- -- parse lexeme without quotes- --- parseNorm [] = ([], noARNum)- parseNorm ("##") = ([], primARNum)- parseNorm ('#':cs) = ([], ((read . check) cs)::Int)- parseNorm (c :cs) = let- (cs', k) = parseNorm cs- in- (c:cs', k)+ = if (null l)+ then+ interr $ "Idents: lexemeToIdent: Empty lexeme! " ++ show pos+ else+ if (head l == '\'')+ then+ parseQuoted (tail l)+ else+ parseNorm l+ where+ -- parse lexeme without quotes+ --+ parseNorm [] = ([], noARNum)+ parseNorm ("##") = ([], primARNum)+ parseNorm ('#':cs) = ([], ((read . check) cs)::Int)+ parseNorm (c :cs) = let+ (cs', k) = parseNorm cs+ in+ (c:cs', k) - check [] = interr "Idents: lexemeToIdent: Missing\- \ number!"- check ('-':cs) = interr "Idents: lexemeToIdent: Illegal\- \ negative number!"- check s = s+ check [] = interr "Idents: lexemeToIdent: Missing\+ \ number!"+ check ('-':cs) = interr "Idents: lexemeToIdent: Illegal\+ \ negative number!"+ check s = s - -- parse lexeme with quotes- --- parseQuoted [] = interr endInQuotes- parseQuoted ('\\':cs) = parseSpecial cs- parseQuoted ('\'':cs) = let- (rmd, k) = parseNorm cs- in- if (null rmd) then ([], k)- else interr afterQuotes- parseQuoted (c :cs) = let- (cs', k) = parseQuoted cs- in- (c:cs', k)+ -- parse lexeme with quotes+ --+ parseQuoted [] = interr endInQuotes+ parseQuoted ('\\':cs) = parseSpecial cs+ parseQuoted ('\'':cs) = let+ (rmd, k) = parseNorm cs+ in+ if (null rmd) then ([], k)+ else interr afterQuotes+ parseQuoted (c :cs) = let+ (cs', k) = parseQuoted cs+ in+ (c:cs', k) - endInQuotes = "Idents: lexemeToIdent: Unexpected end of\- \ lexeme (in quotes)!"+ endInQuotes = "Idents: lexemeToIdent: Unexpected end of\+ \ lexeme (in quotes)!" - afterQuotes = "Idents: lexemeToIdent: Superfluous\- \ characters after quotes!"+ afterQuotes = "Idents: lexemeToIdent: Superfluous\+ \ characters after quotes!" - endInSpecial = "Idents: lexemeToIdent: Unexpected end of\- \ lexeme (in escape sequence)!"+ endInSpecial = "Idents: lexemeToIdent: Unexpected end of\+ \ lexeme (in escape sequence)!" - illegalSpecial = "Idents: lexemeToIdent: Illegal escape\- \ sequence!"+ illegalSpecial = "Idents: lexemeToIdent: Illegal escape\+ \ sequence!" - -- parse single escaped character, then continue with- -- `parseQuoted'- --- parseSpecial [] = interr endInSpecial- parseSpecial (c1:c2:c3:cs)- | isDigit c1- && isDigit c2- && isDigit c3 = let- (cs', k) = parseQuoted cs- ord0 = ord '0'- d1 = ord c1 - ord0- d2 = ord c2 - ord0- d3 = ord c3 - ord0- in- (chr (100*d1 + 10*d2 + d3)- :cs', k)- parseSpecial (c:cs)- | c == '\\' = ('\\':cs', k)- | c == '\"' = ('\"':cs', k)- | c == '\'' = ('\'':cs', k)- | c == 'n' = ('\n':cs', k)- | c == 't' = ('\t':cs', k)- | c == 'r' = ('\r':cs', k)- where- (cs', k) = parseQuoted cs- parseSpecial _ = interr illegalSpecial+ -- parse single escaped character, then continue with+ -- `parseQuoted'+ --+ parseSpecial [] = interr endInSpecial+ parseSpecial (c1:c2:c3:cs)+ | isDigit c1+ && isDigit c2+ && isDigit c3 = let+ (cs', k) = parseQuoted cs+ ord0 = ord '0'+ d1 = ord c1 - ord0+ d2 = ord c2 - ord0+ d3 = ord c3 - ord0+ in+ (chr (100*d1 + 10*d2 + d3)+ :cs', k)+ parseSpecial (c:cs)+ | c == '\\' = ('\\':cs', k)+ | c == '\"' = ('\"':cs', k)+ | c == '\'' = ('\'':cs', k)+ | c == 'n' = ('\n':cs', k)+ | c == 't' = ('\t':cs', k)+ | c == 'r' = ('\r':cs', k)+ where+ (cs', k) = parseQuoted cs+ parseSpecial _ = interr illegalSpecial -- create an identifier identical to the given one, but with its own set of -- attributes (EXPORTED)@@ -312,16 +312,16 @@ -- given an abstract identifier, yield its lexeme (EXPORTED) ---identToLexeme :: Ident -> String+identToLexeme :: Ident -> String identToLexeme (Ident s k _ _) = s ++ suffix- where- suffix = if (k == noARNum)- then ""- else if (k == primARNum)- then "##"- else if (k == internARNum)- then "<internal>"- else "#" ++ show k+ where+ suffix = if (k == noARNum)+ then ""+ else if (k == primARNum)+ then "##"+ else if (k == internARNum)+ then "<internal>"+ else "#" ++ show k -- test if the given identifier is simple, i.e., has no ambiguousness -- resolving number and is not a primitive identifier (EXPORTED)@@ -341,16 +341,16 @@ stripIdentARNum :: Ident -> Ident stripIdentARNum (Ident s k id at) | k == primARNum || k == internARNum = interr "Idents: stripIdentARNum: \- \Not allowed!"- | otherwise = Ident s noARNum id at+ \Not allowed!"+ | otherwise = Ident s noARNum id at -- get the ambiguousness resolving of an identifier (EXPORTED) -- getIdentARNum :: Ident -> Int getIdentARNum (Ident s k id at) | k == primARNum || k == internARNum = interr "Idents: getIdentARNum: \- \Not allowed!"- | otherwise = k+ \Not allowed!"+ | otherwise = k -- enter a new ambiguousness resolving into the identifier (EXPORTED) --@@ -359,10 +359,10 @@ newIdentARNum :: Ident -> Int -> Ident newIdentARNum (Ident s k id at) k' | k' < 0 = interr "Idents: newIdentARNum: \- \Negative number!"+ \Negative number!" | k == primARNum || k == internARNum = interr "Idents: newIdentARNum: \- \Not allowed!"- | otherwise = Ident s k' id at+ \Not allowed!"+ | otherwise = Ident s k' id at -- get the attribute identifier associated with the given identifier (EXPORTED) --
c2hs/base/syms/NameSpaces.hs view
@@ -38,7 +38,7 @@ -- module NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange,- defLocal, find, nameSpaceToList)+ defLocal, find, nameSpaceToList) where import Map (Map)@@ -67,7 +67,7 @@ -- of the most recently defined local identifiers -- data NameSpace a = NameSpace (Map Ident a) -- defs in global range- [[(Ident, a)]] -- stack of local ranges+ [[(Ident, a)]] -- stack of local ranges -- create a name space (EXPORTED) --@@ -85,18 +85,18 @@ -- defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a) defGlobal (NameSpace gs lss) id def = (NameSpace (Map.insert id def gs) lss,- Map.lookup id gs)+ Map.lookup id gs) -- add new range (EXPORTED) ---enterNewRange :: NameSpace a -> NameSpace a+enterNewRange :: NameSpace a -> NameSpace a enterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss) -- pop topmost range and return its definitions (EXPORTED) -- leaveRange :: NameSpace a -> (NameSpace a, [(Ident, a)]) leaveRange (NameSpace gs []) = interr "NameSpaces.leaveRange: \- \No local range!"+ \No local range!" leaveRange (NameSpace gs (ls:lss)) = (NameSpace gs lss, ls) -- add local definition (EXPORTED)@@ -118,7 +118,7 @@ where lookup [] = Nothing lookup ((id', def):ls) | id == id' = Just def- | otherwise = lookup ls+ | otherwise = lookup ls -- search for a definition (EXPORTED) --@@ -126,18 +126,18 @@ -- find :: NameSpace a -> Ident -> Maybe a find (NameSpace gs lss) id = case (lookup lss) of- Nothing -> Map.lookup id gs- Just def -> Just def- where- lookup [] = Nothing- lookup (ls:lss) = case (lookup' ls) of- Nothing -> lookup lss- Just def -> Just def+ Nothing -> Map.lookup id gs+ Just def -> Just def+ where+ lookup [] = Nothing+ lookup (ls:lss) = case (lookup' ls) of+ Nothing -> lookup lss+ Just def -> Just def - lookup' [] = Nothing- lookup' ((id', def):ls)- | id' == id = Just def- | otherwise = lookup' ls+ lookup' [] = Nothing+ lookup' ((id', def):ls)+ | id' == id = Just def+ | otherwise = lookup' ls -- dump a name space into a list (EXPORTED) --
c2hs/base/syntax/Lexers.hs view
@@ -82,7 +82,7 @@ -- -- * In this implementation, the combinators `quest`, `star`, and `plus` are -- *right* associative - this was different in the ``Lazy Lexing is Fast''--- paper. This change was made on a suggestion by Martin Norbäck+-- paper. This change was made on a suggestion by Martin Norb�ck -- <d95mback@dtek.chalmers.se>. -- --- TODO ----------------------------------------------------------------------
c2hs/c/C.hs view
@@ -31,56 +31,56 @@ -- module C (-- interface to KL for all non-KL modules- --- -- stuff from `Common' (reexported)- --- Pos(posOf), - -- - -- structure tree- --- module CAST,- --- -- attributed structure tree with operations (reexported from- -- `CAttrs')- --- AttrC, getCHeader, - CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC,- getDefOfIdentC,- --- -- support for C structure tree traversals- --- module CTrav,- --- -- support for pretty printing C abstract trees- --- module CPretty,- --- loadAttrC, -- locally defined- --- -- misc. reexported stuff- --- Ident, Attrs, Attr(..),- --- -- misc. own stuff- --- csuffix, hsuffix, isuffix)+ --+ -- stuff from `Common' (reexported)+ --+ Pos(posOf), + -- + -- structure tree+ --+ module CAST,+ --+ -- attributed structure tree with operations (reexported from+ -- `CAttrs')+ --+ AttrC, getCHeader, + CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC,+ getDefOfIdentC,+ --+ -- support for C structure tree traversals+ --+ module CTrav,+ --+ -- support for pretty printing C abstract trees+ --+ module CPretty,+ --+ loadAttrC, -- locally defined+ --+ -- misc. reexported stuff+ --+ Ident, Attrs, Attr(..),+ --+ -- misc. own stuff+ --+ csuffix, hsuffix, isuffix) where import Position (Position(..), Pos(posOf))-import Idents (Ident, lexemeToIdent)+import Idents (Ident, lexemeToIdent) import Attributes (Attrs, Attr(..)) import C2HSState (CST, IOMode(..),- readCST, transCST, runCST, nop,- readFileCIO, writeFileCIO, openFileCIO, hCloseCIO,- fatal, errorsPresent, showErrors,- Traces(..), putTraceStr)+ readCST, transCST, runCST, nop,+ readFileCIO, writeFileCIO, openFileCIO, hCloseCIO,+ fatal, errorsPresent, showErrors,+ Traces(..), putTraceStr) import CAST import CParser (parseC) import CPretty-import CAttrs (AttrC, attrC, getCHeader, - CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC,- getDefOfIdentC)+import CAttrs (AttrC, attrC, getCHeader, + CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC,+ getDefOfIdentC) import CNames (nameAnalysis) import CTrav @@ -101,48 +101,48 @@ -- loadAttrC :: String -> CST s (AttrC, String) loadAttrC fname = do- -- read file- --- traceInfoRead fname- contents <- readFileCIO fname+ -- read file+ --+ traceInfoRead fname+ contents <- readFileCIO fname - -- parse- --- traceInfoParse- rawHeader <- parseC contents (Position fname 1 1)- let header = attrC rawHeader+ -- parse+ --+ traceInfoParse+ rawHeader <- parseC contents (Position fname 1 1)+ let header = attrC rawHeader - -- name analysis- --- traceInfoNA- headerWithAttrs <- nameAnalysis header+ -- name analysis+ --+ traceInfoNA+ headerWithAttrs <- nameAnalysis header - -- check for errors and finalize- --- errs <- errorsPresent- if errs- then do- traceInfoErr- errmsgs <- showErrors- fatal ("C header contains \- \errors:\n\n" ++ errmsgs) -- fatal error- else do- traceInfoOK- warnmsgs <- showErrors- return (headerWithAttrs, warnmsgs)- where- traceInfoRead fname = putTraceStr tracePhasesSW- ("Attempting to read file `"- ++ fname ++ "'...\n")- traceInfoParse = putTraceStr tracePhasesSW - ("...parsing `" - ++ fname ++ "'...\n")- traceInfoNA = putTraceStr tracePhasesSW - ("...name analysis of `" - ++ fname ++ "'...\n")- traceInfoErr = putTraceStr tracePhasesSW- ("...error(s) detected in `"- ++ fname ++ "'.\n")- traceInfoOK = putTraceStr tracePhasesSW- ("...successfully loaded `"- ++ fname ++ "'.\n")+ -- check for errors and finalize+ --+ errs <- errorsPresent+ if errs+ then do+ traceInfoErr+ errmsgs <- showErrors+ fatal ("C header contains \+ \errors:\n\n" ++ errmsgs) -- fatal error+ else do+ traceInfoOK+ warnmsgs <- showErrors+ return (headerWithAttrs, warnmsgs)+ where+ traceInfoRead fname = putTraceStr tracePhasesSW+ ("Attempting to read file `"+ ++ fname ++ "'...\n")+ traceInfoParse = putTraceStr tracePhasesSW + ("...parsing `" + ++ fname ++ "'...\n")+ traceInfoNA = putTraceStr tracePhasesSW + ("...name analysis of `" + ++ fname ++ "'...\n")+ traceInfoErr = putTraceStr tracePhasesSW+ ("...error(s) detected in `"+ ++ fname ++ "'.\n")+ traceInfoOK = putTraceStr tracePhasesSW+ ("...successfully loaded `"+ ++ fname ++ "'.\n")
c2hs/c/CAST.hs view
@@ -41,8 +41,8 @@ -- module CAST (CHeader(..), CExtDecl(..), CFunDef(..), CStat(..), CBlockItem(..),- CDecl(..), CDeclSpec(..), CStorageSpec(..), CTypeSpec(..),- CTypeQual(..), CStructUnion(..), CStructTag(..), CEnum(..),+ CDecl(..), CDeclSpec(..), CStorageSpec(..), CTypeSpec(..),+ CTypeQual(..), CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..), CInit(..), CInitList, CDesignator(..), CExpr(..), CAssignOp(..), CBinaryOp(..), CUnaryOp(..), CConst (..)) where@@ -56,7 +56,7 @@ -- a complete C header file (K&R A10) (EXPORTED) -- data CHeader = CHeader [CExtDecl]- Attrs+ Attrs instance Pos CHeader where posOf (CHeader _ at) = posOf at@@ -67,14 +67,14 @@ -- external C declaration (K&R A10) (EXPORTED) -- data CExtDecl = CDeclExt CDecl- | CFDefExt CFunDef- | CAsmExt Attrs -- a chunk of assembly code (which is- -- not itself recorded)+ | CFDefExt CFunDef+ | CAsmExt Attrs -- a chunk of assembly code (which is+ -- not itself recorded) instance Pos CExtDecl where posOf (CDeclExt decl) = posOf decl posOf (CFDefExt fdef) = posOf fdef- posOf (CAsmExt at) = posOf at+ posOf (CAsmExt at) = posOf at instance Eq CExtDecl where CDeclExt decl1 == CDeclExt decl2 = decl1 == decl2@@ -92,11 +92,11 @@ -- -- * The statement must be a compound statement. ---data CFunDef = CFunDef [CDeclSpec] -- type specifier and qualifier- CDeclr -- declarator- [CDecl] -- optional declaration list- CStat -- compound statement- Attrs+data CFunDef = CFunDef [CDeclSpec] -- type specifier and qualifier+ CDeclr -- declarator+ [CDecl] -- optional declaration list+ CStat -- compound statement+ Attrs instance Pos CFunDef where posOf (CFunDef _ _ _ _ at) = posOf at@@ -106,49 +106,49 @@ -- C statement (A9) (EXPORTED) ---data CStat = CLabel Ident -- label- CStat- Attrs- | CCase CExpr -- constant expression- CStat- Attrs- | CCases CExpr -- case range- CExpr -- `case lower .. upper :'- CStat- Attrs- | CDefault CStat -- default case- Attrs- | CExpr (Maybe CExpr) -- expression statement, maybe empty- Attrs- | CCompound [CBlockItem] -- list of declarations and statements- Attrs- | CIf CExpr -- conditional expression- CStat- (Maybe CStat) -- optional "else" case- Attrs- | CSwitch CExpr -- selector- CStat- Attrs+data CStat = CLabel Ident -- label+ CStat+ Attrs+ | CCase CExpr -- constant expression+ CStat+ Attrs+ | CCases CExpr -- case range+ CExpr -- `case lower .. upper :'+ CStat+ Attrs+ | CDefault CStat -- default case+ Attrs+ | CExpr (Maybe CExpr) -- expression statement, maybe empty+ Attrs+ | CCompound [CBlockItem] -- list of declarations and statements+ Attrs+ | CIf CExpr -- conditional expression+ CStat+ (Maybe CStat) -- optional "else" case+ Attrs+ | CSwitch CExpr -- selector+ CStat+ Attrs | CWhile CExpr- CStat- Bool -- `True' implies "do-while" statement- Attrs+ CStat+ Bool -- `True' implies "do-while" statement+ Attrs | CFor (Either (Maybe CExpr)- CDecl)- (Maybe CExpr)- (Maybe CExpr)- CStat- Attrs- | CGoto Ident -- label- Attrs- | CGotoPtr CExpr -- computed address- Attrs- | CCont Attrs -- continue statement- | CBreak Attrs -- break statement- | CReturn (Maybe CExpr)- Attrs- | CAsm Attrs -- a chunk of assembly code (which is- -- not itself recorded)+ CDecl)+ (Maybe CExpr)+ (Maybe CExpr)+ CStat+ Attrs+ | CGoto Ident -- label+ Attrs+ | CGotoPtr CExpr -- computed address+ Attrs+ | CCont Attrs -- continue statement+ | CBreak Attrs -- break statement+ | CReturn (Maybe CExpr)+ Attrs+ | CAsm Attrs -- a chunk of assembly code (which is+ -- not itself recorded) instance Pos CStat where posOf (CLabel _ _ at) = posOf at@@ -161,11 +161,11 @@ posOf (CSwitch _ _ at) = posOf at posOf (CWhile _ _ _ at) = posOf at posOf (CFor _ _ _ _ at) = posOf at- posOf (CGoto _ at) = posOf at+ posOf (CGoto _ at) = posOf at posOf (CGotoPtr _ at) = posOf at- posOf (CCont at) = posOf at- posOf (CBreak at) = posOf at- posOf (CReturn _ at) = posOf at+ posOf (CCont at) = posOf at+ posOf (CBreak at) = posOf at+ posOf (CReturn _ at) = posOf at posOf (CAsm at) = posOf at instance Eq CStat where@@ -179,17 +179,17 @@ (CSwitch _ _ at1) == (CSwitch _ _ at2) = at1 == at2 (CWhile _ _ _ at1) == (CWhile _ _ _ at2) = at1 == at2 (CFor _ _ _ _ at1) == (CFor _ _ _ _ at2) = at1 == at2- (CGoto _ at1) == (CGoto _ at2) = at1 == at2- (CGotoPtr _ at1) == (CGotoPtr _ at2) = at1 == at2- (CCont at1) == (CCont at2) = at1 == at2- (CBreak at1) == (CBreak at2) = at1 == at2- (CReturn _ at1) == (CReturn _ at2) = at1 == at2+ (CGoto _ at1) == (CGoto _ at2) = at1 == at2+ (CGotoPtr _ at1) == (CGotoPtr _ at2) = at1 == at2+ (CCont at1) == (CCont at2) = at1 == at2+ (CBreak at1) == (CBreak at2) = at1 == at2+ (CReturn _ at1) == (CReturn _ at2) = at1 == at2 (CAsm at1) == (CAsm at2) = at1 == at2 -- C99 Block items, things that may appear in compound statements data CBlockItem = CBlockStmt CStat | CBlockDecl CDecl- | CNestedFunDef CFunDef -- GNU C has nested functions+ | CNestedFunDef CFunDef -- GNU C has nested functions instance Pos CBlockItem where posOf (CBlockStmt stmt) = posOf stmt@@ -244,11 +244,11 @@ -- where the declarator must be abstract, ie, must not contain a declared -- identifier. ---data CDecl = CDecl [CDeclSpec] -- type specifier and qualifier- [(Maybe CDeclr, -- declarator (may be omitted)- Maybe CInit, -- optional initializer- Maybe CExpr)] -- optional size (const expr)- Attrs+data CDecl = CDecl [CDeclSpec] -- type specifier and qualifier+ [(Maybe CDeclr, -- declarator (may be omitted)+ Maybe CInit, -- optional initializer+ Maybe CExpr)] -- optional size (const expr)+ Attrs instance Pos CDecl where posOf (CDecl _ _ at) = posOf at@@ -259,9 +259,9 @@ -- C declaration specifiers and qualifiers (EXPORTED) -- data CDeclSpec = CStorageSpec CStorageSpec- | CTypeSpec CTypeSpec- | CTypeQual CTypeQual- deriving (Eq)+ | CTypeSpec CTypeSpec+ | CTypeQual CTypeQual+ deriving (Eq) instance Pos CDeclSpec where posOf (CStorageSpec sspec) = posOf sspec@@ -271,11 +271,11 @@ -- C storage class specifier (K&R A8.1) (EXPORTED) -- data CStorageSpec = CAuto Attrs- | CRegister Attrs- | CStatic Attrs- | CExtern Attrs- | CTypedef Attrs -- syntactic awkwardness of C- | CThread Attrs -- GNUC thread local storage+ | CRegister Attrs+ | CStatic Attrs+ | CExtern Attrs+ | CTypedef Attrs -- syntactic awkwardness of C+ | CThread Attrs -- GNUC thread local storage instance Pos CStorageSpec where posOf (CAuto at) = posOf at@@ -296,26 +296,26 @@ -- C type specifier (K&R A8.2) (EXPORTED) -- data CTypeSpec = CVoidType Attrs- | CCharType Attrs- | CShortType Attrs- | CIntType Attrs- | CLongType Attrs- | CFloatType Attrs- | CDoubleType Attrs- | CSignedType Attrs- | CUnsigType Attrs- | CBoolType Attrs- | CComplexType Attrs- | CSUType CStructUnion- Attrs- | CEnumType CEnum- Attrs- | CTypeDef Ident -- typedef name- Attrs+ | CCharType Attrs+ | CShortType Attrs+ | CIntType Attrs+ | CLongType Attrs+ | CFloatType Attrs+ | CDoubleType Attrs+ | CSignedType Attrs+ | CUnsigType Attrs+ | CBoolType Attrs+ | CComplexType Attrs+ | CSUType CStructUnion+ Attrs+ | CEnumType CEnum+ Attrs+ | CTypeDef Ident -- typedef name+ Attrs | CTypeOfExpr CExpr- Attrs+ Attrs | CTypeOfType CDecl- Attrs+ Attrs instance Pos CTypeSpec where posOf (CVoidType at) = posOf at@@ -358,9 +358,9 @@ -- * plus `restrict' from C99 and `inline' -- data CTypeQual = CConstQual Attrs- | CVolatQual Attrs- | CRestrQual Attrs- | CInlinQual Attrs+ | CVolatQual Attrs+ | CRestrQual Attrs+ | CInlinQual Attrs instance Pos CTypeQual where posOf (CConstQual at) = posOf at@@ -380,9 +380,9 @@ -- non-empty -- data CStructUnion = CStruct CStructTag- (Maybe Ident)- [CDecl] -- *structure* declaration- Attrs+ (Maybe Ident)+ [CDecl] -- *structure* declaration+ Attrs instance Pos CStructUnion where posOf (CStruct _ _ _ at) = posOf at@@ -393,15 +393,15 @@ -- (EXPORTED) -- data CStructTag = CStructTag- | CUnionTag- deriving (Eq)+ | CUnionTag+ deriving (Eq) -- C enumeration declaration (K&R A8.4) (EXPORTED) -- data CEnum = CEnum (Maybe Ident)- [(Ident, -- variant name- Maybe CExpr)] -- explicit variant value- Attrs+ [(Ident, -- variant name+ Maybe CExpr)] -- explicit variant value+ Attrs instance Pos CEnum where posOf (CEnum _ _ at) = posOf at@@ -435,19 +435,19 @@ -- * We unfold K&R's parameter-type-list nonterminal into the declarator -- variant for functions. ---data CDeclr = CVarDeclr (Maybe Ident) -- declared identifier- Attrs- | CPtrDeclr [CTypeQual] -- indirections- CDeclr- Attrs+data CDeclr = CVarDeclr (Maybe Ident) -- declared identifier+ Attrs+ | CPtrDeclr [CTypeQual] -- indirections+ CDeclr+ Attrs | CArrDeclr CDeclr [CTypeQual]- (Maybe CExpr) -- array size- Attrs- | CFunDeclr CDeclr- [CDecl] -- *parameter* declarations- Bool -- is variadic?- Attrs+ (Maybe CExpr) -- array size+ Attrs+ | CFunDeclr CDeclr+ [CDecl] -- *parameter* declarations+ Bool -- is variadic?+ Attrs instance Pos CDeclr where posOf (CVarDeclr _ at) = posOf at@@ -464,9 +464,9 @@ -- C initializer (K&R A8.7) (EXPORTED) -- data CInit = CInitExpr CExpr- Attrs -- assignment expression+ Attrs -- assignment expression | CInitList CInitList- Attrs+ Attrs type CInitList = [([CDesignator], CInit)] @@ -481,12 +481,12 @@ -- C initializer designator (EXPORTED) -- data CDesignator = CArrDesig CExpr- Attrs+ Attrs | CMemberDesig Ident- Attrs- | CRangeDesig CExpr -- GNUC array range designator- CExpr- Attrs+ Attrs+ | CRangeDesig CExpr -- GNUC array range designator+ CExpr+ Attrs instance Pos CDesignator where posOf (CArrDesig _ at) = posOf at@@ -505,56 +505,56 @@ -- -- * GNU C extension: `alignof' ---data CExpr = CComma [CExpr] -- comma expression list, n >= 2- Attrs- | CAssign CAssignOp -- assignment operator- CExpr -- l-value- CExpr -- r-value- Attrs- | CCond CExpr -- conditional- (Maybe CExpr) -- true-expression (GNU allows omitting)- CExpr -- false-expression- Attrs- | CBinary CBinaryOp -- binary operator- CExpr -- lhs- CExpr -- rhs- Attrs- | CCast CDecl -- type name- CExpr- Attrs- | CUnary CUnaryOp -- unary operator- CExpr- Attrs- | CSizeofExpr CExpr- Attrs- | CSizeofType CDecl -- type name- Attrs- | CAlignofExpr CExpr- Attrs- | CAlignofType CDecl -- type name- Attrs- | CIndex CExpr -- array- CExpr -- index- Attrs- | CCall CExpr -- function- [CExpr] -- arguments- Attrs- | CMember CExpr -- structure- Ident -- member name- Bool -- deref structure? (True for `->')- Attrs- | CVar Ident -- identifier (incl. enumeration const)- Attrs- | CConst CConst -- includes strings- Attrs- | CCompoundLit CDecl -- C99 compound literal- CInitList -- type name & initialiser list- Attrs- | CStatExpr CStat -- GNUC compound statement as expr- Attrs+data CExpr = CComma [CExpr] -- comma expression list, n >= 2+ Attrs+ | CAssign CAssignOp -- assignment operator+ CExpr -- l-value+ CExpr -- r-value+ Attrs+ | CCond CExpr -- conditional+ (Maybe CExpr) -- true-expression (GNU allows omitting)+ CExpr -- false-expression+ Attrs+ | CBinary CBinaryOp -- binary operator+ CExpr -- lhs+ CExpr -- rhs+ Attrs+ | CCast CDecl -- type name+ CExpr+ Attrs+ | CUnary CUnaryOp -- unary operator+ CExpr+ Attrs+ | CSizeofExpr CExpr+ Attrs+ | CSizeofType CDecl -- type name+ Attrs+ | CAlignofExpr CExpr+ Attrs+ | CAlignofType CDecl -- type name+ Attrs+ | CIndex CExpr -- array+ CExpr -- index+ Attrs+ | CCall CExpr -- function+ [CExpr] -- arguments+ Attrs+ | CMember CExpr -- structure+ Ident -- member name+ Bool -- deref structure? (True for `->')+ Attrs+ | CVar Ident -- identifier (incl. enumeration const)+ Attrs+ | CConst CConst -- includes strings+ Attrs+ | CCompoundLit CDecl -- C99 compound literal+ CInitList -- type name & initialiser list+ Attrs+ | CStatExpr CStat -- GNUC compound statement as expr+ Attrs | CLabAddrExpr Ident -- GNUC address of label- Attrs- | CBuiltinExpr Attrs -- place holder for GNUC builtin exprs+ Attrs+ | CBuiltinExpr Attrs -- place holder for GNUC builtin exprs instance Pos CExpr where posOf (CComma _ at) = posOf at@@ -578,21 +578,21 @@ posOf (CBuiltinExpr at) = posOf at instance Eq CExpr where- (CComma _ at1) == (CComma _ at2) = at1 == at2- (CAssign _ _ _ at1) == (CAssign _ _ _ at2) = at1 == at2- (CCond _ _ _ at1) == (CCond _ _ _ at2) = at1 == at2- (CBinary _ _ _ at1) == (CBinary _ _ _ at2) = at1 == at2- (CCast _ _ at1) == (CCast _ _ at2) = at1 == at2- (CUnary _ _ at1) == (CUnary _ _ at2) = at1 == at2- (CSizeofExpr _ at1) == (CSizeofExpr _ at2) = at1 == at2- (CSizeofType _ at1) == (CSizeofType _ at2) = at1 == at2+ (CComma _ at1) == (CComma _ at2) = at1 == at2+ (CAssign _ _ _ at1) == (CAssign _ _ _ at2) = at1 == at2+ (CCond _ _ _ at1) == (CCond _ _ _ at2) = at1 == at2+ (CBinary _ _ _ at1) == (CBinary _ _ _ at2) = at1 == at2+ (CCast _ _ at1) == (CCast _ _ at2) = at1 == at2+ (CUnary _ _ at1) == (CUnary _ _ at2) = at1 == at2+ (CSizeofExpr _ at1) == (CSizeofExpr _ at2) = at1 == at2+ (CSizeofType _ at1) == (CSizeofType _ at2) = at1 == at2 (CAlignofExpr _ at1) == (CAlignofExpr _ at2) = at1 == at2 (CAlignofType _ at1) == (CAlignofType _ at2) = at1 == at2- (CIndex _ _ at1) == (CIndex _ _ at2) = at1 == at2- (CCall _ _ at1) == (CCall _ _ at2) = at1 == at2- (CMember _ _ _ at1) == (CMember _ _ _ at2) = at1 == at2- (CVar _ at1) == (CVar _ at2) = at1 == at2- (CConst _ at1) == (CConst _ at2) = at1 == at2+ (CIndex _ _ at1) == (CIndex _ _ at2) = at1 == at2+ (CCall _ _ at1) == (CCall _ _ at2) = at1 == at2+ (CMember _ _ _ at1) == (CMember _ _ _ at2) = at1 == at2+ (CVar _ at1) == (CVar _ at2) = at1 == at2+ (CConst _ at1) == (CConst _ at2) = at1 == at2 (CCompoundLit _ _ at1) == (CCompoundLit _ _ at2) = at1 == at2 (CStatExpr _ at1) == (CStatExpr _ at2) = at1 == at2 (CLabAddrExpr _ at1) == (CLabAddrExpr _ at2) = at1 == at2@@ -601,66 +601,66 @@ -- C assignment operators (K&R A7.17) (EXPORTED) -- data CAssignOp = CAssignOp- | CMulAssOp- | CDivAssOp- | CRmdAssOp -- remainder and assignment- | CAddAssOp- | CSubAssOp- | CShlAssOp- | CShrAssOp- | CAndAssOp- | CXorAssOp- | COrAssOp- deriving (Eq)+ | CMulAssOp+ | CDivAssOp+ | CRmdAssOp -- remainder and assignment+ | CAddAssOp+ | CSubAssOp+ | CShlAssOp+ | CShrAssOp+ | CAndAssOp+ | CXorAssOp+ | COrAssOp+ deriving (Eq) -- C binary operators (K&R A7.6-15) (EXPORTED) -- data CBinaryOp = CMulOp- | CDivOp- | CRmdOp -- remainder of division- | CAddOp- | CSubOp- | CShlOp -- shift left- | CShrOp -- shift right- | CLeOp -- less- | CGrOp -- greater- | CLeqOp -- less or equal- | CGeqOp -- greater or equal- | CEqOp -- equal- | CNeqOp -- not equal- | CAndOp -- bitwise and- | CXorOp -- exclusive bitwise or- | COrOp -- inclusive bitwise or- | CLndOp -- logical and- | CLorOp -- logical or- deriving (Eq)+ | CDivOp+ | CRmdOp -- remainder of division+ | CAddOp+ | CSubOp+ | CShlOp -- shift left+ | CShrOp -- shift right+ | CLeOp -- less+ | CGrOp -- greater+ | CLeqOp -- less or equal+ | CGeqOp -- greater or equal+ | CEqOp -- equal+ | CNeqOp -- not equal+ | CAndOp -- bitwise and+ | CXorOp -- exclusive bitwise or+ | COrOp -- inclusive bitwise or+ | CLndOp -- logical and+ | CLorOp -- logical or+ deriving (Eq) -- C unary operator (K&R A7.3-4) (EXPORTED) ---data CUnaryOp = CPreIncOp -- prefix increment operator- | CPreDecOp -- prefix decrement operator- | CPostIncOp -- postfix increment operator- | CPostDecOp -- postfix decrement operator- | CAdrOp -- address operator- | CIndOp -- indirection operator- | CPlusOp -- prefix plus- | CMinOp -- prefix minus- | CCompOp -- one's complement- | CNegOp -- logical negation- deriving (Eq)+data CUnaryOp = CPreIncOp -- prefix increment operator+ | CPreDecOp -- prefix decrement operator+ | CPostIncOp -- postfix increment operator+ | CPostDecOp -- postfix decrement operator+ | CAdrOp -- address operator+ | CIndOp -- indirection operator+ | CPlusOp -- prefix plus+ | CMinOp -- prefix minus+ | CCompOp -- one's complement+ | CNegOp -- logical negation+ deriving (Eq) -- C constant (K&R A2.5 & A7.2) (EXPORTED) -- -- * we do not list enumeration constants here, as they are identifiers -- data CConst = CIntConst Integer- Attrs- | CCharConst Char- Attrs- | CFloatConst String- Attrs- | CStrConst String- Attrs+ Attrs+ | CCharConst Char+ Attrs+ | CFloatConst String+ Attrs+ | CStrConst String+ Attrs instance Pos CConst where posOf (CIntConst _ at) = posOf at
c2hs/c/CAttrs.hs view
@@ -55,30 +55,30 @@ -- module CAttrs (-- attributed C- --- AttrC, attrC, getCHeader, enterNewRangeC, enterNewObjRangeC,- leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,- lookupDefObjCShadow, addDefTagC, lookupDefTagC,- lookupDefTagCShadow, applyPrefix, getDefOfIdentC,- setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC,- softenDefOfIdentsAttrC,- --- -- C objects- --- CObj(..), CTag(..), CDef(..))+ --+ AttrC, attrC, getCHeader, enterNewRangeC, enterNewObjRangeC,+ leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,+ lookupDefObjCShadow, addDefTagC, lookupDefTagC,+ lookupDefTagCShadow, applyPrefix, getDefOfIdentC,+ setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC,+ softenDefOfIdentsAttrC,+ --+ -- C objects+ --+ CObj(..), CTag(..), CDef(..)) where -import Data.Char (toUpper)+import Data.Char (toUpper) import Data.List (isPrefixOf)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe) import Position (Position, Pos(posOf), nopos, dontCarePos, builtinPos) import Errors (interr)-import Idents (Ident, getIdentAttrs, identToLexeme, onlyPosIdent)+import Idents (Ident, getIdentAttrs, identToLexeme, onlyPosIdent) import Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr,- newAttrTable, freezeAttrTable, softenAttrTable)+ newAttrTable, freezeAttrTable, softenAttrTable) import NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal,- defGlobal, find, nameSpaceToList)+ defGlobal, find, nameSpaceToList) import Binary (Binary(..), putByte, getByte) import CAST@@ -91,23 +91,23 @@ -- (EXPORTED ABSTRACT) -- data AttrC = AttrC {- headerAC :: CHeader, -- raw header- defObjsAC :: CObjNS, -- defined objects- defTagsAC :: CTagNS, -- defined tags- shadowsAC :: CShadowNS, -- shadow definitions (prefix)- defsAC :: CDefTable -- ident-def associations- }+ headerAC :: CHeader, -- raw header+ defObjsAC :: CObjNS, -- defined objects+ defTagsAC :: CTagNS, -- defined tags+ shadowsAC :: CShadowNS, -- shadow definitions (prefix)+ defsAC :: CDefTable -- ident-def associations+ } -- make an attribute structure tree from a raw one (EXPORTED) -- attrC :: CHeader -> AttrC attrC header = AttrC {- headerAC = header, - defObjsAC = cObjNS,- defTagsAC = cTagNS,- shadowsAC = cShadowNS,- defsAC = cDefTable- }+ headerAC = header, + defObjsAC = cObjNS,+ defTagsAC = cTagNS,+ shadowsAC = cShadowNS,+ defsAC = cDefTable+ } -- extract the raw structure tree from an attributes one (EXPORTED) --@@ -122,31 +122,31 @@ -- enterNewRangeC :: AttrC -> AttrC enterNewRangeC ac = ac {- defObjsAC = enterNewRange . defObjsAC $ ac,- defTagsAC = enterNewRange . defTagsAC $ ac- }+ defObjsAC = enterNewRange . defObjsAC $ ac,+ defTagsAC = enterNewRange . defTagsAC $ ac+ } -- enter a new range, only for objects (EXPORTED) -- enterNewObjRangeC :: AttrC -> AttrC enterNewObjRangeC ac = ac {- defObjsAC = enterNewRange . defObjsAC $ ac- }+ defObjsAC = enterNewRange . defObjsAC $ ac+ } -- leave the current range (EXPORTED) -- leaveRangeC :: AttrC -> AttrC leaveRangeC ac = ac {- defObjsAC = fst . leaveRange . defObjsAC $ ac,- defTagsAC = fst . leaveRange . defTagsAC $ ac- }+ defObjsAC = fst . leaveRange . defObjsAC $ ac,+ defTagsAC = fst . leaveRange . defTagsAC $ ac+ } -- leave the current range, only for objects (EXPORTED) -- leaveObjRangeC :: AttrC -> AttrC leaveObjRangeC ac = ac {- defObjsAC = fst . leaveRange . defObjsAC $ ac- }+ defObjsAC = fst . leaveRange . defObjsAC $ ac+ } -- add another definitions to the object name space (EXPORTED) --@@ -154,9 +154,9 @@ -- addDefObjC :: AttrC -> Ident -> CObj -> (AttrC, Maybe CObj) addDefObjC ac ide obj = let om = defObjsAC ac- (ac', obj') = defLocal om ide obj- in- (ac {defObjsAC = ac'}, obj')+ (ac', obj') = defLocal om ide obj+ in+ (ac {defObjsAC = ac'}, obj') -- lookup an identifier in the object name space (EXPORTED) --@@ -173,10 +173,10 @@ case lookupDefObjC ac ide of Just obj -> Just (obj, ide) Nothing -> case find (shadowsAC ac) ide of- Nothing -> Nothing- Just ide' -> case lookupDefObjC ac ide' of- Just obj -> Just (obj, ide')- Nothing -> Nothing+ Nothing -> Nothing+ Just ide' -> case lookupDefObjC ac ide' of+ Just obj -> Just (obj, ide')+ Nothing -> Nothing -- add another definition to the tag name space (EXPORTED) --@@ -184,9 +184,9 @@ -- addDefTagC :: AttrC -> Ident -> CTag -> (AttrC, Maybe CTag) addDefTagC ac ide obj = let tm = defTagsAC ac- (ac', obj') = defLocal tm ide obj- in- (ac {defTagsAC = ac'}, obj')+ (ac', obj') = defLocal tm ide obj+ in+ (ac {defTagsAC = ac'}, obj') -- lookup an identifier in the tag name space (EXPORTED) --@@ -203,10 +203,10 @@ case lookupDefTagC ac ide of Just tag -> Just (tag, ide) Nothing -> case find (shadowsAC ac) ide of- Nothing -> Nothing- Just ide' -> case lookupDefTagC ac ide' of- Just tag -> Just (tag, ide')- Nothing -> Nothing+ Nothing -> Nothing+ Just ide' -> case lookupDefTagC ac ide' of+ Just tag -> Just (tag, ide')+ Nothing -> Nothing -- enrich the shadow name space with identifiers obtained by dropping -- the given prefix from the identifiers already in the object or tag name@@ -222,23 +222,23 @@ let shadows = shadowsAC ac names = map fst (nameSpaceToList (defObjsAC ac))- ++ map fst (nameSpaceToList (defTagsAC ac))+ ++ map fst (nameSpaceToList (defTagsAC ac)) newShadows = mapMaybe (strip prefix) names in ac {shadowsAC = foldl define shadows newShadows} where strip prefix ide = case eat prefix (identToLexeme ide) of- Nothing -> Nothing- Just "" -> Nothing- Just newName -> Just - (onlyPosIdent (posOf ide) newName,- ide)+ Nothing -> Nothing+ Just "" -> Nothing+ Just newName -> Just + (onlyPosIdent (posOf ide) newName,+ ide) -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs- | otherwise = Nothing- eat _ _ = Nothing+ | otherwise = Nothing+ eat _ _ = Nothing -- define ns (ide, def) = fst (defGlobal ns ide def) @@ -275,10 +275,10 @@ -- C objects data definition (EXPORTED) ---data CObj = TypeCO CDecl -- typedef declaration- | ObjCO CDecl -- object or function declaration- | EnumCO Ident CEnum -- enumerator- | BuiltinCO -- builtin object+data CObj = TypeCO CDecl -- typedef declaration+ | ObjCO CDecl -- object or function declaration+ | EnumCO Ident CEnum -- enumerator+ | BuiltinCO -- builtin object -- two C objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute@@ -288,7 +288,7 @@ (TypeCO decl1 ) == (TypeCO decl2 ) = decl1 == decl2 (ObjCO decl1 ) == (ObjCO decl2 ) = decl1 == decl2 (EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 == enum2- _ == _ = False+ _ == _ = False instance Pos CObj where posOf (TypeCO def ) = posOf def@@ -302,8 +302,8 @@ -- C tagged objects data definition (EXPORTED) ---data CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration- | EnumCT CEnum -- toplevel enum declaration+data CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration+ | EnumCT CEnum -- toplevel enum declaration -- two C tag objects are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute@@ -312,7 +312,7 @@ instance Eq CTag where (StructUnionCT struct1) == (StructUnionCT struct2) = struct1 == struct2 (EnumCT enum1 ) == (EnumCT enum2 ) = enum1 == enum2- _ == _ = False+ _ == _ = False instance Pos CTag where posOf (StructUnionCT def) = posOf def@@ -324,10 +324,10 @@ -- C general definition (EXPORTED) ---data CDef = UndefCD -- undefined object- | DontCareCD -- don't care object- | ObjCD CObj -- C object- | TagCD CTag -- C tag+data CDef = UndefCD -- undefined object+ | DontCareCD -- don't care object+ | ObjCD CObj -- C object+ | TagCD CTag -- C tag -- two C definitions are equal iff they are defined by the same structure -- tree node (i.e., the two nodes referenced have the same attribute@@ -337,23 +337,23 @@ instance Eq CDef where (ObjCD obj1) == (ObjCD obj2) = obj1 == obj2 (TagCD tag1) == (TagCD tag2) = tag1 == tag2- DontCareCD == _ = True- _ == DontCareCD = True- UndefCD == _ = + DontCareCD == _ = True+ _ == DontCareCD = True+ UndefCD == _ = interr "CAttrs: Attempt to compare an undefined C definition!"- _ == UndefCD = + _ == UndefCD = interr "CAttrs: Attempt to compare an undefined C definition!"- _ == _ = False+ _ == _ = False instance Attr CDef where undef = UndefCD dontCare = DontCareCD isUndef UndefCD = True- isUndef _ = False+ isUndef _ = False isDontCare DontCareCD = True- isDontCare _ = False+ isDontCare _ = False instance Pos CDef where posOf UndefCD = nopos
c2hs/c/CLexer.x view
@@ -66,7 +66,7 @@ module CLexer (lexC, parseError) where -import Data.Char (isDigit)+import Data.Char (isDigit, ord) import Data.Word (Word8) import Numeric (readDec, readOct, readHex)
c2hs/c/CNames.hs view
@@ -37,18 +37,18 @@ module CNames (nameAnalysis) where -import Control.Monad (when, mapM_)+import Control.Monad (when, mapM_) import Position (Position, posOf)-import Idents (Ident, identToLexeme)+import Idents (Ident, identToLexeme) import C2HSState (CST, nop) import CAST import CAttrs (AttrC, CObj(..), CTag(..), CDef(..)) import CBuiltin (builtinTypeNames) import CTrav (CT, getCHeaderCT, runCT, enter, enterObjs, leave, leaveObjs,- ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj,- defTag, refersToDef, isTypedef) + ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj,+ defTag, refersToDef, isTypedef) -- monad and wrapper@@ -62,8 +62,8 @@ -- nameAnalysis :: AttrC -> CST s AttrC nameAnalysis ac = do- (ac', _) <- runCT naCHeader ac ()- return ac'+ (ac', _) <- runCT naCHeader ac ()+ return ac' -- name analyis traversal@@ -75,14 +75,14 @@ -- naCHeader :: NA () naCHeader = do- -- establish definitions for builtins- --- mapM_ (uncurry defObjOrErr) builtinTypeNames- --- -- analyse the header- --- CHeader decls _ <- getCHeaderCT- mapM_ (\decl -> naCExtDecl decl `ifCTExc` nop) decls+ -- establish definitions for builtins+ --+ mapM_ (uncurry defObjOrErr) builtinTypeNames+ --+ -- analyse the header+ --+ CHeader decls _ <- getCHeaderCT+ mapM_ (\decl -> naCExtDecl decl `ifCTExc` nop) decls -- Processing of toplevel declarations --@@ -103,30 +103,30 @@ where naTriple (odeclr, oinit, oexpr) = do- let obj = if isTypedef decl then TypeCO decl else ObjCO decl+ let obj = if isTypedef decl then TypeCO decl else ObjCO decl mapMaybeM_ (naCDeclr obj) odeclr- mapMaybeM_ naCInit oinit- mapMaybeM_ naCExpr oexpr+ mapMaybeM_ naCInit oinit+ mapMaybeM_ naCExpr oexpr naCDeclSpec :: CDeclSpec -> NA () naCDeclSpec (CTypeSpec tspec) = naCTypeSpec tspec-naCDeclSpec _ = nop+naCDeclSpec _ = nop naCTypeSpec :: CTypeSpec -> NA () naCTypeSpec (CSUType su _) = naCStructUnion (StructUnionCT su) su naCTypeSpec (CEnumType enum _) = naCEnum (EnumCT enum) enum naCTypeSpec (CTypeDef ide _) = do- (obj, _) <- findTypeObj ide False- ide `refersToDef` ObjCD obj-naCTypeSpec _ = nop+ (obj, _) <- findTypeObj ide False+ ide `refersToDef` ObjCD obj+naCTypeSpec _ = nop naCStructUnion :: CTag -> CStructUnion -> NA () naCStructUnion tag (CStruct _ oide decls _) = do mapMaybeM_ (`defTagOrErr` tag) oide- enterObjs -- enter local struct range for objects+ enterObjs -- enter local struct range for objects mapM_ naCDecl decls- leaveObjs -- leave range+ leaveObjs -- leave range naCEnum :: CTag -> CEnum -> NA () naCEnum tag enum@(CEnum oide enumrs _) =@@ -135,8 +135,8 @@ mapM_ naEnumr enumrs where naEnumr (ide, oexpr) = do- ide `defObjOrErr` EnumCO ide enum- mapMaybeM_ naCExpr oexpr+ ide `defObjOrErr` EnumCO ide enum+ mapMaybeM_ naCExpr oexpr naCDeclr :: CObj -> CDeclr -> NA () naCDeclr obj (CVarDeclr oide _) =@@ -150,9 +150,9 @@ naCDeclr obj (CFunDeclr declr decls _ _ ) = do naCDeclr obj declr- enterObjs -- enter range of function arguments+ enterObjs -- enter range of function arguments mapM_ naCDecl decls- leaveObjs -- end of function arguments+ leaveObjs -- end of function arguments naCInit :: CInit -> NA () naCInit (CInitExpr expr _) = naCExpr expr@@ -162,21 +162,21 @@ naCExpr (CComma exprs _) = mapM_ naCExpr exprs naCExpr (CAssign _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2 naCExpr (CCond expr1 expr2 expr3 _) = naCExpr expr1 >> mapMaybeM_ naCExpr expr2- >> naCExpr expr3+ >> naCExpr expr3 naCExpr (CBinary _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2-naCExpr (CCast decl expr _) = naCDecl decl >> naCExpr expr-naCExpr (CUnary _ expr _) = naCExpr expr+naCExpr (CCast decl expr _) = naCDecl decl >> naCExpr expr+naCExpr (CUnary _ expr _) = naCExpr expr naCExpr (CSizeofExpr expr _) = naCExpr expr-naCExpr (CSizeofType decl _) = naCDecl decl+naCExpr (CSizeofType decl _) = naCDecl decl naCExpr (CAlignofExpr expr _) = naCExpr expr-naCExpr (CAlignofType decl _) = naCDecl decl-naCExpr (CIndex expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2-naCExpr (CCall expr exprs _) = naCExpr expr >> mapM_ naCExpr exprs+naCExpr (CAlignofType decl _) = naCDecl decl+naCExpr (CIndex expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2+naCExpr (CCall expr exprs _) = naCExpr expr >> mapM_ naCExpr exprs naCExpr (CMember expr ide _ _) = naCExpr expr-naCExpr (CVar ide _) = do- (obj, _) <- findValueObj ide False- ide `refersToDef` ObjCD obj-naCExpr (CConst _ _) = nop+naCExpr (CVar ide _) = do+ (obj, _) <- findValueObj ide False+ ide `refersToDef` ObjCD obj+naCExpr (CConst _ _) = nop naCExpr (CCompoundLit _ inits _) = mapM_ (naCInit . snd) inits @@ -187,10 +187,10 @@ -- defTagOrErr :: Ident -> CTag -> NA () ide `defTagOrErr` tag = do- otag <- ide `defTag` tag- case otag of- Nothing -> nop- Just tag' -> declaredTwiceErr ide (posOf tag')+ otag <- ide `defTag` tag+ case otag of+ Nothing -> nop+ Just tag' -> declaredTwiceErr ide (posOf tag') -- associate an object with a referring identifier --
c2hs/c/CParserMonad.hs view
@@ -58,7 +58,7 @@ import Position (Position(..), Pos(posOf)) import Errors (interr)-import UNames (Name)+import UNames (Name) import Idents (Ident, lexemeToIdent, identToLexeme) import Control.Applicative (Applicative(..))@@ -70,15 +70,15 @@ data ParseResult a = POk !PState a- | PFailed [String] Position -- The error message and position+ | PFailed [String] Position -- The error message and position data PState = PState { - curPos :: !Position, -- position at current input location- curInput :: !String, -- the current input- prevToken :: CToken, -- the previous token- namesupply :: ![Name], -- the name unique supply- tyidents :: !(Set Ident), -- the set of typedef'ed identifiers- scopes :: ![Set Ident] -- the tyident sets for outer scopes+ curPos :: !Position, -- position at current input location+ curInput :: !String, -- the current input+ prevToken :: CToken, -- the previous token+ namesupply :: ![Name], -- the name unique supply+ tyidents :: !(Set Ident), -- the set of typedef'ed identifiers+ scopes :: ![Set Ident] -- the tyident sets for outer scopes } newtype P a = P { unP :: PState -> ParseResult a }@@ -117,9 +117,9 @@ {-# INLINE thenP #-} thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \s ->- case m s of- POk s' a -> (unP (k a)) s'- PFailed err pos -> PFailed err pos+ case m s of+ POk s' a -> (unP (k a)) s'+ PFailed err pos -> PFailed err pos failP :: Position -> [String] -> P a failP pos msg = P $ \_ -> PFailed msg pos
c2hs/c/CTokens.hs view
@@ -34,124 +34,124 @@ -- possible tokens (EXPORTED) ---data CToken = CTokLParen !Position -- `('- | CTokRParen !Position -- `)'- | CTokLBracket !Position -- `['- | CTokRBracket !Position -- `]'- | CTokArrow !Position -- `->'- | CTokDot !Position -- `.'- | CTokExclam !Position -- `!'- | CTokTilde !Position -- `~'- | CTokInc !Position -- `++'- | CTokDec !Position -- `--'- | CTokPlus !Position -- `+'- | CTokMinus !Position -- `-'- | CTokStar !Position -- `*'- | CTokSlash !Position -- `/'- | CTokPercent !Position -- `%'- | CTokAmper !Position -- `&'- | CTokShiftL !Position -- `<<'- | CTokShiftR !Position -- `>>'- | CTokLess !Position -- `<'- | CTokLessEq !Position -- `<='- | CTokHigh !Position -- `>'- | CTokHighEq !Position -- `>='- | CTokEqual !Position -- `=='- | CTokUnequal !Position -- `!='- | CTokHat !Position -- `^'- | CTokBar !Position -- `|'- | CTokAnd !Position -- `&&'- | CTokOr !Position -- `||'- | CTokQuest !Position -- `?'- | CTokColon !Position -- `:'- | CTokAssign !Position -- `='- | CTokPlusAss !Position -- `+='- | CTokMinusAss !Position -- `-='- | CTokStarAss !Position -- `*='- | CTokSlashAss !Position -- `/='- | CTokPercAss !Position -- `%='- | CTokAmpAss !Position -- `&='- | CTokHatAss !Position -- `^='- | CTokBarAss !Position -- `|='- | CTokSLAss !Position -- `<<='- | CTokSRAss !Position -- `>>='- | CTokComma !Position -- `,'- | CTokSemic !Position -- `;'- | CTokLBrace !Position -- `{'- | CTokRBrace !Position --- | CTokEllipsis !Position -- `...'- | CTokAlignof !Position -- `alignof' - -- (or `__alignof', - -- `__alignof__')- | CTokAsm !Position -- `asm'- -- (or `__asm',- -- `__asm__')- | CTokAuto !Position -- `auto'- | CTokBreak !Position -- `break'- | CTokBool !Position -- `_Bool'- | CTokCase !Position -- `case'- | CTokChar !Position -- `char'- | CTokConst !Position -- `const' - -- (or `__const', `__const__')- | CTokContinue !Position -- `continue' - | CTokComplex !Position -- `_Complex' - | CTokDefault !Position -- `default'- | CTokDo !Position -- `do'- | CTokDouble !Position -- `double'- | CTokElse !Position -- `else'- | CTokEnum !Position -- `enum'- | CTokExtern !Position -- `extern'- | CTokFloat !Position -- `float'- | CTokFor !Position -- `for'- | CTokGoto !Position -- `goto'- | CTokIf !Position -- `if'- | CTokInline !Position -- `inline'- -- (or `__inline', - -- `__inline__')- | CTokInt !Position -- `int'- | CTokLong !Position -- `long'- | CTokLabel !Position -- `__label__'- | CTokRegister !Position -- `register'- | CTokRestrict !Position -- `restrict'- -- (or `__restrict', - -- `__restrict__')- | CTokReturn !Position -- `return'- | CTokShort !Position -- `short'- | CTokSigned !Position -- `signed'- -- (or `__signed', - -- `__signed__')- | CTokSizeof !Position -- `sizeof'- | CTokStatic !Position -- `static'- | CTokStruct !Position -- `struct'- | CTokSwitch !Position -- `switch'- | CTokTypedef !Position -- `typedef'- | CTokTypeof !Position -- `typeof'- | CTokThread !Position -- `__thread'- | CTokUnion !Position -- `union'- | CTokUnsigned !Position -- `unsigned'- | CTokVoid !Position -- `void'- | CTokVolatile !Position -- `volatile'- -- (or `__volatile', - -- `__volatile__')- | CTokWhile !Position -- `while'- | CTokCLit !Position !Char -- character constant- | CTokILit !Position !Integer -- integer constant- | CTokFLit !Position String -- float constant- | CTokSLit !Position String -- string constant (no escapes)- | CTokIdent !Position !Ident -- identifier+data CToken = CTokLParen !Position -- `('+ | CTokRParen !Position -- `)'+ | CTokLBracket !Position -- `['+ | CTokRBracket !Position -- `]'+ | CTokArrow !Position -- `->'+ | CTokDot !Position -- `.'+ | CTokExclam !Position -- `!'+ | CTokTilde !Position -- `~'+ | CTokInc !Position -- `++'+ | CTokDec !Position -- `--'+ | CTokPlus !Position -- `+'+ | CTokMinus !Position -- `-'+ | CTokStar !Position -- `*'+ | CTokSlash !Position -- `/'+ | CTokPercent !Position -- `%'+ | CTokAmper !Position -- `&'+ | CTokShiftL !Position -- `<<'+ | CTokShiftR !Position -- `>>'+ | CTokLess !Position -- `<'+ | CTokLessEq !Position -- `<='+ | CTokHigh !Position -- `>'+ | CTokHighEq !Position -- `>='+ | CTokEqual !Position -- `=='+ | CTokUnequal !Position -- `!='+ | CTokHat !Position -- `^'+ | CTokBar !Position -- `|'+ | CTokAnd !Position -- `&&'+ | CTokOr !Position -- `||'+ | CTokQuest !Position -- `?'+ | CTokColon !Position -- `:'+ | CTokAssign !Position -- `='+ | CTokPlusAss !Position -- `+='+ | CTokMinusAss !Position -- `-='+ | CTokStarAss !Position -- `*='+ | CTokSlashAss !Position -- `/='+ | CTokPercAss !Position -- `%='+ | CTokAmpAss !Position -- `&='+ | CTokHatAss !Position -- `^='+ | CTokBarAss !Position -- `|='+ | CTokSLAss !Position -- `<<='+ | CTokSRAss !Position -- `>>='+ | CTokComma !Position -- `,'+ | CTokSemic !Position -- `;'+ | CTokLBrace !Position -- `{'+ | CTokRBrace !Position --+ | CTokEllipsis !Position -- `...'+ | CTokAlignof !Position -- `alignof' + -- (or `__alignof', + -- `__alignof__')+ | CTokAsm !Position -- `asm'+ -- (or `__asm',+ -- `__asm__')+ | CTokAuto !Position -- `auto'+ | CTokBreak !Position -- `break'+ | CTokBool !Position -- `_Bool'+ | CTokCase !Position -- `case'+ | CTokChar !Position -- `char'+ | CTokConst !Position -- `const' + -- (or `__const', `__const__')+ | CTokContinue !Position -- `continue' + | CTokComplex !Position -- `_Complex' + | CTokDefault !Position -- `default'+ | CTokDo !Position -- `do'+ | CTokDouble !Position -- `double'+ | CTokElse !Position -- `else'+ | CTokEnum !Position -- `enum'+ | CTokExtern !Position -- `extern'+ | CTokFloat !Position -- `float'+ | CTokFor !Position -- `for'+ | CTokGoto !Position -- `goto'+ | CTokIf !Position -- `if'+ | CTokInline !Position -- `inline'+ -- (or `__inline', + -- `__inline__')+ | CTokInt !Position -- `int'+ | CTokLong !Position -- `long'+ | CTokLabel !Position -- `__label__'+ | CTokRegister !Position -- `register'+ | CTokRestrict !Position -- `restrict'+ -- (or `__restrict', + -- `__restrict__')+ | CTokReturn !Position -- `return'+ | CTokShort !Position -- `short'+ | CTokSigned !Position -- `signed'+ -- (or `__signed', + -- `__signed__')+ | CTokSizeof !Position -- `sizeof'+ | CTokStatic !Position -- `static'+ | CTokStruct !Position -- `struct'+ | CTokSwitch !Position -- `switch'+ | CTokTypedef !Position -- `typedef'+ | CTokTypeof !Position -- `typeof'+ | CTokThread !Position -- `__thread'+ | CTokUnion !Position -- `union'+ | CTokUnsigned !Position -- `unsigned'+ | CTokVoid !Position -- `void'+ | CTokVolatile !Position -- `volatile'+ -- (or `__volatile', + -- `__volatile__')+ | CTokWhile !Position -- `while'+ | CTokCLit !Position !Char -- character constant+ | CTokILit !Position !Integer -- integer constant+ | CTokFLit !Position String -- float constant+ | CTokSLit !Position String -- string constant (no escapes)+ | CTokIdent !Position !Ident -- identifier - -- not generated here, but in `CParser.parseCHeader'- | CTokTyIdent !Position !Ident -- `typedef-name' identifier- | CTokGnuC !GnuCTok !Position -- special GNU C tokens- | CTokEof -- end of file+ -- not generated here, but in `CParser.parseCHeader'+ | CTokTyIdent !Position !Ident -- `typedef-name' identifier+ | CTokGnuC !GnuCTok !Position -- special GNU C tokens+ | CTokEof -- end of file -- special tokens used in GNU C extensions to ANSI C ---data GnuCTok = GnuCAttrTok -- `__attribute__'- | GnuCExtTok -- `__extension__'- | GnuCVaArg -- `__builtin_va_arg'- | GnuCOffsetof -- `__builtin_offsetof'- | GnuCTyCompat -- `__builtin_types_compatible_p'+data GnuCTok = GnuCAttrTok -- `__attribute__'+ | GnuCExtTok -- `__extension__'+ | GnuCVaArg -- `__builtin_va_arg'+ | GnuCOffsetof -- `__builtin_offsetof'+ | GnuCTyCompat -- `__builtin_types_compatible_p' instance Pos CToken where posOf (CTokLParen pos ) = pos@@ -181,7 +181,7 @@ posOf (CTokHat pos ) = pos posOf (CTokBar pos ) = pos posOf (CTokAnd pos ) = pos- posOf (CTokOr pos ) = pos+ posOf (CTokOr pos ) = pos posOf (CTokQuest pos ) = pos posOf (CTokColon pos ) = pos posOf (CTokAssign pos ) = pos@@ -255,29 +255,29 @@ showsPrec _ (CTokLBracket _ ) = showString "[" showsPrec _ (CTokRBracket _ ) = showString "]" showsPrec _ (CTokArrow _ ) = showString "->"- showsPrec _ (CTokDot _ ) = showString "."+ showsPrec _ (CTokDot _ ) = showString "." showsPrec _ (CTokExclam _ ) = showString "!" showsPrec _ (CTokTilde _ ) = showString "~"- showsPrec _ (CTokInc _ ) = showString "++"- showsPrec _ (CTokDec _ ) = showString "--"- showsPrec _ (CTokPlus _ ) = showString "+"+ showsPrec _ (CTokInc _ ) = showString "++"+ showsPrec _ (CTokDec _ ) = showString "--"+ showsPrec _ (CTokPlus _ ) = showString "+" showsPrec _ (CTokMinus _ ) = showString "-"- showsPrec _ (CTokStar _ ) = showString "*"+ showsPrec _ (CTokStar _ ) = showString "*" showsPrec _ (CTokSlash _ ) = showString "/" showsPrec _ (CTokPercent _ ) = showString "%" showsPrec _ (CTokAmper _ ) = showString "&" showsPrec _ (CTokShiftL _ ) = showString "<<" showsPrec _ (CTokShiftR _ ) = showString ">>"- showsPrec _ (CTokLess _ ) = showString "<"+ showsPrec _ (CTokLess _ ) = showString "<" showsPrec _ (CTokLessEq _ ) = showString "<="- showsPrec _ (CTokHigh _ ) = showString ">"+ showsPrec _ (CTokHigh _ ) = showString ">" showsPrec _ (CTokHighEq _ ) = showString ">=" showsPrec _ (CTokEqual _ ) = showString "==" showsPrec _ (CTokUnequal _ ) = showString "!="- showsPrec _ (CTokHat _ ) = showString "^"- showsPrec _ (CTokBar _ ) = showString "|"- showsPrec _ (CTokAnd _ ) = showString "&&"- showsPrec _ (CTokOr _ ) = showString "||"+ showsPrec _ (CTokHat _ ) = showString "^"+ showsPrec _ (CTokBar _ ) = showString "|"+ showsPrec _ (CTokAnd _ ) = showString "&&"+ showsPrec _ (CTokOr _ ) = showString "||" showsPrec _ (CTokQuest _ ) = showString "?" showsPrec _ (CTokColon _ ) = showString ":" showsPrec _ (CTokAssign _ ) = showString "="
c2hs/c/CTrav.hs view
@@ -38,7 +38,7 @@ -- -- and ----- struct s ...; /* this is called a forward reference */+-- struct s ...; /* this is called a forward reference */ -- struct s {...} ...; -- -- In contrast enumerations only allow (in ANSI C)@@ -62,43 +62,43 @@ -- module CTrav (CT, readCT, transCT, getCHeaderCT, runCT, throwCTExc, ifCTExc,- raiseErrorCTExc,- enter, enterObjs, leave, leaveObjs, defObj, findObj,- findObjShadow, defTag, findTag, findTagShadow,- applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef,- getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj,- findFunObj,- --- -- C structure tree query functions- --- isTypedef, simplifyDecl, declrFromDecl, declrNamed,- declaredDeclr, declaredName, structMembers, expandDecl,- structName, enumName, tagName, isArrDeclr, isPtrDeclr, dropPtrDeclr,- isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs,- chaseDecl, findAndChaseDecl, checkForAlias,- checkForOneAliasName, lookupEnum, lookupStructUnion,- lookupDeclOrTag)+ raiseErrorCTExc,+ enter, enterObjs, leave, leaveObjs, defObj, findObj,+ findObjShadow, defTag, findTag, findTagShadow,+ applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef,+ getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj,+ findFunObj,+ --+ -- C structure tree query functions+ --+ isTypedef, simplifyDecl, declrFromDecl, declrNamed,+ declaredDeclr, declaredName, structMembers, expandDecl,+ structName, enumName, tagName, isArrDeclr, isPtrDeclr, dropPtrDeclr,+ isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs,+ chaseDecl, findAndChaseDecl, checkForAlias,+ checkForOneAliasName, lookupEnum, lookupStructUnion,+ lookupDeclOrTag) where import Data.List (find)-import Data.Maybe (fromMaybe)-import Control.Monad (liftM)+import Data.Maybe (fromMaybe)+import Control.Monad (liftM) import Control.Exception (assert) import Position (Position, Pos(..), nopos)-import Errors (interr)-import Idents (Ident, dumpIdent, identToLexeme)+import Errors (interr)+import Idents (Ident, dumpIdent, identToLexeme) import Attributes (Attr(..), newAttrsOnlyPos) import C2HSState (CST, nop, readCST, transCST, runCST, raiseError, catchExc,- throwExc, Traces(..), putTraceStr)+ throwExc, Traces(..), putTraceStr) import CAST import CAttrs (AttrC, getCHeader, enterNewRangeC, enterNewObjRangeC,- leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,- lookupDefObjCShadow, addDefTagC, lookupDefTagC,- lookupDefTagCShadow, applyPrefix, getDefOfIdentC,- setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..),- CDef(..)) + leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,+ lookupDefObjCShadow, addDefTagC, lookupDefTagC,+ lookupDefTagCShadow, applyPrefix, getDefOfIdentC,+ setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..),+ CDef(..)) -- the C traversal monad@@ -118,9 +118,9 @@ -- transAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a transAttrCCT trans = transCST $ \(ac, s) -> let- (ac', r) = trans ac- in- ((ac', s), r)+ (ac', r) = trans ac+ in+ ((ac', s), r) -- access to the user-defined state --@@ -134,9 +134,9 @@ -- transCT :: (s -> (s, a)) -> CT s a transCT trans = transCST $ \(ac, s) -> let- (s', r) = trans s- in- ((ac, s'), r)+ (s', r) = trans s+ in+ ((ac, s'), r) -- usage of a traversal monad --@@ -153,11 +153,11 @@ -- runCT :: CT s a -> AttrC -> s -> CST t (AttrC, a) runCT m ac s = runCST m' (ac, s)- where- m' = do- r <- m- (ac, _) <- readCST id- return (ac, r)+ where+ m' = do+ r <- m+ (ac, _) <- readCST id+ return (ac, r) -- exception handling@@ -246,14 +246,14 @@ otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag case otag of Nothing -> do- assertIfEnumThenFull tag- return Nothing -- no collision+ assertIfEnumThenFull tag+ return Nothing -- no collision Just prevTag -> case isRefinedOrUse prevTag tag of- Nothing -> return otag- Just (fullTag, foreIde) -> do- transAttrCCT $ \ac -> addDefTagC ac ide fullTag- foreIde `refersToDef` TagCD fullTag- return Nothing -- transparent for env+ Nothing -> return otag+ Just (fullTag, foreIde) -> do+ transAttrCCT $ \ac -> addDefTagC ac ide fullTag+ foreIde `refersToDef` TagCD fullTag+ return Nothing -- transparent for env where -- compute whether we have the case of a non-conflicting redefined tag -- definition, and if so, return the full definition and the foreward @@ -270,15 +270,15 @@ -- definition -- isRefinedOrUse (StructUnionCT (CStruct _ (Just ide) [] _))- tag@(StructUnionCT (CStruct _ (Just _ ) _ _)) = + tag@(StructUnionCT (CStruct _ (Just _ ) _ _)) = Just (tag, ide) isRefinedOrUse tag@(StructUnionCT (CStruct _ (Just _ ) _ _))- (StructUnionCT (CStruct _ (Just ide) [] _)) = + (StructUnionCT (CStruct _ (Just ide) [] _)) = Just (tag, ide) isRefinedOrUse tag@(EnumCT (CEnum (Just _ ) _ _))- (EnumCT (CEnum (Just ide) [] _)) = + (EnumCT (CEnum (Just ide) [] _)) = Just (tag, ide)- isRefinedOrUse _ _ = Nothing+ isRefinedOrUse _ _ = Nothing -- find an definition in the tag name space (EXPORTED) --@@ -312,9 +312,9 @@ -- getDefOf :: Ident -> CT s CDef getDefOf ide = do- def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide- assert (not . isUndef $ def) $- return def+ def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide+ assert (not . isUndef $ def) $+ return def -- set the definition of an identifier (EXPORTED) --@@ -339,26 +339,26 @@ DontCareCD -> interr "CTrav.getDeclOf: Don't care!" TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" ObjCD obj -> case obj of- TypeCO decl -> traceTypeCO >>- return decl- ObjCO decl -> traceObjCO >>- return decl- EnumCO _ _ -> illegalEnum- BuiltinCO -> illegalBuiltin+ TypeCO decl -> traceTypeCO >>+ return decl+ ObjCO decl -> traceObjCO >>+ return decl+ EnumCO _ _ -> illegalEnum+ BuiltinCO -> illegalBuiltin where illegalEnum = interr "CTrav.getDeclOf: Illegal enum!" illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \- \builtin entity!"- -- if the latter ever becomes necessary, we have to- -- change the representation of builtins and give them- -- some dummy declarator+ \builtin entity!"+ -- if the latter ever becomes necessary, we have to+ -- change the representation of builtins and give them+ -- some dummy declarator traceEnter = traceCTrav $ - "Entering `getDeclOf' for `" ++ identToLexeme ide - ++ "'...\n"+ "Entering `getDeclOf' for `" ++ identToLexeme ide + ++ "'...\n" traceTypeCO = traceCTrav $ - "...found a type object.\n"+ "...found a type object.\n" traceObjCO = traceCTrav $ - "...found a vanilla object.\n"+ "...found a vanilla object.\n" -- convenience functions@@ -373,13 +373,13 @@ findTypeObjMaybe ide useShadows = do oobj <- if useShadows - then findObjShadow ide - else liftM (fmap (\obj -> (obj, ide))) $ findObj ide+ then findObjShadow ide + else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(TypeCO _ , _) -> return $ Just obj Just obj@(BuiltinCO, _) -> return $ Just obj Just _ -> typedefExpectedErr ide- Nothing -> return $ Nothing+ Nothing -> return $ Nothing -- find a type object in the object name space; raises an error and exception -- if the identifier is not defined (EXPORTED)@@ -402,13 +402,13 @@ findValueObj ide useShadows = do oobj <- if useShadows - then findObjShadow ide - else liftM (fmap (\obj -> (obj, ide))) $ findObj ide+ then findObjShadow ide + else liftM (fmap (\obj -> (obj, ide))) $ findObj ide case oobj of Just obj@(ObjCO _ , _) -> return obj Just obj@(EnumCO _ _, _) -> return obj Just _ -> unexpectedTypedefErr (posOf ide)- Nothing -> unknownObjErr ide+ Nothing -> unknownObjErr ide -- find a function in the object name space; raises an error and exception if -- the identifier is not defined (EXPORTED) @@ -422,9 +422,9 @@ case obj of EnumCO _ _ -> funExpectedErr (posOf ide) ObjCO decl -> do- let declr = ide' `declrFromDecl` decl- assertFunDeclr (posOf ide) declr- return (obj, ide')+ let declr = ide' `declrFromDecl` decl+ assertFunDeclr (posOf ide) declr+ return (obj, ide') -- C structure tree query routines@@ -448,11 +448,11 @@ Just declr -> CDecl specs [declr] at where (Just declr, _, _) `declrPlusNamed` ide = declr `declrNamed` ide- _ `declrPlusNamed` _ = False+ _ `declrPlusNamed` _ = False -- err = interr $ "CTrav.simplifyDecl: Wrong C object!\n\- \ Looking for `" ++ identToLexeme ide ++ "' in decl \- \at " ++ show (posOf at)+ \ Looking for `" ++ identToLexeme ide ++ "' in decl \+ \at " ++ show (posOf at) -- extract the declarator that declares the given identifier (EXPORTED) --@@ -475,9 +475,9 @@ declaredDeclr :: CDecl -> Maybe CDeclr declaredDeclr (CDecl _ [] _) = Nothing declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr-declaredDeclr decl = +declaredDeclr decl = interr $ "CTrav.declaredDeclr: Too many declarators!\n\- \ Declaration at " ++ show (posOf decl)+ \ Declaration at " ++ show (posOf decl) -- get the name declared by a declaration that has exactly one declarator -- (EXPORTED) @@ -491,23 +491,23 @@ -- structMembers :: CStructUnion -> ([CDecl], CStructTag) structMembers (CStruct tag _ members _) = (concat . map expandDecl $ members,- tag)+ tag) -- expand declarators declaring more than one identifier into multiple -- declarators, eg, `int x, y;' becomes `int x; int y;' (EXPORTED) ---expandDecl :: CDecl -> [CDecl]+expandDecl :: CDecl -> [CDecl] expandDecl (CDecl specs decls at) = map (\decl -> CDecl specs [decl] at) decls -- get a struct's name (EXPORTED) ---structName :: CStructUnion -> Maybe Ident+structName :: CStructUnion -> Maybe Ident structName (CStruct _ oide _ _) = oide -- get an enum's name (EXPORTED) ---enumName :: CEnum -> Maybe Ident+enumName :: CEnum -> Maybe Ident enumName (CEnum oide _ _) = oide -- get a tag's name (EXPORTED)@@ -518,7 +518,7 @@ tagName tag = case tag of StructUnionCT struct -> maybe err id $ structName struct- EnumCT enum -> maybe err id $ enumName enum+ EnumCT enum -> maybe err id $ enumName enum where err = interr "CTrav.tagName: Anonymous tag definition" @@ -550,8 +550,8 @@ -- * the declarator must declare a pointer object -- -- FIXME: this implementation isn't nice, because we retain the `CVarDeclr'--- unchanged; as the declarator is changed, we should maybe make this--- into an anonymous declarator and also change its attributes+-- unchanged; as the declarator is changed, we should maybe make this+-- into an anonymous declarator and also change its attributes -- dropPtrDeclr :: CDeclr -> CDeclr dropPtrDeclr (CPtrDeclr qs declr@(CVarDeclr _ _) ats) = declr@@ -578,7 +578,7 @@ isPtrDecl :: CDecl -> Bool isPtrDecl (CDecl _ [] _) = False isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr-isPtrDecl _ =+isPtrDecl _ = interr "CTrav.isPtrDecl: There was more than one declarator!" -- checks whether the given declarator defines a function object (EXPORTED)@@ -588,7 +588,7 @@ isFunDeclr (CArrDeclr declr _ _ _) = isFunDeclr declr isFunDeclr (CFunDeclr (CVarDeclr _ _) _ _ _) = True isFunDeclr (CFunDeclr declr _ _ _) = isFunDeclr declr-isFunDeclr _ = False+isFunDeclr _ = False -- extract the structure from the type specifiers of a declaration (EXPORTED) --@@ -607,8 +607,8 @@ funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool) funResultAndArgs (CDecl specs [(Just declr, _, _)] _) = let (args, declr', variadic) = funArgs declr- result = CDecl specs [(Just declr', Nothing, Nothing)]- (newAttrsOnlyPos nopos)+ result = CDecl specs [(Just declr', Nothing, Nothing)]+ (newAttrsOnlyPos nopos) in (args, result, variadic) where@@ -656,9 +656,9 @@ Nothing -> return sdecl where traceEnter = traceCTrav $ - "Entering `chaseDecl' for `" ++ identToLexeme ide - ++ "' " ++ (if ind then "" else "not ") - ++ "following indirections...\n"+ "Entering `chaseDecl' for `" ++ identToLexeme ide + ++ "' " ++ (if ind then "" else "not ") + ++ "following indirections...\n" -- find type object in object name space and then chase it (EXPORTED) --@@ -674,7 +674,7 @@ do (obj, ide') <- findTypeObj ide useShadows -- is there an object def? ide `refersToNewDef` ObjCD obj- ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing+ ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind -- given a declaration (which must have exactly one declarator), if the@@ -706,16 +706,16 @@ lookupEnum ide useShadows = do otag <- if useShadows - then liftM (fmap fst) $ findTagShadow ide- else findTag ide+ then liftM (fmap fst) $ findTagShadow ide+ else findTag ide case otag of Just (StructUnionCT _ ) -> enumExpectedErr ide -- wrong tag definition- Just (EnumCT enum) -> return enum -- enum tag definition- Nothing -> do -- no tag definition- (CDecl specs _ _) <- findAndChaseDecl ide False useShadows- case head [ts | CTypeSpec ts <- specs] of- CEnumType enum _ -> return enum- _ -> enumExpectedErr ide+ Just (EnumCT enum) -> return enum -- enum tag definition+ Nothing -> do -- no tag definition+ (CDecl specs _ _) <- findAndChaseDecl ide False useShadows+ case head [ts | CTypeSpec ts <- specs] of+ CEnumType enum _ -> return enum+ _ -> enumExpectedErr ide -- for the given identifier, either find a struct/union in the tag name space -- or a type definition referring to a struct/union in the object name space;@@ -738,14 +738,14 @@ | otherwise = do otag <- if useShadows - then liftM (fmap fst) $ findTagShadow ide- else findTag ide+ then liftM (fmap fst) $ findTagShadow ide+ else findTag ide maybe chase (extractStruct (posOf ide)) otag -- `chase' if `Nothing' where chase = do- decl <- findAndChaseDecl ide ind useShadows- structFromDecl (posOf ide) decl+ decl <- findAndChaseDecl ide ind useShadows+ structFromDecl (posOf ide) decl -- for the given identifier, check for the existance of both a type definition -- or a struct, union, or enum definition (EXPORTED)@@ -756,19 +756,19 @@ -- -- * if the second argument is `True', look for shadows, too ---lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag)+lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag) lookupDeclOrTag ide useShadows = do oobj <- findTypeObjMaybe ide useShadows case oobj of Just (_, ide) -> liftM Left $ findAndChaseDecl ide False False - -- already did check shadows+ -- already did check shadows Nothing -> do otag <- if useShadows - then liftM (fmap fst) $ findTagShadow ide- else findTag ide- case otag of- Nothing -> unknownObjErr ide- Just tag -> return $ Right tag+ then liftM (fmap fst) $ findTagShadow ide+ else findTag ide+ case otag of+ Nothing -> unknownObjErr ide+ Just tag -> return $ Right tag -- auxiliary routines (internal)@@ -798,14 +798,14 @@ extractAlias :: CDecl -> Bool -> Maybe (Ident, Bool) extractAlias decl@(CDecl specs _ _) ind = case [ts | CTypeSpec ts <- specs] of- [CTypeDef ide' _] -> -- type spec is aliased ident+ [CTypeDef ide' _] -> -- type spec is aliased ident case declaredDeclr decl of- Nothing -> Just (ide', ind)- Just (CVarDeclr _ _ ) -> Just (ide', ind)- Just (CPtrDeclr [_] (CVarDeclr _ _) _)- | ind -> Just (ide', False)- | otherwise -> Nothing- _ -> Nothing+ Nothing -> Just (ide', ind)+ Just (CVarDeclr _ _ ) -> Just (ide', ind)+ Just (CPtrDeclr [_] (CVarDeclr _ _) _)+ | ind -> Just (ide', False)+ | otherwise -> Nothing+ _ -> Nothing _ -> Nothing -- if the given tag is a forward declaration of a structure, follow the@@ -817,12 +817,12 @@ extractStruct pos (EnumCT _ ) = structExpectedErr pos extractStruct pos (StructUnionCT su) = case su of- CStruct _ (Just ide') [] _ -> do -- found forward definition- def <- getDefOf ide'- case def of- TagCD tag -> extractStruct pos tag- _ -> err- _ -> return su+ CStruct _ (Just ide') [] _ -> do -- found forward definition+ def <- getDefOf ide'+ case def of+ TagCD tag -> extractStruct pos tag+ _ -> err+ _ -> return su where err = interr "CTrav.extractStruct: Illegal reference!" @@ -848,7 +848,7 @@ assertFunDeclr pos declr assertFunDeclr pos (CArrDeclr declr _ _ _) = assertFunDeclr pos declr-assertFunDeclr pos _ = +assertFunDeclr pos _ = funExpectedErr pos -- raise an error if the given tag defines an enumeration, but does not fully@@ -856,7 +856,7 @@ -- assertIfEnumThenFull :: CTag -> CT s () assertIfEnumThenFull (EnumCT (CEnum _ [] at)) = enumForwardErr (posOf at)-assertIfEnumThenFull _ = nop+assertIfEnumThenFull _ = nop -- trace for this module --@@ -889,7 +889,7 @@ illegalFunResultErr :: Position -> CT s a illegalFunResultErr pos = raiseErrorCTExc pos ["Function cannot return an array!",- "ANSI C does not allow functions to return an array."]+ "ANSI C does not allow functions to return an array."] funExpectedErr :: Position -> CT s a funExpectedErr pos =
c2hs/chs/CHS.hs view
@@ -50,16 +50,16 @@ -- -- hook -> `{#' inner `#}' -- inner -> `import' ['qualified'] ident--- | `context' ctxt--- | `type' ident--- | `sizeof' ident--- | `enum' idalias trans [`with' prefix] [deriving]--- | `call' [`pure'] [`unsafe'] [`nolock'] idalias--- | `fun' [`pure'] [`unsafe'] [`nolock'] idalias parms--- | `get' apath--- | `set' apath--- | `pointer' ['*'] idalias ptrkind--- | `class' [ident `=>'] ident ident+-- | `context' ctxt+-- | `type' ident+-- | `sizeof' ident+-- | `enum' idalias trans [`with' prefix] [deriving]+-- | `call' [`pure'] [`unsafe'] [`nolock'] idalias+-- | `fun' [`pure'] [`unsafe'] [`nolock'] idalias parms+-- | `get' apath+-- | `set' apath+-- | `pointer' ['*'] idalias ptrkind+-- | `class' [ident `=>'] ident ident -- ctxt -> [`lib' `=' string] [prefix] [lock] -- idalias -> ident [`as' (ident | `^')] -- prefix -> `prefix' `=' string@@ -68,46 +68,46 @@ -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm -- parm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*' | `-']] -- apath -> ident--- | `*' apath--- | apath `.' ident--- | apath `->' ident+-- | `*' apath+-- | apath `.' ident+-- | apath `->' ident -- trans -> `{' alias_1 `,' ... `,' alias_n `}' -- alias -> `underscoreToCase'--- | ident `as' ident+-- | ident `as' ident -- ptrkind -> [`foreign' | `stable' ] ['newtype' | '->' ident] -- -- If `underscoreToCase' occurs in a translation table, it must be the first -- entry. -- -- Remark: Optional Haskell names are normalised during structure tree--- construction, ie, associations that associated a name with itself--- are removed. (They don't carry semantic content, and make some--- tests more complicated.)+-- construction, ie, associations that associated a name with itself+-- are removed. (They don't carry semantic content, and make some+-- tests more complicated.) -- --- TODO ---------------------------------------------------------------------- -- module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..),- CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),- skipToLangPragma, hasCPP,- loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI,- chisuffix, showCHSParm)+ CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),+ skipToLangPragma, hasCPP,+ loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI,+ chisuffix, showCHSParm) where -- standard libraries-import Data.Char (isSpace, toUpper, toLower)-import Data.List (intersperse)-import Control.Monad (when, unless)+import Data.Char (isSpace, toUpper, toLower)+import Data.List (intersperse)+import Control.Monad (when, unless) -- Compiler Toolkit import Position (Position(..), Pos(posOf), nopos, isBuiltinPos)-import Errors (interr)+import Errors (interr) import Idents (Ident, identToLexeme, onlyPosIdent) -- C->Haskell import C2HSState (CST, nop, doesFileExistCIO, readFileCIO, writeFileCIO, getId, - getSwitch, chiPathSB, catchExc, throwExc, raiseError, - fatal, errorsPresent, showErrors, Traces(..), putTraceStr) + getSwitch, chiPathSB, catchExc, throwExc, raiseError, + fatal, errorsPresent, showErrors, Traces(..), putTraceStr) -- friends import CHSLexer (CHSToken(..), lexCHS)@@ -135,19 +135,19 @@ -- * `CHSCond' are strutured conditionals that are being generated by -- `GenHeader.genHeader' from conditional CPP directives (`CHSCPP') ---data CHSFrag = CHSVerb String -- Haskell code- Position- | CHSHook CHSHook -- binding hook- | CHSCPP String -- pre-processor directive- Position+data CHSFrag = CHSVerb String -- Haskell code+ Position+ | CHSHook CHSHook -- binding hook+ | CHSCPP String -- pre-processor directive+ Position | CHSLine Position -- line pragma- | CHSC String -- C code- Position- | CHSCond [(Ident, -- C variable repr. condition- [CHSFrag])] -- then/elif branches- (Maybe [CHSFrag]) -- else branch- | CHSLang [String] -- GHC language pragma- Position+ | CHSC String -- C code+ Position+ | CHSCond [(Ident, -- C variable repr. condition+ [CHSFrag])] -- then/elif branches+ (Maybe [CHSFrag]) -- else branch+ | CHSLang [String] -- GHC language pragma+ Position instance Pos CHSFrag where posOf (CHSVerb _ pos ) = pos@@ -156,59 +156,59 @@ posOf (CHSLine pos ) = pos posOf (CHSC _ pos ) = pos posOf (CHSCond alts _) = case alts of- (_, frag:_):_ -> posOf frag- _ -> nopos+ (_, frag:_):_ -> posOf frag+ _ -> nopos posOf (CHSLang _ pos) = pos -- a CHS binding hook (EXPORTED) ---data CHSHook = CHSImport Bool -- qualified?- Ident -- module name- String -- content of .chi file- Position- | CHSContext (Maybe String) -- library name- (Maybe String) -- prefix- (Maybe String) -- lock function- Position- | CHSType Ident -- C type- Position- | CHSSizeof Ident -- C type- Position- | CHSEnum Ident -- C enumeration type- (Maybe Ident) -- Haskell name- CHSTrans -- translation table- (Maybe String) -- local prefix- [Ident] -- instance requests from user- Position- | CHSCall Bool -- is a pure function?- Bool -- is unsafe?- Bool -- is without lock?- Ident -- C function- (Maybe Ident) -- Haskell name- Position- | CHSFun Bool -- is a pure function?- Bool -- is unsafe?- Bool -- is without lock?- Ident -- C function- (Maybe Ident) -- Haskell name- (Maybe String) -- type context- [CHSParm] -- argument marshalling- CHSParm -- result marshalling- Position- | CHSField CHSAccess -- access type- CHSAPath -- access path- Position - | CHSPointer Bool -- explicit '*' in hook- Ident -- C pointer name- (Maybe Ident) -- Haskell name- CHSPtrType -- Ptr, ForeignPtr or StablePtr- Bool -- create new type?- (Maybe Ident) -- Haskell type pointed to- Position- | CHSClass (Maybe Ident) -- superclass- Ident -- class name- Ident -- name of pointer type- Position+data CHSHook = CHSImport Bool -- qualified?+ Ident -- module name+ String -- content of .chi file+ Position+ | CHSContext (Maybe String) -- library name+ (Maybe String) -- prefix+ (Maybe String) -- lock function+ Position+ | CHSType Ident -- C type+ Position+ | CHSSizeof Ident -- C type+ Position+ | CHSEnum Ident -- C enumeration type+ (Maybe Ident) -- Haskell name+ CHSTrans -- translation table+ (Maybe String) -- local prefix+ [Ident] -- instance requests from user+ Position+ | CHSCall Bool -- is a pure function?+ Bool -- is unsafe?+ Bool -- is without lock?+ Ident -- C function+ (Maybe Ident) -- Haskell name+ Position+ | CHSFun Bool -- is a pure function?+ Bool -- is unsafe?+ Bool -- is without lock?+ Ident -- C function+ (Maybe Ident) -- Haskell name+ (Maybe String) -- type context+ [CHSParm] -- argument marshalling+ CHSParm -- result marshalling+ Position+ | CHSField CHSAccess -- access type+ CHSAPath -- access path+ Position + | CHSPointer Bool -- explicit '*' in hook+ Ident -- C pointer name+ (Maybe Ident) -- Haskell name+ CHSPtrType -- Ptr, ForeignPtr or StablePtr+ Bool -- create new type?+ (Maybe Ident) -- Haskell type pointed to+ Position+ | CHSClass (Maybe Ident) -- superclass+ Ident -- class name+ Ident -- name of pointer type+ Position instance Pos CHSHook where posOf (CHSImport _ _ _ pos) = pos@@ -220,7 +220,7 @@ posOf (CHSFun _ _ _ _ _ _ _ _ pos) = pos posOf (CHSField _ _ pos) = pos posOf (CHSPointer _ _ _ _ _ _ pos) = pos- posOf (CHSClass _ _ _ pos) = pos+ posOf (CHSClass _ _ _ pos) = pos -- two hooks are equal if they have the same Haskell name and reference the -- same C object @@ -240,12 +240,12 @@ (CHSCall _ _ _ ide1 oalias1 _) == (CHSCall _ _ _ ide2 oalias2 _) = oalias1 == oalias2 && ide1 == ide2 (CHSFun _ _ _ ide1 oalias1 _ _ _ _) - == (CHSFun _ _ _ ide2 oalias2 _ _ _ _) = + == (CHSFun _ _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSField acc1 path1 _) == (CHSField acc2 path2 _) = acc1 == acc2 && path1 == path2 (CHSPointer _ ide1 oalias1 _ _ _ _) - == (CHSPointer _ ide2 oalias2 _ _ _ _) =+ == (CHSPointer _ ide2 oalias2 _ _ _ _) = ide1 == ide2 && oalias1 == oalias2 (CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) = ide1 == ide2@@ -253,52 +253,52 @@ -- translation table (EXPORTED) ---data CHSTrans = CHSTrans Bool -- underscore to case?- [(Ident, Ident)] -- alias list+data CHSTrans = CHSTrans Bool -- underscore to case?+ [(Ident, Ident)] -- alias list -- marshalling descriptor for function hooks (EXPORTED) -- -- * a marshaller consists of a function name and flag indicating whether it -- has to be executed in the IO monad ---data CHSParm = CHSParm (Maybe (Ident, CHSArg)) -- "in" marshaller- String -- Haskell type- Bool -- C repr: two values?- (Maybe (Ident, CHSArg)) -- "out" marshaller- Position+data CHSParm = CHSParm (Maybe (Ident, CHSArg)) -- "in" marshaller+ String -- Haskell type+ Bool -- C repr: two values?+ (Maybe (Ident, CHSArg)) -- "out" marshaller+ Position -- kinds of arguments in function hooks (EXPORTED) ---data CHSArg = CHSValArg -- plain value argument- | CHSIOArg -- reference argument- | CHSVoidArg -- no argument- deriving (Eq)+data CHSArg = CHSValArg -- plain value argument+ | CHSIOArg -- reference argument+ | CHSVoidArg -- no argument+ deriving (Eq) -- structure member access types (EXPORTED) ---data CHSAccess = CHSSet -- set structure field- | CHSGet -- get structure field- deriving (Eq)+data CHSAccess = CHSSet -- set structure field+ | CHSGet -- get structure field+ deriving (Eq) -- structure access path (EXPORTED) ---data CHSAPath = CHSRoot Ident -- root of access path- | CHSDeref CHSAPath Position -- dereferencing- | CHSRef CHSAPath Ident -- member referencing- deriving (Eq)+data CHSAPath = CHSRoot Ident -- root of access path+ | CHSDeref CHSAPath Position -- dereferencing+ | CHSRef CHSAPath Ident -- member referencing+ deriving (Eq) -- pointer options (EXPORTED) -- -data CHSPtrType = CHSPtr -- standard Ptr from Haskell- | CHSForeignPtr -- a pointer with a finalizer- | CHSStablePtr -- a pointer into Haskell land- deriving (Eq)+data CHSPtrType = CHSPtr -- standard Ptr from Haskell+ | CHSForeignPtr -- a pointer with a finalizer+ | CHSStablePtr -- a pointer into Haskell land+ deriving (Eq) instance Show CHSPtrType where- show CHSPtr = "Ptr"- show CHSForeignPtr = "ForeignPtr"- show CHSStablePtr = "StablePtr"+ show CHSPtr = "Ptr"+ show CHSForeignPtr = "ForeignPtr"+ show CHSStablePtr = "StablePtr" instance Read CHSPtrType where readsPrec _ ( 'P':'t':'r':rest) = @@ -308,8 +308,8 @@ readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) = [(CHSStablePtr, rest)] readsPrec p (c:cs)- | isSpace c = readsPrec p cs- readsPrec _ _ = []+ | isSpace c = readsPrec p cs+ readsPrec _ _ = [] -- return a modified module description that starts off with a LANGUAGE pragma@@ -355,24 +355,24 @@ traceInfoErr errmsgs <- showErrors fatal ("CHS module contains \- \errors:\n\n" ++ errmsgs) -- fatal error+ \errors:\n\n" ++ errmsgs) -- fatal error else do traceInfoOK warnmsgs <- showErrors return (mod, warnmsgs) where traceInfoRead fname = putTraceStr tracePhasesSW- ("Attempting to read file `"- ++ fname ++ "'...\n")+ ("Attempting to read file `"+ ++ fname ++ "'...\n") traceInfoParse = putTraceStr tracePhasesSW - ("...parsing `" - ++ fname ++ "'...\n")+ ("...parsing `" + ++ fname ++ "'...\n") traceInfoErr = putTraceStr tracePhasesSW- ("...error(s) detected in `"- ++ fname ++ "'.\n")+ ("...error(s) detected in `"+ ++ fname ++ "'.\n") traceInfoOK = putTraceStr tracePhasesSW- ("...successfully loaded `"- ++ fname ++ "'.\n")+ ("...successfully loaded `"+ ++ fname ++ "'.\n") -- given a file name (no suffix) and a CHS module, the module is printed -- into that file (EXPORTED)@@ -385,23 +385,23 @@ dumpCHS fname mod pureHaskell = do let (suffix, kind) = if pureHaskell- then (hssuffix , "(Haskell)")- else (chssuffix, "(C->HS binding)")+ then (hssuffix , "(Haskell)")+ else (chssuffix, "(C->HS binding)") (version, _, _) <- getId writeFileCIO (fname ++ suffix) (contents version kind) where contents version kind | hasCPP mod = showCHSModule mod pureHaskell- | otherwise = + | otherwise = "-- GENERATED by " ++ version ++ " " ++ kind ++ "\n\ \-- Edit the ORIGNAL .chs file instead!\n\n" ++ showCHSModule mod pureHaskell -- to keep track of the current state of the line emission automaton ---data LineState = Emit -- emit LINE pragma if next frag is Haskell- | Wait -- emit LINE pragma after the next '\n'- | NoLine -- no pragma needed- deriving (Eq)+data LineState = Emit -- emit LINE pragma if next frag is Haskell+ | Wait -- emit LINE pragma after the next '\n'+ | NoLine -- no pragma needed+ deriving (Eq) -- convert a CHS module into a string --@@ -420,18 +420,18 @@ showFrags _ _ [] = id showFrags pureHs state (CHSVerb s pos : frags) = let- (Position fname line _) = pos- generated = isBuiltinPos pos- emitNow = state == Emit || - (state == Wait && not (null s) && nlStart)- nlStart = head s == '\n'- nextState = if generated then Wait else NoLine+ (Position fname line _) = pos+ generated = isBuiltinPos pos+ emitNow = state == Emit || + (state == Wait && not (null s) && nlStart)+ nlStart = head s == '\n'+ nextState = if generated then Wait else NoLine in- (if emitNow then- showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ - show fname ++ " #-}" ++- (if nlStart then "" else "\n"))- else id)+ (if emitNow then+ showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ + show fname ++ " #-}" +++ (if nlStart then "" else "\n"))+ else id) . showString s . showFrags pureHs nextState frags showFrags False _ (CHSHook hook : frags) = @@ -456,7 +456,7 @@ showFrags pureHs _ (CHSLang exts _ : frags) = let extsNoCPP = filter ((/=) "CPP") exts in if null extsNoCPP then showFrags pureHs Emit frags else- showString "{-# LANGUAGE "+ showString "{-# LANGUAGE " . showString (concat (intersperse "," extsNoCPP)) . showString " #-}\n" . showFrags pureHs Emit frags@@ -523,7 +523,7 @@ . (case ptrType of CHSForeignPtr -> showString " foreign" CHSStablePtr -> showString " stable"- _ -> showString "")+ _ -> showString "") . (case (isNewtype, oRefType) of (True , _ ) -> showString " newtype" (False, Just ide) -> showString " -> " . showCHSIdent ide@@ -540,9 +540,9 @@ showPrefix :: Maybe String -> Bool -> ShowS showPrefix Nothing _ = showString "" showPrefix (Just prefix) withWith = maybeWith - . showString "prefix = " - . showString prefix - . showString " "+ . showString "prefix = " + . showString prefix + . showString " " where maybeWith = if withWith then showString "with " else id @@ -564,10 +564,10 @@ where showOMarsh Nothing = id showOMarsh (Just (ide, argKind)) = showCHSIdent ide- . (case argKind of- CHSValArg -> id- CHSIOArg -> showString "*"- CHSVoidArg -> showString "-")+ . (case argKind of+ CHSValArg -> id+ CHSIOArg -> showString "*"+ CHSVoidArg -> showString "-") -- showHsVerb str = showChar '`' . showString str . showChar '\'' @@ -581,7 +581,7 @@ maybeComma = if null assocs then "" else ", " -- showAssoc (ide1, ide2) =- showCHSIdent ide1+ showCHSIdent ide1 . showString " as " . showCHSIdent ide2 @@ -634,60 +634,60 @@ -- loadCHI :: FilePath -> CST s String loadCHI fname = do- -- search for .chi files- --- paths <- getSwitch chiPathSB- let fullnames = [path ++ '/':fname ++ chisuffix | - path <- paths]- fullname <- findFirst fullnames- (fatal $ fname++chisuffix++" not found in:\n"++- unlines paths)- -- read file- --- traceInfoRead fullname- contents <- readFileCIO fullname+ -- search for .chi files+ --+ paths <- getSwitch chiPathSB+ let fullnames = [path ++ '/':fname ++ chisuffix | + path <- paths]+ fullname <- findFirst fullnames+ (fatal $ fname++chisuffix++" not found in:\n"+++ unlines paths)+ -- read file+ --+ traceInfoRead fullname+ contents <- readFileCIO fullname - -- parse- --- traceInfoVersion- let ls = lines contents- when (null ls) $- errorCHICorrupt fname- let versline:chi = ls- prefixLen = length versionPrefix- when (length versline < prefixLen- || take prefixLen versline /= versionPrefix) $- errorCHICorrupt fname- let versline' = drop prefixLen versline- (major, minor) <- case majorMinor versline' of- Nothing -> errorCHICorrupt fname- Just majMin -> return majMin- - (version, _, _) <- getId- let Just (myMajor, myMinor) = majorMinor version- when (major /= myMajor || minor /= myMinor) $- errorCHIVersion fname - (major ++ "." ++ minor) (myMajor ++ "." ++ myMinor)+ -- parse+ --+ traceInfoVersion+ let ls = lines contents+ when (null ls) $+ errorCHICorrupt fname+ let versline:chi = ls+ prefixLen = length versionPrefix+ when (length versline < prefixLen+ || take prefixLen versline /= versionPrefix) $+ errorCHICorrupt fname+ let versline' = drop prefixLen versline+ (major, minor) <- case majorMinor versline' of+ Nothing -> errorCHICorrupt fname+ Just majMin -> return majMin+ + (version, _, _) <- getId+ let Just (myMajor, myMinor) = majorMinor version+ when (major /= myMajor || minor /= myMinor) $+ errorCHIVersion fname + (major ++ "." ++ minor) (myMajor ++ "." ++ myMinor) - -- finalize- --- traceInfoOK- return $ concat chi- where- traceInfoRead fname = putTraceStr tracePhasesSW- ("Attempting to read file `"- ++ fname ++ "'...\n")- traceInfoVersion = putTraceStr tracePhasesSW - ("...checking version `" - ++ fname ++ "'...\n")- traceInfoOK = putTraceStr tracePhasesSW- ("...successfully loaded `"- ++ fname ++ "'.\n")- findFirst [] err = err- findFirst (p:aths) err = do- e <- doesFileExistCIO p- if e then return p else findFirst aths err- + -- finalize+ --+ traceInfoOK+ return $ concat chi+ where+ traceInfoRead fname = putTraceStr tracePhasesSW+ ("Attempting to read file `"+ ++ fname ++ "'...\n")+ traceInfoVersion = putTraceStr tracePhasesSW + ("...checking version `" + ++ fname ++ "'...\n")+ traceInfoOK = putTraceStr tracePhasesSW+ ("...successfully loaded `"+ ++ fname ++ "'.\n")+ findFirst [] err = err+ findFirst (p:aths) err = do+ e <- doesFileExistCIO p+ if e then return p else findFirst aths err+ -- given a file name (no suffix) and a CHI file, the information is printed -- into that file (EXPORTED)@@ -705,9 +705,9 @@ -- majorMinor :: String -> Maybe (String, String) majorMinor vers = let (major, rest) = break (== '.') vers- (minor, _ ) = break (== '.') . tail $ rest- in- if null rest then Nothing else Just (major, minor)+ (minor, _ ) = break (== '.') . tail $ rest+ in+ if null rest then Nothing else Just (major, minor) -- parsing a CHS token stream@@ -732,9 +732,9 @@ -- parseCHSModule :: Position -> String -> CST s CHSModule parseCHSModule pos cs = do- toks <- lexCHS cs pos- frags <- parseFrags toks- return (CHSModule frags)+ toks <- lexCHS cs pos+ frags <- parseFrags toks+ return (CHSModule frags) -- parsing of code fragments --@@ -747,23 +747,23 @@ -- parseFrags :: [CHSToken] -> CST s [CHSFrag] parseFrags toks = do- parseFrags0 toks- `ifError` contFrags toks+ parseFrags0 toks+ `ifError` contFrags toks where parseFrags0 :: [CHSToken] -> CST s [CHSFrag] parseFrags0 [] = return [] parseFrags0 (CHSTokHaskell pos s:toks) = do- frags <- parseFrags toks- return $ CHSVerb s pos : frags+ frags <- parseFrags toks+ return $ CHSVerb s pos : frags parseFrags0 (CHSTokCtrl pos c:toks) = do- frags <- parseFrags toks- return $ CHSVerb [c] pos : frags+ frags <- parseFrags toks+ return $ CHSVerb [c] pos : frags parseFrags0 (CHSTokCPP pos s:toks) = do- frags <- parseFrags toks- return $ CHSCPP s pos : frags+ frags <- parseFrags toks+ return $ CHSCPP s pos : frags parseFrags0 (CHSTokLine pos :toks) = do- frags <- parseFrags toks- return $ CHSLine pos : frags+ frags <- parseFrags toks+ return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks parseFrags0 (CHSTokImport pos :toks) = parseImport pos toks parseFrags0 (CHSTokContext pos :toks) = parseContext pos toks@@ -776,8 +776,8 @@ parseFrags0 (CHSTokSet pos :toks) = parseField pos CHSSet toks parseFrags0 (CHSTokClass pos :toks) = parseClass pos toks parseFrags0 (CHSTokPointer pos :toks) = parsePointer pos toks- parseFrags0 (CHSTokPragma pos :toks) = parsePragma pos toks- parseFrags0 toks = syntaxError toks+ parseFrags0 (CHSTokPragma pos :toks) = parsePragma pos toks+ parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token --@@ -793,12 +793,12 @@ return $ CHSC s pos : frags where collectCtrlAndC (CHSTokCtrl pos c:toks) = do- frags <- collectCtrlAndC toks- return $ CHSC [c] pos : frags+ frags <- collectCtrlAndC toks+ return $ CHSC [c] pos : frags collectCtrlAndC (CHSTokC pos s:toks) = do- frags <- collectCtrlAndC toks- return $ CHSC s pos : frags- collectCtrlAndC toks = parseFrags toks+ frags <- collectCtrlAndC toks+ return $ CHSC s pos : frags+ collectCtrlAndC toks = parseFrags toks parseImport :: Position -> [CHSToken] -> CST s [CHSFrag] parseImport pos toks = do@@ -810,7 +810,7 @@ CHSTokQualif _: CHSTokIdent _ ide:toks -> let (ide', toks') = rebuildModuleId ide toks in return (True , ide', toks')- _ -> syntaxError toks+ _ -> syntaxError toks let fName = moduleNameToFileName . identToLexeme $ modid toks'' <- parseEndHook toks' frags <- parseFrags toks''@@ -832,13 +832,13 @@ parseContext :: Position -> [CHSToken] -> CST s [CHSFrag] parseContext pos toks = do- (olib , toks ) <- parseOptLib toks- (opref , toks) <- parseOptPrefix False toks- (olock , toks) <- parseOptLock toks- toks <- parseEndHook toks- frags <- parseFrags toks- let frag = CHSContext olib opref olock pos- return $ CHSHook frag : frags+ (olib , toks ) <- parseOptLib toks+ (opref , toks) <- parseOptPrefix False toks+ (olock , toks) <- parseOptLock toks+ toks <- parseEndHook toks+ frags <- parseFrags toks+ let frag = CHSContext olib opref olock pos+ return $ CHSHook frag : frags parseType :: Position -> [CHSToken] -> CST s [CHSFrag] parseType pos (CHSTokIdent _ ide:toks) =@@ -862,14 +862,14 @@ (oalias, toks' ) <- parseOptAs ide True toks (trans , toks'') <- parseTrans toks' (oprefix, toks''') <- parseOptPrefix True toks''- (derive, toks'''') <- parseDerive toks'''- toks''''' <- parseEndHook toks''''- frags <- parseFrags toks'''''+ (derive, toks'''') <- parseDerive toks'''+ toks''''' <- parseEndHook toks''''+ frags <- parseFrags toks''''' return $ CHSHook (CHSEnum ide (norm oalias) trans oprefix derive pos) : frags where norm Nothing = Nothing norm (Just ide') | ide == ide' = Nothing- | otherwise = Just ide'+ | otherwise = Just ide' parseEnum _ toks = syntaxError toks parseCall :: Position -> [CHSToken] -> CST s [CHSFrag]@@ -880,7 +880,7 @@ (isNolock, toks ) <- parseIsNolock toks (ide , toks ) <- parseIdent toks (oalias , toks ) <- parseOptAs ide False toks- toks <- parseEndHook toks+ toks <- parseEndHook toks frags <- parseFrags toks return $ CHSHook (CHSCall isPure isUnsafe isNolock ide (norm ide oalias) pos) : frags@@ -894,10 +894,10 @@ (ide , toks'4) <- parseIdent toks'3 (oalias , toks'5) <- parseOptAs ide False toks'4 (octxt , toks'6) <- parseOptContext toks'5- (parms , toks'7) <- parseParms toks'6- (parm , toks'8) <- parseParm toks'7- toks'9 <- parseEndHook toks'8- frags <- parseFrags toks'9+ (parms , toks'7) <- parseParms toks'6+ (parm , toks'8) <- parseParm toks'7+ toks'9 <- parseEndHook toks'8+ frags <- parseFrags toks'9 return $ CHSHook (CHSFun isPure isUnsafe isNolock ide (norm ide oalias) octxt parms parm pos) :@@ -905,14 +905,14 @@ where parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks) = return (Just ctxt, toks)- parseOptContext toks =+ parseOptContext toks = return (Nothing , toks) -- parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks) = return ([], toks) parseParms (CHSTokLBrace _ :toks) = parseParms' (CHSTokComma nopos:toks)- parseParms toks = + parseParms toks = syntaxError toks -- parseParms' (CHSTokRBrace _:CHSTokArrow _:toks) = return ([], toks)@@ -922,26 +922,26 @@ return (parm:parms, toks'') parseParms' (CHSTokRBrace _ :toks) = syntaxError toks -- gives better error messages- parseParms' toks = syntaxError toks+ parseParms' toks = syntaxError toks parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsPure (CHSTokPure _:toks) = return (True , toks) parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat.-parseIsPure toks = return (False, toks)+parseIsPure toks = return (False, toks) -- FIXME: eventually, remove `fun'; it's currently deprecated parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks)-parseIsUnsafe toks = return (False, toks)+parseIsUnsafe toks = return (False, toks) parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsNolock (CHSTokNolock _:toks) = return (True , toks)-parseIsNolock toks = return (False, toks)+parseIsNolock toks = return (False, toks) norm :: Ident -> Maybe Ident -> Maybe Ident norm ide Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing- | otherwise = Just ide'+ | otherwise = Just ide' parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) parseParm toks =@@ -949,11 +949,11 @@ (oimMarsh, toks' ) <- parseOptMarsh toks (hsTyStr, twoCVals, pos, toks'2) <- case toks' of- (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) -> - return (hsTyStr, True , pos, toks'2)- (CHSTokHSVerb pos hsTyStr :toks'2) -> - return (hsTyStr, False, pos, toks'2)- toks -> syntaxError toks+ (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) -> + return (hsTyStr, True , pos, toks'2)+ (CHSTokHSVerb pos hsTyStr :toks'2) -> + return (hsTyStr, False, pos, toks'2)+ toks -> syntaxError toks (oomMarsh, toks'3) <- parseOptMarsh toks'2 return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3) where@@ -964,7 +964,7 @@ return (Just (ide, CHSVoidArg), toks) parseOptMarsh (CHSTokIdent _ ide :toks) = return (Just (ide, CHSValArg) , toks)- parseOptMarsh toks =+ parseOptMarsh toks = return (Nothing, toks) parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]@@ -979,18 +979,18 @@ do (isStar, ide, toks') <- case toks of- CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks')- CHSTokIdent _ ide :toks' -> return (False, ide, toks')- _ -> syntaxError toks+ CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks')+ CHSTokIdent _ ide :toks' -> return (False, ide, toks')+ _ -> syntaxError toks (oalias , toks'2) <- parseOptAs ide True toks' (ptrType, toks'3) <- parsePtrType toks'2 let (isNewtype, oRefType, toks'4) = case toks'3 of- CHSTokNewtype _ :toks' -> (True , Nothing , toks' )- CHSTokArrow _:CHSTokIdent _ ide:toks' -> (False, Just ide, toks' )- _ -> (False, Nothing , toks'3)- toks'5 <- parseEndHook toks'4+ CHSTokNewtype _ :toks' -> (True , Nothing , toks' )+ CHSTokArrow _:CHSTokIdent _ ide:toks' -> (False, Just ide, toks' )+ _ -> (False, Nothing , toks'3)+ toks'5 <- parseEndHook toks'4 frags <- parseFrags toks'5 return $ CHSHook @@ -1000,11 +1000,11 @@ parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken]) parsePtrType (CHSTokForeign _:toks) = return (CHSForeignPtr, toks) parsePtrType (CHSTokStable _ :toks) = return (CHSStablePtr, toks)- parsePtrType toks = return (CHSPtr, toks)+ parsePtrType toks = return (CHSPtr, toks) norm ide Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing- | otherwise = Just ide'+ | otherwise = Just ide' parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag] parsePragma pos toks = do@@ -1020,17 +1020,17 @@ parseClass :: Position -> [CHSToken] -> CST s [CHSFrag] parseClass pos (CHSTokIdent _ sclassIde:- CHSTokDArrow _ :- CHSTokIdent _ classIde :- CHSTokIdent _ typeIde :- toks) =+ CHSTokDArrow _ :+ CHSTokIdent _ classIde :+ CHSTokIdent _ typeIde :+ toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' return $ CHSHook (CHSClass (Just sclassIde) classIde typeIde pos) : frags parseClass pos (CHSTokIdent _ classIde :- CHSTokIdent _ typeIde :- toks) =+ CHSTokIdent _ typeIde :+ toks) = do toks' <- parseEndHook toks frags <- parseFrags toks'@@ -1039,33 +1039,33 @@ parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ :- CHSTokEqual _ :- CHSTokString _ str:- toks) = return (Just str, toks)-parseOptLib (CHSTokLib _:toks ) = syntaxError toks-parseOptLib toks = return (Nothing, toks)+ CHSTokEqual _ :+ CHSTokString _ str:+ toks) = return (Just str, toks)+parseOptLib (CHSTokLib _:toks ) = syntaxError toks+parseOptLib toks = return (Nothing, toks) parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLock (CHSTokLock _ :- CHSTokEqual _ :- CHSTokString _ str:- toks) = return (Just str, toks)-parseOptLock (CHSTokLock _:toks ) = syntaxError toks-parseOptLock toks = return (Nothing, toks)+ CHSTokEqual _ :+ CHSTokString _ str:+ toks) = return (Just str, toks)+parseOptLock (CHSTokLock _:toks ) = syntaxError toks+parseOptLock toks = return (Nothing, toks) parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptPrefix False (CHSTokPrefix _ :- CHSTokEqual _ :- CHSTokString _ str:- toks) = return (Just str, toks)+ CHSTokEqual _ :+ CHSTokString _ str:+ toks) = return (Just str, toks) parseOptPrefix True (CHSTokWith _ :- CHSTokPrefix _ :- CHSTokEqual _ :- CHSTokString _ str:- toks) = return (Just str, toks)+ CHSTokPrefix _ :+ CHSTokEqual _ :+ CHSTokString _ str:+ toks) = return (Just str, toks) parseOptPrefix _ (CHSTokWith _:toks) = syntaxError toks parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks-parseOptPrefix _ toks = return (Nothing, toks)+parseOptPrefix _ toks = return (Nothing, toks) -- first argument is the identifier that is to be used when `^' is given and -- the second indicates whether the first character has to be upper case@@ -1076,7 +1076,7 @@ parseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) = return (Just $ underscoreToCase ide upper pos, toks) parseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks-parseOptAs _ _ toks = +parseOptAs _ _ toks = return (Nothing, toks) -- convert C style identifier to Haskell style identifier@@ -1089,10 +1089,10 @@ onlyPosIdent pos . adjustHead . concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s- in - l : case s' of- [] -> []- (_:s'') -> parts s''+ in + l : case s' of+ [] -> []+ (_:s'') -> parts s'' -- adjustCase (c:cs) = toUpper c : map toLower cs --@@ -1138,25 +1138,25 @@ (_2Case, toks' ) <- parse_2Case toks case toks' of (CHSTokRBrace _:toks'') -> return (CHSTrans _2Case [], toks'')- _ ->+ _ -> do- -- if there was no `underscoreToCase', we add a comma token to meet- -- the invariant of `parseTranss'- --- (transs, toks'') <- if _2Case - then parseTranss toks'- else parseTranss (CHSTokComma nopos:toks')+ -- if there was no `underscoreToCase', we add a comma token to meet+ -- the invariant of `parseTranss'+ --+ (transs, toks'') <- if _2Case + then parseTranss toks'+ else parseTranss (CHSTokComma nopos:toks') return (CHSTrans _2Case transs, toks'') where parse_2Case (CHSTok_2Case _:toks) = return (True, toks)- parse_2Case toks = return (False, toks)+ parse_2Case toks = return (False, toks) -- parseTranss (CHSTokRBrace _:toks) = return ([], toks) parseTranss (CHSTokComma _:toks) = do- (assoc, toks' ) <- parseAssoc toks- (trans, toks'') <- parseTranss toks'- return (assoc:trans, toks'')- parseTranss toks = syntaxError toks+ (assoc, toks' ) <- parseAssoc toks+ (trans, toks'') <- parseTranss toks'+ return (assoc:trans, toks'')+ parseTranss toks = syntaxError toks -- parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks) = return ((ide1, ide2), toks)@@ -1164,7 +1164,7 @@ syntaxError toks parseAssoc (CHSTokIdent _ ide1:toks ) = syntaxError toks- parseAssoc toks =+ parseAssoc toks = syntaxError toks parseTrans toks = syntaxError toks @@ -1185,11 +1185,11 @@ parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken]) parseIdent (CHSTokIdent _ ide:toks) = return (ide, toks)-parseIdent toks = syntaxError toks+parseIdent toks = syntaxError toks parseEndHook :: [CHSToken] -> CST s ([CHSToken]) parseEndHook (CHSTokEndHook _:toks) = return toks-parseEndHook toks = syntaxError toks+parseEndHook toks = syntaxError toks syntaxError :: [CHSToken] -> CST s a syntaxError [] = errorEOF@@ -1197,18 +1197,18 @@ errorIllegal :: CHSToken -> CST s a errorIllegal tok = do- raiseError (posOf tok)- ["Syntax error!",- "The phrase `" ++ show tok ++ "' is not allowed \- \here."]- raiseSyntaxError+ raiseError (posOf tok)+ ["Syntax error!",+ "The phrase `" ++ show tok ++ "' is not allowed \+ \here."]+ raiseSyntaxError errorEOF :: CST s a errorEOF = do- raiseError nopos - ["Premature end of file!",- "The .chs file ends in the middle of a binding hook."]- raiseSyntaxError+ raiseError nopos + ["Premature end of file!",+ "The .chs file ends in the middle of a binding hook."]+ raiseSyntaxError errorCHINotFound :: String -> CST s a errorCHINotFound ide = do
c2hs/chs/CHSLexer.hs view
@@ -39,12 +39,12 @@ -- * Base lexer: -- -- haskell -> (inline \\ special)*--- | special \\ `"'--- | comment--- | nested--- | hstring--- | '{#'--- | cpp+-- | special \\ `"'+-- | comment+-- | nested+-- | hstring+-- | '{#'+-- | cpp -- special -> `(' | `{' | `-' | `"' -- ctrl -> `\n' | `\f' | `\r' | `\t' | `\v' --@@ -55,10 +55,10 @@ -- token list. -- -- NOTE: It is important that `{' is an extra lexeme and not added as an--- optional component at the end of the first alternative for--- `haskell'. Otherwise, the principle of the longest match will--- divide `foo {#' into the tokens `foo {' and `#' instead of `foo '--- and `{#'.+-- optional component at the end of the first alternative for+-- `haskell'. Otherwise, the principle of the longest match will+-- divide `foo {#' into the tokens `foo {' and `#' instead of `foo '+-- and `{#'. -- -- One line comments are handled by --@@ -72,13 +72,13 @@ -- -- hstring -> `"' inhstr* `"' -- inhstr -> ` '..`\127' \\ `"'--- | `\"'+-- | `\"' -- -- Pre-precessor directives as well as the switch to inline-C code are -- formed as follows: ----- cpp -> `\n#' (inline | `\t')* `\n'--- | `\n#c' (' ' | '\t')* `\n'+-- cpp -> `\n#' (inline | `\t')* `\n'+-- | `\n#c' (' ' | '\t')* `\n' -- -- We allow whitespace between the `#' and the actual directive, but in `#c' -- and `#endc' the directive must immediately follow the `#'. This might@@ -89,18 +89,18 @@ -- transfers control to the following binding-hook lexer: -- -- ident -> letter (letter | digit | `\'')*--- | `\'' letter (letter | digit)* `\''+-- | `\'' letter (letter | digit)* `\'' -- reservedid -> `as' | `call' | `class' | `context' | `deriving' --- | `enum' | `foreign' | `fun' | `get' | `lib' --- | `newtype' | `pointer' | `prefix' | `pure' | `set'--- | `sizeof' | `stable' | `type' | `underscoreToCase' --- | `unsafe' | `with' | 'lock' | 'unlock'+-- | `enum' | `foreign' | `fun' | `get' | `lib' +-- | `newtype' | `pointer' | `prefix' | `pure' | `set'+-- | `sizeof' | `stable' | `type' | `underscoreToCase' +-- | `unsafe' | `with' | 'lock' | 'unlock' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' --- | `=>' | '-' | `*' | `&' | `^'+-- | `=>' | '-' | `*' | `&' | `^' -- string -> `"' instr* `"' -- verbhs -> `\`' instr* `\'' -- instr -> ` '..`\127' \\ `"'--- comment -> `--' (any \\ `\n')* `\n'+-- comment -> `--' (any \\ `\n')* `\n' -- -- Control characters, white space, and comments are discarded in the -- binding-hook lexer. Nested comments are not allowed in a binding hook.@@ -169,18 +169,18 @@ module CHSLexer (CHSToken(..), lexCHS) where -import Data.List ((\\))-import Data.Char (isDigit)-import Control.Monad (liftM)+import Data.List ((\\))+import Data.Char (isDigit)+import Control.Monad (liftM) import Numeric (readDec, readOct, readHex) import Position (Position(..), Pos(posOf), incPos, retPos, tabPos) import Errors (ErrorLvl(..), Error, makeError)-import UNames (NameSupply, Name, names)+import UNames (NameSupply, Name, names) import Idents (Ident, lexemeToIdent, identToLexeme) import Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,- lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus,- quest, alt, string, LexerState, execLexer)+ lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus,+ quest, alt, string, LexerState, execLexer) import C2HSState (CST, raise, raiseError, nop, getNameSupply) @@ -190,55 +190,55 @@ -- possible tokens (EXPORTED) ---data CHSToken = CHSTokArrow Position -- `->'- | CHSTokDArrow Position -- `=>'- | CHSTokDot Position -- `.'- | CHSTokComma Position -- `,'- | CHSTokEqual Position -- `='- | CHSTokMinus Position -- `-'- | CHSTokStar Position -- `*'- | CHSTokAmp Position -- `&'- | CHSTokHat Position -- `^'- | CHSTokLBrace Position -- `{'- | CHSTokRBrace Position -- `}'- | CHSTokLParen Position -- `('- | CHSTokRParen Position -- `)'- | CHSTokEndHook Position -- `#}'- | CHSTokAs Position -- `as'- | CHSTokCall Position -- `call'- | CHSTokClass Position -- `class'- | CHSTokContext Position -- `context'- | CHSTokDerive Position -- `deriving'- | CHSTokEnum Position -- `enum'- | CHSTokForeign Position -- `foreign'- | CHSTokFun Position -- `fun'- | CHSTokGet Position -- `get'- | CHSTokImport Position -- `import'- | CHSTokLib Position -- `lib'- | CHSTokNewtype Position -- `newtype'- | CHSTokPointer Position -- `pointer'- | CHSTokPrefix Position -- `prefix'- | CHSTokPure Position -- `pure'- | CHSTokQualif Position -- `qualified'- | CHSTokSet Position -- `set'- | CHSTokSizeof Position -- `sizeof'- | CHSTokStable Position -- `stable'- | CHSTokType Position -- `type'- | CHSTok_2Case Position -- `underscoreToCase'- | CHSTokUnsafe Position -- `unsafe'- | CHSTokWith Position -- `with'- | CHSTokLock Position -- `lock'- | CHSTokNolock Position -- `nolock'- | CHSTokString Position String -- string - | CHSTokHSVerb Position String -- verbatim Haskell (`...')- | CHSTokIdent Position Ident -- identifier- | CHSTokHaskell Position String -- verbatim Haskell code- | CHSTokCPP Position String -- pre-processor directive- | CHSTokLine Position -- line pragma- | CHSTokC Position String -- verbatim C code- | CHSTokCtrl Position Char -- control code- | CHSTokPragma Position -- '{-# LANGUAGE' language pragma begin- | CHSTokPragEnd Position -- '#-}' language pragma end+data CHSToken = CHSTokArrow Position -- `->'+ | CHSTokDArrow Position -- `=>'+ | CHSTokDot Position -- `.'+ | CHSTokComma Position -- `,'+ | CHSTokEqual Position -- `='+ | CHSTokMinus Position -- `-'+ | CHSTokStar Position -- `*'+ | CHSTokAmp Position -- `&'+ | CHSTokHat Position -- `^'+ | CHSTokLBrace Position -- `{'+ | CHSTokRBrace Position -- `}'+ | CHSTokLParen Position -- `('+ | CHSTokRParen Position -- `)'+ | CHSTokEndHook Position -- `#}'+ | CHSTokAs Position -- `as'+ | CHSTokCall Position -- `call'+ | CHSTokClass Position -- `class'+ | CHSTokContext Position -- `context'+ | CHSTokDerive Position -- `deriving'+ | CHSTokEnum Position -- `enum'+ | CHSTokForeign Position -- `foreign'+ | CHSTokFun Position -- `fun'+ | CHSTokGet Position -- `get'+ | CHSTokImport Position -- `import'+ | CHSTokLib Position -- `lib'+ | CHSTokNewtype Position -- `newtype'+ | CHSTokPointer Position -- `pointer'+ | CHSTokPrefix Position -- `prefix'+ | CHSTokPure Position -- `pure'+ | CHSTokQualif Position -- `qualified'+ | CHSTokSet Position -- `set'+ | CHSTokSizeof Position -- `sizeof'+ | CHSTokStable Position -- `stable'+ | CHSTokType Position -- `type'+ | CHSTok_2Case Position -- `underscoreToCase'+ | CHSTokUnsafe Position -- `unsafe'+ | CHSTokWith Position -- `with'+ | CHSTokLock Position -- `lock'+ | CHSTokNolock Position -- `nolock'+ | CHSTokString Position String -- string + | CHSTokHSVerb Position String -- verbatim Haskell (`...')+ | CHSTokIdent Position Ident -- identifier+ | CHSTokHaskell Position String -- verbatim Haskell code+ | CHSTokCPP Position String -- pre-processor directive+ | CHSTokLine Position -- line pragma+ | CHSTokC Position String -- verbatim C code+ | CHSTokCtrl Position Char -- control code+ | CHSTokPragma Position -- '{-# LANGUAGE' language pragma begin+ | CHSTokPragEnd Position -- '#-}' language pragma end instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos@@ -334,12 +334,12 @@ (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokIdent _ _) == (CHSTokIdent _ _) = True (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True- (CHSTokCPP _ _) == (CHSTokCPP _ _) = True- (CHSTokC _ _) == (CHSTokC _ _) = True- (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True+ (CHSTokCPP _ _) == (CHSTokCPP _ _) = True+ (CHSTokC _ _) == (CHSTokC _ _) = True+ (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True (CHSTokPragma _ ) == (CHSTokPragma _ ) = True (CHSTokPragEnd _ ) == (CHSTokPragEnd _ ) = True- _ == _ = False+ _ == _ = False instance Show CHSToken where showsPrec _ (CHSTokArrow _ ) = showString "->"@@ -386,7 +386,7 @@ showsPrec _ (CHSTokIdent _ i) = (showString . identToLexeme) i showsPrec _ (CHSTokHaskell _ s) = showString s showsPrec _ (CHSTokCPP _ s) = showString s- showsPrec _ (CHSTokC _ s) = showString s+ showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c showsPrec _ (CHSTokPragma _ ) = showString "{-# LANGUAGE" showsPrec _ (CHSTokPragEnd _ ) = showString "#-}"@@ -398,30 +398,30 @@ -- state threaded through the lexer -- data CHSLexerState = CHSLS {- nestLvl :: Int, -- nesting depth of nested comments- inHook :: Bool, -- within a binding hook?- namesup :: [Name] -- supply of unique names- }+ nestLvl :: Int, -- nesting depth of nested comments+ inHook :: Bool, -- within a binding hook?+ namesup :: [Name] -- supply of unique names+ } -- initial state -- initialState :: CST s CHSLexerState initialState = do- namesup <- liftM names getNameSupply- return $ CHSLS {- nestLvl = 0,- inHook = False,- namesup = namesup- }+ namesup <- liftM names getNameSupply+ return $ CHSLS {+ nestLvl = 0,+ inHook = False,+ namesup = namesup+ } -- raise an error if the given state is not a final state -- assertFinalState :: Position -> CHSLexerState -> CST s () assertFinalState pos CHSLS {nestLvl = nestLvl, inHook = inHook} | nestLvl > 0 = raiseError pos ["Unexpected end of file!",- "Unclosed nested comment."]+ "Unclosed nested comment."] | inHook = raiseError pos ["Unexpected end of file!",- "Unclosed binding hook."]+ "Unclosed binding hook."] | otherwise = nop -- lexer and action type used throughout this specification@@ -434,16 +434,16 @@ -- infixl 3 `lexactionName` lexactionName :: CHSRegexp - -> (String -> Position -> Name -> CHSToken) - -> CHSLexer+ -> (String -> Position -> Name -> CHSToken) + -> CHSLexer re `lexactionName` action = re `lexmeta` action' where action' str pos state = let name:ns = namesup state- in- (Just $ Right (action str pos name),- incPos pos (length str),- state {namesup = ns},- Nothing)+ in+ (Just $ Right (action str pos name),+ incPos pos (length str),+ state {namesup = ns},+ Nothing) -- lexical specification@@ -453,22 +453,22 @@ -- -- chslexer :: CHSLexer-chslexer = pragma -- LANGUAGE pragma- >||< haskell -- Haskell code- >||< nested -- nested comments- >||< ctrl -- control code (that has to be preserved)- >||< hook -- start of a binding hook- >||< cpp -- a pre-processor directive (or `#c')+chslexer = pragma -- LANGUAGE pragma+ >||< haskell -- Haskell code+ >||< nested -- nested comments+ >||< ctrl -- control code (that has to be preserved)+ >||< hook -- start of a binding hook+ >||< cpp -- a pre-processor directive (or `#c') -- the LANGUAGE pragma pragma :: CHSLexer pragma = string "{-# LANGUAGE" `lexmeta` \_ pos s ->- (Just $ Right (CHSTokPragma pos), incPos pos 12, s, Just langLexer)+ (Just $ Right (CHSTokPragma pos), incPos pos 12, s, Just langLexer) langLexer :: CHSLexer langLexer = whitespace >||< identOrKW >||< symbol >||<- (string "#-}" `lexmeta` \_ pos s ->- (Just $ Right (CHSTokPragEnd pos), incPos pos 3, s, Just chslexer))+ (string "#-}" `lexmeta` \_ pos s ->+ (Just $ Right (CHSTokPragEnd pos), incPos pos 3, s, Just chslexer)) -- stream of Haskell code (terminated by a control character or binding hook) --@@ -480,28 +480,28 @@ -- as part of their lexeme). Thus, we special case '"'. This is still a -- kludge, as a program fragment, such as ----- foo'"'strange string"+-- foo'"'strange string" -- -- will not be handled correctly. -- haskell = ( anyButSpecial`star` epsilon- >|< specialButQuotes- >|< char '"' +> inhstr`star` char '"'- >|< string "'\"'" -- special case of "- >|< string "--" +> anyButNL`star` epsilon -- comment- )- `lexaction` copyVerbatim- >||< char '"' -- this is a bad kludge- `lexactionErr` - \_ pos -> (Left $ makeError ErrorErr pos- ["Lexical error!", - "Unclosed string."])- where- anyButSpecial = alt (inlineSet \\ specialSet)- specialButQuotes = alt (specialSet \\ ['"'])- anyButNL = alt (anySet \\ ['\n'])- inhstr = instr >|< char '\\' >|< string "\\\"" >|< gap- gap = char '\\' +> alt (' ':ctrlSet)`plus` char '\\'+ >|< specialButQuotes+ >|< char '"' +> inhstr`star` char '"'+ >|< string "'\"'" -- special case of "+ >|< string "--" +> anyButNL`star` epsilon -- comment+ )+ `lexaction` copyVerbatim+ >||< char '"' -- this is a bad kludge+ `lexactionErr` + \_ pos -> (Left $ makeError ErrorErr pos+ ["Lexical error!", + "Unclosed string."])+ where+ anyButSpecial = alt (inlineSet \\ specialSet)+ specialButQuotes = alt (specialSet \\ ['"'])+ anyButNL = alt (anySet \\ ['\n'])+ inhstr = instr >|< char '\\' >|< string "\\\"" >|< gap+ gap = char '\\' +> alt (' ':ctrlSet)`plus` char '\\' -- action copying the input verbatim to `CHSTokHaskell' tokens --@@ -512,59 +512,59 @@ -- nested :: CHSLexer nested =- string "{-" {- for Haskell emacs mode :-( -}+ string "{-" {- for Haskell emacs mode :-( -} `lexmeta` enterComment >||< string "-}" `lexmeta` leaveComment where enterComment cs pos s =- (copyVerbatim' cs pos, -- collect the lexeme- incPos pos 2, -- advance current position- s {nestLvl = nestLvl s + 1}, -- increase nesting level- Just $ inNestedComment) -- continue in comment lexer+ (copyVerbatim' cs pos, -- collect the lexeme+ incPos pos 2, -- advance current position+ s {nestLvl = nestLvl s + 1}, -- increase nesting level+ Just $ inNestedComment) -- continue in comment lexer -- leaveComment cs pos s = case nestLvl s of- 0 -> (commentCloseErr pos, -- 0: -} outside comment => err- incPos pos 2, -- advance current position- s,- Nothing)- 1 -> (copyVerbatim' cs pos, -- collect the lexeme- incPos pos 2, -- advance current position- s {nestLvl = nestLvl s - 1}, -- decrease nesting level- Just chslexer) -- 1: continue with root lexer- _ -> (copyVerbatim' cs pos, -- collect the lexeme- incPos pos 2, -- advance current position- s {nestLvl = nestLvl s - 1}, -- decrease nesting level- Nothing) -- _: cont with comment lexer+ 0 -> (commentCloseErr pos, -- 0: -} outside comment => err+ incPos pos 2, -- advance current position+ s,+ Nothing)+ 1 -> (copyVerbatim' cs pos, -- collect the lexeme+ incPos pos 2, -- advance current position+ s {nestLvl = nestLvl s - 1}, -- decrease nesting level+ Just chslexer) -- 1: continue with root lexer+ _ -> (copyVerbatim' cs pos, -- collect the lexeme+ incPos pos 2, -- advance current position+ s {nestLvl = nestLvl s - 1}, -- decrease nesting level+ Nothing) -- _: cont with comment lexer -- copyVerbatim' cs pos = Just $ Right (CHSTokHaskell pos cs) -- commentCloseErr pos = Just $ Left (makeError ErrorErr pos- ["Lexical error!", - "`-}' not preceded by a matching `{-'."])- {- for Haskell emacs mode :-( -}+ ["Lexical error!", + "`-}' not preceded by a matching `{-'."])+ {- for Haskell emacs mode :-( -} -- lexer processing the inner of a comment -- inNestedComment :: CHSLexer-inNestedComment = commentInterior -- inside a comment- >||< nested -- nested comments- >||< ctrl -- control code (preserved)+inNestedComment = commentInterior -- inside a comment+ >||< nested -- nested comments+ >||< ctrl -- control code (preserved) -- standard characters in a nested comment -- commentInterior :: CHSLexer commentInterior = ( anyButSpecial`star` epsilon- >|< special- )- `lexaction` copyVerbatim- where- anyButSpecial = alt (inlineSet \\ commentSpecialSet)- special = alt commentSpecialSet+ >|< special+ )+ `lexaction` copyVerbatim+ where+ anyButSpecial = alt (inlineSet \\ commentSpecialSet)+ special = alt commentSpecialSet -- control code in the base lexer (is turned into a token) --@@ -590,7 +590,7 @@ -- hook :: CHSLexer hook = string "{#"- `lexmeta` \_ pos s -> (Nothing, incPos pos 2, s, Just bhLexer)+ `lexmeta` \_ pos s -> (Nothing, incPos pos 2, s, Just bhLexer) -- pre-processor directives and `#c' --@@ -602,21 +602,21 @@ cpp = directive where directive = - string "\n#" +> alt ('\t':inlineSet)`star` epsilon- `lexmeta` - \(_:_:dir) pos s -> -- strip off the "\n#"- case dir of- ['c'] -> -- #c- (Nothing, retPos pos, s, Just cLexer)+ string "\n#" +> alt ('\t':inlineSet)`star` epsilon+ `lexmeta` + \(_:_:dir) pos s -> -- strip off the "\n#"+ case dir of+ ['c'] -> -- #c+ (Nothing, retPos pos, s, Just cLexer) -- a #c may be followed by whitespace- 'c':sp:_ | sp `elem` " \t" -> -- #c- (Nothing, retPos pos, s, Just cLexer)+ 'c':sp:_ | sp `elem` " \t" -> -- #c+ (Nothing, retPos pos, s, Just cLexer) ' ':line@(n:_) | isDigit n -> -- C line pragma let pos' = adjustPosByCLinePragma line pos in (Just $ Right (CHSTokLine pos'), pos', s, Nothing) _ -> -- CPP directive- (Just $ Right (CHSTokCPP pos dir), - retPos pos, s, Nothing)+ (Just $ Right (CHSTokCPP pos dir), + retPos pos, s, Nothing) adjustPosByCLinePragma :: String -> Position -> Position adjustPosByCLinePragma str (Position fname _ _) = @@ -624,13 +624,13 @@ where str' = dropWhite str (rowStr, str'') = span isDigit str'- row' = read rowStr- str''' = dropWhite str''- fnameStr = takeWhile (/= '"') . drop 1 $ str'''- fname' | null str''' || head str''' /= '"' = fname- -- try and get more sharing of file name strings- | fnameStr == fname = fname- | otherwise = fnameStr+ row' = read rowStr+ str''' = dropWhite str''+ fnameStr = takeWhile (/= '"') . drop 1 $ str'''+ fname' | null str''' || head str''' /= '"' = fname+ -- try and get more sharing of file name strings+ | fnameStr == fname = fname+ | otherwise = fnameStr -- dropWhite = dropWhile (\c -> c == ' ' || c == '\t') @@ -638,34 +638,34 @@ -- bhLexer :: CHSLexer bhLexer = identOrKW- >||< symbol- >||< strlit- >||< hsverb- >||< whitespace- >||< endOfHook- >||< string "--" +> anyButNL`star` char '\n' -- comment- `lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing)- where- anyButNL = alt (anySet \\ ['\n'])- endOfHook = string "#}"- `lexmeta` - \_ pos s -> (Just $ Right (CHSTokEndHook pos), - incPos pos 2, s, Just chslexer)+ >||< symbol+ >||< strlit+ >||< hsverb+ >||< whitespace+ >||< endOfHook+ >||< string "--" +> anyButNL`star` char '\n' -- comment+ `lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing)+ where+ anyButNL = alt (anySet \\ ['\n'])+ endOfHook = string "#}"+ `lexmeta` + \_ pos s -> (Just $ Right (CHSTokEndHook pos), + incPos pos 2, s, Just chslexer) -- the inline-C lexer -- cLexer :: CHSLexer-cLexer = inlineC -- inline C code- >||< ctrl -- control code (preserved)- >||< string "\n#endc" -- end of inline C code...- `lexmeta` -- ...preserve '\n' as control token- \_ pos s -> (Just $ Right (CHSTokCtrl pos '\n'), retPos pos, s, - Just chslexer)- where- inlineC = alt inlineSet `lexaction` copyVerbatimC- --- copyVerbatimC :: CHSAction - copyVerbatimC cs pos = Just $ CHSTokC pos cs+cLexer = inlineC -- inline C code+ >||< ctrl -- control code (preserved)+ >||< string "\n#endc" -- end of inline C code...+ `lexmeta` -- ...preserve '\n' as control token+ \_ pos s -> (Just $ Right (CHSTokCtrl pos '\n'), retPos pos, s, + Just chslexer)+ where+ inlineC = alt inlineSet `lexaction` copyVerbatimC+ --+ copyVerbatimC :: CHSAction + copyVerbatimC cs pos = Just $ CHSTokC pos cs -- whitespace --@@ -674,7 +674,7 @@ -- whitespace :: CHSLexer whitespace = (char ' ' `lexaction` \_ _ -> Nothing)- >||< ctrlLexer+ >||< ctrlLexer -- identifiers and keywords --@@ -695,9 +695,9 @@ idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass pos idkwtok pos "context" _ = CHSTokContext pos- idkwtok pos "deriving" _ = CHSTokDerive pos+ idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "enum" _ = CHSTokEnum pos- idkwtok pos "foreign" _ = CHSTokForeign pos+ idkwtok pos "foreign" _ = CHSTokForeign pos idkwtok pos "fun" _ = CHSTokFun pos idkwtok pos "get" _ = CHSTokGet pos idkwtok pos "import" _ = CHSTokImport pos@@ -709,7 +709,7 @@ idkwtok pos "qualified" _ = CHSTokQualif pos idkwtok pos "set" _ = CHSTokSet pos idkwtok pos "sizeof" _ = CHSTokSizeof pos- idkwtok pos "stable" _ = CHSTokStable pos+ idkwtok pos "stable" _ = CHSTokStable pos idkwtok pos "type" _ = CHSTokType pos idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos@@ -724,32 +724,32 @@ -- symbol :: CHSLexer symbol = sym "->" CHSTokArrow- >||< sym "=>" CHSTokDArrow- >||< sym "." CHSTokDot- >||< sym "," CHSTokComma- >||< sym "=" CHSTokEqual- >||< sym "-" CHSTokMinus- >||< sym "*" CHSTokStar- >||< sym "&" CHSTokAmp- >||< sym "^" CHSTokHat- >||< sym "{" CHSTokLBrace- >||< sym "}" CHSTokRBrace- >||< sym "(" CHSTokLParen- >||< sym ")" CHSTokRParen- where- sym cs con = string cs `lexaction` \_ pos -> Just (con pos)+ >||< sym "=>" CHSTokDArrow+ >||< sym "." CHSTokDot+ >||< sym "," CHSTokComma+ >||< sym "=" CHSTokEqual+ >||< sym "-" CHSTokMinus+ >||< sym "*" CHSTokStar+ >||< sym "&" CHSTokAmp+ >||< sym "^" CHSTokHat+ >||< sym "{" CHSTokLBrace+ >||< sym "}" CHSTokRBrace+ >||< sym "(" CHSTokLParen+ >||< sym ")" CHSTokRParen+ where+ sym cs con = string cs `lexaction` \_ pos -> Just (con pos) -- string -- strlit :: CHSLexer strlit = char '"' +> (instr >|< char '\\')`star` char '"'- `lexaction` \cs pos -> Just (CHSTokString pos (init . tail $ cs))+ `lexaction` \cs pos -> Just (CHSTokString pos (init . tail $ cs)) -- verbatim code -- hsverb :: CHSLexer hsverb = char '`' +> inhsverb`star` char '\''- `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs))+ `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs)) -- regular expressions
c2hs/gen/CInfo.hs view
@@ -65,11 +65,11 @@ -- FFI, so this is system dependent -- import C2HSConfig (Ptr, FunPtr, - bitfieldDirection, bitfieldPadding, bitfieldIntSigned,- bitfieldAlignment)+ bitfieldDirection, bitfieldPadding, bitfieldIntSigned,+ bitfieldAlignment) import qualified C2HSConfig as Storable- (Storable(sizeOf, alignment))+ (Storable(sizeOf, alignment)) -- calibration of C's primitive types@@ -80,25 +80,25 @@ -- * `CFunPtrPT' doesn't occur in Haskell representations of C types, but we -- need to know their size, which may be different from `CPtrPT' ---data CPrimType = CPtrPT -- void *- | CFunPtrPT -- void *()- | CCharPT -- char- | CUCharPT -- unsigned char- | CSCharPT -- signed char- | CIntPT -- int- | CShortPT -- short int- | CLongPT -- long int- | CLLongPT -- long long int- | CUIntPT -- unsigned int- | CUShortPT -- unsigned short int- | CULongPT -- unsigned long int- | CULLongPT -- unsigned long long int- | CFloatPT -- float- | CDoublePT -- double- | CLDoublePT -- long double- | CSFieldPT Int -- signed bit field- | CUFieldPT Int -- unsigned bit field- deriving (Eq)+data CPrimType = CPtrPT -- void *+ | CFunPtrPT -- void *()+ | CCharPT -- char+ | CUCharPT -- unsigned char+ | CSCharPT -- signed char+ | CIntPT -- int+ | CShortPT -- short int+ | CLongPT -- long int+ | CLLongPT -- long long int+ | CUIntPT -- unsigned int+ | CUShortPT -- unsigned short int+ | CULongPT -- unsigned long int+ | CULLongPT -- unsigned long long int+ | CFloatPT -- float+ | CDoublePT -- double+ | CLDoublePT -- long double+ | CSFieldPT Int -- signed bit field+ | CUFieldPT Int -- unsigned bit field+ deriving (Eq) -- size of primitive type of C (EXPORTED) --@@ -172,4 +172,4 @@ fieldAlignment :: Int -> Int fieldAlignment 0 = - (size CIntPT - 1) fieldAlignment bs | bitfieldPadding = - bs- | otherwise = 0+ | otherwise = 0
c2hs/gen/GBMonad.hs view
@@ -72,23 +72,23 @@ ) where -- standard libraries-import Data.Char (toUpper, toLower, isSpace)+import Data.Char (toUpper, toLower, isSpace) import Data.List (find)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe) -- Compiler Toolkit import Position (Position, Pos(posOf), nopos, builtinPos)-import Errors (interr)+import Errors (interr) import Idents (Ident, identToLexeme, onlyPosIdent) import Map (Map) import qualified Map as Map (empty, insert, lookup, fromList, toList, union) -- C -> Haskell-import C (CT, readCT, transCT, raiseErrorCTExc)+import C (CT, readCT, transCT, raiseErrorCTExc) -- friends-import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),- CHSAccess(..), CHSAPath(..), CHSPtrType(..))+import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),+ CHSAccess(..), CHSAPath(..), CHSPtrType(..)) -- translation tables@@ -103,17 +103,17 @@ -- underscoreToCase :: TransFun underscoreToCase ide = let lexeme = identToLexeme ide- ps = filter (not . null) . parts $ lexeme- in- concat . map adjustCase $ ps- where- parts s = let (l, s') = break (== '_') s- in - l : case s' of- [] -> []- (_:s'') -> parts s''- - adjustCase (c:cs) = toUpper c : map toLower cs+ ps = filter (not . null) . parts $ lexeme+ in+ concat . map adjustCase $ ps+ where+ parts s = let (l, s') = break (== '_') s+ in + l : case s' of+ [] -> []+ (_:s'') -> parts s''+ + adjustCase (c:cs) = toUpper c : map toLower cs -- takes an identifier association table to a translation function --@@ -126,34 +126,34 @@ transTabToTransFun :: String -> CHSTrans -> TransFun transTabToTransFun prefix (CHSTrans _2Case table) = \ide -> let - lexeme = identToLexeme ide- dft = if _2Case -- default uses maybe the...- then underscoreToCase ide -- ..._2case transformed...- else lexeme -- ...lexeme- in- case lookup ide table of -- lookup original ident- Just ide' -> identToLexeme ide' -- original ident matches- Nothing -> - case eat prefix lexeme of- Nothing -> dft -- no match & no prefix- Just eatenLexeme -> - let - eatenIde = onlyPosIdent (posOf ide) eatenLexeme- eatenDft = if _2Case - then underscoreToCase eatenIde - else eatenLexeme- in- case lookup eatenIde table of -- lookup without prefix- Nothing -> eatenDft -- orig ide without prefix- Just ide' -> identToLexeme ide' -- without prefix matched+ lexeme = identToLexeme ide+ dft = if _2Case -- default uses maybe the...+ then underscoreToCase ide -- ..._2case transformed...+ else lexeme -- ...lexeme+ in+ case lookup ide table of -- lookup original ident+ Just ide' -> identToLexeme ide' -- original ident matches+ Nothing -> + case eat prefix lexeme of+ Nothing -> dft -- no match & no prefix+ Just eatenLexeme -> + let + eatenIde = onlyPosIdent (posOf ide) eatenLexeme+ eatenDft = if _2Case + then underscoreToCase eatenIde + else eatenLexeme+ in+ case lookup eatenIde table of -- lookup without prefix+ Nothing -> eatenDft -- orig ide without prefix+ Just ide' -> identToLexeme ide' -- without prefix matched where -- try to eat prefix and return `Just partialLexeme' if successful -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs- | otherwise = Nothing- eat _ _ = Nothing+ | otherwise = Nothing+ eat _ _ = Nothing -- the local monad@@ -191,13 +191,13 @@ -- 5.04.1 -- data HsObject = Pointer {- ptrTypeHO :: CHSPtrType, -- kind of pointer- isNewtypeHO :: Bool -- newtype?- }- | Class {- superclassHO :: (Maybe Ident),-- superclass- ptrHO :: Ident -- pointer- }+ ptrTypeHO :: CHSPtrType, -- kind of pointer+ isNewtypeHO :: Bool -- newtype?+ }+ | Class {+ superclassHO :: (Maybe Ident),-- superclass+ ptrHO :: Ident -- pointer+ } deriving (Show, Read) type HsObjectMap = Map Ident HsObject @@ -211,13 +211,13 @@ -- super kludgy (depends on Show instance of Ident) instance Read Ident where readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme- in- if null ideChars - then []- else [(onlyPosIdent nopos ideChars, tail rest)]+ in+ if null ideChars + then []+ else [(onlyPosIdent nopos ideChars, tail rest)] readsPrec p (c:cs)- | isSpace c = readsPrec p cs- readsPrec _ _ = []+ | isSpace c = readsPrec p cs+ readsPrec _ _ = [] -- the local state consists of --@@ -235,13 +235,13 @@ -- which we use an instance here -- data GBState = GBState {- lib :: String, -- dynamic library- prefix :: String, -- prefix- mLock :: Maybe String, -- a lock function- frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)- ptrmap :: PointerMap, -- pointer representation- objmap :: HsObjectMap -- generated Haskell objects- }+ lib :: String, -- dynamic library+ prefix :: String, -- prefix+ mLock :: Maybe String, -- a lock function+ frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)+ ptrmap :: PointerMap, -- pointer representation+ objmap :: HsObjectMap -- generated Haskell objects+ } type GB a = CT GBState a @@ -261,11 +261,11 @@ GB () setContext lib prefix newMLock = transCT $ \state -> (state {lib = fromMaybe "" lib,- prefix = fromMaybe "" prefix,- mLock = case newMLock of- Nothing -> mLock state- Just _ -> newMLock },- ())+ prefix = fromMaybe "" prefix,+ mLock = case newMLock of+ Nothing -> mLock state+ Just _ -> newMLock },+ ()) -- get the dynamic library --@@ -299,15 +299,15 @@ newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook))) -- delay hook@(CHSCall isFun isUns _ ide oalias _) frags =- case find (\(hook', _) -> hook' == hook) frags of- Just (CHSCall isFun' isUns' _ ide' _ _, _) - | isFun == isFun' - && isUns == isUns'- && ide == ide' -> return frags- | otherwise -> err (posOf ide) (posOf ide')- Nothing -> return $ frags ++ [newEntry]+ case find (\(hook', _) -> hook' == hook) frags of+ Just (CHSCall isFun' isUns' _ ide' _ _, _) + | isFun == isFun' + && isUns == isUns'+ && ide == ide' -> return frags+ | otherwise -> err (posOf ide) (posOf ide')+ Nothing -> return $ frags ++ [newEntry] delay _ _ =- interr "GBMonad.delayCode: Illegal delay!"+ interr "GBMonad.delayCode: Illegal delay!" -- err = incompatibleCallHooksErr @@ -321,30 +321,30 @@ ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB () (isStar, cName) `ptrMapsTo` hsRepr = transCT (\state -> (state { - ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)- }, ()))+ ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)+ }, ())) -- query the pointer map -- queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep) queryPtr pcName = do- fm <- readCT ptrmap- return $ Map.lookup pcName fm+ fm <- readCT ptrmap+ return $ Map.lookup pcName fm -- add an entry to the Haskell object map -- objIs :: Ident -> HsObject -> GB () hsName `objIs` obj = transCT (\state -> (state { - objmap = Map.insert hsName obj (objmap state)- }, ()))+ objmap = Map.insert hsName obj (objmap state)+ }, ())) -- query the Haskell object map -- queryObj :: Ident -> GB (Maybe HsObject) queryObj hsName = do- fm <- readCT objmap- return $ Map.lookup hsName fm+ fm <- readCT objmap+ return $ Map.lookup hsName fm -- query the Haskell object map for a class --@@ -352,12 +352,12 @@ -- queryClass :: Ident -> GB HsObject queryClass hsName = do- let pos = posOf hsName- oobj <- queryObj hsName- case oobj of- Just obj@(Class _ _) -> return obj- Just _ -> classExpectedErr hsName- Nothing -> hsObjExpectedErr hsName+ let pos = posOf hsName+ oobj <- queryObj hsName+ case oobj of+ Just obj@(Class _ _) -> return obj+ Just _ -> classExpectedErr hsName+ Nothing -> hsObjExpectedErr hsName -- query the Haskell object map for a pointer --@@ -365,12 +365,12 @@ -- queryPointer :: Ident -> GB HsObject queryPointer hsName = do- let pos = posOf hsName- oobj <- queryObj hsName- case oobj of- Just obj@(Pointer _ _) -> return obj- Just _ -> pointerExpectedErr hsName- Nothing -> hsObjExpectedErr hsName+ let pos = posOf hsName+ oobj <- queryObj hsName+ case oobj of+ Just obj@(Pointer _ _) -> return obj+ Just _ -> pointerExpectedErr hsName+ Nothing -> hsObjExpectedErr hsName -- merge the pointer and Haskell object maps --@@ -380,36 +380,36 @@ -- entries are entered after all import hooks anyway -- -- FIXME: This currently has several shortcomings:--- * It just dies in case of a corrupted .chi file--- * We should at least have the option to raise a warning if two--- entries collide in the `objmap'. But it would be better to--- implement qualified names.--- * Do we want position information associated with the read idents?+-- * It just dies in case of a corrupted .chi file+-- * We should at least have the option to raise a warning if two+-- entries collide in the `objmap'. But it would be better to+-- implement qualified names.+-- * Do we want position information associated with the read idents? -- mergeMaps :: String -> GB () mergeMaps str = transCT (\state -> (state { - ptrmap = Map.union (ptrmap state) readPtrMap,- objmap = Map.union (objmap state) readObjMap- }, ()))+ ptrmap = Map.union (ptrmap state) readPtrMap,+ objmap = Map.union (objmap state) readObjMap+ }, ())) where (ptrAssoc, objAssoc) = read str readPtrMap = Map.fromList [((isStar, onlyPosIdent nopos ide), repr)- | ((isStar, ide), repr) <- ptrAssoc]+ | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(onlyPosIdent nopos ide, obj)- | (ide, obj) <- objAssoc]+ | (ide, obj) <- objAssoc] -- convert the whole pointer and Haskell object maps into printable form -- dumpMaps :: GB String dumpMaps = do- ptrFM <- readCT ptrmap- objFM <- readCT objmap- let dumpable = ([((isStar, identToLexeme ide), repr)- | ((isStar, ide), repr) <- Map.toList ptrFM],- [(identToLexeme ide, obj)- | (ide, obj) <- Map.toList objFM])- return $ show dumpable+ ptrFM <- readCT ptrmap+ objFM <- readCT objmap+ let dumpable = ([((isStar, identToLexeme ide), repr)+ | ((isStar, ide), repr) <- Map.toList ptrFM],+ [(identToLexeme ide, obj)+ | (ide, obj) <- Map.toList objFM])+ return $ show dumpable -- error messages
c2hs/gen/GenBind.hs view
@@ -41,1978 +41,1978 @@ -- in square brackets are optional. -- -- void -> ()--- char -> CChar--- unsigned char -> CUChar--- signed char -> CShort--- signed -> CInt--- [signed] int -> CInt--- [signed] short [int] -> CSInt--- [signed] long [int] -> CLong--- [signed] long long [int] -> CLLong--- unsigned [int] -> CUInt--- unsigned short [int] -> CUShort--- unsigned long [int] -> CULong--- unsigned long long [int] -> CULLong--- float -> CFloat--- double -> CDouble--- long double -> CLDouble--- enum ... -> CInt--- struct ... -> ** error **--- union ... -> ** error **------ Plain structures or unions (ie, if not the base type of a pointer type)--- are not supported at the moment (the underlying FFI does not support them--- directly). Named types (ie, in C type names defined using `typedef') are--- traced back to their original definitions. Pointer types are mapped--- to `Ptr a' or `FunPtr a' depending on whether they point to a functional.--- Values obtained from bit fields are represented by `CInt' or `CUInt'--- depending on whether they are signed.------ We obtain the size and alignment constraints for all primitive types of C--- from `CInfo', which obtains it from the Haskell 98 FFI. In the alignment--- computations involving bit fields, we assume that the alignment--- constraints for bitfields (wrt to non-bitfield members) is always the same--- as for `int' irrespective of the size of the bitfield. This seems to be--- implicitly guaranteed by K&R A8.3, but it is not entirely clear.------ Identifier lookup:--- ------------------------ We allow to identify enumerations and structures by the names of `typedef' --- types aliased to them.------ * enumerations: It is first checked whether there is a tag with the given--- identifier; if such a tag does not exist, the definition of a typedef--- with the same name is taken if it exists.--- * structs/unions: like enumerations------ We generally use `shadow' lookups. When an identifier cannot be found,--- we check whether - according to the prefix set by the context hook ---- another identifier casts a shadow that matches. If so, that identifier is--- taken instead of the original one.------- TODO ---------------------------------------------------------------------------- * A function prototype that uses a defined type on its left hand side may--- declare a function, while that is not obvious from the declaration--- itself (without also considering the `typedef'). Calls to such--- functions are currently rejected, which is a BUG.------ * context hook must precede all but the import hooks------ * The use of `++' in the recursive definition of the routines generating--- `Enum' instances is not particularly efficient.------ * Some operands are missing in `applyBin' - unfortunately, Haskell does--- not have standard bit operations. Some constructs are also missing--- from `evalConstCExpr'. Haskell 98 FFI standardises `Bits'; use that.-----module GenBind (expandHooks) -where ---- standard libraries-import Data.Char (toUpper, toLower, isSpace)-import Data.List (deleteBy, intersperse, isPrefixOf, find, nubBy)-import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)-import Control.Monad (when, unless, liftM, mapAndUnzipM)--import Data.Bits ((.&.), (.|.), xor, complement)---- Compiler Toolkit-import Position (Position, Pos(posOf), nopos, builtinPos)-import Errors (interr, todo)-import Idents (Ident, identToLexeme, onlyPosIdent)-import Attributes (newAttrsOnlyPos)---- C->Haskell-import C2HSConfig (dlsuffix)-import C2HSState (CST, nop, errorsPresent, showErrors, fatal,- SwitchBoard(..), Traces(..), putTraceStr, getSwitch,- printCIO)-import C (AttrC, CObj(..), CTag(..), lookupDefObjC, lookupDefTagC,- CHeader(..), CExtDecl, CDecl(..), CDeclSpec(..),- CStorageSpec(..), CTypeSpec(..), CTypeQual(..),- CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..),- CInit(..), CExpr(..), CAssignOp(..), CBinaryOp(..),- CUnaryOp(..), CConst (..),- CT, readCT, transCT, getCHeaderCT, runCT, ifCTExc,- raiseErrorCTExc, findValueObj, findFunObj, findTag,- findTypeObj, applyPrefixToNameSpaces, isTypedef,- simplifyDecl, declrFromDecl, declrNamed, structMembers,- structName, tagName, declaredName , structFromDecl,- funResultAndArgs, chaseDecl, findAndChaseDecl,- findObjShadow,- checkForAlias, checkForOneAliasName, lookupEnum,- lookupStructUnion, lookupDeclOrTag, isPtrDeclr,- isArrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr,- refersToNewDef, CDef(..))---- friends-import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),- CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..),- CHSPtrType(..), showCHSParm) -import CInfo (CPrimType(..), size, alignment, bitfieldIntSigned,- bitfieldAlignment)-import GBMonad (TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep,- initialGBState, setContext, getPrefix, getLock,- delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,- queryObj, queryClass, queryPointer, mergeMaps, dumpMaps)---- default marshallers--- ----------------------- FIXME: --- - we might have a dynamically extended table in the monad if needed (we--- could marshall enums this way and also save the `id' marshallers for--- pointers defined via (newtype) pointer hooks)--- - the checks for the Haskell types are quite kludgy---- determine the default "in" marshaller for the given Haskell and C types----lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))-lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = - return $ Just (cFromBoolIde, CHSValArg)-lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy - &&isIntegralCPrimType pt = - return $ Just (cIntConvIde, CHSValArg)-lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy - &&isFloatCPrimType pt = - return $ Just (cFloatConvIde, CHSValArg)-lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] =- return $ Just (withCStringIde, CHSIOArg)-lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] - | isIntegralCPrimType pt =- return $ Just (withCStringLenIde, CHSIOArg)-lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy =- return $ Just (withIde, CHSIOArg)-lookupDftMarshIn hsTy [PtrET (PrimET pt)] - | isIntegralHsType hsTy && isIntegralCPrimType pt =- return $ Just (withIntConvIde, CHSIOArg)-lookupDftMarshIn hsTy [PtrET (PrimET pt)] - | isFloatHsType hsTy && isFloatCPrimType pt =- return $ Just (withFloatConvIde, CHSIOArg)-lookupDftMarshIn "Bool" [PtrET (PrimET pt)] - | isIntegralCPrimType pt =- return $ Just (withFromBoolIde, CHSIOArg)--- FIXME: handle array-list conversion-lookupDftMarshIn _ _ = - return Nothing---- determine the default "out" marshaller for the given Haskell and C types----lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))-lookupDftMarshOut "()" _ =- return $ Just (voidIde, CHSVoidArg)-lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = - return $ Just (cToBoolIde, CHSValArg)-lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy - &&isIntegralCPrimType pt = - return $ Just (cIntConvIde, CHSValArg)-lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy - &&isFloatCPrimType pt = - return $ Just (cFloatConvIde, CHSValArg)-lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] =- return $ Just (peekCStringIde, CHSIOArg)-lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] - | isIntegralCPrimType pt =- return $ Just (peekCStringLenIde, CHSIOArg)-lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy =- return $ Just (peekIde, CHSIOArg)--- FIXME: add combination, such as "peek" plus "cIntConv" etc--- FIXME: handle array-list conversion-lookupDftMarshOut _ _ = - return Nothing----- check for integral Haskell types----isIntegralHsType :: String -> Bool-isIntegralHsType "Int" = True-isIntegralHsType "Int8" = True-isIntegralHsType "Int16" = True-isIntegralHsType "Int32" = True-isIntegralHsType "Int64" = True-isIntegralHsType "Word8" = True-isIntegralHsType "Word16" = True-isIntegralHsType "Word32" = True-isIntegralHsType "Word64" = True-isIntegralHsType _ = False---- check for floating Haskell types----isFloatHsType :: String -> Bool-isFloatHsType "Float" = True-isFloatHsType "Double" = True-isFloatHsType _ = False---- check for integral C types------ * For marshalling purposes C char's are integral types (see also types--- classes for which the FFI guarantees instances for `CChar', `CSChar', and--- `CUChar')----isIntegralCPrimType :: CPrimType -> Bool-isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT,- CLLongPT, CUIntPT, CUCharPT, CUShortPT,- CULongPT, CULLongPT]) ---- check for floating C types----isFloatCPrimType :: CPrimType -> Bool-isFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT])---- standard conversions----voidIde = noPosIdent "void" -- never appears in the output-cFromBoolIde = noPosIdent "cFromBool"-cToBoolIde = noPosIdent "cToBool"-cIntConvIde = noPosIdent "cIntConv"-cFloatConvIde = noPosIdent "cFloatConv"-withIde = noPosIdent "with"-withCStringIde = noPosIdent "withCString"-withCStringLenIde = noPosIdent "withCStringLenIntConv"-withIntConvIde = noPosIdent "withIntConv"-withFloatConvIde = noPosIdent "withFloatConv"-withFromBoolIde = noPosIdent "withFromBoolConv"-peekIde = noPosIdent "peek"-peekCStringIde = noPosIdent "peekCString"-peekCStringLenIde = noPosIdent "peekCStringLenIntConv"----- expansion of binding hooks--- ------------------------------ given a C header file and a binding file, expand all hooks in the binding--- file using the C header information (EXPORTED)------ * together with the module, returns the contents of the .chi file------ * if any error (not warnings) is encountered, a fatal error is raised.------ * also returns all warning messages encountered (last component of result)----expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)-expandHooks ac mod = do- mLock <- getSwitch lockFunSB- (_, res) <- runCT (expandModule mod) ac (initialGBState mLock)- return res--expandModule :: CHSModule -> GB (CHSModule, String, String)-expandModule (CHSModule frags) =- do- -- expand hooks- --- traceInfoExpand- frags' <- expandFrags frags- delayedFrags <- getDelayedCode-- -- get .chi dump- --- chi <- dumpMaps-- -- check for errors and finalise- --- errs <- errorsPresent- if errs- then do- traceInfoErr- errmsgs <- showErrors- fatal ("Errors during expansion of binding hooks:\n\n" -- fatal error- ++ errmsgs)- else do- traceInfoOK- warnmsgs <- showErrors- return (CHSModule (frags' ++ delayedFrags), chi, warnmsgs)- where- traceInfoExpand = putTraceStr tracePhasesSW - ("...expanding binding hooks...\n")- traceInfoErr = putTraceStr tracePhasesSW - ("...error(s) detected.\n")- traceInfoOK = putTraceStr tracePhasesSW - ("...successfully completed.\n")--expandFrags :: [CHSFrag] -> GB [CHSFrag]-expandFrags = liftM concat . mapM expandFrag--expandFrag :: CHSFrag -> GB [CHSFrag]-expandFrag verb@(CHSVerb _ _ ) = return [verb]-expandFrag line@(CHSLine _ ) = return [line]-expandFrag prag@(CHSLang _ _ ) = return [prag]-expandFrag (CHSHook h ) = - do- code <- expandHook h- return [CHSVerb code builtinPos]- `ifCTExc` return [CHSVerb "** ERROR **" builtinPos]-expandFrag (CHSCPP s _ ) = - interr $ "GenBind.expandFrag: Left over CHSCPP!\n---\n" ++ s ++ "\n---"-expandFrag (CHSC s _ ) = - interr $ "GenBind.expandFrag: Left over CHSC!\n---\n" ++ s ++ "\n---"-expandFrag (CHSCond alts dft) = - do- traceInfoCond- select alts- where- select [] = do- traceInfoDft dft- expandFrags (maybe [] id dft)- select ((ide, frags):alts) = do- oobj <- findTag ide- traceInfoVal ide oobj- if isNothing oobj- then- select alts- else -- found right alternative- expandFrags frags- --- traceInfoCond = traceGenBind "** CPP conditional:\n"- traceInfoVal ide oobj = traceGenBind $ identToLexeme ide ++ " is " ++- (if isNothing oobj then "not " else "") ++- "defined.\n"- traceInfoDft dft = if isNothing dft - then - return () - else - traceGenBind "Choosing else branch.\n"--expandHook :: CHSHook -> GB String-expandHook (CHSImport qual ide chi _) =- do- mergeMaps chi- return $ - "import " ++ (if qual then "qualified " else "") ++ identToLexeme ide-expandHook (CHSContext olib oprefix olock _) =- do- setContext olib oprefix olock -- enter context information- mapMaybeM_ applyPrefixToNameSpaces oprefix -- use the prefix on name spaces- return ""-expandHook (CHSType ide pos) =- do- traceInfoType- decl <- findAndChaseDecl ide False True -- no indirection, but shadows- ty <- extractSimpleType pos decl- traceInfoDump decl ty- return $ "(" ++ showExtType ty ++ ")"- where- traceInfoType = traceGenBind "** Type hook:\n"- traceInfoDump decl ty = traceGenBind $- "Declaration\n" ++ show decl ++ "\ntranslates to\n" - ++ showExtType ty ++ "\n"-expandHook (CHSSizeof ide pos) =- do- traceInfoSizeof- decl <- findAndChaseDecl ide False True -- no indirection, but shadows- (size, _) <- sizeAlignOf decl- traceInfoDump decl size- return $ show (fromIntegral . padBits $ size)- where- traceInfoSizeof = traceGenBind "** Sizeof hook:\n"- traceInfoDump decl size = traceGenBind $- "Size of declaration\n" ++ show decl ++ "\nis " - ++ show (fromIntegral . padBits $ size) ++ "\n"-expandHook (CHSEnum cide oalias chsTrans oprefix derive _) =- do- -- get the corresponding C declaration- --- enum <- lookupEnum cide True -- smart lookup incl error handling- --- -- convert the translation table and generate data type definition code- --- gprefix <- getPrefix- let prefix = fromMaybe gprefix oprefix- trans = transTabToTransFun prefix chsTrans- hide = identToLexeme . fromMaybe cide $ oalias- enumDef enum hide trans (map identToLexeme derive)-expandHook hook@(CHSCall isPure isUns isNol ide oalias pos) =- do- traceEnter- -- get the corresponding C declaration; raises error if not found or not a- -- function; we use shadow identifiers, so the returned identifier is used - -- afterwards instead of the original one- --- (ObjCO cdecl, ide) <- findFunObj ide True- mLock <- if isNol then return Nothing else getLock- let ideLexeme = identToLexeme ide -- orignal name might have been a shadow- hsLexeme = ideLexeme `maybe` identToLexeme $ oalias- cdecl' = ide `simplifyDecl` cdecl- callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl' pos- where- traceEnter = traceGenBind $ - "** Call hook for `" ++ identToLexeme ide ++ "':\n"-expandHook hook@(CHSFun isPure isUns isNol ide oalias ctxt parms parm pos) =- do- traceEnter- -- get the corresponding C declaration; raises error if not found or not a- -- function; we use shadow identifiers, so the returned identifier is used - -- afterwards instead of the original one- --- (ObjCO cdecl, cide) <- findFunObj ide True- mLock <- if isNol then return Nothing else getLock- let ideLexeme = identToLexeme ide -- orignal name might have been a shadow- hsLexeme = ideLexeme `maybe` identToLexeme $ oalias- fiLexeme = hsLexeme ++ "'_" -- *Urgh* - probably unique...- fiIde = onlyPosIdent nopos fiLexeme- cdecl' = cide `simplifyDecl` cdecl- callHook = CHSCall isPure isUns isNol cide (Just fiIde) pos- callImport callHook isPure isUns mLock (identToLexeme cide) fiLexeme cdecl' pos- funDef isPure hsLexeme fiLexeme cdecl' ctxt mLock parms parm pos- where- traceEnter = traceGenBind $ - "** Fun hook for `" ++ identToLexeme ide ++ "':\n"-expandHook (CHSField access path pos) =- do- traceInfoField- (decl, offsets) <- accessPath path- traceDepth offsets- ty <- extractSimpleType pos decl- traceValueType ty- setGet pos access offsets ty- where- accessString = case access of- CHSGet -> "Get"- CHSSet -> "Set"- traceInfoField = traceGenBind $ "** " ++ accessString ++ " hook:\n"- traceDepth offsets = traceGenBind $ "Depth of access path: " - ++ show (length offsets) ++ "\n"- traceValueType et = traceGenBind $ - "Type of accessed value: " ++ showExtType et ++ "\n"-expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType pos) =- do- traceInfoPointer- let hsIde = fromMaybe cName oalias- hsName = identToLexeme hsIde- hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object- --- -- we check for a typedef declaration or tag (struct, union, or enum)- --- declOrTag <- lookupDeclOrTag cName True- case declOrTag of- Left cdecl -> do -- found a typedef declaration- cNameFull <- case declaredName cdecl of- Just ide -> return ide- Nothing -> interr - "GenBind.expandHook: Where is the name?"- cNameFull `refersToNewDef` ObjCD (TypeCO cdecl) - -- assoc needed for chasing- traceInfoCName "declaration" cNameFull- unless (isStar || isPtrDecl cdecl) $ - ptrExpectedErr (posOf cName)- (hsType, isFun) <- - case oRefType of- Nothing -> do- cDecl <- chaseDecl cNameFull (not isStar)- et <- extractPtrType cDecl- let et' = adjustPtr isStar et- return (showExtType et', isFunExtType et')- Just hsType -> return (identToLexeme hsType, False)- -- FIXME: it is not possible to determine whether `hsType'- -- is a function; we would need to extend the syntax to- -- allow `... -> fun HSTYPE' to explicitly mark function- -- types if this ever becomes important- traceInfoHsType hsName hsType- realCName <- liftM (maybe cName snd) $ findObjShadow cName- pointerDef isStar realCName hsName ptrKind isNewtype hsType isFun- Right tag -> do -- found a tag definition- let cNameFull = tagName tag- traceInfoCName "tag definition" cNameFull- unless isStar $ -- tags need an explicit `*'- ptrExpectedErr (posOf cName)- let hsType = case oRefType of- Nothing -> "()"- Just hsType -> identToLexeme hsType- traceInfoHsType hsName hsType- pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False- where- -- remove a pointer level if the first argument is `False'- --- adjustPtr True et = et- adjustPtr False (PtrET et) = et- adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?"- --- traceInfoPointer = traceGenBind "** Pointer hook:\n"- traceInfoCName kind ide = traceGenBind $ - "found C " ++ kind ++ " for `" ++ identToLexeme ide ++ "'\n"- traceInfoHsType name ty = traceGenBind $ - "associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty - ++ "\n"-expandHook (CHSClass oclassIde classIde typeIde pos) =- do- traceInfoClass- classIde `objIs` Class oclassIde typeIde -- register Haskell object- superClasses <- collectClasses oclassIde- Pointer ptrType isNewtype <- queryPointer typeIde- when (ptrType == CHSStablePtr) $- illegalStablePtrErr pos- classDef pos (identToLexeme classIde) (identToLexeme typeIde) - ptrType isNewtype superClasses- where- -- compile a list of all super classes (the direct super class first)- --- collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]- collectClasses Nothing = return []- collectClasses (Just ide) = - do- Class oclassIde typeIde <- queryClass ide- ptr <- queryPointer typeIde- classes <- collectClasses oclassIde- return $ (identToLexeme ide, identToLexeme typeIde, ptr) : classes- --- traceInfoClass = traceGenBind $ "** Class hook:\n"---- produce code for an enumeration------ * an extra instance declaration is required when any of the enumeration--- constants is explicitly assigned a value in its definition------ * the translation function strips prefixes where possible (different--- enumerators maye have different prefixes)----enumDef :: CEnum -> String -> TransFun -> [String] -> GB String-enumDef cenum@(CEnum _ list _) hident trans userDerive =- do- (list', enumAuto) <- evalTagVals list- let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list'] -- translate- defHead = enumHead hident- defBody = enumBody (length defHead - 2) enumVals- inst = makeDerives - (if enumAuto then "Enum" : userDerive else userDerive) ++- if enumAuto then "\n" else "\n" ++ enumInst hident enumVals- return $ defHead ++ defBody ++ inst- where- cpos = posOf cenum- --- evalTagVals [] = return ([], True)- evalTagVals ((ide, Nothing ):list) = - do- (list', derived) <- evalTagVals list- return ((ide, Nothing):list', derived)- evalTagVals ((ide, Just exp):list) = - do- (list', derived) <- evalTagVals list- val <- evalConstCExpr exp- case val of- IntResult val' -> - return ((ide, Just $ CConst (CIntConst val' at1) at2):list', - False)- FloatResult _ ->- illegalConstExprErr (posOf exp) "a float result"- where- at1 = newAttrsOnlyPos nopos- at2 = newAttrsOnlyPos nopos- makeDerives [] = ""- makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")"---- Haskell code for the head of an enumeration definition----enumHead :: String -> String-enumHead ident = "data " ++ ident ++ " = "---- Haskell code for the body of an enumeration definition----enumBody :: Int -> [(String, Maybe CExpr)] -> String-enumBody indent [] = ""-enumBody indent ((ide, _):list) =- ide ++ "\n" ++ replicate indent ' ' - ++ (if null list then "" else "| " ++ enumBody indent list)---- Haskell code for an instance declaration for `Enum'------ * the expression of all explicitly specified tag values already have to be--- in normal form, ie, to be an int constant------ * enumerations start at 0 and whenever an explicit value is specified,--- following tags are assigned values continuing from the explicitly--- specified one----enumInst :: String -> [(String, Maybe CExpr)] -> String-enumInst ident list =- "instance Enum " ++ ident ++ " where\n"- ++ fromDef flatList ++ "\n" ++ toDef flatList ++ "\n"- ++ succDef names ++ "\n" ++ predDef names ++ "\n"- ++ enumFromToDef names- where- names = map fst list- flatList = flatten list 0-- flatten [] n = []- flatten ((ide, exp):list) n = (ide, val) : flatten list (val + 1)- where- val = case exp of- Nothing -> n- Just (CConst (CIntConst m _) _) -> m- Just _ -> interr "GenBind.enumInst: Integer constant expected!"-- show' x = if x < 0 then "(" ++ show x ++ ")" else show x- fromDef list = concat- [ " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n"- | (ide, val) <- list- ]- toDef list = concat- [ " toEnum " ++ show' val ++ " = " ++ ide ++ "\n"- | (ide, val) <- nubBy (\x y -> snd x == snd y) list- ]- ++ " toEnum unmatched = error (\"" ++ ident- ++ ".toEnum: Cannot match \" ++ show unmatched)\n"-- succDef [] = " succ _ = undefined\n"- succDef [x] = " succ _ = undefined\n"- succDef (x:x':xs) =- " succ " ++ x ++ " = " ++ x' ++ "\n"- ++ succDef (x':xs)- predDef [] = " pred _ = undefined\n"- predDef [x] = " pred _ = undefined\n"- predDef (x:x':xs) =- " pred " ++ x' ++ " = " ++ x ++ "\n"- ++ predDef (x':xs)- enumFromToDef [] = ""- enumFromToDef names =- " enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"- ++ " | otherwise = x : enumFromTo (succ x) y\n"- ++ " enumFrom x = enumFromTo x " ++ last names ++ "\n"- ++ " enumFromThen _ _ = "- ++ " error \"Enum "++ident++": enumFromThen not implemented\"\n"- ++ " enumFromThenTo _ _ _ = "- ++ " error \"Enum "++ident++": enumFromThenTo not implemented\"\n"----- generate a foreign import declaration that is put into the delayed code------ * the C declaration is a simplified declaration of the function that we--- want to import into Haskell land----callImport :: CHSHook -> Bool -> Bool -> Maybe String -> String -> String- -> CDecl -> Position -> GB String-callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl pos =- do- -- compute the external type from the declaration, and delay the foreign- -- export declaration- --- (mHsPtrRep, extType) <- extractFunType pos cdecl isPure- header <- getSwitch headerSB- delayCode hook (foreignImport header ideLexeme hsLexeme isUns extType)- traceFunType extType- -- if the type any special pointer aliases, generate a lambda expression- -- which strips off the constructors- if any isJust mHsPtrRep- then createLambdaExpr mHsPtrRep- else return funStr- where- createLambdaExpr :: [Maybe HsPtrRep] -> GB String- createLambdaExpr foreignVec = return $- "(\\" ++- unwords (zipWith wrPattern foreignVec [1..])++ " -> "++- concat (zipWith wrForPtr foreignVec [1..])++funStr++" "++- unwords (zipWith wrArg foreignVec [1..])++")"- wrPattern (Just (_,_,Just con,_)) n = "("++con++" arg"++show n++")"- wrPattern _ n = "arg"++show n- wrForPtr (Just (_,CHSForeignPtr,_,_)) n - = "withForeignPtr arg"++show n++" $ \\argPtr"++show n++" ->"- wrForPtr _ n = ""- wrArg (Just (_,CHSForeignPtr,_,_)) n = "argPtr"++show n- wrArg (Just (_,CHSStablePtr,_,_)) n = - "(castStablePtrToPtr arg"++show n++")"- wrArg _ n = "arg"++show n-- funStr = case mLock of Nothing -> hsLexeme- Just lockFun -> lockFun ++ " $ " ++ hsLexeme- traceFunType et = traceGenBind $ - "Imported function type: " ++ showExtType et ++ "\n"---- Haskell code for the foreign import declaration needed by a call hook------ On Windows, the paths for headers in "entity" may include backslashes, like--- dist\build\System\Types\GIO.h--- It seems GHC expects these to be escaped. Below, we make an educated guess--- that it in fact expects a Haskell string, and use the "show" function to do--- the escaping of this (and any other cases) for us.-foreignImport :: String -> String -> String -> Bool -> ExtType -> String-foreignImport header ident hsIdent isUnsafe ty =- "foreign import ccall " ++ safety ++ " " ++ show entity ++- "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n"- where- safety = if isUnsafe then "unsafe" else "safe"- entity | null header = ident- | otherwise = header ++ " " ++ ident---- produce a Haskell function definition for a fun hook----funDef :: Bool -- pure function?- -> String -- name of the new Haskell function- -> String -- Haskell name of the foreign imported C function- -> CDecl -- simplified declaration of the C function- -> Maybe String -- type context of the new Haskell function- -> Maybe String -- lock function- -> [CHSParm] -- parameter marshalling description- -> CHSParm -- result marshalling description - -> Position -- source location of the hook- -> GB String -- Haskell code in text form-funDef isPure hsLexeme fiLexeme cdecl octxt mLock parms parm pos =- do- (parms', parm', isImpure) <- addDftMarshaller pos parms parm cdecl- traceMarsh parms' parm' isImpure- let - sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n"- marshs = [marshArg i parm | (i, parm) <- zip [1..] parms']- funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""]- marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs]- callArgs = [callArg | (_, _, callArg, _, _) <- marshs]- marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""]- retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""]- funHead = hsLexeme ++ join funArgs ++ " =\n" ++- if isPure && isImpure then " unsafePerformIO $\n" else ""- lock = case mLock of Nothing -> ""- Just lock -> lock ++ " $"- call = if isPure - then " let {res = " ++ fiLexeme ++ join callArgs ++ "} in\n"- else " " ++ lock ++ fiLexeme ++ join callArgs ++ " >>= \\res ->\n"- marshRes = case parm' of- CHSParm _ _ twoCVal (Just (_ , CHSVoidArg)) _ -> ""- CHSParm _ _ twoCVal (Just (omIde, CHSIOArg )) _ -> - " " ++ identToLexeme omIde ++ " res >>= \\res' ->\n"- CHSParm _ _ twoCVal (Just (omIde, CHSValArg )) _ -> - " let {res' = " ++ identToLexeme omIde ++ " res} in\n"- CHSParm _ _ _ Nothing _ ->- interr "GenBind.funDef: marshRes: no default?"- retArgs' = case parm' of- CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs- _ -> "res'":retArgs- ret = "(" ++ concat (intersperse ", " retArgs') ++ ")"- funBody = joinLines marshIns ++ - call ++- joinLines marshOuts ++ - marshRes ++ - " " ++ - (if isImpure || not isPure then "return " else "") ++ ret- return $ sig ++ funHead ++ funBody- where- join = concatMap (' ':)- joinLines = concatMap (\s -> " " ++ s ++ "\n")- --- -- construct the function type- --- -- * specified types appear in the argument and result only if their "in"- -- and "out" marshaller, respectively, is not the `void' marshaller- --- funTy parms parm =- let- ctxt = case octxt of- Nothing -> ""- Just ctxtStr -> ctxtStr ++ " => "- argTys = [ty | CHSParm im ty _ _ _ <- parms , notVoid im]- resTys = [ty | CHSParm _ ty _ om _ <- parm:parms, notVoid om]- resTup = let- (lp, rp) = if isPure && length resTys == 1 - then ("", "") - else ("(", ")") - io = if isPure then "" else "IO "- in- io ++ lp ++ concat (intersperse ", " resTys) ++ rp- - in- ctxt ++ concat (intersperse " -> " (argTys ++ [resTup]))- where- notVoid Nothing = interr "GenBind.funDef: \- \No default marshaller?"- notVoid (Just (_, kind)) = kind /= CHSVoidArg- --- -- for an argument marshaller, generate all "in" and "out" marshalling- -- code fragments- --- marshArg i (CHSParm (Just (imIde, imArgKind)) _ twoCVal - (Just (omIde, omArgKind)) _ ) =- let- a = "a" ++ show i- imStr = identToLexeme imIde- imApp = imStr ++ " " ++ a- funArg = if imArgKind == CHSVoidArg then "" else a- inBndr = if twoCVal - then "(" ++ a ++ "'1, " ++ a ++ "'2)"- else a ++ "'"- marshIn = case imArgKind of- CHSVoidArg -> imStr ++ " $ \\" ++ inBndr ++ " -> "- CHSIOArg -> imApp ++ " $ \\" ++ inBndr ++ " -> "- CHSValArg -> "let {" ++ inBndr ++ " = " ++ - imApp ++ "} in "- callArg = if twoCVal - then "" ++ a ++ "'1 " ++ a ++ "'2"- else a ++ "'"- omApp = identToLexeme omIde ++ " " ++ callArg- outBndr = a ++ "''"- marshOut = case omArgKind of- CHSVoidArg -> ""- CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> "- CHSValArg -> "let {" ++ outBndr ++ " = " ++ - omApp ++ "} in "- retArg = if omArgKind == CHSVoidArg then "" else outBndr- in- (funArg, marshIn, callArg, marshOut, retArg)- marshArg _ _ = interr "GenBind.funDef: Missing default?"- --- traceMarsh parms parm isImpure = traceGenBind $ - "Marshalling specification including defaults: \n" ++- showParms (parms ++ [parm]) "" ++- " The marshalling is " ++ if isImpure then "impure.\n" else "pure.\n"- where- showParms [] = id- showParms (parm:parms) = showString " "- . showCHSParm parm - . showChar '\n' - . showParms parms---- add default marshallers for "in" and "out" marshalling----addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl - -> GB ([CHSParm], CHSParm, Bool)-addDftMarshaller pos parms parm cdecl = do- (_, fType) <- extractFunType pos cdecl True- let (resTy, argTys) = splitFunTy fType- (parm' , isImpure1) <- checkResMarsh parm resTy- (parms', isImpure2) <- addDft parms argTys- return (parms', parm', isImpure1 || isImpure2)- where- -- the result marshalling may not use an "in" marshaller and can only have- -- one C value- --- -- * a default marshaller maybe used for "out" marshalling- --- checkResMarsh (CHSParm (Just _) _ _ _ pos) _ = - resMarshIllegalInErr pos- checkResMarsh (CHSParm _ _ True _ pos) _ = - resMarshIllegalTwoCValErr pos- checkResMarsh (CHSParm _ ty _ omMarsh pos) cTy = do- (imMarsh', _ ) <- addDftVoid Nothing- (omMarsh', isImpure) <- addDftOut pos omMarsh ty [cTy]- return (CHSParm imMarsh' ty False omMarsh' pos, isImpure)- --- splitFunTy (FunET UnitET ty ) = splitFunTy ty- splitFunTy (FunET ty1 ty2) = let - (resTy, argTys) = splitFunTy ty2- in- (resTy, ty1:argTys)- splitFunTy resTy = (resTy, [])- --- -- match Haskell with C arguments (and results)- --- addDft ((CHSParm imMarsh hsTy False omMarsh p):parms) (cTy :cTys) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy]- (omMarsh', isImpureOut) <- addDftVoid omMarsh- (parms' , isImpure ) <- addDft parms cTys- return (CHSParm imMarsh' hsTy False omMarsh' p : parms',- isImpure || isImpureIn || isImpureOut)- addDft ((CHSParm imMarsh hsTy True omMarsh p):parms) (cTy1:cTy2:cTys) = do- (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2]- (omMarsh', isImpureOut) <- addDftVoid omMarsh- (parms' , isImpure ) <- addDft parms cTys- return (CHSParm imMarsh' hsTy True omMarsh' p : parms',- isImpure || isImpureIn || isImpureOut)- addDft [] [] = - return ([], False)- addDft ((CHSParm _ _ _ _ pos):parms) [] = - marshArgMismatchErr pos "This parameter is in excess of the C arguments."- addDft [] (_:_) = - marshArgMismatchErr pos "Parameter marshallers are missing."- --- addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh,- kind == CHSIOArg)- addDftIn pos imMarsh@Nothing hsTy cTys = do- marsh <- lookupDftMarshIn hsTy cTys- when (isNothing marsh) $- noDftMarshErr pos "\"in\"" hsTy cTys- return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})- --- addDftOut _ omMarsh@(Just (_, kind)) _ _ = return (omMarsh,- kind == CHSIOArg)- addDftOut pos omMarsh@Nothing hsTy cTys = do- marsh <- lookupDftMarshOut hsTy cTys- when (isNothing marsh) $- noDftMarshErr pos "\"out\"" hsTy cTys- return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})- --- -- add void marshaller if no explict one is given- --- addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg)- addDftVoid Nothing = do- return (Just (noPosIdent "void", CHSVoidArg), False)---- compute from an access path, the declarator finally accessed and the index--- path required for the access------ * each element in the index path specifies dereferencing an address and the --- offset to be added to the address before dereferencing------ * the returned declaration is already normalised (ie, alias have been--- expanded) ------ * it may appear as if `t.m' and `t->m' should have different access paths,--- as the latter specifies one more dereferencing; this is certainly true in--- C, but it doesn't apply here, as `t.m' is merely provided for the--- convenience of the interface writer - it is strictly speaking an--- impossible access paths, as in Haskell we always have a pointer to a--- structure, we can never have the structure as a value itself----accessPath :: CHSAPath -> GB (CDecl, [BitSize])-accessPath (CHSRoot ide) = -- t- do- decl <- findAndChaseDecl ide False True- return (ide `simplifyDecl` decl, [BitSize 0 0])-accessPath (CHSDeref (CHSRoot ide) _) = -- *t- do- decl <- findAndChaseDecl ide True True- return (ide `simplifyDecl` decl, [BitSize 0 0])-accessPath (CHSRef root@(CHSRoot ide1) ide2) = -- t.m- do- su <- lookupStructUnion ide1 False True- (offset, decl') <- refStruct su ide2- adecl <- replaceByAlias decl'- return (adecl, [offset])-accessPath (CHSRef (CHSDeref (CHSRoot ide1) _) ide2) = -- t->m- do- su <- lookupStructUnion ide1 True True- (offset, decl') <- refStruct su ide2- adecl <- replaceByAlias decl'- return (adecl, [offset])-accessPath (CHSRef path ide) = -- a.m- do- (decl, offset:offsets) <- accessPath path- assertPrimDeclr ide decl- su <- structFromDecl (posOf ide) decl- (addOffset, decl') <- refStruct su ide- adecl <- replaceByAlias decl'- return (adecl, offset `addBitSize` addOffset : offsets)- where- assertPrimDeclr ide (CDecl _ [declr] _) =- case declr of- (Just (CVarDeclr _ _), _, _) -> nop- _ -> structExpectedErr ide-accessPath (CHSDeref path pos) = -- *a- do- (decl, offsets) <- accessPath path- decl' <- derefOrErr decl- adecl <- replaceByAlias decl'- return (adecl, BitSize 0 0 : offsets)- where- derefOrErr (CDecl specs [declr] at) =- case declr of- (Just (CPtrDeclr [_] declr at), oinit, oexpr) -> - return $ CDecl specs [(Just declr, oinit, oexpr)] at- (Just (CPtrDeclr (_:quals) declr at), oinit, oexpr) -> - return $ - CDecl specs [(Just (CPtrDeclr quals declr at), oinit, oexpr)] at- _ -> - ptrExpectedErr pos---- replaces a decleration by its alias if any------ * the alias inherits any field size specification that the original--- declaration may have------ * declaration must have exactly one declarator----replaceByAlias :: CDecl -> GB CDecl-replaceByAlias cdecl@(CDecl _ [(_, _, size)] at) =- do- ocdecl <- checkForAlias cdecl- case ocdecl of- Nothing -> return cdecl- Just (CDecl specs [(declr, init, _)] at) -> -- form of an alias- return $ CDecl specs [(declr, init, size)] at---- given a structure declaration and member name, compute the offset of the--- member in the structure and the declaration of the referenced member----refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)-refStruct su ide =- do- -- get the list of fields and check for our selector- --- let (fields, tag) = structMembers su- (pre, post) = span (not . flip declNamed ide) fields- when (null post) $- unknownFieldErr (posOf su) ide- --- -- get sizes of preceding fields and the result type (`pre' are all- -- declarators preceding `ide' and the first declarator in `post' defines - -- `ide')- --- let decl = head post- offset <- case tag of- CStructTag -> offsetInStruct pre decl tag- CUnionTag -> return $ BitSize 0 0- return (offset, decl)---- does the given declarator define the given name?----declNamed :: CDecl -> Ident -> Bool-(CDecl _ [(Nothing , _, _)] _) `declNamed` ide = False-(CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide-(CDecl _ [] _) `declNamed` _ =- interr "GenBind.declNamed: Abstract declarator in structure!"-_ `declNamed` _ =- interr "GenBind.declNamed: More than one declarator!"---- Haskell code for writing to or reading from a struct----setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String-setGet pos access offsets ty =- do- let pre = case access of - CHSSet -> "(\\ptr val -> do {"- CHSGet -> "(\\ptr -> do {"- body <- setGetBody (reverse offsets)- return $ pre ++ body ++ "})"- where- setGetBody [BitSize offset bitOffset] =- do- let ty' = case ty of- t@(DefinedET _ _) -> PtrET t- t -> t- let tyTag = showExtType ty'- bf <- checkType ty'- case bf of- Nothing -> return $ case access of -- not a bitfield- CHSGet -> peekOp offset tyTag- CHSSet -> pokeOp offset tyTag "val"---FIXME: must take `bitfieldDirection' into account- Just (_, bs) -> return $ case access of -- a bitfield- CHSGet -> "val <- " ++ peekOp offset tyTag- ++ extractBitfield- CHSSet -> "org <- " ++ peekOp offset tyTag- ++ insertBitfield - ++ pokeOp offset tyTag "val'"- where- -- we have to be careful here to ensure proper sign extension;- -- in particular, shifting right followed by anding a mask is- -- *not* sufficient; instead, we exploit in the following that- -- `shiftR' performs sign extension- --- extractBitfield = "; return $ (val `shiftL` (" - ++ bitsPerField ++ " - " - ++ show (bs + bitOffset) ++ ")) `shiftR` ("- ++ bitsPerField ++ " - " ++ show bs- ++ ")"- bitsPerField = show $ size CIntPT * 8- --- insertBitfield = "; let {val' = (org .&. " ++ middleMask- ++ ") .|. (val `shiftL` " - ++ show bitOffset ++ ")}; "- middleMask = "fromIntegral (((maxBound::CUInt) `shiftL` "- ++ show bs ++ ") `rotateL` " - ++ show bitOffset ++ ")"- setGetBody (BitSize offset 0 : offsets) =- do- code <- setGetBody offsets- return $ "ptr <- peekByteOff ptr " ++ show offset ++ "; " ++ code- setGetBody (BitSize _ _ : _ ) =- derefBitfieldErr pos- --- -- check that the type can be marshalled and compute extra operations for- -- bitfields- --- checkType (IOET _ ) = interr "GenBind.setGet: Illegal \- \type!"- checkType (UnitET ) = voidFieldErr pos- checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)- checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)- checkType _ = return Nothing- --- peekOp off tyTag = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag- pokeOp off tyTag var = "pokeByteOff ptr " ++ show off ++ " (" ++ var- ++ "::" ++ tyTag ++ ")"---- generate the type definition for a pointer hook and enter the required type--- mapping into the `ptrmap'----pointerDef :: Bool -- explicit `*' in pointer hook- -> Ident -- full C name- -> String -- Haskell name- -> CHSPtrType -- kind of the pointer- -> Bool -- explicit newtype tag- -> String -- Haskell type expression of pointer argument- -> Bool -- do we have a pointer to a function?- -> GB String-pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun =- do- keepOld <- getSwitch oldFFI- let ptrArg = if keepOld - then "()" -- legacy FFI interface- else if isNewtype - then hsName -- abstract type- else hsType -- concrete type- ptrCon = case ptrKind of- CHSPtr | isFun -> "FunPtr"- _ -> show ptrKind- ptrType = ptrCon ++ " (" ++ ptrArg ++ ")"- thePtr = (isStar, cNameFull)-- thePtr `ptrMapsTo` (isFun,- ptrKind,- if isNewtype then Just hsName else Nothing,- ptrArg)- return $- if isNewtype - then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")"- else "type " ++ hsName ++ " = " ++ ptrType---- generate the class and instance definitions for a class hook------ * the pointer type must not be a stable pointer------ * the first super class (if present) must be the direct superclass------ * all Haskell objects in the superclass list must be pointer objects----classDef :: Position -- for error messages- -> String -- class name- -> String -- pointer type name- -> CHSPtrType -- type of the pointer- -> Bool -- is a newtype?- -> [(String, String, HsObject)] -- superclasses- -> GB String-classDef pos className typeName ptrType isNewtype superClasses =- do- let- toMethodName = case typeName of- "" -> interr "GenBind.classDef: \- \Illegal identifier!"- c:cs -> toLower c : cs- fromMethodName = "from" ++ typeName- classDefContext = case superClasses of- [] -> "" - (superName, _, _):_ -> superName ++ " p => "- classDef = - "class " ++ classDefContext ++ className ++ " p where\n" - ++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n"- ++ " " ++ fromMethodName ++ " :: " ++ typeName ++ " -> p\n"- instDef = - "instance " ++ className ++ " " ++ typeName ++ " where\n"- ++ " " ++ toMethodName ++ " = id\n"- ++ " " ++ fromMethodName ++ " = id\n"- instDefs <- castInstDefs superClasses- return $ classDef ++ instDefs ++ instDef- where - castInstDefs [] = return ""- castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) =- do- unless (ptrType == ptrType') $- pointerTypeMismatchErr pos className superName- let toMethodName = case ptrName of- "" -> interr "GenBind.classDef: \- \Illegal identifier - 2!"- c:cs -> toLower c : cs- fromMethodName = "from" ++ ptrName- castFun = "cast" ++ show ptrType- typeConstr = if isNewtype then typeName ++ " " else ""- superConstr = if isNewtype' then ptrName ++ " " else ""- instDef =- "instance " ++ superName ++ " " ++ typeName ++ " where\n"- ++ " " ++ toMethodName ++ " (" ++ typeConstr ++ "p) = " - ++ superConstr ++ "(" ++ castFun ++ " p)\n"- ++ " " ++ fromMethodName ++ " (" ++ superConstr ++ "p) = " - ++ typeConstr ++ "(" ++ castFun ++ " p)\n"- instDefs <- castInstDefs classes- return $ instDef ++ instDefs----- C code computations--- ----------------------- the result of a constant expression----data ConstResult = IntResult Integer- | FloatResult Float---- types that may occur in foreign declarations, ie, Haskell land types------ * we reprsent C functions with no arguments (ie, the ANSI C `void'--- argument) by `FunET UnitET res' rather than just `res' internally,--- although the latter representation is finally emitted into the binding--- file; this is because we need to know which types are functions (in--- particular, to distinguish between `Ptr a' and `FunPtr a')------ * aliased types (`DefinedET') are represented by a string plus their C--- declaration; the latter is for functions interpreting the following--- structure; an aliased type is always a pointer type that is contained in--- the pointer map (and got there either from a .chi or from a pointer hook--- in the same module)------ * the representation for pointers does not distinguish between normal,--- function, foreign, and stable pointers; function pointers are identified--- by their argument and foreign and stable pointers are only used--- indirectly, by referring to type names introduced by a `pointer' hook----data ExtType = FunET ExtType ExtType -- function- | IOET ExtType -- operation with side effect- | PtrET ExtType -- typed pointer- | DefinedET CDecl HsPtrRep -- aliased type- | PrimET CPrimType -- basic C type- | UnitET -- void--instance Eq ExtType where- (FunET t1 t2 ) == (FunET t1' t2' ) = t1 == t1' && t2 == t2'- (IOET t ) == (IOET t' ) = t == t'- (PtrET t ) == (PtrET t' ) = t == t'- (DefinedET _ rep ) == (DefinedET _ rep' ) = rep == rep'- (PrimET t ) == (PrimET t' ) = t == t'- UnitET == UnitET = True---- composite C type----data CompType = ExtType ExtType -- external type- | SUType CStructUnion -- structure or union---- check whether an external type denotes a function type----isFunExtType :: ExtType -> Bool-isFunExtType (FunET _ _) = True-isFunExtType (IOET _ ) = True-isFunExtType (DefinedET _ (isFun,_,_,_)) = isFun-isFunExtType _ = False---- pretty print an external type------ * a previous version of this function attempted to not print unnecessary--- brackets; this however doesn't work consistently due to `DefinedET'; so,--- we give up on the idea (preferring simplicity)----showExtType :: ExtType -> String-showExtType (FunET UnitET res) = showExtType res-showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " - ++ showExtType res ++ ")"-showExtType (IOET t) = "(IO " ++ showExtType t ++ ")"-showExtType (PtrET t) = let ptrCon = if isFunExtType t - then "FunPtr" else "Ptr"- in- "(" ++ ptrCon ++ " " ++ showExtType t - ++ ")"-showExtType (DefinedET _ (_,_,_,str)) = str-showExtType (PrimET CPtrPT) = "(Ptr ())"-showExtType (PrimET CFunPtrPT) = "(FunPtr ())"-showExtType (PrimET CCharPT) = "CChar"-showExtType (PrimET CUCharPT) = "CUChar"-showExtType (PrimET CSCharPT) = "CSChar"-showExtType (PrimET CIntPT) = "CInt"-showExtType (PrimET CShortPT) = "CShort"-showExtType (PrimET CLongPT) = "CLong"-showExtType (PrimET CLLongPT) = "CLLong"-showExtType (PrimET CUIntPT) = "CUInt"-showExtType (PrimET CUShortPT) = "CUShort"-showExtType (PrimET CULongPT) = "CULong"-showExtType (PrimET CULLongPT) = "CULLong"-showExtType (PrimET CFloatPT) = "CFloat"-showExtType (PrimET CDoublePT) = "CDouble"-showExtType (PrimET CLDoublePT) = "CLDouble"-showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}"-showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}"-showExtType UnitET = "()"---- compute the type of the C function declared by the given C object------ * the identifier specifies in which of the declarators we are interested------ * if the third argument is `True', the function result should not be--- wrapped into an `IO' type------ * the caller has to guarantee that the object does indeed refer to a--- function ----extractFunType :: Position -> CDecl -> Bool ->- GB ([Maybe HsPtrRep], ExtType)-extractFunType pos cdecl isPure = - do- -- remove all declarators except that of the function we are processing;- -- then, extract the functions arguments and result type (also check that- -- the function is not variadic); finally, compute the external type for- -- the result- --- let (args, resultDecl, variadic) = funResultAndArgs cdecl- when variadic $- variadicErr pos cpos- preResultType <- liftM (snd . expandSpecialPtrs) $ - extractSimpleType pos resultDecl- --- -- we can now add the `IO' monad if this is no pure function - --- let resultType = if isPure - then preResultType - else IOET preResultType- --- -- compute function arguments and create a function type (a function- -- prototype with `void' as its single argument declares a nullary- -- function) - --- (foreignSyn, argTypes) <- liftM (unzip . map expandSpecialPtrs) $- mapM (extractSimpleType pos) args-- return (foreignSyn, foldr FunET resultType argTypes)- where- cpos = posOf cdecl-- -- provide info on Haskell wrappers around C pointers- expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)- -- no special treatment for a simple type synonym- expandSpecialPtrs all@(DefinedET cdecl (_, CHSPtr, Nothing, _)) = - (Nothing, PtrET all)- -- all other Haskell pointer wrappings require- -- special calling conventions- expandSpecialPtrs all@(DefinedET cdecl hsPtrRep) = - (Just hsPtrRep, PtrET all)- -- non-pointer arguments are passed normal- expandSpecialPtrs all = (Nothing, all)---- compute a non-struct/union type from the given declaration ------ * the declaration may have at most one declarator------ * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in--- compatibility mode (ie, `--old-ffi=yes')----extractSimpleType :: Position -> CDecl -> GB ExtType-extractSimpleType pos cdecl =- do- traceEnter- ct <- extractCompType cdecl- case ct of- ExtType et -> return et- SUType _ -> illegalStructUnionErr (posOf cdecl) pos- where- traceEnter = traceGenBind $ - "Entering `extractSimpleType'...\n"---- compute a Haskell type for a type referenced in a C pointer type------ * the declaration may have at most one declarator------ * struct/union types are mapped to `()'------ * NB: this is by definition not a result type----extractPtrType :: CDecl -> GB ExtType-extractPtrType cdecl = do- ct <- extractCompType cdecl- case ct of- ExtType et -> return et- SUType _ -> return UnitET---- compute a Haskell type from the given C declaration, where C functions are--- represented by function pointers------ * the declaration may have at most one declarator------ * all C pointers (including functions) are represented as `Addr' if in--- compatibility mode (--old-ffi)------ * typedef'ed types are chased------ * takes the pointer map into account------ * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced--- for pointer types; if this ever changes, we need to--- handle `DefinedET's differently. The problem is that--- entries in the pointer map currently prevent--- `extractCompType' from looking further "into" the--- definition of that pointer.----extractCompType :: CDecl -> GB CompType-extractCompType cdecl@(CDecl specs declrs ats) =- if length declrs > 1 - then interr "GenBind.extractCompType: Too many declarators!"- else case declrs of- [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr- | isFunDeclr declr -> funType- | otherwise -> aliasOrSpecType size- [] -> aliasOrSpecType Nothing- where- -- handle explicit pointer types- --- ptrType declr = do- tracePtrType- let declrs' = dropPtrDeclr declr -- remove indirection- cdecl' = CDecl specs [(Just declrs', Nothing, Nothing)] ats- oalias = checkForOneAliasName cdecl' -- is only an alias remaining?- oHsRepr <- case oalias of- Nothing -> return $ Nothing- Just ide -> queryPtr (True, ide)- case oHsRepr of- Just repr -> ptrAlias repr -- got an alias- Nothing -> do -- no alias => recurs- ct <- extractCompType cdecl'- returnX $ case ct of- ExtType et -> PtrET et- SUType _ -> PtrET UnitET- --- -- handle explicit function types- --- -- FIXME: we currently regard any functions as being impure (ie, being IO- -- functions); is this ever going to be a problem?- --- funType = do- traceFunType- (_, et) <- extractFunType (posOf cdecl) cdecl False- returnX et- --- -- handle all types, which are not obviously pointers or functions - --- aliasOrSpecType :: Maybe CExpr -> GB CompType- aliasOrSpecType size = do- traceAliasOrSpecType size- case checkForOneAliasName cdecl of- Nothing -> specType (posOf cdecl) specs size- Just ide -> do -- this is a typedef alias- traceAlias ide- oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias - case oHsRepr of- Nothing -> do -- skip current alias (only one)- cdecl' <- getDeclOf ide- let CDecl specs [(declr, init, _)] at =- ide `simplifyDecl` cdecl'- sdecl = CDecl specs [(declr, init, size)] at- -- propagate `size' down (slightly kludgy)- extractCompType sdecl- Just repr -> ptrAlias repr -- found a pointer hook alias- --- -- compute the result for a pointer alias- --- ptrAlias (isFun, ptrTy, wrapped, tyArg) = - returnX $ DefinedET cdecl (isFun, ptrTy, wrapped, tyArg)- --- -- wrap an `ExtType' into a `CompType' and convert parametrised pointers- -- to `Addr' if needed- --- returnX retval@(PtrET et) = do- keepOld <- getSwitch oldFFI- if keepOld - then return $ ExtType (PrimET CPtrPT)- else return $ ExtType retval- returnX retval = return $ ExtType retval- --- tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n"- traceFunType = traceGenBind $ "extractCompType: explicit function type\n"- traceAliasOrSpecType Nothing = traceGenBind $ - "extractCompType: checking for alias\n"- traceAliasOrSpecType (Just _) = traceGenBind $ - "extractCompType: checking for alias of bitfield\n"- traceAlias ide = traceGenBind $ - "extractCompType: found an alias called `" ++ identToLexeme ide ++ "'\n"---- C to Haskell type mapping described in the DOCU section----typeMap :: [([CTypeSpec], ExtType)]-typeMap = [([void] , UnitET ),- ([char] , PrimET CCharPT ),- ([unsigned, char] , PrimET CUCharPT ),- ([signed, char] , PrimET CSCharPT ),- ([signed] , PrimET CIntPT ),- ([int] , PrimET CIntPT ),- ([signed, int] , PrimET CIntPT ),- ([short] , PrimET CShortPT ),- ([short, int] , PrimET CShortPT ),- ([signed, short] , PrimET CShortPT ),- ([signed, short, int] , PrimET CShortPT ),- ([long] , PrimET CLongPT ),- ([long, int] , PrimET CLongPT ),- ([signed, long] , PrimET CLongPT ),- ([signed, long, int] , PrimET CLongPT ),- ([long, long] , PrimET CLLongPT ),- ([long, long, int] , PrimET CLLongPT ),- ([signed, long, long] , PrimET CLLongPT ),- ([signed, long, long, int] , PrimET CLLongPT ),- ([unsigned] , PrimET CUIntPT ),- ([unsigned, int] , PrimET CUIntPT ),- ([unsigned, short] , PrimET CUShortPT ),- ([unsigned, short, int] , PrimET CUShortPT ),- ([unsigned, long] , PrimET CULongPT ),- ([unsigned, long, int] , PrimET CULongPT ),- ([unsigned, long, long] , PrimET CULLongPT ),- ([unsigned, long, long, int] , PrimET CULLongPT ),- ([float] , PrimET CFloatPT ),- ([double] , PrimET CDoublePT ),- ([long, double] , PrimET CLDoublePT),- ([enum] , PrimET CIntPT )]- where- void = CVoidType undefined- char = CCharType undefined- short = CShortType undefined- int = CIntType undefined- long = CLongType undefined- float = CFloatType undefined- double = CDoubleType undefined- signed = CSignedType undefined- unsigned = CUnsigType undefined- enum = CEnumType undefined undefined---- compute the complex (external) type determined by a list of type specifiers------ * may not be called for a specifier that defines a typedef alias----specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType-specType cpos specs osize = - let tspecs = [ts | CTypeSpec ts <- specs]- in case lookupTSpec tspecs typeMap of- Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos- | isNothing osize -> return $ ExtType et -- not a bitfield- | otherwise -> bitfieldSpec tspecs et osize -- bitfield- Nothing -> - case tspecs of- [CSUType cu _] -> return $ SUType cu -- struct or union- [CEnumType _ _] -> return $ ExtType (PrimET CIntPT) -- enum- [CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!"- _ -> illegalTypeSpecErr cpos- where- lookupTSpec = lookupBy matches- --- isUnsupportedType (PrimET et) = size et == 0 -- can't be a bitfield (yet)- isUnsupportedType _ = False- --- -- check whether two type specifier lists denote the same type; handles- -- types like `long long' correctly, as `deleteBy' removes only the first- -- occurrence of the given element- --- matches :: [CTypeSpec] -> [CTypeSpec] -> Bool- [] `matches` [] = True- [] `matches` (_:_) = False- (spec:specs) `matches` specs' - | any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs'- | otherwise = False- --- eqSpec (CVoidType _) (CVoidType _) = True- eqSpec (CCharType _) (CCharType _) = True- eqSpec (CShortType _) (CShortType _) = True- eqSpec (CIntType _) (CIntType _) = True- eqSpec (CLongType _) (CLongType _) = True- eqSpec (CFloatType _) (CFloatType _) = True- eqSpec (CDoubleType _) (CDoubleType _) = True- eqSpec (CSignedType _) (CSignedType _) = True- eqSpec (CUnsigType _) (CUnsigType _) = True- eqSpec (CSUType _ _) (CSUType _ _) = True- eqSpec (CEnumType _ _) (CEnumType _ _) = True- eqSpec (CTypeDef _ _) (CTypeDef _ _) = True- eqSpec _ _ = False- --- bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType- bitfieldSpec tspecs et (Just sizeExpr) = -- never called with `Nothing'- do- let pos = posOf sizeExpr- sizeResult <- evalConstCExpr sizeExpr- case sizeResult of- FloatResult _ -> illegalConstExprErr pos "a float result"- IntResult size' -> do- let size = fromInteger size'- case et of- PrimET CUIntPT -> returnCT $ CUFieldPT size- PrimET CIntPT - | [signed] `matches` tspecs - || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT size- | [int] `matches` tspecs -> - returnCT $ if bitfieldIntSigned then CSFieldPT size - else CUFieldPT size- _ -> illegalFieldSizeErr pos- where- returnCT = return . ExtType . PrimET- --- int = CIntType undefined- signed = CSignedType undefined----- offset and size computations--- -------------------------------- precise size representation------ * this is a pair of a number of octets and a number of bits------ * if the number of bits is nonzero, the octet component is aligned by the--- alignment constraint for `CIntPT' (important for accessing bitfields with--- more than 8 bits)----data BitSize = BitSize Int Int- deriving (Eq, Show)---- ordering relation compares in terms of required storage units----instance Ord BitSize where- bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) = - padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2)- bs1 <= bs2 = bs1 < bs2 || bs1 == bs2- -- the <= instance is needed for Ord's compare functions, which is used in- -- the defaults for all other members---- add two bit size values----addBitSize :: BitSize -> BitSize -> BitSize-addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow) rest- where- bitsPerBitfield = size CIntPT * 8- (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield---- pad any storage unit that is partially used by a bitfield----padBits :: BitSize -> Int-padBits (BitSize o 0) = o-padBits (BitSize o _) = o + size CIntPT---- compute the offset of the declarator in the second argument when it is--- preceded by the declarators in the first argument----offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize-offsetInStruct [] _ _ = return $ BitSize 0 0-offsetInStruct decls decl tag = - do- (offset, _) <- sizeAlignOfStruct decls tag- (_, align) <- sizeAlignOf decl- return $ alignOffset offset align---- compute the size and alignment (no padding at the end) of a set of--- declarators from a struct----sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)-sizeAlignOfStruct [] _ = return (BitSize 0 0, 1)-sizeAlignOfStruct decls CStructTag = - do- (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag- (size, align) <- sizeAlignOf (last decls)- let sizeOfStruct = alignOffset offset align `addBitSize` size- align' = if align > 0 then align else bitfieldAlignment- alignOfStruct = preAlign `max` align'- return (sizeOfStruct, alignOfStruct)-sizeAlignOfStruct decls CUnionTag =- do- (sizes, aligns) <- mapAndUnzipM sizeAlignOf decls- let aligns' = [if align > 0 then align else bitfieldAlignment- | align <- aligns]- return (maximum sizes, maximum aligns')---- compute the size and alignment of the declarators forming a struct--- including any end-of-struct padding that is needed to make the struct ``tile--- in an array'' (K&R A7.4.8)----sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)-sizeAlignOfStructPad decls tag =- do- (size, align) <- sizeAlignOfStruct decls tag- return (alignOffset size align, align)---- compute the size and alignment constraint of a given C declaration----sizeAlignOf :: CDecl -> GB (BitSize, Int)------ * we make use of the assertion that `extractCompType' can only return a--- `DefinedET' when the declaration is a pointer declaration----sizeAlignOf (CDecl specs [(Just declr, _, size)] ats) | isArrDeclr declr =- interr $ "sizeAlignOf: calculating size of constant array not supported."-sizeAlignOf cdecl = - do- ct <- extractCompType cdecl- case ct of- ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT, - alignment CFunPtrPT)- ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!"- ExtType (PtrET t ) - | isFunExtType t -> return (bitSize CFunPtrPT, - alignment CFunPtrPT)- | otherwise -> return (bitSize CPtrPT, alignment CPtrPT)- ExtType (DefinedET _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT)- -- FIXME: The defined type could be a function pointer!!!- ExtType (PrimET pt ) -> return (bitSize pt, alignment pt)- ExtType UnitET -> voidFieldErr (posOf cdecl)- SUType su -> - do- let (fields, tag) = structMembers su- fields' <- let ide = structName su - in- if (not . null $ fields) || isNothing ide- then return fields- else do -- get the real...- tag <- findTag (fromJust ide) -- ...definition- case tag of- Just (StructUnionCT su) -> return- (fst . structMembers $ su)- _ -> return fields- sizeAlignOfStructPad fields' tag- where- bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits- | otherwise = BitSize sz 0- where- sz = size et---- apply the given alignment constraint at the given offset------ * if the alignment constraint is negative or zero, it is the alignment--- constraint for a bitfield----alignOffset :: BitSize -> Int -> BitSize-alignOffset offset@(BitSize octetOffset bitOffset) align - | align > 0 && bitOffset /= 0 = -- close bitfield first- alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align- | align > 0 && bitOffset == 0 = -- no bitfields involved- BitSize (((octetOffset - 1) `div` align + 1) * align) 0- | bitOffset == 0 -- start a bitfield- || overflowingBitfield = -- .. or overflowing bitfield- alignOffset offset bitfieldAlignment- | otherwise = -- stays in current bitfield- offset- where- bitsPerBitfield = size CIntPT * 8- overflowingBitfield = bitOffset - align >= bitsPerBitfield- -- note, `align' is negative----- constant folding--- -------------------- evaluate a constant expression------ FIXME: this is a bit too simplistic, as the range of expression allowed as--- constant expression varies depending on the context in which the--- constant expression occurs----evalConstCExpr :: CExpr -> GB ConstResult-evalConstCExpr (CComma _ at) =- illegalConstExprErr (posOf at) "a comma expression"-evalConstCExpr (CAssign _ _ _ at) =- illegalConstExprErr (posOf at) "an assignment"-evalConstCExpr (CCond b (Just t) e _) =- do- bv <- evalConstCExpr b- case bv of- IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e- FloatResult _ -> illegalConstExprErr (posOf b) "a float result"-evalConstCExpr (CBinary op lhs rhs at) =- do- lhsVal <- evalConstCExpr lhs- rhsVal <- evalConstCExpr rhs- let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal- applyBin (posOf at) op lhsVal' rhsVal'-evalConstCExpr (CCast _ _ _) =- todo "GenBind.evalConstCExpr: Casts are not implemented yet."-evalConstCExpr (CUnary op arg at) =- do- argVal <- evalConstCExpr arg- applyUnary (posOf at) op argVal-evalConstCExpr (CSizeofExpr _ _) =- todo "GenBind.evalConstCExpr: sizeof not implemented yet."-evalConstCExpr (CSizeofType decl _) =- do- (size, _) <- sizeAlignOf decl- return $ IntResult (fromIntegral . padBits $ size)-evalConstCExpr (CAlignofExpr _ _) =- todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."-evalConstCExpr (CAlignofType decl _) =- do- (_, align) <- sizeAlignOf decl- return $ IntResult (fromIntegral align)-evalConstCExpr (CIndex _ _ at) =- illegalConstExprErr (posOf at) "array indexing"-evalConstCExpr (CCall _ _ at) =- illegalConstExprErr (posOf at) "function call"-evalConstCExpr (CMember _ _ _ at) =- illegalConstExprErr (posOf at) "a . or -> operator"-evalConstCExpr (CVar ide at) =- do- (cobj, _) <- findValueObj ide False- case cobj of- EnumCO ide (CEnum _ enumrs _) -> liftM IntResult $ - enumTagValue ide enumrs 0- _ -> - todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++- show (posOf at)- where- -- FIXME: this is not very nice; instead, CTrav should have some support- -- for determining enum tag values (but then, constant folding needs- -- to be moved to CTrav, too)- --- -- Compute the tag value for `ide' defined in the given enumerator list- --- enumTagValue _ [] _ = - interr "GenBind.enumTagValue: enumerator not in declaration"- enumTagValue ide ((ide', oexpr):enumrs) val =- do- val' <- case oexpr of- Nothing -> return val- Just exp -> - do- val' <- evalConstCExpr exp- case val' of- IntResult val' -> return val'- FloatResult _ ->- illegalConstExprErr (posOf exp) "a float result"- if ide == ide'- then -- found the right enumerator- return val'- else -- continue down the enumerator list- enumTagValue ide enumrs (val' + 1)-evalConstCExpr (CConst c _) =- evalCConst c--evalCConst :: CConst -> GB ConstResult-evalCConst (CIntConst i _ ) = return $ IntResult i-evalCConst (CCharConst c _ ) = return $ IntResult (toInteger (fromEnum c))-evalCConst (CFloatConst s _ ) = - todo "GenBind.evalCConst: Float conversion from literal misses."-evalCConst (CStrConst s at) = - illegalConstExprErr (posOf at) "a string constant"--usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)-usualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs)-usualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs)-usualArithConv lhs rhs = (lhs, rhs)--toFloat :: ConstResult -> ConstResult-toFloat x@(FloatResult _) = x-toFloat (IntResult i) = FloatResult . fromIntegral $ i--applyBin :: Position - -> CBinaryOp - -> ConstResult - -> ConstResult - -> GB ConstResult-applyBin cpos CMulOp (IntResult x) - (IntResult y) = return $ IntResult (x * y)-applyBin cpos CMulOp (FloatResult x) - (FloatResult y) = return $ FloatResult (x * y)-applyBin cpos CDivOp (IntResult x) - (IntResult y) = return $ IntResult (x `div` y)-applyBin cpos CDivOp (FloatResult x) - (FloatResult y) = return $ FloatResult (x / y)-applyBin cpos CRmdOp (IntResult x) - (IntResult y) = return$ IntResult (x `mod` y)-applyBin cpos CRmdOp (FloatResult x) - (FloatResult y) = - illegalConstExprErr cpos "a % operator applied to a float"-applyBin cpos CAddOp (IntResult x) - (IntResult y) = return $ IntResult (x + y)-applyBin cpos CAddOp (FloatResult x) - (FloatResult y) = return $ FloatResult (x + y)-applyBin cpos CSubOp (IntResult x) - (IntResult y) = return $ IntResult (x - y)-applyBin cpos CSubOp (FloatResult x) - (FloatResult y) = return $ FloatResult (x - y)-applyBin cpos CShlOp (IntResult x) - (IntResult y) = return $ IntResult (x * 2^y)-applyBin cpos CShlOp (FloatResult x) - (FloatResult y) = - illegalConstExprErr cpos "a << operator applied to a float"-applyBin cpos CShrOp (IntResult x) - (IntResult y) = return $ IntResult (x `div` 2^y)-applyBin cpos CShrOp (FloatResult x) - (FloatResult y) = - illegalConstExprErr cpos "a >> operator applied to a float"-applyBin cpos CAndOp (IntResult x)- (IntResult y) = return $ IntResult (x .&. y)-applyBin cpos COrOp (IntResult x)- (IntResult y) = return $ IntResult (x .|. y)-applyBin cpos CXorOp (IntResult x)- (IntResult y) = return $ IntResult (x `xor` y)-applyBin cpos _ (IntResult x) - (IntResult y) = - todo "GenBind.applyBin: Not yet implemented operator in constant expression."-applyBin cpos _ (FloatResult x) - (FloatResult y) = - todo "GenBind.applyBin: Not yet implemented operator in constant expression."-applyBin _ _ _ _ = - interr "GenBind.applyBinOp: Illegal combination!"--applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult-applyUnary cpos CPreIncOp _ = - illegalConstExprErr cpos "a ++ operator"-applyUnary cpos CPreDecOp _ = - illegalConstExprErr cpos "a -- operator"-applyUnary cpos CPostIncOp _ = - illegalConstExprErr cpos "a ++ operator"-applyUnary cpos CPostDecOp _ = - illegalConstExprErr cpos "a -- operator"-applyUnary cpos CAdrOp _ = - illegalConstExprErr cpos "a & operator"-applyUnary cpos CIndOp _ = - illegalConstExprErr cpos "a * operator"-applyUnary cpos CPlusOp arg = return arg-applyUnary cpos CMinOp (IntResult x) = return (IntResult (-x))-applyUnary cpos CMinOp (FloatResult x) = return (FloatResult (-x))-applyUnary cpos CCompOp (IntResult x) = return (IntResult (complement x))-applyUnary cpos CNegOp (IntResult x) = - let r = toInteger . fromEnum $ (x == 0)- in return (IntResult r)-applyUnary cpos CNegOp (FloatResult _) = - illegalConstExprErr cpos "! applied to a float"----- auxilliary functions--- ------------------------ create an identifier without position information----noPosIdent :: String -> Ident-noPosIdent = onlyPosIdent nopos---- print trace message----traceGenBind :: String -> GB ()-traceGenBind = putTraceStr traceGenBindSW---- generic lookup----lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b-lookupBy eq x = fmap snd . find (eq x . fst)---- maps some monad operation into a `Maybe', discarding the result----mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()-mapMaybeM_ m Nothing = return ()-mapMaybeM_ m (Just a) = m a >> return ()----- error messages--- ----------------unknownFieldErr :: Position -> Ident -> GB a-unknownFieldErr cpos ide =- raiseErrorCTExc (posOf ide) - ["Unknown member name!",- "The structure has no member called `" ++ identToLexeme ide - ++ "'. The structure is defined at",- show cpos ++ "."]--illegalStructUnionErr :: Position -> Position -> GB a-illegalStructUnionErr cpos pos =- raiseErrorCTExc pos - ["Illegal structure or union type!",- "There is not automatic support for marshaling of structures and",- "unions; the offending type is declared at "- ++ show cpos ++ "."]--illegalTypeSpecErr :: Position -> GB a-illegalTypeSpecErr cpos =- raiseErrorCTExc cpos - ["Illegal type!",- "The type specifiers of this declaration do not form a legal ANSI C(89) \- \type."- ]--unsupportedTypeSpecErr :: Position -> GB a-unsupportedTypeSpecErr cpos =- raiseErrorCTExc cpos - ["Unsupported type!",- "The type specifier of this declaration is not supported by your C \- \compiler."- ]--variadicErr :: Position -> Position -> GB a-variadicErr pos cpos =- raiseErrorCTExc pos - ["Variadic function!",- "Calling variadic functions is not supported by the FFI; the function",- "is defined at " ++ show cpos ++ "."]--illegalConstExprErr :: Position -> String -> GB a-illegalConstExprErr cpos hint =- raiseErrorCTExc cpos ["Illegal constant expression!",- "Encountered " ++ hint ++ " in a constant expression,",- "which ANSI C89 does not permit."]--voidFieldErr :: Position -> GB a-voidFieldErr cpos =- raiseErrorCTExc cpos ["Void field in struct!",- "Attempt to access a structure field of type void."]+-- char -> CChar+-- unsigned char -> CUChar+-- signed char -> CShort+-- signed -> CInt+-- [signed] int -> CInt+-- [signed] short [int] -> CSInt+-- [signed] long [int] -> CLong+-- [signed] long long [int] -> CLLong+-- unsigned [int] -> CUInt+-- unsigned short [int] -> CUShort+-- unsigned long [int] -> CULong+-- unsigned long long [int] -> CULLong+-- float -> CFloat+-- double -> CDouble+-- long double -> CLDouble+-- enum ... -> CInt+-- struct ... -> ** error **+-- union ... -> ** error **+--+-- Plain structures or unions (ie, if not the base type of a pointer type)+-- are not supported at the moment (the underlying FFI does not support them+-- directly). Named types (ie, in C type names defined using `typedef') are+-- traced back to their original definitions. Pointer types are mapped+-- to `Ptr a' or `FunPtr a' depending on whether they point to a functional.+-- Values obtained from bit fields are represented by `CInt' or `CUInt'+-- depending on whether they are signed.+--+-- We obtain the size and alignment constraints for all primitive types of C+-- from `CInfo', which obtains it from the Haskell 98 FFI. In the alignment+-- computations involving bit fields, we assume that the alignment+-- constraints for bitfields (wrt to non-bitfield members) is always the same+-- as for `int' irrespective of the size of the bitfield. This seems to be+-- implicitly guaranteed by K&R A8.3, but it is not entirely clear.+--+-- Identifier lookup:+-- ------------------+--+-- We allow to identify enumerations and structures by the names of `typedef' +-- types aliased to them.+--+-- * enumerations: It is first checked whether there is a tag with the given+-- identifier; if such a tag does not exist, the definition of a typedef+-- with the same name is taken if it exists.+-- * structs/unions: like enumerations+--+-- We generally use `shadow' lookups. When an identifier cannot be found,+-- we check whether - according to the prefix set by the context hook -+-- another identifier casts a shadow that matches. If so, that identifier is+-- taken instead of the original one.+--+--- TODO ----------------------------------------------------------------------+--+-- * A function prototype that uses a defined type on its left hand side may+-- declare a function, while that is not obvious from the declaration+-- itself (without also considering the `typedef'). Calls to such+-- functions are currently rejected, which is a BUG.+--+-- * context hook must precede all but the import hooks+--+-- * The use of `++' in the recursive definition of the routines generating+-- `Enum' instances is not particularly efficient.+--+-- * Some operands are missing in `applyBin' - unfortunately, Haskell does+-- not have standard bit operations. Some constructs are also missing+-- from `evalConstCExpr'. Haskell 98 FFI standardises `Bits'; use that.+--++module GenBind (expandHooks) +where ++-- standard libraries+import Data.Char (toUpper, toLower, isSpace)+import Data.List (deleteBy, intersperse, isPrefixOf, find, nubBy)+import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)+import Control.Monad (when, unless, liftM, mapAndUnzipM)++import Data.Bits ((.&.), (.|.), xor, complement)++-- Compiler Toolkit+import Position (Position, Pos(posOf), nopos, builtinPos)+import Errors (interr, todo)+import Idents (Ident, identToLexeme, onlyPosIdent)+import Attributes (newAttrsOnlyPos)++-- C->Haskell+import C2HSConfig (dlsuffix)+import C2HSState (CST, nop, errorsPresent, showErrors, fatal,+ SwitchBoard(..), Traces(..), putTraceStr, getSwitch,+ printCIO)+import C (AttrC, CObj(..), CTag(..), lookupDefObjC, lookupDefTagC,+ CHeader(..), CExtDecl, CDecl(..), CDeclSpec(..),+ CStorageSpec(..), CTypeSpec(..), CTypeQual(..),+ CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..),+ CInit(..), CExpr(..), CAssignOp(..), CBinaryOp(..),+ CUnaryOp(..), CConst (..),+ CT, readCT, transCT, getCHeaderCT, runCT, ifCTExc,+ raiseErrorCTExc, findValueObj, findFunObj, findTag,+ findTypeObj, applyPrefixToNameSpaces, isTypedef,+ simplifyDecl, declrFromDecl, declrNamed, structMembers,+ structName, tagName, declaredName , structFromDecl,+ funResultAndArgs, chaseDecl, findAndChaseDecl,+ findObjShadow,+ checkForAlias, checkForOneAliasName, lookupEnum,+ lookupStructUnion, lookupDeclOrTag, isPtrDeclr,+ isArrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr,+ refersToNewDef, CDef(..))++-- friends+import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),+ CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..),+ CHSPtrType(..), showCHSParm) +import CInfo (CPrimType(..), size, alignment, bitfieldIntSigned,+ bitfieldAlignment)+import GBMonad (TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep,+ initialGBState, setContext, getPrefix, getLock,+ delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,+ queryObj, queryClass, queryPointer, mergeMaps, dumpMaps)++-- default marshallers+-- -------------------++-- FIXME: +-- - we might have a dynamically extended table in the monad if needed (we+-- could marshall enums this way and also save the `id' marshallers for+-- pointers defined via (newtype) pointer hooks)+-- - the checks for the Haskell types are quite kludgy++-- determine the default "in" marshaller for the given Haskell and C types+--+lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))+lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt = + return $ Just (cFromBoolIde, CHSValArg)+lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy + &&isIntegralCPrimType pt = + return $ Just (cIntConvIde, CHSValArg)+lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy + &&isFloatCPrimType pt = + return $ Just (cFloatConvIde, CHSValArg)+lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] =+ return $ Just (withCStringIde, CHSIOArg)+lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] + | isIntegralCPrimType pt =+ return $ Just (withCStringLenIde, CHSIOArg)+lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy =+ return $ Just (withIde, CHSIOArg)+lookupDftMarshIn hsTy [PtrET (PrimET pt)] + | isIntegralHsType hsTy && isIntegralCPrimType pt =+ return $ Just (withIntConvIde, CHSIOArg)+lookupDftMarshIn hsTy [PtrET (PrimET pt)] + | isFloatHsType hsTy && isFloatCPrimType pt =+ return $ Just (withFloatConvIde, CHSIOArg)+lookupDftMarshIn "Bool" [PtrET (PrimET pt)] + | isIntegralCPrimType pt =+ return $ Just (withFromBoolIde, CHSIOArg)+-- FIXME: handle array-list conversion+lookupDftMarshIn _ _ = + return Nothing++-- determine the default "out" marshaller for the given Haskell and C types+--+lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))+lookupDftMarshOut "()" _ =+ return $ Just (voidIde, CHSVoidArg)+lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt = + return $ Just (cToBoolIde, CHSValArg)+lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy + &&isIntegralCPrimType pt = + return $ Just (cIntConvIde, CHSValArg)+lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy + &&isFloatCPrimType pt = + return $ Just (cFloatConvIde, CHSValArg)+lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] =+ return $ Just (peekCStringIde, CHSIOArg)+lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] + | isIntegralCPrimType pt =+ return $ Just (peekCStringLenIde, CHSIOArg)+lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy =+ return $ Just (peekIde, CHSIOArg)+-- FIXME: add combination, such as "peek" plus "cIntConv" etc+-- FIXME: handle array-list conversion+lookupDftMarshOut _ _ = + return Nothing+++-- check for integral Haskell types+--+isIntegralHsType :: String -> Bool+isIntegralHsType "Int" = True+isIntegralHsType "Int8" = True+isIntegralHsType "Int16" = True+isIntegralHsType "Int32" = True+isIntegralHsType "Int64" = True+isIntegralHsType "Word8" = True+isIntegralHsType "Word16" = True+isIntegralHsType "Word32" = True+isIntegralHsType "Word64" = True+isIntegralHsType _ = False++-- check for floating Haskell types+--+isFloatHsType :: String -> Bool+isFloatHsType "Float" = True+isFloatHsType "Double" = True+isFloatHsType _ = False++-- check for integral C types+--+-- * For marshalling purposes C char's are integral types (see also types+-- classes for which the FFI guarantees instances for `CChar', `CSChar', and+-- `CUChar')+--+isIntegralCPrimType :: CPrimType -> Bool+isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT,+ CLLongPT, CUIntPT, CUCharPT, CUShortPT,+ CULongPT, CULLongPT]) ++-- check for floating C types+--+isFloatCPrimType :: CPrimType -> Bool+isFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT])++-- standard conversions+--+voidIde = noPosIdent "void" -- never appears in the output+cFromBoolIde = noPosIdent "cFromBool"+cToBoolIde = noPosIdent "cToBool"+cIntConvIde = noPosIdent "cIntConv"+cFloatConvIde = noPosIdent "cFloatConv"+withIde = noPosIdent "with"+withCStringIde = noPosIdent "withCString"+withCStringLenIde = noPosIdent "withCStringLenIntConv"+withIntConvIde = noPosIdent "withIntConv"+withFloatConvIde = noPosIdent "withFloatConv"+withFromBoolIde = noPosIdent "withFromBoolConv"+peekIde = noPosIdent "peek"+peekCStringIde = noPosIdent "peekCString"+peekCStringLenIde = noPosIdent "peekCStringLenIntConv"+++-- expansion of binding hooks+-- --------------------------++-- given a C header file and a binding file, expand all hooks in the binding+-- file using the C header information (EXPORTED)+--+-- * together with the module, returns the contents of the .chi file+--+-- * if any error (not warnings) is encountered, a fatal error is raised.+--+-- * also returns all warning messages encountered (last component of result)+--+expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)+expandHooks ac mod = do+ mLock <- getSwitch lockFunSB+ (_, res) <- runCT (expandModule mod) ac (initialGBState mLock)+ return res++expandModule :: CHSModule -> GB (CHSModule, String, String)+expandModule (CHSModule frags) =+ do+ -- expand hooks+ --+ traceInfoExpand+ frags' <- expandFrags frags+ delayedFrags <- getDelayedCode++ -- get .chi dump+ --+ chi <- dumpMaps++ -- check for errors and finalise+ --+ errs <- errorsPresent+ if errs+ then do+ traceInfoErr+ errmsgs <- showErrors+ fatal ("Errors during expansion of binding hooks:\n\n" -- fatal error+ ++ errmsgs)+ else do+ traceInfoOK+ warnmsgs <- showErrors+ return (CHSModule (frags' ++ delayedFrags), chi, warnmsgs)+ where+ traceInfoExpand = putTraceStr tracePhasesSW + ("...expanding binding hooks...\n")+ traceInfoErr = putTraceStr tracePhasesSW + ("...error(s) detected.\n")+ traceInfoOK = putTraceStr tracePhasesSW + ("...successfully completed.\n")++expandFrags :: [CHSFrag] -> GB [CHSFrag]+expandFrags = liftM concat . mapM expandFrag++expandFrag :: CHSFrag -> GB [CHSFrag]+expandFrag verb@(CHSVerb _ _ ) = return [verb]+expandFrag line@(CHSLine _ ) = return [line]+expandFrag prag@(CHSLang _ _ ) = return [prag]+expandFrag (CHSHook h ) = + do+ code <- expandHook h+ return [CHSVerb code builtinPos]+ `ifCTExc` return [CHSVerb "** ERROR **" builtinPos]+expandFrag (CHSCPP s _ ) = + interr $ "GenBind.expandFrag: Left over CHSCPP!\n---\n" ++ s ++ "\n---"+expandFrag (CHSC s _ ) = + interr $ "GenBind.expandFrag: Left over CHSC!\n---\n" ++ s ++ "\n---"+expandFrag (CHSCond alts dft) = + do+ traceInfoCond+ select alts+ where+ select [] = do+ traceInfoDft dft+ expandFrags (maybe [] id dft)+ select ((ide, frags):alts) = do+ oobj <- findTag ide+ traceInfoVal ide oobj+ if isNothing oobj+ then+ select alts+ else -- found right alternative+ expandFrags frags+ --+ traceInfoCond = traceGenBind "** CPP conditional:\n"+ traceInfoVal ide oobj = traceGenBind $ identToLexeme ide ++ " is " +++ (if isNothing oobj then "not " else "") +++ "defined.\n"+ traceInfoDft dft = if isNothing dft + then + return () + else + traceGenBind "Choosing else branch.\n"++expandHook :: CHSHook -> GB String+expandHook (CHSImport qual ide chi _) =+ do+ mergeMaps chi+ return $ + "import " ++ (if qual then "qualified " else "") ++ identToLexeme ide+expandHook (CHSContext olib oprefix olock _) =+ do+ setContext olib oprefix olock -- enter context information+ mapMaybeM_ applyPrefixToNameSpaces oprefix -- use the prefix on name spaces+ return ""+expandHook (CHSType ide pos) =+ do+ traceInfoType+ decl <- findAndChaseDecl ide False True -- no indirection, but shadows+ ty <- extractSimpleType pos decl+ traceInfoDump decl ty+ return $ "(" ++ showExtType ty ++ ")"+ where+ traceInfoType = traceGenBind "** Type hook:\n"+ traceInfoDump decl ty = traceGenBind $+ "Declaration\n" ++ show decl ++ "\ntranslates to\n" + ++ showExtType ty ++ "\n"+expandHook (CHSSizeof ide pos) =+ do+ traceInfoSizeof+ decl <- findAndChaseDecl ide False True -- no indirection, but shadows+ (size, _) <- sizeAlignOf decl+ traceInfoDump decl size+ return $ show (fromIntegral . padBits $ size)+ where+ traceInfoSizeof = traceGenBind "** Sizeof hook:\n"+ traceInfoDump decl size = traceGenBind $+ "Size of declaration\n" ++ show decl ++ "\nis " + ++ show (fromIntegral . padBits $ size) ++ "\n"+expandHook (CHSEnum cide oalias chsTrans oprefix derive _) =+ do+ -- get the corresponding C declaration+ --+ enum <- lookupEnum cide True -- smart lookup incl error handling+ --+ -- convert the translation table and generate data type definition code+ --+ gprefix <- getPrefix+ let prefix = fromMaybe gprefix oprefix+ trans = transTabToTransFun prefix chsTrans+ hide = identToLexeme . fromMaybe cide $ oalias+ enumDef enum hide trans (map identToLexeme derive)+expandHook hook@(CHSCall isPure isUns isNol ide oalias pos) =+ do+ traceEnter+ -- get the corresponding C declaration; raises error if not found or not a+ -- function; we use shadow identifiers, so the returned identifier is used + -- afterwards instead of the original one+ --+ (ObjCO cdecl, ide) <- findFunObj ide True+ mLock <- if isNol then return Nothing else getLock+ let ideLexeme = identToLexeme ide -- orignal name might have been a shadow+ hsLexeme = ideLexeme `maybe` identToLexeme $ oalias+ cdecl' = ide `simplifyDecl` cdecl+ callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl' pos+ where+ traceEnter = traceGenBind $ + "** Call hook for `" ++ identToLexeme ide ++ "':\n"+expandHook hook@(CHSFun isPure isUns isNol ide oalias ctxt parms parm pos) =+ do+ traceEnter+ -- get the corresponding C declaration; raises error if not found or not a+ -- function; we use shadow identifiers, so the returned identifier is used + -- afterwards instead of the original one+ --+ (ObjCO cdecl, cide) <- findFunObj ide True+ mLock <- if isNol then return Nothing else getLock+ let ideLexeme = identToLexeme ide -- orignal name might have been a shadow+ hsLexeme = ideLexeme `maybe` identToLexeme $ oalias+ fiLexeme = hsLexeme ++ "'_" -- *Urgh* - probably unique...+ fiIde = onlyPosIdent nopos fiLexeme+ cdecl' = cide `simplifyDecl` cdecl+ callHook = CHSCall isPure isUns isNol cide (Just fiIde) pos+ callImport callHook isPure isUns mLock (identToLexeme cide) fiLexeme cdecl' pos+ funDef isPure hsLexeme fiLexeme cdecl' ctxt mLock parms parm pos+ where+ traceEnter = traceGenBind $ + "** Fun hook for `" ++ identToLexeme ide ++ "':\n"+expandHook (CHSField access path pos) =+ do+ traceInfoField+ (decl, offsets) <- accessPath path+ traceDepth offsets+ ty <- extractSimpleType pos decl+ traceValueType ty+ setGet pos access offsets ty+ where+ accessString = case access of+ CHSGet -> "Get"+ CHSSet -> "Set"+ traceInfoField = traceGenBind $ "** " ++ accessString ++ " hook:\n"+ traceDepth offsets = traceGenBind $ "Depth of access path: " + ++ show (length offsets) ++ "\n"+ traceValueType et = traceGenBind $ + "Type of accessed value: " ++ showExtType et ++ "\n"+expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType pos) =+ do+ traceInfoPointer+ let hsIde = fromMaybe cName oalias+ hsName = identToLexeme hsIde+ hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object+ --+ -- we check for a typedef declaration or tag (struct, union, or enum)+ --+ declOrTag <- lookupDeclOrTag cName True+ case declOrTag of+ Left cdecl -> do -- found a typedef declaration+ cNameFull <- case declaredName cdecl of+ Just ide -> return ide+ Nothing -> interr + "GenBind.expandHook: Where is the name?"+ cNameFull `refersToNewDef` ObjCD (TypeCO cdecl) + -- assoc needed for chasing+ traceInfoCName "declaration" cNameFull+ unless (isStar || isPtrDecl cdecl) $ + ptrExpectedErr (posOf cName)+ (hsType, isFun) <- + case oRefType of+ Nothing -> do+ cDecl <- chaseDecl cNameFull (not isStar)+ et <- extractPtrType cDecl+ let et' = adjustPtr isStar et+ return (showExtType et', isFunExtType et')+ Just hsType -> return (identToLexeme hsType, False)+ -- FIXME: it is not possible to determine whether `hsType'+ -- is a function; we would need to extend the syntax to+ -- allow `... -> fun HSTYPE' to explicitly mark function+ -- types if this ever becomes important+ traceInfoHsType hsName hsType+ realCName <- liftM (maybe cName snd) $ findObjShadow cName+ pointerDef isStar realCName hsName ptrKind isNewtype hsType isFun+ Right tag -> do -- found a tag definition+ let cNameFull = tagName tag+ traceInfoCName "tag definition" cNameFull+ unless isStar $ -- tags need an explicit `*'+ ptrExpectedErr (posOf cName)+ let hsType = case oRefType of+ Nothing -> "()"+ Just hsType -> identToLexeme hsType+ traceInfoHsType hsName hsType+ pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False+ where+ -- remove a pointer level if the first argument is `False'+ --+ adjustPtr True et = et+ adjustPtr False (PtrET et) = et+ adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?"+ --+ traceInfoPointer = traceGenBind "** Pointer hook:\n"+ traceInfoCName kind ide = traceGenBind $ + "found C " ++ kind ++ " for `" ++ identToLexeme ide ++ "'\n"+ traceInfoHsType name ty = traceGenBind $ + "associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty + ++ "\n"+expandHook (CHSClass oclassIde classIde typeIde pos) =+ do+ traceInfoClass+ classIde `objIs` Class oclassIde typeIde -- register Haskell object+ superClasses <- collectClasses oclassIde+ Pointer ptrType isNewtype <- queryPointer typeIde+ when (ptrType == CHSStablePtr) $+ illegalStablePtrErr pos+ classDef pos (identToLexeme classIde) (identToLexeme typeIde) + ptrType isNewtype superClasses+ where+ -- compile a list of all super classes (the direct super class first)+ --+ collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]+ collectClasses Nothing = return []+ collectClasses (Just ide) = + do+ Class oclassIde typeIde <- queryClass ide+ ptr <- queryPointer typeIde+ classes <- collectClasses oclassIde+ return $ (identToLexeme ide, identToLexeme typeIde, ptr) : classes+ --+ traceInfoClass = traceGenBind $ "** Class hook:\n"++-- produce code for an enumeration+--+-- * an extra instance declaration is required when any of the enumeration+-- constants is explicitly assigned a value in its definition+--+-- * the translation function strips prefixes where possible (different+-- enumerators maye have different prefixes)+--+enumDef :: CEnum -> String -> TransFun -> [String] -> GB String+enumDef cenum@(CEnum _ list _) hident trans userDerive =+ do+ (list', enumAuto) <- evalTagVals list+ let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list'] -- translate+ defHead = enumHead hident+ defBody = enumBody (length defHead - 2) enumVals+ inst = makeDerives + (if enumAuto then "Enum" : userDerive else userDerive) +++ if enumAuto then "\n" else "\n" ++ enumInst hident enumVals+ return $ defHead ++ defBody ++ inst+ where+ cpos = posOf cenum+ --+ evalTagVals [] = return ([], True)+ evalTagVals ((ide, Nothing ):list) = + do+ (list', derived) <- evalTagVals list+ return ((ide, Nothing):list', derived)+ evalTagVals ((ide, Just exp):list) = + do+ (list', derived) <- evalTagVals list+ val <- evalConstCExpr exp+ case val of+ IntResult val' -> + return ((ide, Just $ CConst (CIntConst val' at1) at2):list', + False)+ FloatResult _ ->+ illegalConstExprErr (posOf exp) "a float result"+ where+ at1 = newAttrsOnlyPos nopos+ at2 = newAttrsOnlyPos nopos+ makeDerives [] = ""+ makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")"++-- Haskell code for the head of an enumeration definition+--+enumHead :: String -> String+enumHead ident = "data " ++ ident ++ " = "++-- Haskell code for the body of an enumeration definition+--+enumBody :: Int -> [(String, Maybe CExpr)] -> String+enumBody indent [] = ""+enumBody indent ((ide, _):list) =+ ide ++ "\n" ++ replicate indent ' ' + ++ (if null list then "" else "| " ++ enumBody indent list)++-- Haskell code for an instance declaration for `Enum'+--+-- * the expression of all explicitly specified tag values already have to be+-- in normal form, ie, to be an int constant+--+-- * enumerations start at 0 and whenever an explicit value is specified,+-- following tags are assigned values continuing from the explicitly+-- specified one+--+enumInst :: String -> [(String, Maybe CExpr)] -> String+enumInst ident list =+ "instance Enum " ++ ident ++ " where\n"+ ++ fromDef flatList ++ "\n" ++ toDef flatList ++ "\n"+ ++ succDef names ++ "\n" ++ predDef names ++ "\n"+ ++ enumFromToDef names+ where+ names = map fst list+ flatList = flatten list 0++ flatten [] n = []+ flatten ((ide, exp):list) n = (ide, val) : flatten list (val + 1)+ where+ val = case exp of+ Nothing -> n+ Just (CConst (CIntConst m _) _) -> m+ Just _ -> interr "GenBind.enumInst: Integer constant expected!"++ show' x = if x < 0 then "(" ++ show x ++ ")" else show x+ fromDef list = concat+ [ " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n"+ | (ide, val) <- list+ ]+ toDef list = concat+ [ " toEnum " ++ show' val ++ " = " ++ ide ++ "\n"+ | (ide, val) <- nubBy (\x y -> snd x == snd y) list+ ]+ ++ " toEnum unmatched = error (\"" ++ ident+ ++ ".toEnum: Cannot match \" ++ show unmatched)\n"++ succDef [] = " succ _ = undefined\n"+ succDef [x] = " succ _ = undefined\n"+ succDef (x:x':xs) =+ " succ " ++ x ++ " = " ++ x' ++ "\n"+ ++ succDef (x':xs)+ predDef [] = " pred _ = undefined\n"+ predDef [x] = " pred _ = undefined\n"+ predDef (x:x':xs) =+ " pred " ++ x' ++ " = " ++ x ++ "\n"+ ++ predDef (x':xs)+ enumFromToDef [] = ""+ enumFromToDef names =+ " enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"+ ++ " | otherwise = x : enumFromTo (succ x) y\n"+ ++ " enumFrom x = enumFromTo x " ++ last names ++ "\n"+ ++ " enumFromThen _ _ = "+ ++ " error \"Enum "++ident++": enumFromThen not implemented\"\n"+ ++ " enumFromThenTo _ _ _ = "+ ++ " error \"Enum "++ident++": enumFromThenTo not implemented\"\n"+++-- generate a foreign import declaration that is put into the delayed code+--+-- * the C declaration is a simplified declaration of the function that we+-- want to import into Haskell land+--+callImport :: CHSHook -> Bool -> Bool -> Maybe String -> String -> String+ -> CDecl -> Position -> GB String+callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl pos =+ do+ -- compute the external type from the declaration, and delay the foreign+ -- export declaration+ --+ (mHsPtrRep, extType) <- extractFunType pos cdecl isPure+ header <- getSwitch headerSB+ delayCode hook (foreignImport header ideLexeme hsLexeme isUns extType)+ traceFunType extType+ -- if the type any special pointer aliases, generate a lambda expression+ -- which strips off the constructors+ if any isJust mHsPtrRep+ then createLambdaExpr mHsPtrRep+ else return funStr+ where+ createLambdaExpr :: [Maybe HsPtrRep] -> GB String+ createLambdaExpr foreignVec = return $+ "(\\" +++ unwords (zipWith wrPattern foreignVec [1..])++ " -> "+++ concat (zipWith wrForPtr foreignVec [1..])++funStr++" "+++ unwords (zipWith wrArg foreignVec [1..])++")"+ wrPattern (Just (_,_,Just con,_)) n = "("++con++" arg"++show n++")"+ wrPattern _ n = "arg"++show n+ wrForPtr (Just (_,CHSForeignPtr,_,_)) n + = "withForeignPtr arg"++show n++" $ \\argPtr"++show n++" ->"+ wrForPtr _ n = ""+ wrArg (Just (_,CHSForeignPtr,_,_)) n = "argPtr"++show n+ wrArg (Just (_,CHSStablePtr,_,_)) n = + "(castStablePtrToPtr arg"++show n++")"+ wrArg _ n = "arg"++show n++ funStr = case mLock of Nothing -> hsLexeme+ Just lockFun -> lockFun ++ " $ " ++ hsLexeme+ traceFunType et = traceGenBind $ + "Imported function type: " ++ showExtType et ++ "\n"++-- Haskell code for the foreign import declaration needed by a call hook+--+-- On Windows, the paths for headers in "entity" may include backslashes, like+-- dist\build\System\Types\GIO.h+-- It seems GHC expects these to be escaped. Below, we make an educated guess+-- that it in fact expects a Haskell string, and use the "show" function to do+-- the escaping of this (and any other cases) for us.+foreignImport :: String -> String -> String -> Bool -> ExtType -> String+foreignImport header ident hsIdent isUnsafe ty =+ "foreign import ccall " ++ safety ++ " " ++ show entity +++ "\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n"+ where+ safety = if isUnsafe then "unsafe" else "safe"+ entity | null header = ident+ | otherwise = header ++ " " ++ ident++-- produce a Haskell function definition for a fun hook+--+funDef :: Bool -- pure function?+ -> String -- name of the new Haskell function+ -> String -- Haskell name of the foreign imported C function+ -> CDecl -- simplified declaration of the C function+ -> Maybe String -- type context of the new Haskell function+ -> Maybe String -- lock function+ -> [CHSParm] -- parameter marshalling description+ -> CHSParm -- result marshalling description + -> Position -- source location of the hook+ -> GB String -- Haskell code in text form+funDef isPure hsLexeme fiLexeme cdecl octxt mLock parms parm pos =+ do+ (parms', parm', isImpure) <- addDftMarshaller pos parms parm cdecl+ traceMarsh parms' parm' isImpure+ let + sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n"+ marshs = [marshArg i parm | (i, parm) <- zip [1..] parms']+ funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""]+ marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs]+ callArgs = [callArg | (_, _, callArg, _, _) <- marshs]+ marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""]+ retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""]+ funHead = hsLexeme ++ join funArgs ++ " =\n" +++ if isPure && isImpure then " unsafePerformIO $\n" else ""+ lock = case mLock of Nothing -> ""+ Just lock -> lock ++ " $"+ call = if isPure + then " let {res = " ++ fiLexeme ++ join callArgs ++ "} in\n"+ else " " ++ lock ++ fiLexeme ++ join callArgs ++ " >>= \\res ->\n"+ marshRes = case parm' of+ CHSParm _ _ twoCVal (Just (_ , CHSVoidArg)) _ -> ""+ CHSParm _ _ twoCVal (Just (omIde, CHSIOArg )) _ -> + " " ++ identToLexeme omIde ++ " res >>= \\res' ->\n"+ CHSParm _ _ twoCVal (Just (omIde, CHSValArg )) _ -> + " let {res' = " ++ identToLexeme omIde ++ " res} in\n"+ CHSParm _ _ _ Nothing _ ->+ interr "GenBind.funDef: marshRes: no default?"+ retArgs' = case parm' of+ CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs+ _ -> "res'":retArgs+ ret = "(" ++ concat (intersperse ", " retArgs') ++ ")"+ funBody = joinLines marshIns ++ + call +++ joinLines marshOuts ++ + marshRes ++ + " " ++ + (if isImpure || not isPure then "return " else "") ++ ret+ return $ sig ++ funHead ++ funBody+ where+ join = concatMap (' ':)+ joinLines = concatMap (\s -> " " ++ s ++ "\n")+ --+ -- construct the function type+ --+ -- * specified types appear in the argument and result only if their "in"+ -- and "out" marshaller, respectively, is not the `void' marshaller+ --+ funTy parms parm =+ let+ ctxt = case octxt of+ Nothing -> ""+ Just ctxtStr -> ctxtStr ++ " => "+ argTys = [ty | CHSParm im ty _ _ _ <- parms , notVoid im]+ resTys = [ty | CHSParm _ ty _ om _ <- parm:parms, notVoid om]+ resTup = let+ (lp, rp) = if isPure && length resTys == 1 + then ("", "") + else ("(", ")") + io = if isPure then "" else "IO "+ in+ io ++ lp ++ concat (intersperse ", " resTys) ++ rp+ + in+ ctxt ++ concat (intersperse " -> " (argTys ++ [resTup]))+ where+ notVoid Nothing = interr "GenBind.funDef: \+ \No default marshaller?"+ notVoid (Just (_, kind)) = kind /= CHSVoidArg+ --+ -- for an argument marshaller, generate all "in" and "out" marshalling+ -- code fragments+ --+ marshArg i (CHSParm (Just (imIde, imArgKind)) _ twoCVal + (Just (omIde, omArgKind)) _ ) =+ let+ a = "a" ++ show i+ imStr = identToLexeme imIde+ imApp = imStr ++ " " ++ a+ funArg = if imArgKind == CHSVoidArg then "" else a+ inBndr = if twoCVal + then "(" ++ a ++ "'1, " ++ a ++ "'2)"+ else a ++ "'"+ marshIn = case imArgKind of+ CHSVoidArg -> imStr ++ " $ \\" ++ inBndr ++ " -> "+ CHSIOArg -> imApp ++ " $ \\" ++ inBndr ++ " -> "+ CHSValArg -> "let {" ++ inBndr ++ " = " ++ + imApp ++ "} in "+ callArg = if twoCVal + then "" ++ a ++ "'1 " ++ a ++ "'2"+ else a ++ "'"+ omApp = identToLexeme omIde ++ " " ++ callArg+ outBndr = a ++ "''"+ marshOut = case omArgKind of+ CHSVoidArg -> ""+ CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> "+ CHSValArg -> "let {" ++ outBndr ++ " = " ++ + omApp ++ "} in "+ retArg = if omArgKind == CHSVoidArg then "" else outBndr+ in+ (funArg, marshIn, callArg, marshOut, retArg)+ marshArg _ _ = interr "GenBind.funDef: Missing default?"+ --+ traceMarsh parms parm isImpure = traceGenBind $ + "Marshalling specification including defaults: \n" +++ showParms (parms ++ [parm]) "" +++ " The marshalling is " ++ if isImpure then "impure.\n" else "pure.\n"+ where+ showParms [] = id+ showParms (parm:parms) = showString " "+ . showCHSParm parm + . showChar '\n' + . showParms parms++-- add default marshallers for "in" and "out" marshalling+--+addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl + -> GB ([CHSParm], CHSParm, Bool)+addDftMarshaller pos parms parm cdecl = do+ (_, fType) <- extractFunType pos cdecl True+ let (resTy, argTys) = splitFunTy fType+ (parm' , isImpure1) <- checkResMarsh parm resTy+ (parms', isImpure2) <- addDft parms argTys+ return (parms', parm', isImpure1 || isImpure2)+ where+ -- the result marshalling may not use an "in" marshaller and can only have+ -- one C value+ --+ -- * a default marshaller maybe used for "out" marshalling+ --+ checkResMarsh (CHSParm (Just _) _ _ _ pos) _ = + resMarshIllegalInErr pos+ checkResMarsh (CHSParm _ _ True _ pos) _ = + resMarshIllegalTwoCValErr pos+ checkResMarsh (CHSParm _ ty _ omMarsh pos) cTy = do+ (imMarsh', _ ) <- addDftVoid Nothing+ (omMarsh', isImpure) <- addDftOut pos omMarsh ty [cTy]+ return (CHSParm imMarsh' ty False omMarsh' pos, isImpure)+ --+ splitFunTy (FunET UnitET ty ) = splitFunTy ty+ splitFunTy (FunET ty1 ty2) = let + (resTy, argTys) = splitFunTy ty2+ in+ (resTy, ty1:argTys)+ splitFunTy resTy = (resTy, [])+ --+ -- match Haskell with C arguments (and results)+ --+ addDft ((CHSParm imMarsh hsTy False omMarsh p):parms) (cTy :cTys) = do+ (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy]+ (omMarsh', isImpureOut) <- addDftVoid omMarsh+ (parms' , isImpure ) <- addDft parms cTys+ return (CHSParm imMarsh' hsTy False omMarsh' p : parms',+ isImpure || isImpureIn || isImpureOut)+ addDft ((CHSParm imMarsh hsTy True omMarsh p):parms) (cTy1:cTy2:cTys) = do+ (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2]+ (omMarsh', isImpureOut) <- addDftVoid omMarsh+ (parms' , isImpure ) <- addDft parms cTys+ return (CHSParm imMarsh' hsTy True omMarsh' p : parms',+ isImpure || isImpureIn || isImpureOut)+ addDft [] [] = + return ([], False)+ addDft ((CHSParm _ _ _ _ pos):parms) [] = + marshArgMismatchErr pos "This parameter is in excess of the C arguments."+ addDft [] (_:_) = + marshArgMismatchErr pos "Parameter marshallers are missing."+ --+ addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh,+ kind == CHSIOArg)+ addDftIn pos imMarsh@Nothing hsTy cTys = do+ marsh <- lookupDftMarshIn hsTy cTys+ when (isNothing marsh) $+ noDftMarshErr pos "\"in\"" hsTy cTys+ return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})+ --+ addDftOut _ omMarsh@(Just (_, kind)) _ _ = return (omMarsh,+ kind == CHSIOArg)+ addDftOut pos omMarsh@Nothing hsTy cTys = do+ marsh <- lookupDftMarshOut hsTy cTys+ when (isNothing marsh) $+ noDftMarshErr pos "\"out\"" hsTy cTys+ return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})+ --+ -- add void marshaller if no explict one is given+ --+ addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg)+ addDftVoid Nothing = do+ return (Just (noPosIdent "void", CHSVoidArg), False)++-- compute from an access path, the declarator finally accessed and the index+-- path required for the access+--+-- * each element in the index path specifies dereferencing an address and the +-- offset to be added to the address before dereferencing+--+-- * the returned declaration is already normalised (ie, alias have been+-- expanded) +--+-- * it may appear as if `t.m' and `t->m' should have different access paths,+-- as the latter specifies one more dereferencing; this is certainly true in+-- C, but it doesn't apply here, as `t.m' is merely provided for the+-- convenience of the interface writer - it is strictly speaking an+-- impossible access paths, as in Haskell we always have a pointer to a+-- structure, we can never have the structure as a value itself+--+accessPath :: CHSAPath -> GB (CDecl, [BitSize])+accessPath (CHSRoot ide) = -- t+ do+ decl <- findAndChaseDecl ide False True+ return (ide `simplifyDecl` decl, [BitSize 0 0])+accessPath (CHSDeref (CHSRoot ide) _) = -- *t+ do+ decl <- findAndChaseDecl ide True True+ return (ide `simplifyDecl` decl, [BitSize 0 0])+accessPath (CHSRef root@(CHSRoot ide1) ide2) = -- t.m+ do+ su <- lookupStructUnion ide1 False True+ (offset, decl') <- refStruct su ide2+ adecl <- replaceByAlias decl'+ return (adecl, [offset])+accessPath (CHSRef (CHSDeref (CHSRoot ide1) _) ide2) = -- t->m+ do+ su <- lookupStructUnion ide1 True True+ (offset, decl') <- refStruct su ide2+ adecl <- replaceByAlias decl'+ return (adecl, [offset])+accessPath (CHSRef path ide) = -- a.m+ do+ (decl, offset:offsets) <- accessPath path+ assertPrimDeclr ide decl+ su <- structFromDecl (posOf ide) decl+ (addOffset, decl') <- refStruct su ide+ adecl <- replaceByAlias decl'+ return (adecl, offset `addBitSize` addOffset : offsets)+ where+ assertPrimDeclr ide (CDecl _ [declr] _) =+ case declr of+ (Just (CVarDeclr _ _), _, _) -> nop+ _ -> structExpectedErr ide+accessPath (CHSDeref path pos) = -- *a+ do+ (decl, offsets) <- accessPath path+ decl' <- derefOrErr decl+ adecl <- replaceByAlias decl'+ return (adecl, BitSize 0 0 : offsets)+ where+ derefOrErr (CDecl specs [declr] at) =+ case declr of+ (Just (CPtrDeclr [_] declr at), oinit, oexpr) -> + return $ CDecl specs [(Just declr, oinit, oexpr)] at+ (Just (CPtrDeclr (_:quals) declr at), oinit, oexpr) -> + return $ + CDecl specs [(Just (CPtrDeclr quals declr at), oinit, oexpr)] at+ _ -> + ptrExpectedErr pos++-- replaces a decleration by its alias if any+--+-- * the alias inherits any field size specification that the original+-- declaration may have+--+-- * declaration must have exactly one declarator+--+replaceByAlias :: CDecl -> GB CDecl+replaceByAlias cdecl@(CDecl _ [(_, _, size)] at) =+ do+ ocdecl <- checkForAlias cdecl+ case ocdecl of+ Nothing -> return cdecl+ Just (CDecl specs [(declr, init, _)] at) -> -- form of an alias+ return $ CDecl specs [(declr, init, size)] at++-- given a structure declaration and member name, compute the offset of the+-- member in the structure and the declaration of the referenced member+--+refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)+refStruct su ide =+ do+ -- get the list of fields and check for our selector+ --+ let (fields, tag) = structMembers su+ (pre, post) = span (not . flip declNamed ide) fields+ when (null post) $+ unknownFieldErr (posOf su) ide+ --+ -- get sizes of preceding fields and the result type (`pre' are all+ -- declarators preceding `ide' and the first declarator in `post' defines + -- `ide')+ --+ let decl = head post+ offset <- case tag of+ CStructTag -> offsetInStruct pre decl tag+ CUnionTag -> return $ BitSize 0 0+ return (offset, decl)++-- does the given declarator define the given name?+--+declNamed :: CDecl -> Ident -> Bool+(CDecl _ [(Nothing , _, _)] _) `declNamed` ide = False+(CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide+(CDecl _ [] _) `declNamed` _ =+ interr "GenBind.declNamed: Abstract declarator in structure!"+_ `declNamed` _ =+ interr "GenBind.declNamed: More than one declarator!"++-- Haskell code for writing to or reading from a struct+--+setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String+setGet pos access offsets ty =+ do+ let pre = case access of + CHSSet -> "(\\ptr val -> do {"+ CHSGet -> "(\\ptr -> do {"+ body <- setGetBody (reverse offsets)+ return $ pre ++ body ++ "})"+ where+ setGetBody [BitSize offset bitOffset] =+ do+ let ty' = case ty of+ t@(DefinedET _ _) -> PtrET t+ t -> t+ let tyTag = showExtType ty'+ bf <- checkType ty'+ case bf of+ Nothing -> return $ case access of -- not a bitfield+ CHSGet -> peekOp offset tyTag+ CHSSet -> pokeOp offset tyTag "val"+--FIXME: must take `bitfieldDirection' into account+ Just (_, bs) -> return $ case access of -- a bitfield+ CHSGet -> "val <- " ++ peekOp offset tyTag+ ++ extractBitfield+ CHSSet -> "org <- " ++ peekOp offset tyTag+ ++ insertBitfield + ++ pokeOp offset tyTag "val'"+ where+ -- we have to be careful here to ensure proper sign extension;+ -- in particular, shifting right followed by anding a mask is+ -- *not* sufficient; instead, we exploit in the following that+ -- `shiftR' performs sign extension+ --+ extractBitfield = "; return $ (val `shiftL` (" + ++ bitsPerField ++ " - " + ++ show (bs + bitOffset) ++ ")) `shiftR` ("+ ++ bitsPerField ++ " - " ++ show bs+ ++ ")"+ bitsPerField = show $ size CIntPT * 8+ --+ insertBitfield = "; let {val' = (org .&. " ++ middleMask+ ++ ") .|. (val `shiftL` " + ++ show bitOffset ++ ")}; "+ middleMask = "fromIntegral (((maxBound::CUInt) `shiftL` "+ ++ show bs ++ ") `rotateL` " + ++ show bitOffset ++ ")"+ setGetBody (BitSize offset 0 : offsets) =+ do+ code <- setGetBody offsets+ return $ "ptr <- peekByteOff ptr " ++ show offset ++ "; " ++ code+ setGetBody (BitSize _ _ : _ ) =+ derefBitfieldErr pos+ --+ -- check that the type can be marshalled and compute extra operations for+ -- bitfields+ --+ checkType (IOET _ ) = interr "GenBind.setGet: Illegal \+ \type!"+ checkType (UnitET ) = voidFieldErr pos+ checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)+ checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)+ checkType _ = return Nothing+ --+ peekOp off tyTag = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag+ pokeOp off tyTag var = "pokeByteOff ptr " ++ show off ++ " (" ++ var+ ++ "::" ++ tyTag ++ ")"++-- generate the type definition for a pointer hook and enter the required type+-- mapping into the `ptrmap'+--+pointerDef :: Bool -- explicit `*' in pointer hook+ -> Ident -- full C name+ -> String -- Haskell name+ -> CHSPtrType -- kind of the pointer+ -> Bool -- explicit newtype tag+ -> String -- Haskell type expression of pointer argument+ -> Bool -- do we have a pointer to a function?+ -> GB String+pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun =+ do+ keepOld <- getSwitch oldFFI+ let ptrArg = if keepOld + then "()" -- legacy FFI interface+ else if isNewtype + then hsName -- abstract type+ else hsType -- concrete type+ ptrCon = case ptrKind of+ CHSPtr | isFun -> "FunPtr"+ _ -> show ptrKind+ ptrType = ptrCon ++ " (" ++ ptrArg ++ ")"+ thePtr = (isStar, cNameFull)++ thePtr `ptrMapsTo` (isFun,+ ptrKind,+ if isNewtype then Just hsName else Nothing,+ ptrArg)+ return $+ if isNewtype + then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")"+ else "type " ++ hsName ++ " = " ++ ptrType++-- generate the class and instance definitions for a class hook+--+-- * the pointer type must not be a stable pointer+--+-- * the first super class (if present) must be the direct superclass+--+-- * all Haskell objects in the superclass list must be pointer objects+--+classDef :: Position -- for error messages+ -> String -- class name+ -> String -- pointer type name+ -> CHSPtrType -- type of the pointer+ -> Bool -- is a newtype?+ -> [(String, String, HsObject)] -- superclasses+ -> GB String+classDef pos className typeName ptrType isNewtype superClasses =+ do+ let+ toMethodName = case typeName of+ "" -> interr "GenBind.classDef: \+ \Illegal identifier!"+ c:cs -> toLower c : cs+ fromMethodName = "from" ++ typeName+ classDefContext = case superClasses of+ [] -> "" + (superName, _, _):_ -> superName ++ " p => "+ classDef = + "class " ++ classDefContext ++ className ++ " p where\n" + ++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n"+ ++ " " ++ fromMethodName ++ " :: " ++ typeName ++ " -> p\n"+ instDef = + "instance " ++ className ++ " " ++ typeName ++ " where\n"+ ++ " " ++ toMethodName ++ " = id\n"+ ++ " " ++ fromMethodName ++ " = id\n"+ instDefs <- castInstDefs superClasses+ return $ classDef ++ instDefs ++ instDef+ where + castInstDefs [] = return ""+ castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) =+ do+ unless (ptrType == ptrType') $+ pointerTypeMismatchErr pos className superName+ let toMethodName = case ptrName of+ "" -> interr "GenBind.classDef: \+ \Illegal identifier - 2!"+ c:cs -> toLower c : cs+ fromMethodName = "from" ++ ptrName+ castFun = "cast" ++ show ptrType+ typeConstr = if isNewtype then typeName ++ " " else ""+ superConstr = if isNewtype' then ptrName ++ " " else ""+ instDef =+ "instance " ++ superName ++ " " ++ typeName ++ " where\n"+ ++ " " ++ toMethodName ++ " (" ++ typeConstr ++ "p) = " + ++ superConstr ++ "(" ++ castFun ++ " p)\n"+ ++ " " ++ fromMethodName ++ " (" ++ superConstr ++ "p) = " + ++ typeConstr ++ "(" ++ castFun ++ " p)\n"+ instDefs <- castInstDefs classes+ return $ instDef ++ instDefs+++-- C code computations+-- -------------------++-- the result of a constant expression+--+data ConstResult = IntResult Integer+ | FloatResult Float++-- types that may occur in foreign declarations, ie, Haskell land types+--+-- * we reprsent C functions with no arguments (ie, the ANSI C `void'+-- argument) by `FunET UnitET res' rather than just `res' internally,+-- although the latter representation is finally emitted into the binding+-- file; this is because we need to know which types are functions (in+-- particular, to distinguish between `Ptr a' and `FunPtr a')+--+-- * aliased types (`DefinedET') are represented by a string plus their C+-- declaration; the latter is for functions interpreting the following+-- structure; an aliased type is always a pointer type that is contained in+-- the pointer map (and got there either from a .chi or from a pointer hook+-- in the same module)+--+-- * the representation for pointers does not distinguish between normal,+-- function, foreign, and stable pointers; function pointers are identified+-- by their argument and foreign and stable pointers are only used+-- indirectly, by referring to type names introduced by a `pointer' hook+--+data ExtType = FunET ExtType ExtType -- function+ | IOET ExtType -- operation with side effect+ | PtrET ExtType -- typed pointer+ | DefinedET CDecl HsPtrRep -- aliased type+ | PrimET CPrimType -- basic C type+ | UnitET -- void++instance Eq ExtType where+ (FunET t1 t2 ) == (FunET t1' t2' ) = t1 == t1' && t2 == t2'+ (IOET t ) == (IOET t' ) = t == t'+ (PtrET t ) == (PtrET t' ) = t == t'+ (DefinedET _ rep ) == (DefinedET _ rep' ) = rep == rep'+ (PrimET t ) == (PrimET t' ) = t == t'+ UnitET == UnitET = True++-- composite C type+--+data CompType = ExtType ExtType -- external type+ | SUType CStructUnion -- structure or union++-- check whether an external type denotes a function type+--+isFunExtType :: ExtType -> Bool+isFunExtType (FunET _ _) = True+isFunExtType (IOET _ ) = True+isFunExtType (DefinedET _ (isFun,_,_,_)) = isFun+isFunExtType _ = False++-- pretty print an external type+--+-- * a previous version of this function attempted to not print unnecessary+-- brackets; this however doesn't work consistently due to `DefinedET'; so,+-- we give up on the idea (preferring simplicity)+--+showExtType :: ExtType -> String+showExtType (FunET UnitET res) = showExtType res+showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> " + ++ showExtType res ++ ")"+showExtType (IOET t) = "(IO " ++ showExtType t ++ ")"+showExtType (PtrET t) = let ptrCon = if isFunExtType t + then "FunPtr" else "Ptr"+ in+ "(" ++ ptrCon ++ " " ++ showExtType t + ++ ")"+showExtType (DefinedET _ (_,_,_,str)) = str+showExtType (PrimET CPtrPT) = "(Ptr ())"+showExtType (PrimET CFunPtrPT) = "(FunPtr ())"+showExtType (PrimET CCharPT) = "CChar"+showExtType (PrimET CUCharPT) = "CUChar"+showExtType (PrimET CSCharPT) = "CSChar"+showExtType (PrimET CIntPT) = "CInt"+showExtType (PrimET CShortPT) = "CShort"+showExtType (PrimET CLongPT) = "CLong"+showExtType (PrimET CLLongPT) = "CLLong"+showExtType (PrimET CUIntPT) = "CUInt"+showExtType (PrimET CUShortPT) = "CUShort"+showExtType (PrimET CULongPT) = "CULong"+showExtType (PrimET CULLongPT) = "CULLong"+showExtType (PrimET CFloatPT) = "CFloat"+showExtType (PrimET CDoublePT) = "CDouble"+showExtType (PrimET CLDoublePT) = "CLDouble"+showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}"+showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}"+showExtType UnitET = "()"++-- compute the type of the C function declared by the given C object+--+-- * the identifier specifies in which of the declarators we are interested+--+-- * if the third argument is `True', the function result should not be+-- wrapped into an `IO' type+--+-- * the caller has to guarantee that the object does indeed refer to a+-- function +--+extractFunType :: Position -> CDecl -> Bool ->+ GB ([Maybe HsPtrRep], ExtType)+extractFunType pos cdecl isPure = + do+ -- remove all declarators except that of the function we are processing;+ -- then, extract the functions arguments and result type (also check that+ -- the function is not variadic); finally, compute the external type for+ -- the result+ --+ let (args, resultDecl, variadic) = funResultAndArgs cdecl+ when variadic $+ variadicErr pos cpos+ preResultType <- liftM (snd . expandSpecialPtrs) $ + extractSimpleType pos resultDecl+ --+ -- we can now add the `IO' monad if this is no pure function + --+ let resultType = if isPure + then preResultType + else IOET preResultType+ --+ -- compute function arguments and create a function type (a function+ -- prototype with `void' as its single argument declares a nullary+ -- function) + --+ (foreignSyn, argTypes) <- liftM (unzip . map expandSpecialPtrs) $+ mapM (extractSimpleType pos) args++ return (foreignSyn, foldr FunET resultType argTypes)+ where+ cpos = posOf cdecl++ -- provide info on Haskell wrappers around C pointers+ expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)+ -- no special treatment for a simple type synonym+ expandSpecialPtrs all@(DefinedET cdecl (_, CHSPtr, Nothing, _)) = + (Nothing, PtrET all)+ -- all other Haskell pointer wrappings require+ -- special calling conventions+ expandSpecialPtrs all@(DefinedET cdecl hsPtrRep) = + (Just hsPtrRep, PtrET all)+ -- non-pointer arguments are passed normal+ expandSpecialPtrs all = (Nothing, all)++-- compute a non-struct/union type from the given declaration +--+-- * the declaration may have at most one declarator+--+-- * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in+-- compatibility mode (ie, `--old-ffi=yes')+--+extractSimpleType :: Position -> CDecl -> GB ExtType+extractSimpleType pos cdecl =+ do+ traceEnter+ ct <- extractCompType cdecl+ case ct of+ ExtType et -> return et+ SUType _ -> illegalStructUnionErr (posOf cdecl) pos+ where+ traceEnter = traceGenBind $ + "Entering `extractSimpleType'...\n"++-- compute a Haskell type for a type referenced in a C pointer type+--+-- * the declaration may have at most one declarator+--+-- * struct/union types are mapped to `()'+--+-- * NB: this is by definition not a result type+--+extractPtrType :: CDecl -> GB ExtType+extractPtrType cdecl = do+ ct <- extractCompType cdecl+ case ct of+ ExtType et -> return et+ SUType _ -> return UnitET++-- compute a Haskell type from the given C declaration, where C functions are+-- represented by function pointers+--+-- * the declaration may have at most one declarator+--+-- * all C pointers (including functions) are represented as `Addr' if in+-- compatibility mode (--old-ffi)+--+-- * typedef'ed types are chased+--+-- * takes the pointer map into account+--+-- * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced+-- for pointer types; if this ever changes, we need to+-- handle `DefinedET's differently. The problem is that+-- entries in the pointer map currently prevent+-- `extractCompType' from looking further "into" the+-- definition of that pointer.+--+extractCompType :: CDecl -> GB CompType+extractCompType cdecl@(CDecl specs declrs ats) =+ if length declrs > 1 + then interr "GenBind.extractCompType: Too many declarators!"+ else case declrs of+ [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr+ | isFunDeclr declr -> funType+ | otherwise -> aliasOrSpecType size+ [] -> aliasOrSpecType Nothing+ where+ -- handle explicit pointer types+ --+ ptrType declr = do+ tracePtrType+ let declrs' = dropPtrDeclr declr -- remove indirection+ cdecl' = CDecl specs [(Just declrs', Nothing, Nothing)] ats+ oalias = checkForOneAliasName cdecl' -- is only an alias remaining?+ oHsRepr <- case oalias of+ Nothing -> return $ Nothing+ Just ide -> queryPtr (True, ide)+ case oHsRepr of+ Just repr -> ptrAlias repr -- got an alias+ Nothing -> do -- no alias => recurs+ ct <- extractCompType cdecl'+ returnX $ case ct of+ ExtType et -> PtrET et+ SUType _ -> PtrET UnitET+ --+ -- handle explicit function types+ --+ -- FIXME: we currently regard any functions as being impure (ie, being IO+ -- functions); is this ever going to be a problem?+ --+ funType = do+ traceFunType+ (_, et) <- extractFunType (posOf cdecl) cdecl False+ returnX et+ --+ -- handle all types, which are not obviously pointers or functions + --+ aliasOrSpecType :: Maybe CExpr -> GB CompType+ aliasOrSpecType size = do+ traceAliasOrSpecType size+ case checkForOneAliasName cdecl of+ Nothing -> specType (posOf cdecl) specs size+ Just ide -> do -- this is a typedef alias+ traceAlias ide+ oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias + case oHsRepr of+ Nothing -> do -- skip current alias (only one)+ cdecl' <- getDeclOf ide+ let CDecl specs [(declr, init, _)] at =+ ide `simplifyDecl` cdecl'+ sdecl = CDecl specs [(declr, init, size)] at+ -- propagate `size' down (slightly kludgy)+ extractCompType sdecl+ Just repr -> ptrAlias repr -- found a pointer hook alias+ --+ -- compute the result for a pointer alias+ --+ ptrAlias (isFun, ptrTy, wrapped, tyArg) = + returnX $ DefinedET cdecl (isFun, ptrTy, wrapped, tyArg)+ --+ -- wrap an `ExtType' into a `CompType' and convert parametrised pointers+ -- to `Addr' if needed+ --+ returnX retval@(PtrET et) = do+ keepOld <- getSwitch oldFFI+ if keepOld + then return $ ExtType (PrimET CPtrPT)+ else return $ ExtType retval+ returnX retval = return $ ExtType retval+ --+ tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n"+ traceFunType = traceGenBind $ "extractCompType: explicit function type\n"+ traceAliasOrSpecType Nothing = traceGenBind $ + "extractCompType: checking for alias\n"+ traceAliasOrSpecType (Just _) = traceGenBind $ + "extractCompType: checking for alias of bitfield\n"+ traceAlias ide = traceGenBind $ + "extractCompType: found an alias called `" ++ identToLexeme ide ++ "'\n"++-- C to Haskell type mapping described in the DOCU section+--+typeMap :: [([CTypeSpec], ExtType)]+typeMap = [([void] , UnitET ),+ ([char] , PrimET CCharPT ),+ ([unsigned, char] , PrimET CUCharPT ),+ ([signed, char] , PrimET CSCharPT ),+ ([signed] , PrimET CIntPT ),+ ([int] , PrimET CIntPT ),+ ([signed, int] , PrimET CIntPT ),+ ([short] , PrimET CShortPT ),+ ([short, int] , PrimET CShortPT ),+ ([signed, short] , PrimET CShortPT ),+ ([signed, short, int] , PrimET CShortPT ),+ ([long] , PrimET CLongPT ),+ ([long, int] , PrimET CLongPT ),+ ([signed, long] , PrimET CLongPT ),+ ([signed, long, int] , PrimET CLongPT ),+ ([long, long] , PrimET CLLongPT ),+ ([long, long, int] , PrimET CLLongPT ),+ ([signed, long, long] , PrimET CLLongPT ),+ ([signed, long, long, int] , PrimET CLLongPT ),+ ([unsigned] , PrimET CUIntPT ),+ ([unsigned, int] , PrimET CUIntPT ),+ ([unsigned, short] , PrimET CUShortPT ),+ ([unsigned, short, int] , PrimET CUShortPT ),+ ([unsigned, long] , PrimET CULongPT ),+ ([unsigned, long, int] , PrimET CULongPT ),+ ([unsigned, long, long] , PrimET CULLongPT ),+ ([unsigned, long, long, int] , PrimET CULLongPT ),+ ([float] , PrimET CFloatPT ),+ ([double] , PrimET CDoublePT ),+ ([long, double] , PrimET CLDoublePT),+ ([enum] , PrimET CIntPT )]+ where+ void = CVoidType undefined+ char = CCharType undefined+ short = CShortType undefined+ int = CIntType undefined+ long = CLongType undefined+ float = CFloatType undefined+ double = CDoubleType undefined+ signed = CSignedType undefined+ unsigned = CUnsigType undefined+ enum = CEnumType undefined undefined++-- compute the complex (external) type determined by a list of type specifiers+--+-- * may not be called for a specifier that defines a typedef alias+--+specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType+specType cpos specs osize = + let tspecs = [ts | CTypeSpec ts <- specs]+ in case lookupTSpec tspecs typeMap of+ Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos+ | isNothing osize -> return $ ExtType et -- not a bitfield+ | otherwise -> bitfieldSpec tspecs et osize -- bitfield+ Nothing -> + case tspecs of+ [CSUType cu _] -> return $ SUType cu -- struct or union+ [CEnumType _ _] -> return $ ExtType (PrimET CIntPT) -- enum+ [CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!"+ _ -> illegalTypeSpecErr cpos+ where+ lookupTSpec = lookupBy matches+ --+ isUnsupportedType (PrimET et) = size et == 0 -- can't be a bitfield (yet)+ isUnsupportedType _ = False+ --+ -- check whether two type specifier lists denote the same type; handles+ -- types like `long long' correctly, as `deleteBy' removes only the first+ -- occurrence of the given element+ --+ matches :: [CTypeSpec] -> [CTypeSpec] -> Bool+ [] `matches` [] = True+ [] `matches` (_:_) = False+ (spec:specs) `matches` specs' + | any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs'+ | otherwise = False+ --+ eqSpec (CVoidType _) (CVoidType _) = True+ eqSpec (CCharType _) (CCharType _) = True+ eqSpec (CShortType _) (CShortType _) = True+ eqSpec (CIntType _) (CIntType _) = True+ eqSpec (CLongType _) (CLongType _) = True+ eqSpec (CFloatType _) (CFloatType _) = True+ eqSpec (CDoubleType _) (CDoubleType _) = True+ eqSpec (CSignedType _) (CSignedType _) = True+ eqSpec (CUnsigType _) (CUnsigType _) = True+ eqSpec (CSUType _ _) (CSUType _ _) = True+ eqSpec (CEnumType _ _) (CEnumType _ _) = True+ eqSpec (CTypeDef _ _) (CTypeDef _ _) = True+ eqSpec _ _ = False+ --+ bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType+ bitfieldSpec tspecs et (Just sizeExpr) = -- never called with `Nothing'+ do+ let pos = posOf sizeExpr+ sizeResult <- evalConstCExpr sizeExpr+ case sizeResult of+ FloatResult _ -> illegalConstExprErr pos "a float result"+ IntResult size' -> do+ let size = fromInteger size'+ case et of+ PrimET CUIntPT -> returnCT $ CUFieldPT size+ PrimET CIntPT + | [signed] `matches` tspecs + || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT size+ | [int] `matches` tspecs -> + returnCT $ if bitfieldIntSigned then CSFieldPT size + else CUFieldPT size+ _ -> illegalFieldSizeErr pos+ where+ returnCT = return . ExtType . PrimET+ --+ int = CIntType undefined+ signed = CSignedType undefined+++-- offset and size computations+-- ----------------------------++-- precise size representation+--+-- * this is a pair of a number of octets and a number of bits+--+-- * if the number of bits is nonzero, the octet component is aligned by the+-- alignment constraint for `CIntPT' (important for accessing bitfields with+-- more than 8 bits)+--+data BitSize = BitSize Int Int+ deriving (Eq, Show)++-- ordering relation compares in terms of required storage units+--+instance Ord BitSize where+ bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) = + padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2)+ bs1 <= bs2 = bs1 < bs2 || bs1 == bs2+ -- the <= instance is needed for Ord's compare functions, which is used in+ -- the defaults for all other members++-- add two bit size values+--+addBitSize :: BitSize -> BitSize -> BitSize+addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow) rest+ where+ bitsPerBitfield = size CIntPT * 8+ (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield++-- pad any storage unit that is partially used by a bitfield+--+padBits :: BitSize -> Int+padBits (BitSize o 0) = o+padBits (BitSize o _) = o + size CIntPT++-- compute the offset of the declarator in the second argument when it is+-- preceded by the declarators in the first argument+--+offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize+offsetInStruct [] _ _ = return $ BitSize 0 0+offsetInStruct decls decl tag = + do+ (offset, _) <- sizeAlignOfStruct decls tag+ (_, align) <- sizeAlignOf decl+ return $ alignOffset offset align++-- compute the size and alignment (no padding at the end) of a set of+-- declarators from a struct+--+sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)+sizeAlignOfStruct [] _ = return (BitSize 0 0, 1)+sizeAlignOfStruct decls CStructTag = + do+ (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag+ (size, align) <- sizeAlignOf (last decls)+ let sizeOfStruct = alignOffset offset align `addBitSize` size+ align' = if align > 0 then align else bitfieldAlignment+ alignOfStruct = preAlign `max` align'+ return (sizeOfStruct, alignOfStruct)+sizeAlignOfStruct decls CUnionTag =+ do+ (sizes, aligns) <- mapAndUnzipM sizeAlignOf decls+ let aligns' = [if align > 0 then align else bitfieldAlignment+ | align <- aligns]+ return (maximum sizes, maximum aligns')++-- compute the size and alignment of the declarators forming a struct+-- including any end-of-struct padding that is needed to make the struct ``tile+-- in an array'' (K&R A7.4.8)+--+sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)+sizeAlignOfStructPad decls tag =+ do+ (size, align) <- sizeAlignOfStruct decls tag+ return (alignOffset size align, align)++-- compute the size and alignment constraint of a given C declaration+--+sizeAlignOf :: CDecl -> GB (BitSize, Int)+--+-- * we make use of the assertion that `extractCompType' can only return a+-- `DefinedET' when the declaration is a pointer declaration+--+sizeAlignOf (CDecl specs [(Just declr, _, size)] ats) | isArrDeclr declr =+ interr $ "sizeAlignOf: calculating size of constant array not supported."+sizeAlignOf cdecl = + do+ ct <- extractCompType cdecl+ case ct of+ ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT, + alignment CFunPtrPT)+ ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!"+ ExtType (PtrET t ) + | isFunExtType t -> return (bitSize CFunPtrPT, + alignment CFunPtrPT)+ | otherwise -> return (bitSize CPtrPT, alignment CPtrPT)+ ExtType (DefinedET _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT)+ -- FIXME: The defined type could be a function pointer!!!+ ExtType (PrimET pt ) -> return (bitSize pt, alignment pt)+ ExtType UnitET -> voidFieldErr (posOf cdecl)+ SUType su -> + do+ let (fields, tag) = structMembers su+ fields' <- let ide = structName su + in+ if (not . null $ fields) || isNothing ide+ then return fields+ else do -- get the real...+ tag <- findTag (fromJust ide) -- ...definition+ case tag of+ Just (StructUnionCT su) -> return+ (fst . structMembers $ su)+ _ -> return fields+ sizeAlignOfStructPad fields' tag+ where+ bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits+ | otherwise = BitSize sz 0+ where+ sz = size et++-- apply the given alignment constraint at the given offset+--+-- * if the alignment constraint is negative or zero, it is the alignment+-- constraint for a bitfield+--+alignOffset :: BitSize -> Int -> BitSize+alignOffset offset@(BitSize octetOffset bitOffset) align + | align > 0 && bitOffset /= 0 = -- close bitfield first+ alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align+ | align > 0 && bitOffset == 0 = -- no bitfields involved+ BitSize (((octetOffset - 1) `div` align + 1) * align) 0+ | bitOffset == 0 -- start a bitfield+ || overflowingBitfield = -- .. or overflowing bitfield+ alignOffset offset bitfieldAlignment+ | otherwise = -- stays in current bitfield+ offset+ where+ bitsPerBitfield = size CIntPT * 8+ overflowingBitfield = bitOffset - align >= bitsPerBitfield+ -- note, `align' is negative+++-- constant folding+-- ----------------++-- evaluate a constant expression+--+-- FIXME: this is a bit too simplistic, as the range of expression allowed as+-- constant expression varies depending on the context in which the+-- constant expression occurs+--+evalConstCExpr :: CExpr -> GB ConstResult+evalConstCExpr (CComma _ at) =+ illegalConstExprErr (posOf at) "a comma expression"+evalConstCExpr (CAssign _ _ _ at) =+ illegalConstExprErr (posOf at) "an assignment"+evalConstCExpr (CCond b (Just t) e _) =+ do+ bv <- evalConstCExpr b+ case bv of+ IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e+ FloatResult _ -> illegalConstExprErr (posOf b) "a float result"+evalConstCExpr (CBinary op lhs rhs at) =+ do+ lhsVal <- evalConstCExpr lhs+ rhsVal <- evalConstCExpr rhs+ let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal+ applyBin (posOf at) op lhsVal' rhsVal'+evalConstCExpr (CCast _ _ _) =+ todo "GenBind.evalConstCExpr: Casts are not implemented yet."+evalConstCExpr (CUnary op arg at) =+ do+ argVal <- evalConstCExpr arg+ applyUnary (posOf at) op argVal+evalConstCExpr (CSizeofExpr _ _) =+ todo "GenBind.evalConstCExpr: sizeof not implemented yet."+evalConstCExpr (CSizeofType decl _) =+ do+ (size, _) <- sizeAlignOf decl+ return $ IntResult (fromIntegral . padBits $ size)+evalConstCExpr (CAlignofExpr _ _) =+ todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."+evalConstCExpr (CAlignofType decl _) =+ do+ (_, align) <- sizeAlignOf decl+ return $ IntResult (fromIntegral align)+evalConstCExpr (CIndex _ _ at) =+ illegalConstExprErr (posOf at) "array indexing"+evalConstCExpr (CCall _ _ at) =+ illegalConstExprErr (posOf at) "function call"+evalConstCExpr (CMember _ _ _ at) =+ illegalConstExprErr (posOf at) "a . or -> operator"+evalConstCExpr (CVar ide at) =+ do+ (cobj, _) <- findValueObj ide False+ case cobj of+ EnumCO ide (CEnum _ enumrs _) -> liftM IntResult $ + enumTagValue ide enumrs 0+ _ -> + todo $ "GenBind.evalConstCExpr: variable names not implemented yet " +++ show (posOf at)+ where+ -- FIXME: this is not very nice; instead, CTrav should have some support+ -- for determining enum tag values (but then, constant folding needs+ -- to be moved to CTrav, too)+ --+ -- Compute the tag value for `ide' defined in the given enumerator list+ --+ enumTagValue _ [] _ = + interr "GenBind.enumTagValue: enumerator not in declaration"+ enumTagValue ide ((ide', oexpr):enumrs) val =+ do+ val' <- case oexpr of+ Nothing -> return val+ Just exp -> + do+ val' <- evalConstCExpr exp+ case val' of+ IntResult val' -> return val'+ FloatResult _ ->+ illegalConstExprErr (posOf exp) "a float result"+ if ide == ide'+ then -- found the right enumerator+ return val'+ else -- continue down the enumerator list+ enumTagValue ide enumrs (val' + 1)+evalConstCExpr (CConst c _) =+ evalCConst c++evalCConst :: CConst -> GB ConstResult+evalCConst (CIntConst i _ ) = return $ IntResult i+evalCConst (CCharConst c _ ) = return $ IntResult (toInteger (fromEnum c))+evalCConst (CFloatConst s _ ) = + todo "GenBind.evalCConst: Float conversion from literal misses."+evalCConst (CStrConst s at) = + illegalConstExprErr (posOf at) "a string constant"++usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)+usualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs)+usualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs)+usualArithConv lhs rhs = (lhs, rhs)++toFloat :: ConstResult -> ConstResult+toFloat x@(FloatResult _) = x+toFloat (IntResult i) = FloatResult . fromIntegral $ i++applyBin :: Position + -> CBinaryOp + -> ConstResult + -> ConstResult + -> GB ConstResult+applyBin cpos CMulOp (IntResult x) + (IntResult y) = return $ IntResult (x * y)+applyBin cpos CMulOp (FloatResult x) + (FloatResult y) = return $ FloatResult (x * y)+applyBin cpos CDivOp (IntResult x) + (IntResult y) = return $ IntResult (x `div` y)+applyBin cpos CDivOp (FloatResult x) + (FloatResult y) = return $ FloatResult (x / y)+applyBin cpos CRmdOp (IntResult x) + (IntResult y) = return$ IntResult (x `mod` y)+applyBin cpos CRmdOp (FloatResult x) + (FloatResult y) = + illegalConstExprErr cpos "a % operator applied to a float"+applyBin cpos CAddOp (IntResult x) + (IntResult y) = return $ IntResult (x + y)+applyBin cpos CAddOp (FloatResult x) + (FloatResult y) = return $ FloatResult (x + y)+applyBin cpos CSubOp (IntResult x) + (IntResult y) = return $ IntResult (x - y)+applyBin cpos CSubOp (FloatResult x) + (FloatResult y) = return $ FloatResult (x - y)+applyBin cpos CShlOp (IntResult x) + (IntResult y) = return $ IntResult (x * 2^y)+applyBin cpos CShlOp (FloatResult x) + (FloatResult y) = + illegalConstExprErr cpos "a << operator applied to a float"+applyBin cpos CShrOp (IntResult x) + (IntResult y) = return $ IntResult (x `div` 2^y)+applyBin cpos CShrOp (FloatResult x) + (FloatResult y) = + illegalConstExprErr cpos "a >> operator applied to a float"+applyBin cpos CAndOp (IntResult x)+ (IntResult y) = return $ IntResult (x .&. y)+applyBin cpos COrOp (IntResult x)+ (IntResult y) = return $ IntResult (x .|. y)+applyBin cpos CXorOp (IntResult x)+ (IntResult y) = return $ IntResult (x `xor` y)+applyBin cpos _ (IntResult x) + (IntResult y) = + todo "GenBind.applyBin: Not yet implemented operator in constant expression."+applyBin cpos _ (FloatResult x) + (FloatResult y) = + todo "GenBind.applyBin: Not yet implemented operator in constant expression."+applyBin _ _ _ _ = + interr "GenBind.applyBinOp: Illegal combination!"++applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult+applyUnary cpos CPreIncOp _ = + illegalConstExprErr cpos "a ++ operator"+applyUnary cpos CPreDecOp _ = + illegalConstExprErr cpos "a -- operator"+applyUnary cpos CPostIncOp _ = + illegalConstExprErr cpos "a ++ operator"+applyUnary cpos CPostDecOp _ = + illegalConstExprErr cpos "a -- operator"+applyUnary cpos CAdrOp _ = + illegalConstExprErr cpos "a & operator"+applyUnary cpos CIndOp _ = + illegalConstExprErr cpos "a * operator"+applyUnary cpos CPlusOp arg = return arg+applyUnary cpos CMinOp (IntResult x) = return (IntResult (-x))+applyUnary cpos CMinOp (FloatResult x) = return (FloatResult (-x))+applyUnary cpos CCompOp (IntResult x) = return (IntResult (complement x))+applyUnary cpos CNegOp (IntResult x) = + let r = toInteger . fromEnum $ (x == 0)+ in return (IntResult r)+applyUnary cpos CNegOp (FloatResult _) = + illegalConstExprErr cpos "! applied to a float"+++-- auxilliary functions+-- --------------------++-- create an identifier without position information+--+noPosIdent :: String -> Ident+noPosIdent = onlyPosIdent nopos++-- print trace message+--+traceGenBind :: String -> GB ()+traceGenBind = putTraceStr traceGenBindSW++-- generic lookup+--+lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b+lookupBy eq x = fmap snd . find (eq x . fst)++-- maps some monad operation into a `Maybe', discarding the result+--+mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()+mapMaybeM_ m Nothing = return ()+mapMaybeM_ m (Just a) = m a >> return ()+++-- error messages+-- --------------++unknownFieldErr :: Position -> Ident -> GB a+unknownFieldErr cpos ide =+ raiseErrorCTExc (posOf ide) + ["Unknown member name!",+ "The structure has no member called `" ++ identToLexeme ide + ++ "'. The structure is defined at",+ show cpos ++ "."]++illegalStructUnionErr :: Position -> Position -> GB a+illegalStructUnionErr cpos pos =+ raiseErrorCTExc pos + ["Illegal structure or union type!",+ "There is not automatic support for marshaling of structures and",+ "unions; the offending type is declared at "+ ++ show cpos ++ "."]++illegalTypeSpecErr :: Position -> GB a+illegalTypeSpecErr cpos =+ raiseErrorCTExc cpos + ["Illegal type!",+ "The type specifiers of this declaration do not form a legal ANSI C(89) \+ \type."+ ]++unsupportedTypeSpecErr :: Position -> GB a+unsupportedTypeSpecErr cpos =+ raiseErrorCTExc cpos + ["Unsupported type!",+ "The type specifier of this declaration is not supported by your C \+ \compiler."+ ]++variadicErr :: Position -> Position -> GB a+variadicErr pos cpos =+ raiseErrorCTExc pos + ["Variadic function!",+ "Calling variadic functions is not supported by the FFI; the function",+ "is defined at " ++ show cpos ++ "."]++illegalConstExprErr :: Position -> String -> GB a+illegalConstExprErr cpos hint =+ raiseErrorCTExc cpos ["Illegal constant expression!",+ "Encountered " ++ hint ++ " in a constant expression,",+ "which ANSI C89 does not permit."]++voidFieldErr :: Position -> GB a+voidFieldErr cpos =+ raiseErrorCTExc cpos ["Void field in struct!",+ "Attempt to access a structure field of type void."] structExpectedErr :: Ident -> GB a structExpectedErr ide =
c2hs/gen/GenHeader.hs view
@@ -52,17 +52,17 @@ -- Compiler Toolkit import Position (Position, Pos(..), nopos)-import DLists (DList, openDL, closeDL, zeroDL, unitDL, joinDL, snocDL)-import Errors (interr)-import Idents (onlyPosIdent)+import DLists (DList, openDL, closeDL, zeroDL, unitDL, joinDL, snocDL)+import Errors (interr)+import Idents (onlyPosIdent) import UNames (NameSupply, Name, names) -- C->Haskell import C2HSState (CST, getNameSupply, runCST, transCST, raiseError, catchExc,- throwExc, errorsPresent, showErrors, fatal)+ throwExc, errorsPresent, showErrors, fatal) -- friends-import CHS (CHSModule(..), CHSFrag(..))+import CHS (CHSModule(..), CHSFrag(..)) -- The header generation monad@@ -81,18 +81,18 @@ do supply <- getNameSupply (header, mod) <- runCST (ghModule mod) (names supply)- `ifGHExc` return ([], CHSModule [])+ `ifGHExc` return ([], CHSModule []) -- check for errors and finalise -- errs <- errorsPresent if errs then do- errmsgs <- showErrors- fatal ("Errors during generation of C header:\n\n" -- fatal error- ++ errmsgs)+ errmsgs <- showErrors+ fatal ("Errors during generation of C header:\n\n" -- fatal error+ ++ errmsgs) else do- warnmsgs <- showErrors+ warnmsgs <- showErrors return (header, mod, warnmsgs) -- Obtain a new base name that may be used, in C, to encode the result of a@@ -105,17 +105,17 @@ -- Various forms of processed fragments -- data FragElem = Frag CHSFrag- | Elif String Position- | Else Position- | Endif Position- | EOF+ | Elif String Position+ | Else Position+ | Endif Position+ | EOF instance Pos FragElem where posOf (Frag frag ) = posOf frag posOf (Elif _ pos) = pos posOf (Else pos) = pos posOf (Endif pos) = pos- posOf EOF = nopos+ posOf EOF = nopos -- check for end of file --@@ -151,10 +151,10 @@ (header, frag, rest) <- ghFrag frags case frag of Frag aFrag -> do- (header2, frags', frag', rest) <- ghFrags rest- -- FIXME: Not tail rec- return (header `joinDL` header2, aFrag:frags', - frag', rest)+ (header2, frags', frag', rest) <- ghFrags rest+ -- FIXME: Not tail rec+ return (header `joinDL` header2, aFrag:frags', + frag', rest) _ -> return (header, [], frag, rest) -- Process a single fragment *structure*; i.e., if the first fragment@@ -162,8 +162,8 @@ -- the first fragment -- ghFrag :: [CHSFrag] -> GH (DList String, -- partial header file- FragElem, -- processed fragment- [CHSFrag]) -- not yet processed fragments+ FragElem, -- processed fragment+ [CHSFrag]) -- not yet processed fragments ghFrag [] = return (zeroDL, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) = @@ -176,7 +176,7 @@ return (zeroDL, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do- (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment+ (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment return (unitDL s `joinDL` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : frags) =@@ -184,11 +184,11 @@ ghFrag (frag@(CHSCPP s pos) : frags) = let (directive, _) = break (`elem` " \t")- . dropWhile (`elem` " \t") - $ s+ . dropWhile (`elem` " \t") + $ s in case directive of- "if" -> openIf s pos frags+ "if" -> openIf s pos frags "ifdef" -> openIf s pos frags "ifndef" -> openIf s pos frags "else" -> return (zeroDL , Else pos , frags)@@ -204,40 +204,40 @@ openIf s pos frags = do (headerTh, fragsTh, last, rest) <- ghFrags frags- case last of- Else pos -> do- (headerEl, fragsEl, last, rest) <- ghFrags rest- case last of- Else pos -> notOpenCondErr pos- Elif _ pos -> notOpenCondErr pos- Endif pos -> closeIf - ((headerTh - `snocDL` "#else\n")- `joinDL` - (headerEl- `snocDL` "#endif\n"))- (s, fragsTh)- []- (Just fragsEl)- rest- EOF -> notClosedCondErr pos- Elif s' pos -> do- (headerEl, condFrag, rest) <- openIf s' pos rest- case condFrag of- Frag (CHSCond alts dft) -> - closeIf (headerTh `joinDL` headerEl)- (s, fragsTh)- alts- dft- rest- _ -> - interr "GenHeader.ghFrag: Expected CHSCond!"- Endif pos -> closeIf (headerTh `snocDL` "#endif\n") - (s, fragsTh)- []- (Just []) - rest- EOF -> notClosedCondErr pos+ case last of+ Else pos -> do+ (headerEl, fragsEl, last, rest) <- ghFrags rest+ case last of+ Else pos -> notOpenCondErr pos+ Elif _ pos -> notOpenCondErr pos+ Endif pos -> closeIf + ((headerTh + `snocDL` "#else\n")+ `joinDL` + (headerEl+ `snocDL` "#endif\n"))+ (s, fragsTh)+ []+ (Just fragsEl)+ rest+ EOF -> notClosedCondErr pos+ Elif s' pos -> do+ (headerEl, condFrag, rest) <- openIf s' pos rest+ case condFrag of+ Frag (CHSCond alts dft) -> + closeIf (headerTh `joinDL` headerEl)+ (s, fragsTh)+ alts+ dft+ rest+ _ -> + interr "GenHeader.ghFrag: Expected CHSCond!"+ Endif pos -> closeIf (headerTh `snocDL` "#endif\n") + (s, fragsTh)+ []+ (Just []) + rest+ EOF -> notClosedCondErr pos -- -- turn a completed conditional into a `CHSCond' fragment --@@ -248,14 +248,14 @@ closeIf headerTail (s, fragsTh) alts oelse rest = do sentryName <- newName- let sentry = onlyPosIdent nopos sentryName- -- don't use an internal ident, as we need to test for- -- equality with identifiers read from the .i file- -- during binding hook expansion- header = openDL ['#':s, "\n",- "struct ", sentryName, ";\n"] - `joinDL` headerTail- return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)+ let sentry = onlyPosIdent nopos sentryName+ -- don't use an internal ident, as we need to test for+ -- equality with identifiers read from the .i file+ -- during binding hook expansion+ header = openDL ['#':s, "\n",+ "struct ", sentryName, ";\n"] + `joinDL` headerTail+ return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest) -- exception handling
c2hs/state/C2HSState.hs view
@@ -38,17 +38,17 @@ -- module C2HSState (-- re-exports all of `State'- --- module State,- --- -- instantiation of `PreCST' with C2HS's extra state- --- CST, runC2HS,- --- -- switches- --- SwitchBoard(..), Traces(..), setTraces, traceSet,- putTraceStr, setSwitch, getSwitch) + --+ module State,+ --+ -- instantiation of `PreCST' with C2HS's extra state+ --+ CST, runC2HS,+ --+ -- switches+ --+ SwitchBoard(..), Traces(..), setTraces, traceSet,+ putTraceStr, setSwitch, getSwitch) where import Control.Monad (when)@@ -56,7 +56,7 @@ import State import Switches (SwitchBoard(..), Traces(..), - initialSwitchBoard)+ initialSwitchBoard) -- instantiation of the extra state@@ -90,9 +90,9 @@ -- putTraceStr :: (Traces -> Bool) -> String -> CST s () putTraceStr t msg = do- set <- traceSet t- when set $- hPutStrCIO stderr msg+ set <- traceSet t+ when set $+ hPutStrCIO stderr msg -- set a switch value --
c2hs/state/Switches.hs view
@@ -69,39 +69,39 @@ -- all switches of the toolkit (EXPORTED) -- data SwitchBoard = SwitchBoard {- cppOptsSB :: [String], -- cpp options- cppSB :: FilePath, -- cpp executable- hpathsSB :: [FilePath], -- header file directories- -- since 0.11.1 `hpathsSB' isn't really needed anymore..- -- ..remove from 0.12 series- keepSB :: Bool, -- keep intermediate file- tracesSB :: Traces, -- trace flags- outputSB :: FilePath, -- basename of generated files- outDirSB :: FilePath, -- dir where generated files go- headerSB :: FilePath, -- generated header file- preCompSB :: Maybe FilePath,-- optional binary header r/w- oldFFI :: Bool, -- GHC 4.XX compatible code- chiPathSB :: [FilePath], -- .chi file directories- lockFunSB :: Maybe String -- a function to wrap each call- }+ cppOptsSB :: [String], -- cpp options+ cppSB :: FilePath, -- cpp executable+ hpathsSB :: [FilePath], -- header file directories+ -- since 0.11.1 `hpathsSB' isn't really needed anymore..+ -- ..remove from 0.12 series+ keepSB :: Bool, -- keep intermediate file+ tracesSB :: Traces, -- trace flags+ outputSB :: FilePath, -- basename of generated files+ outDirSB :: FilePath, -- dir where generated files go+ headerSB :: FilePath, -- generated header file+ preCompSB :: Maybe FilePath,-- optional binary header r/w+ oldFFI :: Bool, -- GHC 4.XX compatible code+ chiPathSB :: [FilePath], -- .chi file directories+ lockFunSB :: Maybe String -- a function to wrap each call+ } -- switch states on startup (EXPORTED) -- initialSwitchBoard :: SwitchBoard initialSwitchBoard = SwitchBoard {- cppOptsSB = [],- cppSB = "cpp",- hpathsSB = [],- keepSB = False,- tracesSB = initialTraces,- outputSB = "",- outDirSB = "",- headerSB = "",- preCompSB = Nothing,- oldFFI = False,- chiPathSB = ["."],- lockFunSB = Nothing- }+ cppOptsSB = [],+ cppSB = "cpp",+ hpathsSB = [],+ keepSB = False,+ tracesSB = initialTraces,+ outputSB = "",+ outDirSB = "",+ headerSB = "",+ preCompSB = Nothing,+ oldFFI = False,+ chiPathSB = ["."],+ lockFunSB = Nothing+ } -- traces@@ -110,11 +110,11 @@ -- different kinds of traces possible (EXPORTED) -- data Traces = Traces {- tracePhasesSW :: Bool,- traceGenBindSW :: Bool,- traceCTravSW :: Bool,- dumpCHSSW :: Bool- }+ tracePhasesSW :: Bool,+ traceGenBindSW :: Bool,+ traceCTravSW :: Bool,+ dumpCHSSW :: Bool+ } -- trace setting on startup --@@ -122,8 +122,8 @@ -- initialTraces :: Traces initialTraces = Traces {- tracePhasesSW = False,- traceGenBindSW = False,- traceCTravSW = False,- dumpCHSSW = False- }+ tracePhasesSW = False,+ traceGenBindSW = False,+ traceCTravSW = False,+ dumpCHSSW = False+ }
c2hs/toplevel/C2HSConfig.hs view
@@ -1,4 +1,4 @@--- -*-haskell-*-+-- -*-haskell-*- -- =========================================================================== -- C -> Haskell Compiler: configuration --
c2hs/toplevel/Main.hs view
@@ -43,7 +43,7 @@ -- -- .h C header file -- .i pre-processeed C header file--- .hs Haskell file+-- .hs Haskell file -- .chs Haskell file with C->Haskell hooks (binding file) -- .chi C->Haskell interface file --@@ -66,11 +66,11 @@ -- --dump=TYPE -- Dump intermediate representation: ----- + if TYPE is `trace', trace the compiler phases (to stderr)--- + if TYPE is `genbind', trace binding generation (to stderr)--- + if TYPE is `ctrav', trace C declaration traversal (to stderr)--- + if TYPE is `chs', dump the binding file (insert `.dump' into the--- file name to avoid overwriting the original file)+-- + if TYPE is `trace', trace the compiler phases (to stderr)+-- + if TYPE is `genbind', trace binding generation (to stderr)+-- + if TYPE is `ctrav', trace C declaration traversal (to stderr)+-- + if TYPE is `chs', dump the binding file (insert `.dump' into the+-- file name to avoid overwriting the original file) -- -- -h, -? -- --help@@ -79,7 +79,7 @@ -- -i DIRS -- --include=DIRS -- Search the colon separated list of directories DIRS when searching--- for .chi files.+-- for .chi files. -- -- -k -- --keep@@ -91,11 +91,11 @@ -- Place output in file FILE. -- -- If `-o' is not specified, the default is to put the output for--- `source.chs' in `source.hs' in the same directory that contains the--- binding file. If specified, the emitted C header file is put into--- the same directory as the output file. The same holds for--- C->Haskell interface file. All generated files also share the--- basename. +-- `source.chs' in `source.hs' in the same directory that contains the+-- binding file. If specified, the emitted C header file is put into+-- the same directory as the output file. The same holds for+-- C->Haskell interface file. All generated files also share the+-- basename. -- -- -t PATH -- --output-dir=PATH@@ -108,7 +108,7 @@ -- -v, -- --version -- Print (on standard error output) the version and copyright--- information of the compiler (before doing anything else).+-- information of the compiler (before doing anything else). -- -- -p FILE -- --precomp=FILE@@ -120,9 +120,9 @@ -- significantly speed up the translation of a binding module. -- -- --old-ffi [=yes|=no]--- Generate hooks using pre-standard FFI libraries. This currently--- affects only call hooks where instead of `Addr' types --- `Ptr <someOtherType>' is used.+-- Generate hooks using pre-standard FFI libraries. This currently+-- affects only call hooks where instead of `Addr' types +-- `Ptr <someOtherType>' is used. -- -- --lock=NAME -- Wrap each foreign function call in the function NAME. This@@ -140,35 +140,35 @@ where -- standard libraries-import Data.List (isPrefixOf)-import System.IO (openFile)-import System.Process (runProcess, waitForProcess)+import Data.List (isPrefixOf)+import System.IO (openFile)+import System.Process (runProcess, waitForProcess) import Control.Monad (when, unless, mapM) import Data.Maybe (fromJust) -- base libraries import System.Console.GetOpt - (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt)+ (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import FNameOps (suffix, basename, dirname, stripSuffix, addPath, splitSearchPath)-import Errors (interr)+import Errors (interr) import UNames (saveRootNameSupply, restoreRootNameSupply)-import Binary (Binary(..), putBinFileWithDict, getBinFileWithDict)+import Binary (Binary(..), putBinFileWithDict, getBinFileWithDict) -- c2hs modules import C2HSState (CST, nop, runC2HS, fatal, fatalsHandledBy, getId,- ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO,- hPutStrLnCIO, exitWithCIO, getArgsCIO, getProgNameCIO,- ioeGetErrorString, ioeGetFileName, doesFileExistCIO,- removeFileCIO, liftIO,- fileFindInCIO, mktempCIO, openFileCIO, hCloseCIO,- SwitchBoard(..), Traces(..), setTraces,- traceSet, setSwitch, getSwitch, putTraceStr)-import C (AttrC, hsuffix, isuffix, loadAttrC)-import CHS (CHSModule, skipToLangPragma, hasCPP, loadCHS, dumpCHS, loadAllCHI,- hssuffix, chssuffix, dumpCHI)+ ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO,+ hPutStrLnCIO, exitWithCIO, getArgsCIO, getProgNameCIO,+ ioeGetErrorString, ioeGetFileName, doesFileExistCIO,+ removeFileCIO, liftIO,+ fileFindInCIO, mktempCIO, openFileCIO, hCloseCIO,+ SwitchBoard(..), Traces(..), setTraces,+ traceSet, setSwitch, getSwitch, putTraceStr)+import C (AttrC, hsuffix, isuffix, loadAttrC)+import CHS (CHSModule, skipToLangPragma, hasCPP, loadCHS, dumpCHS, loadAllCHI,+ hssuffix, chssuffix, dumpCHI) import GenHeader (genHeader)-import GenBind (expandHooks)+import GenBind (expandHooks) import Version (version, copyright, disclaimer) import C2HSConfig (cpp, cppopts, cppoptsdef, hpaths, tmpdir) @@ -193,73 +193,73 @@ trailer, errTrailer :: String trailer = "\n\- \The header file must be a C header file matching the given \- \binding file.\n\- \The dump TYPE can be\n\- \ trace -- trace compiler phases\n\- \ genbind -- trace binding generation\n\- \ ctrav -- trace C declaration traversal\n\- \ chs -- dump the binding file (adds `.dump' to the name)\n"+ \The header file must be a C header file matching the given \+ \binding file.\n\+ \The dump TYPE can be\n\+ \ trace -- trace compiler phases\n\+ \ genbind -- trace binding generation\n\+ \ ctrav -- trace C declaration traversal\n\+ \ chs -- dump the binding file (adds `.dump' to the name)\n" errTrailer = "Try the option `--help' on its own for more information.\n" -- supported option types -- data Flag = CPPOpts String -- additional options for C preprocessor- | CPP String -- program name of C preprocessor- | Dump DumpType -- dump internal information- | Help -- print brief usage information- | Keep -- keep the .i file- | Include String -- list of directories to search .chi files- | Output String -- file where the generated file should go- | OutDir String -- directory where generates files should go- | PreComp String -- write or read a precompiled header- | LockFun String -- wrap each function call in this function- | Version -- print version information on stderr- | Error String -- error occured during processing of options- deriving Eq+ | CPP String -- program name of C preprocessor+ | Dump DumpType -- dump internal information+ | Help -- print brief usage information+ | Keep -- keep the .i file+ | Include String -- list of directories to search .chi files+ | Output String -- file where the generated file should go+ | OutDir String -- directory where generates files should go+ | PreComp String -- write or read a precompiled header+ | LockFun String -- wrap each function call in this function+ | Version -- print version information on stderr+ | Error String -- error occured during processing of options+ deriving Eq -data DumpType = Trace -- compiler trace- | GenBind -- trace `GenBind'- | CTrav -- trace `CTrav'- | CHS -- dump binding file- deriving Eq+data DumpType = Trace -- compiler trace+ | GenBind -- trace `GenBind'+ | CTrav -- trace `CTrav'+ | CHS -- dump binding file+ deriving Eq -- option description suitable for `GetOpt' -- options :: [OptDescr Flag] options = [ Option ['C'] - ["cppopts"] - (ReqArg CPPOpts "CPPOPTS") - "pass CPPOPTS to the C preprocessor",+ ["cppopts"] + (ReqArg CPPOpts "CPPOPTS") + "pass CPPOPTS to the C preprocessor", Option ['c'] - ["cpp"] - (ReqArg CPP "CPP") - "use executable CPP to invoke C preprocessor",+ ["cpp"] + (ReqArg CPP "CPP") + "use executable CPP to invoke C preprocessor", Option ['d'] - ["dump"] - (ReqArg dumpArg "TYPE") - "dump internal information (for debugging)",+ ["dump"] + (ReqArg dumpArg "TYPE") + "dump internal information (for debugging)", Option ['h', '?'] - ["help"] - (NoArg Help) - "brief help (the present message)",+ ["help"] + (NoArg Help) + "brief help (the present message)", Option ['i']- ["include"]- (ReqArg Include "INCLUDE")- "include paths for .chi files",+ ["include"]+ (ReqArg Include "INCLUDE")+ "include paths for .chi files", Option ['k'] - ["keep"] - (NoArg Keep) - "keep pre-processed C header",+ ["keep"] + (NoArg Keep) + "keep pre-processed C header", Option ['o'] - ["output"] - (ReqArg Output "FILE") - "output result to FILE (should end in .hs)",+ ["output"] + (ReqArg Output "FILE") + "output result to FILE (should end in .hs)", Option ['t'] - ["output-dir"] - (ReqArg OutDir "PATH") - "place generated files in PATH",+ ["output-dir"] + (ReqArg OutDir "PATH") + "place generated files in PATH", Option ['p'] ["precomp"] (ReqArg PreComp "FILE")@@ -269,9 +269,9 @@ (ReqArg LockFun "NAME") "wrap each foreign call with the function NAME", Option ['v'] - ["version"] - (NoArg Version) - "show version information"]+ ["version"] + (NoArg Version) + "show version information"] -- convert argument of `Dump' option --@@ -301,13 +301,13 @@ (_ , _ , errs) -> raiseErrs errs where properArgs [file1, file2] = suffix file1 == hsuffix - && suffix file2 == chssuffix + && suffix file2 == chssuffix properArgs _ = False -- doExecute opts args = do- execute opts args- `fatalsHandledBy` failureHandler- exitWithCIO ExitSuccess+ execute opts args+ `fatalsHandledBy` failureHandler+ exitWithCIO ExitSuccess -- wrongNoOfArgsErr = "Supply the header file followed by the binding file.\n\@@ -318,28 +318,28 @@ -- failureHandler err = do- let msg = ioeGetErrorString err- fnMsg = case ioeGetFileName err of- Nothing -> ""- Just s -> " (file: `" ++ s ++ "')"- hPutStrLnCIO stderr (msg ++ fnMsg)- exitWithCIO $ ExitFailure 1+ let msg = ioeGetErrorString err+ fnMsg = case ioeGetFileName err of+ Nothing -> ""+ Just s -> " (file: `" ++ s ++ "')"+ hPutStrLnCIO stderr (msg ++ fnMsg)+ exitWithCIO $ ExitFailure 1 -- set up base configuration -- setup :: CST s () setup = do- setCPP cpp- addCPPOpts cppopts- addHPaths hpaths+ setCPP cpp+ addCPPOpts cppopts+ addHPaths hpaths -- output error message -- raiseErrs :: [String] -> CST s a raiseErrs errs = do- hPutStrCIO stderr (concat errs)- hPutStrCIO stderr errTrailer- exitWithCIO $ ExitFailure 1+ hPutStrCIO stderr (concat errs)+ hPutStrCIO stderr errTrailer+ exitWithCIO $ ExitFailure 1 -- Process tasks -- -------------@@ -353,10 +353,10 @@ -- execute :: [Flag] -> [FilePath] -> CST s () execute opts args | Help `elem` opts = help- | otherwise = + | otherwise = do let vs = filter (== Version) opts- opts' = filter (/= Version) opts+ opts' = filter (/= Version) opts mapM_ processOpt (atMostOne vs ++ opts') let (headerFile, bndFile) = determineFileTypes args@@ -371,28 +371,28 @@ unless (null bndFile) $ do computeOutputName bndFileWithoutSuffix process headerFile preCompFile bndFileWithoutSuffix- `fatalsHandledBy` ioErrorHandler+ `fatalsHandledBy` ioErrorHandler where atMostOne = (foldl (\_ x -> [x]) []) determineFileTypes [hfile, bfile] = (hfile, bfile) determineFileTypes [file] | suffix file==hsuffix = (file, "")- | otherwise = ("", file)+ | otherwise = ("", file) determineFileTypes [] = ("", "") ioErrorHandler ioerr = do- name <- getProgNameCIO- putStrCIO $- name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"- exitWithCIO $ ExitFailure 1+ name <- getProgNameCIO+ putStrCIO $+ name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"+ exitWithCIO $ ExitFailure 1 -- emit help message -- help :: CST s () help = do- (version, copyright, disclaimer) <- getId- putStrCIO (usageInfo (header version copyright disclaimer) options)- putStrCIO trailer+ (version, copyright, disclaimer) <- getId+ putStrCIO (usageInfo (header version copyright disclaimer) options)+ putStrCIO trailer -- process an option --@@ -409,17 +409,17 @@ processOpt (PreComp fname ) = setPreComp fname processOpt (LockFun name ) = setLockFun name processOpt Version = do- (version, _, _) <- getId - putStrCIO (version ++ "\n")+ (version, _, _) <- getId + putStrCIO (version ++ "\n") processOpt (Error msg ) = abort msg -- emit error message and raise an error -- abort :: String -> CST s () abort msg = do- hPutStrLnCIO stderr msg- hPutStrCIO stderr errTrailer- fatal "Error in command line options"+ hPutStrLnCIO stderr msg+ hPutStrCIO stderr errTrailer+ fatal "Error in command line options" -- Compute the base name for all generated files (Haskell, C header, and .chi -- file)@@ -432,14 +432,14 @@ output <- getSwitch outputSB outDir <- getSwitch outDirSB let dir = if null outDir && null output then dirname bndFileNoSuffix- else if null outDir then dirname output- else outDir+ else if null outDir then dirname output+ else outDir let base = if null output then basename bndFileNoSuffix- else basename output+ else basename output setSwitch $ \sb -> sb {- outputSB = dir `addPath` base,- outDirSB = dir- }+ outputSB = dir `addPath` base,+ outDirSB = dir+ } -- set switches@@ -476,7 +476,7 @@ setDump Trace = setTraces $ \ts -> ts {tracePhasesSW = True} setDump GenBind = setTraces $ \ts -> ts {traceGenBindSW = True} setDump CTrav = setTraces $ \ts -> ts {traceCTravSW = True}-setDump CHS = setTraces $ \ts -> ts {dumpCHSSW = True}+setDump CHS = setTraces $ \ts -> ts {dumpCHSSW = True} -- set flag to keep the pre-processed header file --@@ -499,9 +499,9 @@ -- setOutput :: FilePath -> CST s () setOutput fname = do- when (suffix fname /= hssuffix) $- raiseErrs ["Output file should end in .hs!\n"]- setSwitch $ \sb -> sb {outputSB = stripSuffix fname}+ when (suffix fname /= hssuffix) $+ raiseErrs ["Output file should end in .hs!\n"]+ setSwitch $ \sb -> sb {outputSB = stripSuffix fname} -- set the output directory --@@ -551,30 +551,30 @@ chsMod <- case skipToLangPragma chsMod of Nothing -> loadAllCHI chsMod Just chsMod | not (hasCPP chsMod) -> loadAllCHI chsMod- | otherwise -> do- outFName <- getSwitch outputSB- let outFileBase = if null outFName then basename bndFile else outFName- let ppFile = outFileBase ++ "_pp" ++ chssuffix- cpp <- getSwitch cppSB- cppOpts <- getSwitch cppOptsSB+ | otherwise -> do+ outFName <- getSwitch outputSB+ let outFileBase = if null outFName then basename bndFile else outFName+ let ppFile = outFileBase ++ "_pp" ++ chssuffix+ cpp <- getSwitch cppSB+ cppOpts <- getSwitch cppOptsSB let args = cppOpts ++ [cppoptsdef, headerFile, bndFile] tracePreproc (unwords (cpp:args))- exitCode <- liftIO $ do+ exitCode <- liftIO $ do ppHnd <- openFile ppFile WriteMode process <- runProcess cpp args Nothing Nothing Nothing (Just ppHnd) Nothing waitForProcess process- case exitCode of - ExitFailure _ -> fatal "Error during preprocessing chs file"- _ -> nop+ case exitCode of + ExitFailure _ -> fatal "Error during preprocessing chs file"+ _ -> nop (chsMod , warnmsgs) <- loadCHS ppFile - keep <- getSwitch keepSB- unless keep $- removeFileCIO ppFile+ keep <- getSwitch keepSB+ unless keep $+ removeFileCIO ppFile - case skipToLangPragma chsMod of Just chsMod -> loadAllCHI chsMod+ case skipToLangPragma chsMod of Just chsMod -> loadAllCHI chsMod traceCHSDump chsMod --@@ -648,21 +648,21 @@ outFName <- getSwitch outputSB let hsFile = if null outFName then basename bndFile else outFName dumpCHS hsFile hsMod True- dumpCHI hsFile chi -- different suffix will be appended+ dumpCHI hsFile chi -- different suffix will be appended where bndFile = bndFileStripped ++ chssuffix traceReadPrecomp fName = putTraceStr tracePhasesSW $ "Reading precompiled header file " ++ fName ++ "...\n" tracePreproc cmd = putTraceStr tracePhasesSW $- "Invoking cpp as `" ++ cmd ++ "'...\n"+ "Invoking cpp as `" ++ cmd ++ "'...\n" traceCHSDump mod = do- flag <- traceSet dumpCHSSW- when flag $- (do- putStrCIO ("...dumping CHS to `" ++ chsName - ++ "'...\n")- dumpCHS chsName mod False)+ flag <- traceSet dumpCHSSW+ when flag $+ (do+ putStrCIO ("...dumping CHS to `" ++ chsName + ++ "'...\n")+ dumpCHS chsName mod False) chsName = basename bndFile ++ ".dump"
c2hs/toplevel/Version.hs view
@@ -8,10 +8,10 @@ name = "C->Haskell Compiler" versnum = "0.13.13 (gtk2hs branch)" versnick = "\"Bin IO\""-date = "27 May 2012"+date = "27 May 2012" version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) [1999..2004] Manuel M T Chakravarty" disclaimer = "This software is distributed under the \- \terms of the GNU Public Licence.\n\- \NO WARRANTY WHATSOEVER IS PROVIDED. \- \See the details in the documentation."+ \terms of the GNU Public Licence.\n\+ \NO WARRANTY WHATSOEVER IS PROVIDED. \+ \See the details in the documentation."
callbackGen/HookGenerator.hs view
@@ -13,29 +13,29 @@ -- Define all possible data types the GTK will supply in callbacks. ---data Types = Tunit -- ()- | Tbool -- Bool- | Tchar- | Tuchar- | Tint -- Int- | Tuint- | Tlong- | Tulong- | Tenum- | Tflags- | Tfloat- | Tdouble- | Tstring+data Types = Tunit -- ()+ | Tbool -- Bool+ | Tchar+ | Tuchar+ | Tint -- Int+ | Tuint+ | Tlong+ | Tulong+ | Tenum+ | Tflags+ | Tfloat+ | Tdouble+ | Tstring | Tmstring | Tgstring | Tmgstring- | Tboxed -- a struct which is passed by value- | Tptr -- pointer- | Ttobject -- foreign with WidgetClass context- | Tmtobject -- foreign with WidgetClass context using a Maybe type- | Tobject -- foreign with GObjectClass context- | Tmobject -- foreign with GObjectClass context using a Maybe type- deriving Eq+ | Tboxed -- a struct which is passed by value+ | Tptr -- pointer+ | Ttobject -- foreign with WidgetClass context+ | Tmtobject -- foreign with WidgetClass context using a Maybe type+ | Tobject -- foreign with GObjectClass context+ | Tmobject -- foreign with GObjectClass context using a Maybe type+ deriving Eq type Signature = (Types,[Types]) type Signatures = [Signature]@@ -48,9 +48,9 @@ parseSignatures content = (nub.parseSig 1.scan) content data Token = TokColon- | TokType Types- | TokComma- | TokEOL+ | TokType Types+ | TokComma+ | TokEOL instance Show Token where showsPrec _ TokColon = shows ":"@@ -67,8 +67,8 @@ let (args,rem') = parseArg l rem in (ret,args): parseSig (l+1) rem' parseSig l rem = error ("parse error on line "++show l++- ": expected type and colon, found\n"++- concatMap show (take 5 rem))+ ": expected type and colon, found\n"+++ concatMap show (take 5 rem)) parseArg :: Int -> [Token] -> ([Types],[Token]) parseArg l [TokType ty] = ([ty],[])@@ -78,7 +78,7 @@ (ty:args, rem') parseArg l rem = error ("parse error on line "++show l++": expected type"++ " followed by comma or EOL, found\n "++- concatMap show (take 5 rem))+ concatMap show (take 5 rem)) scan :: String -> [Token] scan "" = []@@ -113,7 +113,7 @@ scan ('N':'O':'N':'E':xs) = TokType Tunit:scan xs scan ('B':'O':'O':'L':xs) = TokType Tbool:scan xs scan str = error ("Invalid character in input file:\n"++- concatMap ((flip showLitChar) "") (take 5 str))+ concatMap ((flip showLitChar) "") (take 5 str)) -------------------------------------------------------------------------------@@ -135,7 +135,7 @@ identifier Tbool = ss "BOOL" identifier Tchar = ss "CHAR" identifier Tuchar = ss "UCHAR"-identifier Tint = ss "INT"+identifier Tint = ss "INT" identifier Tuint = ss "WORD" identifier Tlong = ss "LONG" identifier Tulong = ss "ULONG"@@ -148,7 +148,7 @@ identifier Tgstring = ss "GLIBSTRING" identifier Tmgstring = ss "MGLIBSTRING" identifier Tboxed = ss "BOXED"-identifier Tptr = ss "PTR"+identifier Tptr = ss "PTR" identifier Ttobject = ss "OBJECT" identifier Tmtobject = ss "MOBJECT" identifier Tobject = ss "OBJECT"@@ -162,7 +162,7 @@ rawtype Tbool = ss "Bool" rawtype Tchar = ss "Char" rawtype Tuchar = ss "Char"-rawtype Tint = ss "Int"+rawtype Tint = ss "Int" rawtype Tuint = ss "Word" rawtype Tlong = ss "Int" rawtype Tulong = ss "Word"@@ -175,7 +175,7 @@ rawtype Tgstring = ss "CString" rawtype Tmgstring = ss "CString" rawtype Tboxed = ss "Ptr ()"-rawtype Tptr = ss "Ptr ()"+rawtype Tptr = ss "Ptr ()" rawtype Ttobject = ss "Ptr GObject" rawtype Tmtobject = ss "Ptr GObject" rawtype Tobject = ss "Ptr GObject"@@ -190,7 +190,7 @@ rawtype Tbool = ss "{#type gboolean#}" rawtype Tchar = ss "{#type gchar#}" rawtype Tuchar = ss "{#type guchar#}"-rawtype Tint = ss "{#type gint#}"+rawtype Tint = ss "{#type gint#}" rawtype Tuint = ss "{#type guint#}" rawtype Tlong = ss "{#type glong#}" rawtype Tulong = ss "{#type gulong#}"@@ -203,7 +203,7 @@ rawtype Tgstring = ss "CString" rawtype Tmgstring = ss "CString" rawtype Tboxed = ss "Ptr ()"-rawtype Tptr = ss "Ptr ()"+rawtype Tptr = ss "Ptr ()" rawtype Ttobject = ss "Ptr GObject" rawtype Tmtobject = ss "Ptr GObject" rawtype Tobject = ss "Ptr GObject"@@ -213,24 +213,24 @@ -- The possibly polymorphic type which usertype :: Types -> [Char] -> (ShowS,[Char])-usertype Tunit cs = (ss "()",cs)-usertype Tbool (c:cs) = (ss "Bool",cs)-usertype Tchar (c:cs) = (ss "Char",cs)-usertype Tuchar (c:cs) = (ss "Char",cs)-usertype Tint (c:cs) = (ss "Int",cs)-usertype Tuint (c:cs) = (ss "Word",cs)-usertype Tlong (c:cs) = (ss "Int",cs)-usertype Tulong (c:cs) = (ss "Int",cs)-usertype Tenum (c:cs) = (sc c,cs)+usertype Tunit cs = (ss "()",cs)+usertype Tbool (c:cs) = (ss "Bool",cs)+usertype Tchar (c:cs) = (ss "Char",cs)+usertype Tuchar (c:cs) = (ss "Char",cs)+usertype Tint (c:cs) = (ss "Int",cs)+usertype Tuint (c:cs) = (ss "Word",cs)+usertype Tlong (c:cs) = (ss "Int",cs)+usertype Tulong (c:cs) = (ss "Int",cs)+usertype Tenum (c:cs) = (sc c,cs) usertype Tflags cs = usertype Tenum cs-usertype Tfloat (c:cs) = (ss "Float",cs)+usertype Tfloat (c:cs) = (ss "Float",cs) usertype Tdouble (c:cs) = (ss "Double",cs) usertype Tstring (c:cs) = (ss "String",cs) usertype Tmstring (c:cs) = (ss "Maybe String",cs) usertype Tgstring (c:cs) = (sc c.sc '\'',cs) usertype Tmgstring (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) usertype Tboxed (c:cs) = (sc c,cs)-usertype Tptr (c:cs) = (ss "Ptr ".sc c,cs)+usertype Tptr (c:cs) = (ss "Ptr ".sc c,cs) usertype Ttobject (c:cs) = (sc c.sc '\'',cs) usertype Tmtobject (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) usertype Tobject (c:cs) = (sc c.sc '\'',cs)@@ -251,22 +251,22 @@ context (Tmobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs context (Tmgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs-context (_:ts) (c:cs) = context ts cs-context [] _ = []+context (_:ts) (c:cs) = context ts cs+context [] _ = [] marshType :: [Types] -> [Char] -> [ShowS] marshType (Tint:ts) (c:cs) = marshType ts cs-marshType (Tuint:ts) (c:cs) = marshType ts cs-marshType (Tenum:ts) (c:cs) = marshType ts cs-marshType (Tflags:ts) cs = marshType (Tenum:ts) cs-marshType (Tboxed:ts) (c:cs) = ss "(Ptr ".sc c.ss "' -> IO ".- sc c.ss ") -> ":- marshType ts cs-marshType (Tptr:ts) (c:cs) = marshType ts cs-marshType (Tobject:ts) (c:cs) = marshType ts cs+marshType (Tuint:ts) (c:cs) = marshType ts cs+marshType (Tenum:ts) (c:cs) = marshType ts cs+marshType (Tflags:ts) cs = marshType (Tenum:ts) cs+marshType (Tboxed:ts) (c:cs) = ss "(Ptr ".sc c.ss "' -> IO ".+ sc c.ss ") -> ":+ marshType ts cs+marshType (Tptr:ts) (c:cs) = marshType ts cs+marshType (Tobject:ts) (c:cs) = marshType ts cs marshType (_:ts) (c:cs) = marshType ts cs-marshType [] _ = []+marshType [] _ = [] -- arguments for user defined marshalling @@ -274,25 +274,25 @@ marshArg :: Types -> ArgNo -> ShowS marshArg Tboxed c = ss "boxedPre".shows c.sc ' '-marshArg _ _ = id+marshArg _ _ = id -- generate a name for every passed argument, nameArg :: Types -> ArgNo -> ShowS-nameArg Tunit _ = id-nameArg Tbool c = ss "bool".shows c+nameArg Tunit _ = id+nameArg Tbool c = ss "bool".shows c nameArg Tchar c = ss "char".shows c nameArg Tuchar c = ss "char".shows c-nameArg Tint c = ss "int".shows c-nameArg Tuint c = ss "int".shows c-nameArg Tlong c = ss "long".shows c-nameArg Tulong c = ss "long".shows c-nameArg Tenum c = ss "enum".shows c-nameArg Tflags c = ss "flags".shows c-nameArg Tfloat c = ss "float".shows c-nameArg Tdouble c = ss "double".shows c-nameArg Tstring c = ss "str".shows c+nameArg Tint c = ss "int".shows c+nameArg Tuint c = ss "int".shows c+nameArg Tlong c = ss "long".shows c+nameArg Tulong c = ss "long".shows c+nameArg Tenum c = ss "enum".shows c+nameArg Tflags c = ss "flags".shows c+nameArg Tfloat c = ss "float".shows c+nameArg Tdouble c = ss "double".shows c+nameArg Tstring c = ss "str".shows c nameArg Tmstring c = ss "str".shows c-nameArg Tgstring c = ss "str".shows c+nameArg Tgstring c = ss "str".shows c nameArg Tmgstring c = ss "str".shows c nameArg Tboxed c = ss "box".shows c nameArg Tptr c = ss "ptr".shows c@@ -308,14 +308,14 @@ #ifdef USE_GCLOSURE_SIGNALS_IMPL marshExec :: Types -> ShowS -> Int -> (ShowS -> ShowS)-marshExec Tbool arg _ body = body. sc ' '. arg-marshExec Tchar arg _ body = body. sc ' '. arg+marshExec Tbool arg _ body = body. sc ' '. arg+marshExec Tchar arg _ body = body. sc ' '. arg marshExec Tuchar arg _ body = body. sc ' '. arg-marshExec Tint arg _ body = body. sc ' '. arg-marshExec Tuint arg _ body = body. sc ' '. arg-marshExec Tlong arg _ body = body. sc ' '. arg+marshExec Tint arg _ body = body. sc ' '. arg+marshExec Tuint arg _ body = body. sc ' '. arg+marshExec Tlong arg _ body = body. sc ' '. arg marshExec Tulong arg _ body = body. sc ' '. arg-marshExec Tenum arg _ body = body. ss " (toEnum ". arg. sc ')'+marshExec Tenum arg _ body = body. ss " (toEnum ". arg. sc ')' marshExec Tflags arg _ body = body. ss " (toFlags ". arg. sc ')' marshExec Tfloat arg _ body = body. sc ' '. arg marshExec Tdouble arg _ body = body. sc ' '. arg@@ -329,7 +329,7 @@ body. sc ' '. arg. sc '\'' marshExec Tboxed arg n body = indent 5. ss "boxedPre". ss (show n). ss " (castPtr ". arg. ss ") >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\''-marshExec Tptr arg _ body = body. ss " (castPtr ". arg. sc ')'+marshExec Tptr arg _ body = body. ss " (castPtr ". arg. sc ')' marshExec Ttobject arg _ body = indent 5.ss "makeNewGObject (GObject, objectUnrefFromMainloop) (return ". arg. ss ") >>= \\". arg. ss "\' ->". body. ss " (unsafeCastGObject ". arg. ss "\')" marshExec Tmtobject arg _ body = indent 5.ss "maybeNull (makeNewGObject (GObject, objectUnrefFromMainloop)) (return ". arg. ss ") >>= \\". arg. ss "\' ->".@@ -340,15 +340,15 @@ body. ss " (liftM unsafeCastGObject ". arg. ss "\')" marshRet :: Types -> (ShowS -> ShowS)-marshRet Tunit body = body-marshRet Tbool body = body-marshRet Tint body = body-marshRet Tuint body = body-marshRet Tlong body = body-marshRet Tulong body = body-marshRet Tenum body = indent 5. ss "liftM fromEnum $ ". body-marshRet Tflags body = indent 5. ss "liftM fromFlags $ ". body-marshRet Tfloat body = body+marshRet Tunit body = body+marshRet Tbool body = body+marshRet Tint body = body+marshRet Tuint body = body+marshRet Tlong body = body+marshRet Tulong body = body+marshRet Tenum body = indent 5. ss "liftM fromEnum $ ". body+marshRet Tflags body = indent 5. ss "liftM fromFlags $ ". body+marshRet Tfloat body = body marshRet Tdouble body = body marshRet Tstring body = body. indent 5. ss ">>= newUTFString" marshRet Tgstring body = body. indent 5. ss ">>= newUTFString"@@ -358,60 +358,60 @@ #else marshExec :: Types -> ArgNo -> ShowS-marshExec Tbool n = indent 4.ss "let bool".shows n.- ss "' = toBool bool".shows n-marshExec Tchar n = indent 4.ss "let char".shows n.- ss "' = (toEnum.fromEnum) char".shows n+marshExec Tbool n = indent 4.ss "let bool".shows n.+ ss "' = toBool bool".shows n+marshExec Tchar n = indent 4.ss "let char".shows n.+ ss "' = (toEnum.fromEnum) char".shows n marshExec Tuchar n = indent 4.ss "let char".shows n.- ss "' = (toEnum.fromEnum) char".shows n-marshExec Tint n = indent 4.ss "let int".shows n.- ss "' = fromIntegral int".shows n-marshExec Tuint n = indent 4.ss "let int".shows n.- ss "' = fromIntegral int".shows n-marshExec Tlong n = indent 4.ss "let long".shows n.- ss "' = toInteger long".shows n+ ss "' = (toEnum.fromEnum) char".shows n+marshExec Tint n = indent 4.ss "let int".shows n.+ ss "' = fromIntegral int".shows n+marshExec Tuint n = indent 4.ss "let int".shows n.+ ss "' = fromIntegral int".shows n+marshExec Tlong n = indent 4.ss "let long".shows n.+ ss "' = toInteger long".shows n marshExec Tulong n = indent 4.ss "let long".shows n.- ss "' = toInteger long".shows n-marshExec Tenum n = indent 4.ss "let enum".shows n.- ss "' = (toEnum.fromEnum) enum".shows n+ ss "' = toInteger long".shows n+marshExec Tenum n = indent 4.ss "let enum".shows n.+ ss "' = (toEnum.fromEnum) enum".shows n marshExec Tflags n = indent 4.ss "let flags".shows n.- ss "' = (toEnum.fromEnum) flags".shows n+ ss "' = (toEnum.fromEnum) flags".shows n marshExec Tfloat n = indent 4.ss "let float".shows n.- ss "' = (fromRational.toRational) float".shows n+ ss "' = (fromRational.toRational) float".shows n marshExec Tdouble n = indent 4.ss "let double".shows n.- ss "' = (fromRational.toRational) double".shows n+ ss "' = (fromRational.toRational) double".shows n marshExec Tstring n = indent 4.ss "str".shows n.- ss "' <- peekCString str".shows n+ ss "' <- peekCString str".shows n marshExec Tmstring n = indent 4.ss "str".shows n.- ss "' <- maybePeekCString str".shows n+ ss "' <- maybePeekCString str".shows n marshExec Tgstring n = indent 4.ss "str".shows n.- ss "' <- peekCString str".shows n+ ss "' <- peekCString str".shows n marshExec Tmgstring n = indent 4.ss "str".shows n.- ss "' <- maybePeekCString str".shows n+ ss "' <- maybePeekCString str".shows n marshExec Tboxed n = indent 4.ss "box".shows n.ss "' <- boxedPre".- shows n.ss " $ castPtr box".shows n-marshExec Tptr n = indent 4.ss "let ptr".shows n.ss "' = castPtr ptr".- shows n+ shows n.ss " $ castPtr box".shows n+marshExec Tptr n = indent 4.ss "let ptr".shows n.ss "' = castPtr ptr".+ shows n marshExec Ttobject n = indent 4.ss "objectRef obj".shows n.- indent 4.ss "obj".shows n.- ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".- indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)"+ indent 4.ss "obj".shows n.+ ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".+ indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)" marshExec Tobject n = indent 4.ss "objectRef obj".shows n.- indent 4.ss "obj".shows n.- ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".- indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)"-marshExec _ _ = id+ indent 4.ss "obj".shows n.+ ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".+ indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)"+marshExec _ _ = id marshRet :: Types -> ShowS-marshRet Tunit = ss "id"-marshRet Tbool = ss "fromBool"-marshRet Tint = ss "fromIntegral"-marshRet Tuint = ss "fromIntegral"-marshRet Tlong = ss "fromIntegral"-marshRet Tulong = ss "fromIntegral"-marshRet Tenum = ss "(toEnum.fromEnum)"-marshRet Tflags = ss "fromFlags"-marshRet Tfloat = ss "(toRational.fromRational)"+marshRet Tunit = ss "id"+marshRet Tbool = ss "fromBool"+marshRet Tint = ss "fromIntegral"+marshRet Tuint = ss "fromIntegral"+marshRet Tlong = ss "fromIntegral"+marshRet Tulong = ss "fromIntegral"+marshRet Tenum = ss "(toEnum.fromEnum)"+marshRet Tflags = ss "fromFlags"+marshRet Tfloat = ss "(toRational.fromRational)" marshRet Tdouble = ss "(toRational.fromRational)" marshRet Tptr = ss "castPtr" marshRet _ = ss "(error \"Signal handlers cannot return structured types.\")"@@ -425,8 +425,8 @@ mkUserType :: Signature -> ShowS mkUserType (ret,ts) = let (str,cs) = foldl (\(str,cs) t ->- let (str',cs') = usertype t cs in (str.str'.ss " -> ",cs'))- (sc '(',['a'..]) ts+ let (str',cs') = usertype t cs in (str.str'.ss " -> ",cs'))+ (sc '(',['a'..]) ts (str',_) = usertype ret cs str'' = if ' ' `elem` (str' "") then (sc '('.str'.sc ')') else str' in str.ss "IO ".str''.sc ')'@@ -459,14 +459,14 @@ mkMarshExec :: Signature -> ShowS mkMarshExec (_,ts) = foldl (.) id $- zipWith marshExec ts [1..]+ zipWith marshExec ts [1..] #endif mkIdentifier :: Signature -> ShowS mkIdentifier (ret,[]) = identifier Tunit . ss "__".identifier ret mkIdentifier (ret,ts) = foldl1 (\a b -> a.sc '_'.b) (map identifier ts).- ss "__".identifier ret+ ss "__".identifier ret mkRawtype :: Signature -> ShowS mkRawtype (ret,ts) =@@ -482,13 +482,13 @@ mkLambdaArgs :: Signature -> ShowS mkLambdaArgs (_,ts) = foldl (.) id $- zipWith (\a b -> nameArg a b.sc ' ') ts [1..]+ zipWith (\a b -> nameArg a b.sc ' ') ts [1..] #ifndef USE_GCLOSURE_SIGNALS_IMPL mkFuncArgs :: Signature -> ShowS mkFuncArgs (_,ts) = foldl (.) id $- zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..]+ zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..] mkMarshRet :: Signature -> ShowS mkMarshRet (ret,_) = marshRet ret@@ -518,13 +518,13 @@ filter ("--help" `isPrefixOf`) args)) || null args if showHelp then usage else do let outModuleName = case map (drop 10) (filter ("--modname=" `isPrefixOf`) args) of- (modName:_) -> modName+ (modName:_) -> modName templateFile <- case map (drop 11) (filter ("--template=" `isPrefixOf`) args) of- [tplName] -> return tplName- _ -> getDataFileName "callbackGen/Signal.chs.template"+ [tplName] -> return tplName+ _ -> getDataFileName "callbackGen/Signal.chs.template" typesFile <- case map (drop 8) (filter ("--types=" `isPrefixOf`) args) of- [typName] -> return typName- _ -> usage+ [typName] -> return typName+ _ -> usage let extraImports = map (drop 9) (filter ("--import=" `isPrefixOf`) args) content <- readFile typesFile let sigs = parseSignatures content
gtk2hs-buildtools.cabal view
@@ -1,5 +1,5 @@ Name: gtk2hs-buildtools-Version: 0.13.0.4+Version: 0.13.0.5 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team
hierarchyGen/TypeGen.hs view
@@ -34,10 +34,10 @@ type Tag = String data ParserState = ParserState {- line :: Int,- col :: Int,- hierObjs :: ObjectSpec,- onlyTags :: [Tag]+ line :: Int,+ col :: Int,+ hierObjs :: ObjectSpec,+ onlyTags :: [Tag] } freshParserState :: [Tag] -> ParserState@@ -49,16 +49,16 @@ pFreshLine :: ParserState -> String -> [(ObjectSpec, TypeQuery)] pFreshLine ps input = pFL ps input where- pFL ps ('#':rem) = pFL ps (dropWhile ((/=) '\n') rem)- pFL ps ('\n':rem) = pFL (ps {line = line ps+1, col=1}) rem- pFL ps (' ':rem) = pFL (ps {col=col ps+1}) rem- pFL ps ('\t':rem) = pFL (ps {col=col ps+8}) rem+ pFL ps ('#':rem) = pFL ps (dropWhile ((/=) '\n') rem)+ pFL ps ('\n':rem) = pFL (ps {line = line ps+1, col=1}) rem+ pFL ps (' ':rem) = pFL (ps {col=col ps+1}) rem+ pFL ps ('\t':rem) = pFL (ps {col=col ps+8}) rem pFL ps all@('G':'t':'k':rem)= pGetObject ps all rem pFL ps all@('G':'d':'k':rem)= pGetObject ps all rem pFL ps all@('G':'s':'t':rem)= pGetObject ps all rem pFL ps all@('G':'n':'o':'m':'e':rem)= pGetObject ps all rem- pFL ps [] = []- pFL ps all = pGetObject ps all all+ pFL ps [] = []+ pFL ps all = pGetObject ps all all pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)] pGetObject ps@ParserState { onlyTags=tags } txt txt' = @@ -80,10 +80,10 @@ ('a':'s':r) -> let (tyName,r') = span isAlphaNum_ (dropWhile isBlank r) in case (dropWhile isBlank r') of- (',':r) ->- let (tyQuery,r') = span isAlphaNum_ (dropWhile isBlank r) in- (tyName, (tyName, TypeInfo origCName (Just tyQuery) eqInst defDestr), r')- r -> (tyName, (tyName, TypeInfo origCName Nothing eqInst defDestr), r)+ (',':r) ->+ let (tyQuery,r') = span isAlphaNum_ (dropWhile isBlank r) in+ (tyName, (tyName, TypeInfo origCName (Just tyQuery) eqInst defDestr), r')+ r -> (tyName, (tyName, TypeInfo origCName Nothing eqInst defDestr), r) r -> (origHsName, (origHsName, TypeInfo origCName Nothing eqInst defDestr), r) parents = dropWhile (\(c,_) -> c>=col ps) (hierObjs ps) spec = (col ps,name):parents@@ -120,18 +120,18 @@ let tags = map (drop 6) (filter ("--tag=" `isPrefixOf`) rem) let lib = case map (drop 6) (filter ("--lib=" `isPrefixOf`) rem) of [] -> "gtk"- (lib:_) -> lib+ (lib:_) -> lib let prefix = case map (drop 9) (filter ("--prefix=" `isPrefixOf`) rem) of [] -> "gtk" (prefix:_) -> prefix let modName = case map (drop 10) (filter ("--modname=" `isPrefixOf`) rem) of- [] -> "Hierarchy"- (modName:_) -> modName+ [] -> "Hierarchy"+ (modName:_) -> modName where bareFName = reverse .- takeWhile isAlphaNum .- drop 1 .- dropWhile isAlpha .- reverse+ takeWhile isAlphaNum .+ drop 1 .+ dropWhile isAlpha .+ reverse let extraNames = map (drop 9) (filter ("--import=" `isPrefixOf`) rem) let rootObject = case map (drop 7) (filter ("--root=" `isPrefixOf`) rem) of [] -> "GObject"@@ -154,7 +154,7 @@ -- Parse the contents of the hierarchy file -- let (objs', specialQueries) = unzip $- pFreshLine (freshParserState tags) hierarchy+ pFreshLine (freshParserState tags) hierarchy objs = map (map snd) objs' let showImport ('*':m ) = ss "{#import " .ss m .ss "#}" . indent 0 showImport m = ss "import " . ss m . indent 0@@ -166,42 +166,42 @@ case var of "MODULE_NAME" -> ss modName "MODULE_EXPORTS" -> generateExports rootObject (map (dropWhile ((==) '*')) forwardNames) objs- "MODULE_IMPORTS" -> foldl (.) id (map showImport (extraNames++forwardNames))- "CONTEXT_LIB" -> ss lib- "CONTEXT_PREFIX" -> ss prefix- "DECLARATIONS" -> generateDeclarations rootObject destrFun prefix objs specialQueries- "ROOTOBJECT" -> ss rootObject- _ -> ss ""+ "MODULE_IMPORTS" -> foldl (.) id (map showImport (extraNames++forwardNames))+ "CONTEXT_LIB" -> ss lib+ "CONTEXT_PREFIX" -> ss prefix+ "DECLARATIONS" -> generateDeclarations rootObject destrFun prefix objs specialQueries+ "ROOTOBJECT" -> ss rootObject+ _ -> ss "" ) "" usage = do hPutStr stderr "\nProgram to generate Gtk's object hierarchy in Haskell. Usage:\n\- \TypeGenerator {--tag=<tag>} [--lib=<lib>] [--prefix=<prefix>]\n\- \ [--modname=<modName>] {--import=<*><importName>}\n\- \ {--forward=<*><fwdName>} [--destructor=<destrName>]\n\- \ [--hierarchy=<hierName>]\n\- \where\n\- \ <tag> generate entries that have the tag <tag>\n\- \ specify `default' for types without tags\n\- \ <lib> set the lib to use in the c2hs {#context #}\n\- \ declaration (the default is \"gtk\")\n\- \ <prefix> set the prefix to use in the c2hs {#context #}\n\- \ declaration (the default is \"gtk\")\n\- \ <modName> specify module name if it does not match the\n\- \ file name, eg a hierarchical module name\n\- \ <importName> additionally import this module without\n\- \ re-exporting it\n\- \ <fwdName> specify a number of modules that are imported\n\- \ <*> use an asterix as prefix if the import should\n\- \ be a .chs import statement\n\- \ as well as exported from the generated module\n\- \ <destrName> specify a non-standard C function pointer that\n\- \ is called to destroy the objects\n\- \ <hierName> the name of the file containing the hierarchy list,\n\- \ defaults to the built-in list\n\- \\n\- \The resulting Haskell module is written to the standard output.\n"+ \TypeGenerator {--tag=<tag>} [--lib=<lib>] [--prefix=<prefix>]\n\+ \ [--modname=<modName>] {--import=<*><importName>}\n\+ \ {--forward=<*><fwdName>} [--destructor=<destrName>]\n\+ \ [--hierarchy=<hierName>]\n\+ \where\n\+ \ <tag> generate entries that have the tag <tag>\n\+ \ specify `default' for types without tags\n\+ \ <lib> set the lib to use in the c2hs {#context #}\n\+ \ declaration (the default is \"gtk\")\n\+ \ <prefix> set the prefix to use in the c2hs {#context #}\n\+ \ declaration (the default is \"gtk\")\n\+ \ <modName> specify module name if it does not match the\n\+ \ file name, eg a hierarchical module name\n\+ \ <importName> additionally import this module without\n\+ \ re-exporting it\n\+ \ <fwdName> specify a number of modules that are imported\n\+ \ <*> use an asterix as prefix if the import should\n\+ \ be a .chs import statement\n\+ \ as well as exported from the generated module\n\+ \ <destrName> specify a non-standard C function pointer that\n\+ \ is called to destroy the objects\n\+ \ <hierName> the name of the file containing the hierarchy list,\n\+ \ defaults to the built-in list\n\+ \\n\+ \The resulting Haskell module is written to the standard output.\n" exitWith $ ExitFailure 1 @@ -232,7 +232,7 @@ | obj <- objs ] makeUpcast :: String -> [String] -> ShowS-makeUpcast rootObject [obj] = id -- no casting for root+makeUpcast rootObject [obj] = id -- no casting for root makeUpcast rootObject (obj:_:_) = indent 0.ss "castTo".ss obj.ss " :: ".ss rootObject.ss "Class obj => obj -> ".ss obj. indent 0.ss "castTo".ss obj.ss " = castTo gType".ss obj.ss " \"".ss obj.ss "\"".@@ -247,30 +247,30 @@ ss (case lookup obj table of (Just TypeInfo { tiAlternateName = Just get_type_func }) -> get_type_func- (Just TypeInfo { tiQueryFunction = cname}) ->- tail $ c2u True cname++"_get_type").+ (Just TypeInfo { tiQueryFunction = cname}) ->+ tail $ c2u True cname++"_get_type"). ss " #}". indent 0 where -- case to underscore translation: the boolean arg specifies whether -- the first uppercase letter X is to be replaced by _x (True) or by x. --- -- translation: HButtonBox -> hbutton_box+ -- translation: HButtonBox -> hbutton_box c2u :: Bool -> String -> String c2u True (x:xs) | isUpper x = '_':toLower x:c2u False xs c2u False (x:xs) | isUpper x = toLower x:c2u True xs c2u _ (x:xs) | otherwise = x:c2u True xs- c2u _ [] = []+ c2u _ [] = [] makeOrd fill [] = id makeOrd fill (obj:preds) = indent 1.ss "compare ".ss obj.ss "Tag ".- fill obj.ss obj.ss "Tag".fill obj.- ss " = EQ".makeGT obj preds+ fill obj.ss obj.ss "Tag".fill obj.+ ss " = EQ".makeGT obj preds where- makeGT obj [] = id+ makeGT obj [] = id makeGT obj (pr:eds) = indent 1.ss "compare ".ss obj.ss "Tag ".- fill obj.ss pr.ss "Tag".fill pr.- ss " = GT".makeGT obj eds+ fill obj.ss pr.ss "Tag".fill pr.+ ss " = GT".makeGT obj eds makeClass :: String -> String -> String -> TypeTable -> [String] -> ShowS makeClass rootObject destr prefix table (name:[]) = id@@ -280,7 +280,7 @@ indent 0.ss "{#pointer *". (case lookup name table of (Just TypeInfo { tiQueryFunction = cname }) -> ss cname.ss " as ".ss name- ).+ ). ss " foreign newtype #}". (case lookup name table of (Just (TypeInfo { tiNoEqualInst = False })) -> ss " deriving (Eq,Ord)"