\begin{code} #if defined(__YALE_HASKELL__) -- Native.hs -- native data conversions and I/O -- -- author : Sandra Loosemore -- date : 07 Jun 1994 -- -- -- Unlike in the original hbc version of this library, a Byte is a completely -- abstract data type and not a character. You can't read and write Bytes -- to ordinary text files; you must use the operations defined here on -- Native files. -- It's guaranteed to be more efficient to read and write objects directly -- to a file than to do the conversion to a Byte stream and read/write -- the Byte stream. #endif module Native( Native(..), Bytes, shortIntToBytes, bytesToShortInt, longIntToBytes, bytesToLongInt, showB, readB #if defined(__YALE_HASKELL__) , openInputByteFile, openOutputByteFile, closeByteFile , readBFile, readBytesFromByteFile , shortIntToByteFile, bytesToShortIntIO , ByteFile , Byte #endif ) where import Ix -- 1.3 import Array -- 1.3 #if defined(__YALE_HASKELL__) import NativePrims -- these data types are completely opaque on the Haskell side. data Byte = Byte data ByteFile = ByteFile type Bytes = [Byte] instance Show(Byte) where showsPrec _ _ = showString "Byte" instance Show(ByteFile) where showsPrec _ _ = showString "ByteFile" -- Byte file primitives openInputByteFile :: String -> IO (ByteFile) openOutputByteFile :: String -> IO (ByteFile) closeByteFile :: ByteFile -> IO () openInputByteFile = primOpenInputByteFile openOutputByteFile = primOpenOutputByteFile closeByteFile = primCloseByteFile #endif {- YALE-} #if defined(__GLASGOW_HASKELL__) import ByteOps -- partain type Bytes = [Char] #endif #if defined(__HBC__) import LMLbyteops type Bytes = [Char] #endif -- Here are the basic operations defined on the class. class Native a where -- these are primitives showBytes :: a -> Bytes -> Bytes -- convert to bytes readBytes :: Bytes -> Maybe (a, Bytes) -- get an item and the rest #if defined(__YALE_HASKELL__) showByteFile :: a -> ByteFile -> IO () readByteFile :: ByteFile -> IO a #endif -- these are derived listShowBytes :: [a] -> Bytes -> Bytes -- convert a list to bytes listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) -- get n items and the rest #if defined(__YALE_HASKELL__) listShowByteFile :: [a] -> ByteFile -> IO () listReadByteFile :: Int -> ByteFile -> IO [a] #endif -- here are defaults for the derived methods. listShowBytes [] bs = bs listShowBytes (x:xs) bs = showBytes x (listShowBytes xs bs) listReadBytes 0 bs = Just ([], bs) listReadBytes n bs = case readBytes bs of Nothing -> Nothing Just (x,bs') -> case listReadBytes (n-1) bs' of Nothing -> Nothing Just (xs,bs'') -> Just (x:xs, bs'') #if defined(__YALE_HASKELL__) listShowByteFile l f = foldr (\ head tail -> (showByteFile head f) >> tail) (return ()) l listReadByteFile 0 f = return [] listReadByteFile n f = readByteFile f >>= \ h -> listReadByteFile (n - 1) f >>= \ t -> return (h:t) #endif #if ! defined(__YALE_HASKELL__) -- Some utilities that Yale doesn't use hasNElems :: Int -> [a] -> Bool hasNElems 0 _ = True hasNElems 1 (_:_) = True -- speedup hasNElems 2 (_:_:_) = True -- speedup hasNElems 3 (_:_:_:_) = True -- speedup hasNElems 4 (_:_:_:_:_) = True -- speedup hasNElems _ [] = False hasNElems n (_:xs) = hasNElems (n-1) xs lenLong, lenInt, lenShort, lenFloat, lenDouble :: Int lenLong = length (longToBytes 0 []) lenInt = length (intToBytes 0 []) lenShort = length (shortToBytes 0 []) lenFloat = length (floatToBytes 0 []) lenDouble = length (doubleToBytes 0 []) #endif -- Basic instances, defined as primitives instance Native Char where #if defined(__YALE_HASKELL__) showBytes = primCharShowBytes readBytes = primCharReadBytes showByteFile = primCharShowByteFile readByteFile = primCharReadByteFile #else showBytes c bs = c:bs readBytes [] = Nothing readBytes (c:cs) = Just (c,cs) listReadBytes n bs = f n bs [] where f 0 bs cs = Just (reverse cs, bs) f _ [] _ = Nothing f n (b:bs) cs = f (n-1::Int) bs (b:cs) #endif instance Native Int where #if defined(__YALE_HASKELL__) showBytes = primIntShowBytes readBytes = primIntReadBytes showByteFile = primIntShowByteFile readByteFile = primIntReadByteFile #else showBytes i bs = intToBytes i bs readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing #endif instance Native Float where #if defined(__YALE_HASKELL__) showBytes = primFloatShowBytes readBytes = primFloatReadBytes showByteFile = primFloatShowByteFile readByteFile = primFloatReadByteFile #else showBytes i bs = floatToBytes i bs readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing #endif instance Native Double where #if defined(__YALE_HASKELL__) showBytes = primDoubleShowBytes readBytes = primDoubleReadBytes showByteFile = primDoubleShowByteFile readByteFile = primDoubleReadByteFile #else showBytes i bs = doubleToBytes i bs readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing #endif instance Native Bool where #if defined(__YALE_HASKELL__) showBytes = primBoolShowBytes readBytes = primBoolReadBytes showByteFile = primBoolShowByteFile readByteFile = primBoolReadByteFile #else showBytes b bs = if b then '\x01':bs else '\x00':bs readBytes [] = Nothing readBytes (c:cs) = Just(c/='\x00', cs) #endif #if defined(__YALE_HASKELL__) -- Byte instances, so you can write Bytes to a ByteFile instance Native Byte where showBytes = (:) readBytes l = case l of [] -> Nothing h:t -> Just(h,t) showByteFile = primByteShowByteFile readByteFile = primByteReadByteFile #endif -- A pair is stored as two consecutive items. instance (Native a, Native b) => Native (a,b) where showBytes (a,b) = showBytes a . showBytes b readBytes bs = readBytes bs >>= \(a,bs') -> readBytes bs' >>= \(b,bs'') -> return ((a,b), bs'') #if defined(__YALE_HASKELL__) showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f) readByteFile f = readByteFile f >>= \ a -> readByteFile f >>= \ b -> return (a,b) #endif -- A triple is stored as three consectutive items. instance (Native a, Native b, Native c) => Native (a,b,c) where showBytes (a,b,c) = showBytes a . showBytes b . showBytes c readBytes bs = readBytes bs >>= \(a,bs') -> readBytes bs' >>= \(b,bs'') -> readBytes bs'' >>= \(c,bs''') -> return ((a,b,c), bs''') #if defined(__YALE_HASKELL__) showByteFile (a,b,c) f = (showByteFile a f) >> (showByteFile b f) >> (showByteFile c f) readByteFile f = readByteFile f >>= \ a -> readByteFile f >>= \ b -> readByteFile f >>= \ c -> return (a,b,c) #endif -- A list is stored with an Int with the number of items followed by the items. instance (Native a) => Native [a] where showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs f (x:xs) = showBytes x (f xs) readBytes bs = readBytes bs >>= \(n,bs') -> listReadBytes n bs' >>= \(xs, bs'') -> return (xs, bs'') #if defined(__YALE_HASKELL__) showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f) readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f #endif -- A Maybe is stored as a Boolean possibly followed by a value instance (Native a) => Native (Maybe a) where #if !defined(__YALE_HASKELL__) showBytes Nothing = ('\x00' :) showBytes (Just x) = ('\x01' :) . showBytes x readBytes ('\x00':bs) = Just (Nothing, bs) readBytes ('\x01':bs) = readBytes bs >>= \(a,bs') -> return (Just a, bs') readBytes _ = Nothing #else showBytes (Just a) = showBytes True . showBytes a showBytes Nothing = showBytes False readBytes bs = readBytes bs >>= \ (isJust, bs') -> if isJust then readBytes bs' >>= \ (a, bs'') -> return (Just a, bs'') else return (Nothing, bs') showByteFile (Just a) f = showByteFile True f >> showByteFile a f showByteFile Nothing f = showByteFile False f readByteFile f = readByteFile f >>= \ isJust -> if isJust then readByteFile f >>= \ a -> return (Just a) else return Nothing #endif instance (Native a, Ix a, Native b) => Native (Array a b) where showBytes a = showBytes (bounds a) . showBytes (elems a) readBytes bs = readBytes bs >>= \(b, bs')-> readBytes bs' >>= \(xs, bs'')-> return (listArray b xs, bs'') shortIntToBytes :: Int -> Bytes -> Bytes bytesToShortInt :: Bytes -> Maybe (Int, Bytes) longIntToBytes :: Int -> Bytes -> Bytes bytesToLongInt :: Bytes -> Maybe (Int, Bytes) #if defined(__YALE_HASKELL__) shortIntToByteFile :: Int -> ByteFile -> IO () bytesToShortIntIO :: ByteFile -> IO Int #endif #if defined(__YALE_HASKELL__) -- These functions are like the primIntxx but use a "short" rather than -- "int" representation. shortIntToBytes = primShortShowBytes bytesToShortInt = primShortReadBytes shortIntToByteFile = primShortShowByteFile bytesToShortIntIO = primShortReadByteFile #else {-! YALE-} shortIntToBytes s bs = shortToBytes s bs bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing longIntToBytes s bs = longToBytes s bs bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing #endif {-! YALE-} showB :: (Native a) => a -> Bytes showB x = showBytes x [] readB :: (Native a) => Bytes -> a readB bs = case readBytes bs of Just (x,[]) -> x Just (_,_) -> error "Native.readB data too long" Nothing -> error "Native.readB data too short" #if defined(__YALE_HASKELL__) readBFile :: String -> IO(Bytes) readBFile name = openInputByteFile name >>= \ f -> readBytesFromByteFile f readBytesFromByteFile :: ByteFile -> IO(Bytes) readBytesFromByteFile f = try (primByteReadByteFile f >>= \ h -> readBytesFromByteFile f >>= \ t -> return (h:t)) onEOF where onEOF EOF = closeByteFile f >> return [] onEOF err = closeByteFile f >> failwith err #endif \end{code}