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   = length (longToBytes   0 [])
 131 lenInt    = length (intToBytes    0 [])
 132 lenShort  = length (shortToBytes  0 [])
 133 lenFloat  = length (floatToBytes  0 [])
 134 lenDouble = length (doubleToBytes 0 [])
 135 #endif
 136
 137 -- Basic instances, defined as primitives
 138
 139 instance Native Char where
 140 #if defined(__YALE_HASKELL__)
 141     showBytes           = primCharShowBytes
 142     readBytes           = primCharReadBytes
 143     showByteFile        = primCharShowByteFile
 144     readByteFile        = primCharReadByteFile
 145 #else
 146     showBytes   c bs = c:bs
 147     readBytes [] = Nothing
 148     readBytes (c:cs) = Just (c,cs)
 149     listReadBytes n bs = f n bs []
 150         where f 0 bs cs = Just (reverse cs, bs)
 151               f _ [] _  = Nothing
 152               f n (b:bs) cs = f (n-1::Int) bs (b:cs)
 153 #endif
 154
 155 instance Native Int where
 156 #if defined(__YALE_HASKELL__)
 157     showBytes           = primIntShowBytes
 158     readBytes           = primIntReadBytes
 159     showByteFile        = primIntShowByteFile
 160     readByteFile        = primIntReadByteFile
 161 #else
 162     showBytes i bs = intToBytes i bs
 163     readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing
 164 #endif
 165
 166 instance Native Float where
 167 #if defined(__YALE_HASKELL__)
 168     showBytes           = primFloatShowBytes
 169     readBytes           = primFloatReadBytes
 170     showByteFile        = primFloatShowByteFile
 171     readByteFile        = primFloatReadByteFile
 172 #else
 173     showBytes i bs = floatToBytes i bs
 174     readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing
 175 #endif
 176
 177 instance Native Double where
 178 #if defined(__YALE_HASKELL__)
 179     showBytes           = primDoubleShowBytes
 180     readBytes           = primDoubleReadBytes
 181     showByteFile        = primDoubleShowByteFile
 182     readByteFile        = primDoubleReadByteFile
 183 #else
 184     showBytes i bs = doubleToBytes i bs
 185     readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing
 186 #endif
 187
 188 instance Native Bool where
 189 #if defined(__YALE_HASKELL__)
 190     showBytes           = primBoolShowBytes
 191     readBytes           = primBoolReadBytes
 192     showByteFile        = primBoolShowByteFile
 193     readByteFile        = primBoolReadByteFile
 194 #else
 195     showBytes b bs = if b then '\x01':bs else '\x00':bs
 196     readBytes [] = Nothing
 197     readBytes (c:cs) = Just(c/='\x00', cs)
 198 #endif
 199
 200 #if defined(__YALE_HASKELL__)
 201 -- Byte instances, so you can write Bytes to a ByteFile
 202
 203 instance Native Byte where
 204     showBytes           = (:)
 205     readBytes l =
 206       case l of
 207         []  -> Nothing
 208         h:t -> Just(h,t)
 209     showByteFile                = primByteShowByteFile
 210     readByteFile                = primByteReadByteFile
 211 #endif
 212
 213 -- A pair is stored as two consecutive items.
 214 instance (Native a, Native b) => Native (a,b) where
 215     showBytes (a,b) = showBytes a . showBytes b
 216     readBytes bs = readBytes bs  >>= \(a,bs') ->
 217                    readBytes bs' >>= \(b,bs'') ->
 218                    return ((a,b), bs'')
 219 #if defined(__YALE_HASKELL__)
 220     showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f)
 221
 222     readByteFile f =
 223       readByteFile f        >>= \ a ->
 224       readByteFile f        >>= \ b ->
 225       return (a,b)
 226 #endif
 227
 228 -- A triple is stored as three consectutive items.
 229 instance (Native a, Native b, Native c) => Native (a,b,c) where
 230     showBytes (a,b,c) = showBytes a . showBytes b . showBytes c
 231     readBytes bs = readBytes bs   >>= \(a,bs') ->
 232                    readBytes bs'  >>= \(b,bs'') ->
 233                    readBytes bs'' >>= \(c,bs''') ->
 234                    return ((a,b,c), bs''')
 235 #if defined(__YALE_HASKELL__)
 236     showByteFile (a,b,c) f =
 237       (showByteFile a f) >>
 238       (showByteFile b f) >>
 239       (showByteFile c f)
 240
 241     readByteFile f =
 242       readByteFile f    >>= \ a ->
 243       readByteFile f    >>= \ b ->
 244       readByteFile f    >>= \ c ->
 245       return (a,b,c)
 246 #endif
 247
 248 -- A list is stored with an Int with the number of items followed by the items.
 249 instance (Native a) => Native [a] where
 250     showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs
 251                                                          f (x:xs) = showBytes x (f xs)
 252     readBytes bs = readBytes bs         >>= \(n,bs') ->
 253                    listReadBytes n bs'  >>= \(xs, bs'') ->
 254                    return (xs, bs'')
 255 #if defined(__YALE_HASKELL__)
 256     showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f)
 257     readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f
 258 #endif
 259
 260 -- A Maybe is stored as a Boolean possibly followed by a value
 261 instance (Native a) => Native (Maybe a) where
 262 #if !defined(__YALE_HASKELL__)
 263     showBytes Nothing = ('\x00' :)
 264     showBytes (Just x) = ('\x01' :) . showBytes x
 265     readBytes ('\x00':bs) = Just (Nothing, bs)
 266     readBytes ('\x01':bs) = readBytes bs >>= \(a,bs') ->
 267                             return (Just a, bs')
 268     readBytes _ = Nothing
 269 #else
 270     showBytes (Just a) = showBytes True . showBytes a
 271     showBytes Nothing  = showBytes False
 272     readBytes bs =
 273         readBytes bs            >>= \ (isJust, bs') ->
 274         if isJust then
 275                 readBytes bs'   >>= \ (a, bs'') ->
 276                 return (Just a, bs'')
 277         else
 278                 return (Nothing, bs')
 279
 280     showByteFile (Just a) f = showByteFile True f >> showByteFile a f
 281     showByteFile Nothing  f = showByteFile False f
 282     readByteFile f =
 283         readByteFile f          >>= \ isJust ->
 284         if isJust then
 285                 readByteFile f  >>= \ a ->
 286                 return (Just a)
 287         else
 288                 return Nothing
 289 #endif
 290
 291 instance (Native a, Ix a, Native b) => Native (Array a b) where
 292     showBytes a = showBytes (bounds a) . showBytes (elems a)
 293     readBytes bs = readBytes bs  >>= \(b, bs')->
 294                    readBytes bs' >>= \(xs, bs'')->
 295                    return (listArray b xs, bs'')
 296
 297 shortIntToBytes :: Int   -> Bytes -> Bytes
 298 bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
 299 longIntToBytes  :: Int   -> Bytes -> Bytes
 300 bytesToLongInt  :: Bytes -> Maybe (Int, Bytes)
 301 #if defined(__YALE_HASKELL__)
 302 shortIntToByteFile      :: Int -> ByteFile -> IO ()
 303 bytesToShortIntIO       :: ByteFile -> IO Int
 304 #endif
 305
 306 #if defined(__YALE_HASKELL__)
 307 -- These functions are like the primIntxx but use a "short" rather than
 308 -- "int" representation.
 309 shortIntToBytes         = primShortShowBytes
 310 bytesToShortInt         = primShortReadBytes
 311 shortIntToByteFile      = primShortShowByteFile
 312 bytesToShortIntIO       = primShortReadByteFile
 313
 314 #else {-! YALE-}
 315
 316 shortIntToBytes s bs = shortToBytes s bs
 317
 318 bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing
 319
 320 longIntToBytes s bs = longToBytes s bs
 321
 322 bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing
 323
 324 #endif {-! YALE-}
 325
 326 showB :: (Native a) => a -> Bytes
 327 showB x = showBytes x []
 328
 329 readB :: (Native a) => Bytes -> a
 330 readB bs =
 331         case readBytes bs of
 332         Just (x,[]) -> x
 333         Just (_,_)  -> error "Native.readB data too long"
 334         Nothing     -> error "Native.readB data too short"
 335
 336 #if defined(__YALE_HASKELL__)
 337 readBFile :: String -> IO(Bytes)
 338 readBFile name =
 339   openInputByteFile name >>= \ f ->
 340   readBytesFromByteFile f
 341
 342 readBytesFromByteFile :: ByteFile -> IO(Bytes)
 343 readBytesFromByteFile f =
 344   try
 345     (primByteReadByteFile f  >>= \ h ->
 346      readBytesFromByteFile f >>= \ t ->
 347      return (h:t))
 348     onEOF
 349  where
 350    onEOF EOF = closeByteFile f >> return []
 351    onEOF err = closeByteFile f >> failwith err
 352 #endif
 353 \end{code}