Fast CSS hex scaling

CSSScaling.hs

-- Scales colours found in a given file by a given factor, manages ~150MB/s
{-# LANGUAGE OverloadedStrings #-}
import           Data.Attoparsec.ByteString      (Parser, satisfy)
import           Data.Attoparsec.ByteString.Lazy as A
import           Data.ByteString.Lazy            as BSL hiding (concatMap, map)
import           Data.Monoid                     ((<>))
import           Data.Word                       (Word8)
import           Prelude                         hiding (readFile, writeFile)
import           System.Environment              (getArgs)

type Colour = (Word8,Word8,Word8)

main :: IO ()
main = do
  args <- getArgs
  case args of
    (inFile:scaleS:outfile:_) ->
      writeFile outfile . BSL.intercalate "#" . map (scaleHex (read scaleS)) . BSL.split 35 =<< readFile inFile
    _ -> error "Usage: <infile> <scale> <outfile>"
  where
    scaleHex :: Double -> ByteString -> ByteString
    scaleHex d bs = either id (\(c,r) -> renderColour (scaleColour d c) <> r) . colour $ bs

    scaleColour :: Double -> Colour -> Colour
    scaleColour d (r,g,b) = (scale r, scale g, scale b) where
      scale :: Word8 -> Word8
      scale = floor . (*d) . fromIntegral

    parseColour :: Parser Colour
    parseColour = (,,) <$> hexPair <*> hexPair <*> hexPair
      where
        hexPair = (\a b -> a*16 + b) <$> hex <*> hex
        hex = fromHex <$> satisfy isHexDigit
        isHexDigit w = (w >= 48 && w <= 57) || (w >= 97 && w <= 102) || (w >= 65 && w <= 70)
        fromHex w  | w >= 48 && w <= 57  = w - 48
                  | w >= 97 = w - 87
                  | otherwise = w - 55

    -- | Either parse a colour from the front of the input or return the input unchanged
    colour :: ByteString -> Either ByteString (Colour,ByteString)
    colour bs = case A.parse parseColour bs of
      Done rest clr -> Right (clr,rest)
      _             -> Left bs

    renderColour :: Colour -> ByteString
    renderColour (r,g,b) = BSL.pack . concatMap renderByte $ [r,g,b] where
      renderByte w = case quotRem w 16 of (x,y) -> map nibble [x,y]
      nibble w | w < 10 = w + 48
              | otherwise = w + 87 -- b + 97-10, aka 'a'-10