GHC/IO/Encoding/Latin1.hs

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