ghc/lib/hbc/Native.hs

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