path: root/ghc/lib/misc/Native.lhs

\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}