Avoid using deprecated flags
[packages/base.git] / GHC / Pack.lhs
1 \begin{code}
2 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
3 {-# OPTIONS_HADDOCK hide #-}
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module      :  GHC.Pack
7 -- Copyright   :  (c) The University of Glasgow 1997-2002
8 -- License     :  see libraries/base/LICENSE
9 -- 
10 -- Maintainer  :  cvs-ghc@haskell.org
11 -- Stability   :  internal
12 -- Portability :  non-portable (GHC Extensions)
13 --
14 -- This module provides a small set of low-level functions for packing
15 -- and unpacking a chunk of bytes. Used by code emitted by the compiler
16 -- plus the prelude libraries.
17 -- 
18 -- The programmer level view of packed strings is provided by a GHC
19 -- system library PackedString.
20 --
21 -----------------------------------------------------------------------------
22
23 -- #hide
24 module GHC.Pack
25        (
26         -- (**) - emitted by compiler.
27
28         packCString#,      -- :: [Char] -> ByteArray#    (**)
29         unpackCString,
30         unpackCString#,    -- :: Addr# -> [Char]         (**)
31         unpackNBytes#,     -- :: Addr# -> Int# -> [Char] (**)
32         unpackFoldrCString#,  -- (**)
33         unpackAppendCString#,  -- (**)
34        ) 
35         where
36
37 import GHC.Base
38 import GHC.Err ( error )
39 import GHC.List ( length )
40 import GHC.ST
41 import GHC.Num
42 import GHC.Ptr
43
44 data ByteArray ix              = ByteArray        ix ix ByteArray#
45 data MutableByteArray s ix     = MutableByteArray ix ix (MutableByteArray# s)
46
47 unpackCString :: Ptr a -> [Char]
48 unpackCString a@(Ptr addr)
49   | a == nullPtr  = []
50   | otherwise      = unpackCString# addr
51
52 packCString#         :: [Char]          -> ByteArray#
53 packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }
54
55 packString :: [Char] -> ByteArray Int
56 packString str = runST (packStringST str)
57
58 packStringST :: [Char] -> ST s (ByteArray Int)
59 packStringST str =
60   let len = length str  in
61   packNBytesST len str
62
63 packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
64 packNBytesST (I# length#) str =
65   {- 
66    allocate an array that will hold the string
67    (not forgetting the NUL byte at the end)
68   -}
69  new_ps_array (length# +# 1#) >>= \ ch_array ->
70    -- fill in packed string from "str"
71  fill_in ch_array 0# str   >>
72    -- freeze the puppy:
73  freeze_ps_array ch_array length#
74  where
75   fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
76   fill_in arr_in# idx [] =
77    write_ps_array arr_in# idx (chr# 0#) >>
78    return ()
79
80   fill_in arr_in# idx (C# c : cs) =
81    write_ps_array arr_in# idx c  >>
82    fill_in arr_in# (idx +# 1#) cs
83
84 -- (Very :-) ``Specialised'' versions of some CharArray things...
85
86 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
87 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s () 
88 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
89
90 new_ps_array size = ST $ \ s ->
91     case (newByteArray# size s)   of { (# s2#, barr# #) ->
92     (# s2#, MutableByteArray bot bot barr# #) }
93   where
94     bot = error "new_ps_array"
95
96 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
97     case writeCharArray# barr# n ch s#  of { s2#   ->
98     (# s2#, () #) }
99
100 -- same as unsafeFreezeByteArray
101 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
102     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
103     (# s2#, ByteArray 0 (I# len#) frozen# #) }
104 \end{code}