ghc/lib/misc/Native.lhs

   1 \begin{code}
   2 #if defined(__YALE_HASKELL__)
   3 -- Native.hs -- native data conversions and I/O
   4 --
   5 -- author :  Sandra Loosemore
   6 -- date   :  07 Jun 1994
   7 --
   8 --
   9 -- Unlike in the original hbc version of this library, a Byte is a completely
  10 -- abstract data type and not a character.  You can't read and write Bytes
  11 -- to ordinary text files; you must use the operations defined here on
  12 -- Native files.
  13 -- It's guaranteed to be more efficient to read and write objects directly
  14 -- to a file than to do the conversion to a Byte stream and read/write
  15 -- the Byte stream.
  16 #endif
  17
  18 module Native(
  19        Native(..), Bytes,
  20        shortIntToBytes, bytesToShortInt,
  21        longIntToBytes, bytesToLongInt,
  22        showB, readB
  23 #if defined(__YALE_HASKELL__)
  24        , openInputByteFile, openOutputByteFile, closeByteFile
  25        , readBFile, readBytesFromByteFile
  26        , shortIntToByteFile, bytesToShortIntIO
  27        , ByteFile
  28        , Byte
  29 #endif
  30     ) where
  31
  32 import Ix -- 1.3
  33 import Array -- 1.3
  34
  35 #if defined(__YALE_HASKELL__)
  36 import NativePrims
  37
  38 -- these data types are completely opaque on the Haskell side.
  39
  40 data Byte = Byte
  41 data ByteFile = ByteFile
  42 type Bytes = [Byte]
  43
  44 instance Show(Byte) where
  45  showsPrec _ _ = showString "Byte"
  46
  47 instance Show(ByteFile) where
  48  showsPrec _ _ = showString "ByteFile"
  49
  50 -- Byte file primitives
  51
  52 openInputByteFile       :: String -> IO (ByteFile)
  53 openOutputByteFile      :: String -> IO (ByteFile)
  54 closeByteFile           :: ByteFile -> IO ()
  55
  56 openInputByteFile       = primOpenInputByteFile
  57 openOutputByteFile      = primOpenOutputByteFile
  58 closeByteFile           = primCloseByteFile
  59 #endif {- YALE-}
  60
  61 #if defined(__GLASGOW_HASKELL__)
  62 import ByteOps -- partain
  63 type Bytes = [Char]
  64 #endif
  65
  66 #if defined(__HBC__)
  67 import LMLbyteops
  68 type Bytes = [Char]
  69 #endif
  70
  71 -- Here are the basic operations defined on the class.
  72
  73 class Native a where
  74
  75     -- these are primitives
  76     showBytes     :: a -> Bytes -> Bytes                -- convert to bytes
  77     readBytes     :: Bytes -> Maybe (a, Bytes)          -- get an item and the rest
  78 #if defined(__YALE_HASKELL__)
  79     showByteFile  :: a -> ByteFile -> IO ()
  80     readByteFile  :: ByteFile -> IO a
  81 #endif
  82
  83     -- these are derived
  84     listShowBytes :: [a] -> Bytes -> Bytes              -- convert a list to bytes
  85     listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) -- get n items and the rest
  86 #if defined(__YALE_HASKELL__)
  87     listShowByteFile :: [a] -> ByteFile -> IO ()
  88     listReadByteFile :: Int -> ByteFile -> IO [a]
  89 #endif
  90
  91     -- here are defaults for the derived methods.
  92
  93     listShowBytes []     bs = bs
  94     listShowBytes (x:xs) bs = showBytes x (listShowBytes xs bs)
  95
  96     listReadBytes 0 bs = Just ([], bs)
  97     listReadBytes n bs =
  98         case readBytes bs of
  99         Nothing -> Nothing
 100         Just (x,bs') ->
 101                 case listReadBytes (n-1) bs' of
 102                 Nothing -> Nothing
 103                 Just (xs,bs'') -> Just (x:xs, bs'')
 104
 105 #if defined(__YALE_HASKELL__)
 106     listShowByteFile l f =
 107       foldr (\ head tail -> (showByteFile head f) >> tail)
 108             (return ())
 109             l
 110
 111     listReadByteFile 0 f =
 112       return []
 113     listReadByteFile n f =
 114       readByteFile f                    >>= \ h ->
 115       listReadByteFile (n - 1) f        >>= \ t ->
 116       return (h:t)
 117 #endif
 118
 119 #if ! defined(__YALE_HASKELL__)
 120 -- Some utilities that Yale doesn't use
 121 hasNElems :: Int -> [a] -> Bool
 122 hasNElems 0 _      = True
 123 hasNElems 1 (_:_)  = True               -- speedup
 124 hasNElems 2 (_:_:_)  = True             -- speedup
 125 hasNElems 3 (_:_:_:_)  = True           -- speedup
 126 hasNElems 4 (_:_:_:_:_)  = True         -- speedup
 127 hasNElems _ []     = False
 128 hasNElems n (_:xs) = hasNElems (n-1) xs
 129
 130 lenLong, lenInt, lenShort, lenFloat, lenDouble :: Int
 131 lenLong   = length (longToBytes   0 [])
 132 lenInt    = length (intToBytes    0 [])
 133 lenShort  = length (shortToBytes  0 [])
 134 lenFloat  = length (floatToBytes  0 [])
 135 lenDouble = length (doubleToBytes 0 [])
 136 #endif
 137
 138 -- Basic instances, defined as primitives
 139
 140 instance Native Char where
 141 #if defined(__YALE_HASKELL__)
 142     showBytes           = primCharShowBytes
 143     readBytes           = primCharReadBytes
 144     showByteFile        = primCharShowByteFile
 145     readByteFile        = primCharReadByteFile
 146 #else
 147     showBytes   c bs = c:bs
 148     readBytes [] = Nothing
 149     readBytes (c:cs) = Just (c,cs)
 150     listReadBytes n bs = f n bs []
 151         where f 0 bs cs = Just (reverse cs, bs)
 152               f _ [] _  = Nothing
 153               f n (b:bs) cs = f (n-1::Int) bs (b:cs)
 154 #endif
 155
 156 instance Native Int where
 157 #if defined(__YALE_HASKELL__)
 158     showBytes           = primIntShowBytes
 159     readBytes           = primIntReadBytes
 160     showByteFile        = primIntShowByteFile
 161     readByteFile        = primIntReadByteFile
 162 #else
 163     showBytes i bs = intToBytes i bs
 164     readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing
 165 #endif
 166
 167 instance Native Float where
 168 #if defined(__YALE_HASKELL__)
 169     showBytes           = primFloatShowBytes
 170     readBytes           = primFloatReadBytes
 171     showByteFile        = primFloatShowByteFile
 172     readByteFile        = primFloatReadByteFile
 173 #else
 174     showBytes i bs = floatToBytes i bs
 175     readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing
 176 #endif
 177
 178 instance Native Double where
 179 #if defined(__YALE_HASKELL__)
 180     showBytes           = primDoubleShowBytes
 181     readBytes           = primDoubleReadBytes
 182     showByteFile        = primDoubleShowByteFile
 183     readByteFile        = primDoubleReadByteFile
 184 #else
 185     showBytes i bs = doubleToBytes i bs
 186     readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing
 187 #endif
 188
 189 instance Native Bool where
 190 #if defined(__YALE_HASKELL__)
 191     showBytes           = primBoolShowBytes
 192     readBytes           = primBoolReadBytes
 193     showByteFile        = primBoolShowByteFile
 194     readByteFile        = primBoolReadByteFile
 195 #else
 196     showBytes b bs = if b then '\x01':bs else '\x00':bs
 197     readBytes [] = Nothing
 198     readBytes (c:cs) = Just(c/='\x00', cs)
 199 #endif
 200
 201 #if defined(__YALE_HASKELL__)
 202 -- Byte instances, so you can write Bytes to a ByteFile
 203
 204 instance Native Byte where
 205     showBytes           = (:)
 206     readBytes l =
 207       case l of
 208         []  -> Nothing
 209         h:t -> Just(h,t)
 210     showByteFile                = primByteShowByteFile
 211     readByteFile                = primByteReadByteFile
 212 #endif
 213
 214 -- A pair is stored as two consecutive items.
 215 instance (Native a, Native b) => Native (a,b) where
 216     showBytes (a,b) = showBytes a . showBytes b
 217     readBytes bs = readBytes bs  >>= \(a,bs') ->
 218                    readBytes bs' >>= \(b,bs'') ->
 219                    return ((a,b), bs'')
 220 #if defined(__YALE_HASKELL__)
 221     showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f)
 222
 223     readByteFile f =
 224       readByteFile f        >>= \ a ->
 225       readByteFile f        >>= \ b ->
 226       return (a,b)
 227 #endif
 228
 229 -- A triple is stored as three consectutive items.
 230 instance (Native a, Native b, Native c) => Native (a,b,c) where
 231     showBytes (a,b,c) = showBytes a . showBytes b . showBytes c
 232     readBytes bs = readBytes bs   >>= \(a,bs') ->
 233                    readBytes bs'  >>= \(b,bs'') ->
 234                    readBytes bs'' >>= \(c,bs''') ->
 235                    return ((a,b,c), bs''')
 236 #if defined(__YALE_HASKELL__)
 237     showByteFile (a,b,c) f =
 238       (showByteFile a f) >>
 239       (showByteFile b f) >>
 240       (showByteFile c f)
 241
 242     readByteFile f =
 243       readByteFile f    >>= \ a ->
 244       readByteFile f    >>= \ b ->
 245       readByteFile f    >>= \ c ->
 246       return (a,b,c)
 247 #endif
 248
 249 -- A list is stored with an Int with the number of items followed by the items.
 250 instance (Native a) => Native [a] where
 251     showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs
 252                                                          f (x:xs) = showBytes x (f xs)
 253     readBytes bs = readBytes bs         >>= \(n,bs') ->
 254                    listReadBytes n bs'  >>= \(xs, bs'') ->
 255                    return (xs, bs'')
 256 #if defined(__YALE_HASKELL__)
 257     showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f)
 258     readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f
 259 #endif
 260
 261 -- A Maybe is stored as a Boolean possibly followed by a value
 262 instance (Native a) => Native (Maybe a) where
 263 #if !defined(__YALE_HASKELL__)
 264     showBytes Nothing = ('\x00' :)
 265     showBytes (Just x) = ('\x01' :) . showBytes x
 266     readBytes ('\x00':bs) = Just (Nothing, bs)
 267     readBytes ('\x01':bs) = readBytes bs >>= \(a,bs') ->
 268                             return (Just a, bs')
 269     readBytes _ = Nothing
 270 #else
 271     showBytes (Just a) = showBytes True . showBytes a
 272     showBytes Nothing  = showBytes False
 273     readBytes bs =
 274         readBytes bs            >>= \ (isJust, bs') ->
 275         if isJust then
 276                 readBytes bs'   >>= \ (a, bs'') ->
 277                 return (Just a, bs'')
 278         else
 279                 return (Nothing, bs')
 280
 281     showByteFile (Just a) f = showByteFile True f >> showByteFile a f
 282     showByteFile Nothing  f = showByteFile False f
 283     readByteFile f =
 284         readByteFile f          >>= \ isJust ->
 285         if isJust then
 286                 readByteFile f  >>= \ a ->
 287                 return (Just a)
 288         else
 289                 return Nothing
 290 #endif
 291
 292 instance (Native a, Ix a, Native b) => Native (Array a b) where
 293     showBytes a = showBytes (bounds a) . showBytes (elems a)
 294     readBytes bs = readBytes bs  >>= \(b, bs')->
 295                    readBytes bs' >>= \(xs, bs'')->
 296                    return (listArray b xs, bs'')
 297
 298 shortIntToBytes :: Int   -> Bytes -> Bytes
 299 bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
 300 longIntToBytes  :: Int   -> Bytes -> Bytes
 301 bytesToLongInt  :: Bytes -> Maybe (Int, Bytes)
 302 #if defined(__YALE_HASKELL__)
 303 shortIntToByteFile      :: Int -> ByteFile -> IO ()
 304 bytesToShortIntIO       :: ByteFile -> IO Int
 305 #endif
 306
 307 #if defined(__YALE_HASKELL__)
 308 -- These functions are like the primIntxx but use a "short" rather than
 309 -- "int" representation.
 310 shortIntToBytes         = primShortShowBytes
 311 bytesToShortInt         = primShortReadBytes
 312 shortIntToByteFile      = primShortShowByteFile
 313 bytesToShortIntIO       = primShortReadByteFile
 314
 315 #else {-! YALE-}
 316
 317 shortIntToBytes s bs = shortToBytes s bs
 318
 319 bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing
 320
 321 longIntToBytes s bs = longToBytes s bs
 322
 323 bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing
 324
 325 #endif {-! YALE-}
 326
 327 showB :: (Native a) => a -> Bytes
 328 showB x = showBytes x []
 329
 330 readB :: (Native a) => Bytes -> a
 331 readB bs =
 332         case readBytes bs of
 333         Just (x,[]) -> x
 334         Just (_,_)  -> error "Native.readB data too long"
 335         Nothing     -> error "Native.readB data too short"
 336
 337 #if defined(__YALE_HASKELL__)
 338 readBFile :: String -> IO(Bytes)
 339 readBFile name =
 340   openInputByteFile name >>= \ f ->
 341   readBytesFromByteFile f
 342
 343 readBytesFromByteFile :: ByteFile -> IO(Bytes)
 344 readBytesFromByteFile f =
 345   try
 346     (primByteReadByteFile f  >>= \ h ->
 347      readBytesFromByteFile f >>= \ t ->
 348      return (h:t))
 349     onEOF
 350  where
 351    onEOF EOF = closeByteFile f >> return []
 352    onEOF err = closeByteFile f >> failwith err
 353 #endif
 354 \end{code}