From 66ef41ac5e297f4b93e854c641e3bc2e8300fd80 Mon Sep 17 00:00:00 2001
From: normalcoder <normalcoder@gmail.com>
Date: Sun, 29 Oct 2023 23:10:32 +0100
Subject: [PATCH] Add StringInterpolation

---
 compiler/GHC/Driver/Make.hs                |  4 +-
 compiler/GHC/Driver/Pipeline/Execute.hs    |  4 +-
 compiler/GHC/Driver/StringInterpolation.hs | 65 ++++++++++++++++++++++
 compiler/ghc.cabal.in                      |  1 +
 4 files changed, 72 insertions(+), 2 deletions(-)
 create mode 100644 compiler/GHC/Driver/StringInterpolation.hs

diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 9b3dfe8c0a11..d5a3176c9b86 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -154,6 +154,8 @@ import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
 import GHC.Types.Unique
 import GHC.Iface.Errors.Types
 
+import GHC.Driver.StringInterpolation
+
 import qualified GHC.Data.Word64Set as W
 
 -- -----------------------------------------------------------------------------
@@ -2309,7 +2311,7 @@ getPreprocessedImports
 getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
   (pi_local_dflags, pi_hspp_fn)
       <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
+  pi_hspp_buf <- liftIO $ interpolateStringsInBuffer =<< hGetStringBuffer pi_hspp_fn
   (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)
       <- ExceptT $ do
           let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index bd2f453ec46a..7949299d4781 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -77,6 +77,8 @@ import GHC.Driver.Config.Finder
 import GHC.Rename.Names
 import GHC.StgToJS.Linker.Linker (embedJsFile)
 
+import GHC.Driver.StringInterpolation
+
 import Language.Haskell.Syntax.Module.Name
 import GHC.Unit.Home.ModInfo
 import GHC.Runtime.Loader (initializePlugins)
@@ -673,7 +675,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
 
   -- gather the imports and module name
   (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
-    buf <- hGetStringBuffer input_fn
+    buf <- interpolateStringsInBuffer =<< hGetStringBuffer input_fn
     let imp_prelude = xopt LangExt.ImplicitPrelude dflags
         popts = initParserOpts dflags
         rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
diff --git a/compiler/GHC/Driver/StringInterpolation.hs b/compiler/GHC/Driver/StringInterpolation.hs
new file mode 100644
index 000000000000..ad3e129b187b
--- /dev/null
+++ b/compiler/GHC/Driver/StringInterpolation.hs
@@ -0,0 +1,65 @@
+module GHC.Driver.StringInterpolation where
+
+import GHC.Prelude
+import GHC.Data.StringBuffer
+
+import Foreign.C.String (peekCStringLen)
+import Foreign.ForeignPtr
+import Foreign.Ptr
+
+interpolateStringsInBuffer :: StringBuffer -> IO StringBuffer
+interpolateStringsInBuffer buf = do
+  (stringToStringBuffer . interpolateStrings) <$> stringBufferToString buf
+
+stringBufferToString :: StringBuffer -> IO String
+stringBufferToString (StringBuffer buf len _) = do
+  withForeignPtr buf $ \p -> peekCStringLen (castPtr p, len)
+
+interpolateStrings :: String -> String
+interpolateStrings s = go s WaitingForString
+ where
+ go s state = case state of
+  WaitingForString -> case s of
+   "" -> ""
+   '\n':s -> '\n': skipSpaces s
+   '-':'-':s -> '-':'-': skipOneLineComment s
+   '{':'-':s -> '{':'-': skipComment s
+   '\\':'"':s -> '\\':'"': go s state -- warning: met some escaped quotes but not in string
+   '\'' : '"' : '\'' : s -> '\'' : '"' : '\'' : go s state
+   '"':s -> (go s $ InStringWaitingForVar False "")
+   c:s -> c : go s state
+  InStringWaitingForVar hasInterpolations acc -> case s of
+   "" -> error "we were waiting for var, but text ended unexpectedly"
+   '"':'\\':'\\':'?':'\\':'"':s -> go s (InStringWaitingForVar hasInterpolations $ '"':'\\':'?':'\\':'\\':'"':acc)
+   '\\':'\\':s -> go s (InStringWaitingForVar hasInterpolations $ '\\':'\\':acc)
+   '\\':'"':s -> go s (InStringWaitingForVar hasInterpolations $ '"':'\\':acc)
+   '#':'{':s -> go s (InStringInVar hasInterpolations "" $ acc)
+   '"':s -> inBraketsIfNeeded ("\"" ++ (reverse acc) ++ "\"") ++ go s WaitingForString
+    where
+    inBraketsIfNeeded s
+     | hasInterpolations = "(" ++ s ++ ")"
+     | otherwise = s
+   c:s -> go s (InStringWaitingForVar hasInterpolations $ c:acc)
+  InStringInVar hasInterpolations var acc -> case s of
+   "" -> error "we were collecting var name, but text ended unexpectedly"
+   '}':'"':s -> "(\"" ++ (reverse acc) ++ "\" ++ " ++ (reverse var) ++ ")" ++ go s WaitingForString
+   '}':s -> go s (InStringWaitingForVar True $ "\" ++ " ++ var ++ " ++ \"" ++ acc)
+   '"':_ -> error "we were collecting var name, but the string ended unexpectedly"
+   c:s -> go s (InStringInVar hasInterpolations (c:var) acc)
+  where
+  skipSpaces "" = go "" state
+  skipSpaces (' ':s) = ' ' : skipSpaces s
+  skipSpaces s@(_:_) = go s state
+
+  skipOneLineComment "" = go "" state
+  skipOneLineComment s@('\n':_) = go s state
+  skipOneLineComment (c:s) = c : skipOneLineComment s
+
+  skipComment "" = go "" state
+  skipComment ('-':'}':s) = '-':'}': go s state
+  skipComment (c:s) = c : skipComment s
+
+data State
+ = WaitingForString
+ | InStringWaitingForVar Bool String
+ | InStringInVar Bool String String
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 968e99a0e3f3..3b3933654e1a 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -502,6 +502,7 @@ Library
         GHC.Driver.Plugins.External
         GHC.Driver.Ppr
         GHC.Driver.Session
+        GHC.Driver.StringInterpolation
         GHC.Hs
         GHC.Hs.Binds
         GHC.Hs.Decls
-- 
GitLab