GottaGoFast.hs

{-
results:
benchmarking no mangling needed/abc old
time                 67.46 ns   (64.77 ns .. 71.53 ns)
                     0.982 R²   (0.968 R² .. 0.996 R²)
mean                 66.03 ns   (64.32 ns .. 69.47 ns)
std dev              7.724 ns   (4.564 ns .. 12.10 ns)
variance introduced by outliers: 93% (severely inflated)

benchmarking no mangling needed/abc new
time                 17.48 ns   (17.37 ns .. 17.56 ns)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 17.32 ns   (17.25 ns .. 17.40 ns)
std dev              245.8 ps   (217.2 ps .. 285.0 ps)
variance introduced by outliers: 18% (moderately inflated)

benchmarking no mangling needed/helloworld old
time                 571.4 ns   (556.5 ns .. 592.6 ns)
                     0.990 R²   (0.982 R² .. 0.999 R²)
mean                 565.6 ns   (553.8 ns .. 592.5 ns)
std dev              51.91 ns   (31.10 ns .. 78.05 ns)
variance introduced by outliers: 88% (severely inflated)

benchmarking no mangling needed/helloworld new
time                 64.98 ns   (64.26 ns .. 65.76 ns)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 64.31 ns   (64.00 ns .. 64.89 ns)
std dev              1.253 ns   (885.6 ps .. 1.740 ns)
variance introduced by outliers: 27% (moderately inflated)

benchmarking mangling needed/mangling old
time                 31.72 μs   (31.65 μs .. 31.81 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 31.79 μs   (31.73 μs .. 31.86 μs)
std dev              218.5 ns   (174.2 ns .. 288.2 ns)

benchmarking mangling needed/mangling new
time                 1.136 μs   (1.126 μs .. 1.148 μs)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 1.143 μs   (1.136 μs .. 1.163 μs)
std dev              38.12 ns   (16.47 ns .. 79.76 ns)
variance introduced by outliers: 46% (moderately inflated)

-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import Test.QuickCheck
import Test.QuickCheck.Instances
import Criterion.Main
import Data.Char
import Data.List (foldl')
import qualified Data.Text as T
import qualified Data.Text.Array as TA
import qualified Data.Text.Internal as T
import qualified Data.Text.Lazy as TL (Text, fromStrict)
import Data.Word
import Text.Printf

isAsciiLetter :: Char -> Bool
isAsciiLetter c = isAsciiLower c || isAsciiUpper c

isAllowedStart :: Char -> Bool
isAllowedStart c = c == '_' || isAsciiLetter c

isAllowedPart :: Char -> Bool
isAllowedPart c = c == '_' || isAsciiLetter c || isDigit c

mangleIdentifier :: T.Text -> Either String TL.Text
mangleIdentifier txt = case T.unpack txt of
    [] -> Left "Empty identifier"
    ch : chs -> Right $ TL.fromStrict $ T.pack $ escapeStart ch ++ concatMap escapePart chs

escapeStart :: Char -> String
escapeStart ch
  | ch == '$' = "$$"
  | isAllowedStart ch = [ch]
  | otherwise = escapeChar ch

escapePart :: Char -> String
escapePart ch
  | ch == '$' = "$$"
  | isAllowedPart ch = [ch]
  | otherwise = escapeChar ch

escapeChar :: Char -> String
escapeChar ch = let
  codePoint = fromEnum ch
  in if codePoint > 0xFFFF
    then printf "$U%08x" codePoint
    else printf "$u%04x" codePoint

data MangledSize = MangledSize
    { unmangledChars :: !Int
    , mangledWord16s :: !Int
    }

ord' :: Char -> Word16
ord' = fromIntegral . ord

mangleIdentifier' :: T.Text -> Either String TL.Text
mangleIdentifier' txt = case T.foldl' f (MangledSize 0 0) txt of
    MangledSize 0 _ -> Left "Empty identifier"
    MangledSize chars word16s
      | chars == word16s -> Right $! TL.fromStrict txt
      | otherwise -> Right $! TL.fromStrict $
        let !arr = TA.run $ do
            a <- TA.new word16s
            let poke !j !minj !x
                  | j < minj = pure ()
                  | otherwise = do
                        let !(!x', !r) = quotRem x 16
                        TA.unsafeWrite a j (fromIntegral $ ord $ intToDigit r)
                        poke (j - 1) minj x'
                go !i t = case T.uncons t of
                    Nothing -> pure ()
                    Just (!c, !t')
                      | isAllowedStart c || i > 0 && isDigit c -> TA.unsafeWrite a i (fromIntegral $ ord c) >> go (i + 1) t'
                      | c == '$' -> do
                            TA.unsafeWrite a i (ord' '$')
                            TA.unsafeWrite a (i + 1) (ord' '$')
                            go (i + 2) t'
                      | ord c <= 0xFFFF -> do
                            TA.unsafeWrite a i (ord' '$')
                            TA.unsafeWrite a (i + 1) (ord' 'u')
                            poke (i + 5) (i + 2) (ord c)
                            go (i + 6) t'
                      | otherwise -> do
                            TA.unsafeWrite a i (ord' '$')
                            TA.unsafeWrite a (i + 1) (ord' 'U')
                            poke (i + 9) (i + 2) (ord c)
                            go (i + 10) t'
            go 0 txt
            pure a
        in T.text arr 0 word16s
    where f :: MangledSize -> Char -> MangledSize
          f (MangledSize chars word16s) c
            | isAllowedStart c || chars > 0 && isDigit c = MangledSize (chars + 1) (word16s + 1)
            | c == '$' = MangledSize 1 (word16s + 2)
            | ord c > 0xFFFF = MangledSize 1 (word16s + 10)
            | otherwise = MangledSize 1 (word16s + 6)

criterionMain :: IO ()
criterionMain = defaultMain
    [ bgroup "no mangling needed"
          [ bench "abc old" $ nf mangleIdentifier "abc"
          , bench "abc new" $ nf mangleIdentifier' "abc"
          , bench "helloworld old" $ nf mangleIdentifier "helloworldhelloworldhelloworld"
          , bench "helloworld new" $ nf mangleIdentifier' "helloworldhelloworldhelloworld"
          ]
    , bgroup "mangling needed"
          [ bench "mangling old" $ nf mangleIdentifier "$ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ "
          , bench "mangling new" $ nf mangleIdentifier' "$ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ "
          ]
    ]

quickCheckMain :: IO ()
quickCheckMain = quickCheck $ withMaxSuccess 10000 $ \t -> mangleIdentifier t === mangleIdentifier' t

main :: IO ()
main = criterionMain