GHC/IO/Encoding/Latin1.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -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 { mkTextDecoder = latin1_DF,
  43                         mkTextEncoder = latin1_EF }
  44
  45 latin1_DF :: IO TextDecoder
  46 latin1_DF = return (BufferCodec latin1_decode (return ()))
  47
  48 latin1_EF :: IO TextEncoder
  49 latin1_EF = return (BufferCodec latin1_encode (return ()))
  50
  51 latin1_checked :: TextEncoding
  52 latin1_checked = TextEncoding { mkTextDecoder = latin1_DF,
  53                                 mkTextEncoder = latin1_checked_EF }
  54
  55 latin1_checked_EF :: IO TextEncoder
  56 latin1_checked_EF = return (BufferCodec latin1_checked_encode (return ()))
  57
  58
  59 latin1_decode :: DecodeBuffer
  60 latin1_decode
  61   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  62   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  63  = let
  64        loop !ir !ow
  65          | ow >= os || ir >= iw =  done ir ow
  66          | otherwise = do
  67               c0 <- readWord8Buf iraw ir
  68               writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
  69               loop (ir+1) (ow+1)
  70
  71        -- lambda-lifted, to avoid thunks being built in the inner-loop:
  72        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
  73                                           else input{ bufL=ir },
  74                          output{ bufR=ow })
  75     in
  76     loop ir0 ow0
  77
  78 latin1_encode :: EncodeBuffer
  79 latin1_encode
  80   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  81   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  82  = let
  83       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
  84                                          else input{ bufL=ir },
  85                              output{ bufR=ow })
  86       loop !ir !ow
  87         | ow >= os || ir >= iw =  done ir ow
  88         | otherwise = do
  89            (c,ir') <- readCharBuf iraw ir
  90            writeWord8Buf oraw ow (fromIntegral (ord c))
  91            loop ir' (ow+1)
  92     in
  93     loop ir0 ow0
  94
  95 latin1_checked_encode :: EncodeBuffer
  96 latin1_checked_encode
  97   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  98   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  99  = let
 100       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 101                                          else input{ bufL=ir },
 102                              output{ bufR=ow })
 103       loop !ir !ow
 104         | ow >= os || ir >= iw =  done ir ow
 105         | otherwise = do
 106            (c,ir') <- readCharBuf iraw ir
 107            if ord c > 0xff then invalid else do
 108            writeWord8Buf oraw ow (fromIntegral (ord c))
 109            loop ir' (ow+1)
 110         where
 111            invalid = if ir > ir0 then done ir ow else ioe_encodingError
 112     in
 113     loop ir0 ow0
 114
 115 ioe_encodingError :: IO a
 116 ioe_encodingError = ioException
 117      (IOError Nothing InvalidArgument "latin1_checked_encode"
 118           "character is out of range for this encoding" Nothing Nothing)