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, mkLatin1,
  27   latin1_checked, mkLatin1_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.Buffer
  38 import GHC.IO.Encoding.Failure
  39 import GHC.IO.Encoding.Types
  40
  41 -- -----------------------------------------------------------------------------
  42 -- Latin1
  43
  44 latin1 :: TextEncoding
  45 latin1 = mkLatin1 ErrorOnCodingFailure
  46
  47 mkLatin1 :: CodingFailureMode -> TextEncoding
  48 mkLatin1 cfm = TextEncoding { textEncodingName = "ISO8859-1",
  49                               mkTextDecoder = latin1_DF cfm,
  50                               mkTextEncoder = latin1_EF cfm }
  51
  52 latin1_DF :: CodingFailureMode -> IO (TextDecoder ())
  53 latin1_DF cfm =
  54   return (BufferCodec {
  55              encode   = latin1_decode,
  56              recover  = recoverDecode cfm,
  57              close    = return (),
  58              getState = return (),
  59              setState = const $ return ()
  60           })
  61
  62 latin1_EF :: CodingFailureMode -> IO (TextEncoder ())
  63 latin1_EF cfm =
  64   return (BufferCodec {
  65              encode   = latin1_encode,
  66              recover  = recoverEncode cfm,
  67              close    = return (),
  68              getState = return (),
  69              setState = const $ return ()
  70           })
  71
  72 latin1_checked :: TextEncoding
  73 latin1_checked = mkLatin1_checked ErrorOnCodingFailure
  74
  75 mkLatin1_checked :: CodingFailureMode -> TextEncoding
  76 mkLatin1_checked cfm = TextEncoding { textEncodingName = "ISO8859-1(checked)",
  77                                       mkTextDecoder = latin1_DF cfm,
  78                                       mkTextEncoder = latin1_checked_EF cfm }
  79
  80 latin1_checked_EF :: CodingFailureMode -> IO (TextEncoder ())
  81 latin1_checked_EF cfm =
  82   return (BufferCodec {
  83              encode   = latin1_checked_encode,
  84              recover  = recoverEncode cfm,
  85              close    = return (),
  86              getState = return (),
  87              setState = const $ return ()
  88           })
  89
  90
  91 latin1_decode :: DecodeBuffer
  92 latin1_decode
  93   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  94   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  95  = let
  96        loop !ir !ow
  97          | ow >= os = done OutputUnderflow ir ow
  98          | ir >= iw = done InputUnderflow ir ow
  99          | otherwise = do
 100               c0 <- readWord8Buf iraw ir
 101               ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
 102               loop (ir+1) ow'
 103
 104        -- lambda-lifted, to avoid thunks being built in the inner-loop:
 105        done why !ir !ow = return (why,
 106                                   if ir == iw then input{ bufL=0, bufR=0 }
 107                                               else input{ bufL=ir },
 108                                   output{ bufR=ow })
 109     in
 110     loop ir0 ow0
 111
 112 latin1_encode :: EncodeBuffer
 113 latin1_encode
 114   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 115   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 116  = let
 117       done why !ir !ow = return (why,
 118                                  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 = done OutputUnderflow ir ow
 123         | ir >= iw = done InputUnderflow ir ow
 124         | otherwise = do
 125            (c,ir') <- readCharBuf iraw ir
 126            writeWord8Buf oraw ow (fromIntegral (ord c))
 127            loop ir' (ow+1)
 128     in
 129     loop ir0 ow0
 130
 131 latin1_checked_encode :: EncodeBuffer
 132 latin1_checked_encode
 133   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 134   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 135  = let
 136       done why !ir !ow = return (why,
 137                                  if ir == iw then input{ bufL=0, bufR=0 }
 138                                              else input{ bufL=ir },
 139                                  output{ bufR=ow })
 140       loop !ir !ow
 141         | ow >= os = done OutputUnderflow ir ow
 142         | ir >= iw = done InputUnderflow ir ow
 143         | otherwise = do
 144            (c,ir') <- readCharBuf iraw ir
 145            if ord c > 0xff then invalid else do
 146            writeWord8Buf oraw ow (fromIntegral (ord c))
 147            loop ir' (ow+1)
 148         where
 149            invalid = done InvalidSequence ir ow
 150     in
 151     loop ir0 ow0