--- /dev/null
+#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 __HASKELL1__ < 3
+ , Maybe..
+#endif
+#if defined(__YALE_HASKELL__)
+ , openInputByteFile, openOutputByteFile, closeByteFile
+ , readBFile, readBytesFromByteFile
+ , shortIntToByteFile, bytesToShortIntIO
+ , ByteFile
+ , Byte
+#endif
+ ) where
+
+#if __HASKELL1__ < 3
+import {-flummox mkdependHS-}
+ Maybe
+#endif
+
+#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 Text(Byte) where
+ showsPrec _ _ = showString "Byte"
+
+instance Text(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 = 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 `thenMaybe` \(a,bs') ->
+ readBytes bs' `thenMaybe` \(b,bs'') ->
+ Just ((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 `thenMaybe` \(a,bs') ->
+ readBytes bs' `thenMaybe` \(b,bs'') ->
+ readBytes bs'' `thenMaybe` \(c,bs''') ->
+ Just ((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 `thenMaybe` \(n,bs') ->
+ listReadBytes n bs' `thenMaybe` \(xs, bs'') ->
+ Just (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 `thenMaybe` \(a,bs') ->
+ Just (Just a, bs')
+ readBytes _ = Nothing
+#else
+ showBytes (Just a) = showBytes True . showBytes a
+ showBytes Nothing = showBytes False
+ readBytes bs =
+ readBytes bs `thenMaybe` \ (isJust, bs') ->
+ if isJust then
+ readBytes bs' `thenMaybe` \ (a, bs'') ->
+ Just (Just a, bs'')
+ else
+ Just (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 `thenMaybe` \(b, bs')->
+ readBytes bs' `thenMaybe` \(xs, bs'')->
+ Just (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
projects / ghc-hetmet.git / blobdiff