GHC/IO/Encoding/Latin1.hs

   1 {-# OPTIONS_GHC  -XNoImplicitPrelude -funbox-strict-fields #-}
   2 {-# LANGUAGE BangPatterns #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Encoding.Latin1
   6 -- Copyright   :  (c) The University of Glasgow, 2009
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  libraries@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable
  12 --
  13 -- UTF-32 Codecs for the IO library
  14 --
  15 -- Portions Copyright   : (c) Tom Harper 2008-2009,
  16 --                        (c) Bryan O'Sullivan 2009,
  17 --                        (c) Duncan Coutts 2009
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 module GHC.IO.Encoding.Latin1 (
  22   latin1,
  23   latin1_checked,
  24   latin1_decode,
  25   latin1_encode,
  26   latin1_checked_encode,
  27   ) where
  28
  29 import GHC.Base
  30 import GHC.Real
  31 import GHC.Num
  32 -- import GHC.IO
  33 import GHC.IO.Exception
  34 import GHC.IO.Buffer
  35 import GHC.IO.Encoding.Types
  36 import Data.Maybe
  37
  38 -- -----------------------------------------------------------------------------
  39 -- Latin1
  40
  41 latin1 :: TextEncoding
  42 latin1 = TextEncoding { textEncodingName = "ISO8859-1",
  43                         mkTextDecoder = latin1_DF,
  44                         mkTextEncoder = latin1_EF }
  45
  46 latin1_DF :: IO (TextDecoder ())
  47 latin1_DF =
  48   return (BufferCodec {
  49              encode   = latin1_decode,
  50              close    = return (),
  51              getState = return (),
  52              setState = const $ return ()
  53           })
  54
  55 latin1_EF :: IO (TextEncoder ())
  56 latin1_EF =
  57   return (BufferCodec {
  58              encode   = latin1_encode,
  59              close    = return (),
  60              getState = return (),
  61              setState = const $ return ()
  62           })
  63
  64 latin1_checked :: TextEncoding
  65 latin1_checked = TextEncoding { textEncodingName = "ISO8859-1(checked)",
  66                                 mkTextDecoder = latin1_DF,
  67                                 mkTextEncoder = latin1_checked_EF }
  68
  69 latin1_checked_EF :: IO (TextEncoder ())
  70 latin1_checked_EF =
  71   return (BufferCodec {
  72              encode   = latin1_checked_encode,
  73              close    = return (),
  74              getState = return (),
  75              setState = const $ return ()
  76           })
  77
  78
  79 latin1_decode :: DecodeBuffer
  80 latin1_decode
  81   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  82   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  83  = let
  84        loop !ir !ow
  85          | ow >= os || ir >= iw =  done ir ow
  86          | otherwise = do
  87               c0 <- readWord8Buf iraw ir
  88               ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
  89               loop (ir+1) ow'
  90
  91        -- lambda-lifted, to avoid thunks being built in the inner-loop:
  92        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
  93                                           else input{ bufL=ir },
  94                          output{ bufR=ow })
  95     in
  96     loop ir0 ow0
  97
  98 latin1_encode :: EncodeBuffer
  99 latin1_encode
 100   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 101   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 102  = let
 103       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 104                                          else input{ bufL=ir },
 105                              output{ bufR=ow })
 106       loop !ir !ow
 107         | ow >= os || ir >= iw =  done ir ow
 108         | otherwise = do
 109            (c,ir') <- readCharBuf iraw ir
 110            writeWord8Buf oraw ow (fromIntegral (ord c))
 111            loop ir' (ow+1)
 112     in
 113     loop ir0 ow0
 114
 115 latin1_checked_encode :: EncodeBuffer
 116 latin1_checked_encode
 117   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 118   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 119  = let
 120       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 121                                          else input{ bufL=ir },
 122                              output{ bufR=ow })
 123       loop !ir !ow
 124         | ow >= os || ir >= iw =  done ir ow
 125         | otherwise = do
 126            (c,ir') <- readCharBuf iraw ir
 127            if ord c > 0xff then invalid else do
 128            writeWord8Buf oraw ow (fromIntegral (ord c))
 129            loop ir' (ow+1)
 130         where
 131            invalid = if ir > ir0 then done ir ow else ioe_encodingError
 132     in
 133     loop ir0 ow0
 134
 135 ioe_encodingError :: IO a
 136 ioe_encodingError = ioException
 137      (IOError Nothing InvalidArgument "latin1_checked_encode"
 138           "character is out of range for this encoding" Nothing Nothing)