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