Don't crash with StackoverflowException when long triple-quoted strings are parsed

src/Fantomas.Tests/InterpolatedStringTests.fs

@@ -349,3 +349,17 @@ longLeadingStringPaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
                                                                                                                                 )}
 "
 """
+
+[<Test>]
+let ``very long triple-quoted strings do not cause the interpolated string active pattern to stack overflow, 1837`` () =
+    let loremIpsum =
+        String.replicate
+            1000
+            "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\n\n"
+
+    formatSourceString false $"let value = \"\"\"{loremIpsum}\"\"\"" config
+    |> should
+        equal
+        $"let value =
+    \"\"\"{loremIpsum}\"\"\"
+"

src/Fantomas.Tests/UtilsTests.fs

@@ -4,6 +4,7 @@ open System
 open NUnit.Framework
 open Fantomas
 open Fantomas.Tests.TestHelper
+open FsCheck
 
 let private mergeAndCompare a b expected =
     let result =
@@ -112,3 +113,65 @@ SetupTesting.generateSetupScript __SOURCE_DIRECTORY__
 #endif
 """
     |> mergeAndCompare a b
+
+[<Test>]
+let ``when input is empty`` () =
+    let property (p: bool) : bool =
+        let before, after = List.partitionWhile (fun _ _ -> p) []
+        before = [] && after = []
+
+    Check.QuickThrowOnFailure(property true)
+    Check.QuickThrowOnFailure(property false)
+
+[<Test>]
+let ``when predicate always returns false`` () =
+    let property (xs: int list) : bool =
+        let before, after =
+            List.partitionWhile (fun _ _ -> false) xs
+
+        before = [] && after = xs
+
+    Check.QuickThrowOnFailure property
+
+[<Test>]
+let ``when predicate always returns true`` () =
+    let property (xs: int list) : bool =
+        let before, after =
+            List.partitionWhile (fun _ _ -> true) xs
+
+        before = xs && after = []
+
+    Check.QuickThrowOnFailure property
+
+[<Test>]
+let ``when predicate returns true until certain index`` () =
+    let property (xs: int list, i: int) : bool =
+        let before, after =
+            List.partitionWhile (fun index _ -> i <> index) xs
+
+        let beforeLength = List.length before
+        let afterLength = List.length after
+
+        beforeLength = i
+        && afterLength = List.length xs - i
+        && before @ after = xs
+
+    let gen =
+        gen {
+            let! xs =
+                Arb.generate<int>
+                |> Gen.listOf
+                |> Gen.filter (fun l -> l.Length > 0)
+
+            let len = List.length xs
+
+            let! n =
+                Arb.generate<int>
+                |> Gen.filter (fun n -> n >= 0 && n < len)
+
+            return (xs, n)
+        }
+
+    property
+    |> Prop.forAll (Arb.fromGen gen)
+    |> Check.QuickThrowOnFailure

src/Fantomas/TokenParser.fs

@@ -547,11 +547,26 @@ let private (|InterpStringEndOrPartToken|_|) token =
 let escapedCharacterRegex =
     System.Text.RegularExpressions.Regex("(\\\\(a|b|f|n|r|t|u|v|x|'|\\\"|\\\\))+")
 
-let rec private (|EndOfInterpolatedString|_|) tokens =
+let private (|MultipleStringTextTokens|_|) tokens =
+    let f _ =
+        function
+        | StringTextToken _ -> true
+        | _ -> false
+
+    tokens
+    |> List.partitionWhile f
+    |> fun (before, after) ->
+        if List.isEmpty before then
+            None
+        else
+            Some(before, after)
+
+let private (|EndOfInterpolatedString|_|) tokens =
     match tokens with
-    | StringTextToken stToken :: InterpStringEndOrPartToken endToken :: rest -> Some([ stToken ], endToken, rest)
-    | StringTextToken stToken :: EndOfInterpolatedString (stringTokens, endToken, rest) ->
-        Some(stToken :: stringTokens, endToken, rest)
+    | MultipleStringTextTokens (stringTokens, rest) ->
+        match rest with
+        | InterpStringEndOrPartToken endToken :: rest2 -> Some(stringTokens, endToken, rest2)
+        | _ -> None
     | _ -> None
 
 let private (|StringText|_|) tokens =

src/Fantomas/Utils.fs

@@ -152,6 +152,17 @@ module List =
         | [ _ ] -> false
         | _ -> true
 
+    let partitionWhile (f: int -> 'a -> bool) (xs: 'a list) : ('a list * 'a list) =
+        let rec go i before after =
+            match after with
+            | head :: tail ->
+                match f i head with
+                | true -> go (i + 1) (head :: before) tail
+                | false -> List.rev before, after
+            | [] -> List.rev before, after
+
+        go 0 [] xs
+
 module Map =
     let tryFindOrDefault (defaultValue: 'g) (key: 't) (map: Map<'t, 'g>) =
         match Map.tryFind key map with