Merge pull request #5656 from unisonweb/lookbehind

Add lookbehind to builtin patterns

Author: runarorama

parser-typechecker/src/Unison/Builtin.hs

@@ -513,6 +513,8 @@ builtinsSrc =
     B "Text.patterns.notCharRange" $ char --> char --> pat text,
     B "Text.patterns.charIn" $ list char --> pat text,
     B "Text.patterns.notCharIn" $ list char --> pat text,
+    B "Text.patterns.lookbehind" $ charClass --> pat text,
+    B "Text.patterns.negativeLookbehind" $ charClass --> pat text,
     -- Pattern.many : Pattern a -> Pattern a
     B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a),
     B "Pattern.many.corrected" $ forall1 "a" (\a -> pat a --> pat a),

parser-typechecker/src/Unison/Util/Text/Pattern.hs

@@ -17,8 +17,10 @@ data Pattern
   | Eof -- succeed if given the empty text, fail otherwise
   | Literal Text -- succeed if input starts with the given text, advance by that text
   | Char CharPattern -- succeed if input starts with a char matching the given pattern, advance by 1 char
-  | Lookahead Pattern -- Positive lookahead
-  | NegativeLookahead Pattern -- Negative lookahead
+  | Lookahead Pattern -- Succeed if the given pattern matches the input, but don't consume any input
+  | NegativeLookahead Pattern -- Succeed if the given pattern does not match the input, but don't consume any input
+  | Lookbehind1 CharPattern -- Succeed if the previous char matches.
+  | NegativeLookbehind1 CharPattern -- Succeed if the previous char does not match. Needed because lookbehind with negation is not exactly semantically equivalent.
   deriving (Show, Eq, Ord)
 
 data CharPattern
@@ -67,28 +69,28 @@ cpattern p = CP p (run p)
 
 run :: Pattern -> Text -> Maybe ([Text], Text)
 run p =
-  let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (s acc, rem))
+  let cp = compile p (\_ _ _ -> Nothing) (\acc _ rem -> Just (s acc, rem))
       s = reverse . capturesToList . stackCaptures
-   in \t -> cp (Empty emptyCaptures) t
+   in \t -> cp (Empty emptyCaptures) Nothing t
 
 -- Stack used to track captures and to support backtracking.
 -- A `try` will push a `Mark` that allows the old state
 -- (both the list of captures and the current remainder)
 -- to be restored on failure.
-data Stack = Empty !Captures | Mark !Captures !Text !Stack
+data Stack = Empty !Captures | Mark !Captures !(Maybe Char) !Text !Stack
 
 -- A difference list for representing the captures of a pattern.
 -- So that capture lists can be appended in O(1).
 type Captures = [Text] -> [Text]
 
 stackCaptures :: Stack -> Captures
-stackCaptures (Mark cs _ _) = cs
+stackCaptures (Mark cs _ _ _) = cs
 stackCaptures (Empty cs) = cs
 {-# INLINE stackCaptures #-}
 
 pushCaptures :: Captures -> Stack -> Stack
 pushCaptures c (Empty cs) = Empty (appendCaptures c cs)
-pushCaptures c (Mark cs t s) = Mark (appendCaptures c cs) t s
+pushCaptures c (Mark cs oc t s) = Mark (appendCaptures c cs) oc t s
 {-# INLINE pushCaptures #-}
 
 pushCapture :: Text -> Stack -> Stack
@@ -105,38 +107,47 @@ emptyCaptures = id
 capturesToList :: Captures -> [Text]
 capturesToList c = c []
 
-type Compiled r = (Stack -> Text -> r) -> (Stack -> Text -> r) -> Stack -> Text -> r
+type Compiled r = (Stack -> Maybe Char -> Text -> r) -> (Stack -> Maybe Char -> Text -> r) -> Stack -> Maybe Char -> Text -> r
 
 compile :: Pattern -> Compiled r
 compile Eof !err !success = go
   where
-    go acc t
-      | Text.size t == 0 = success acc t
-      | otherwise = err acc t
+    go acc c t
+      | Text.size t == 0 = success acc c t
+      | otherwise = err acc c t
 compile (Literal txt) !err !success = go
   where
-    go acc t
-      | Text.take (Text.size txt) t == txt = success acc (Text.drop (Text.size txt) t)
-      | otherwise = err acc t
+    go acc oc t =
+      let candidate = Text.take (Text.size txt) t
+       in if candidate == txt
+            then
+              let t' = Text.drop (Text.size txt) t
+               in case Text.unsnoc candidate of
+                    Just (_, c) -> success acc (Just c) t'
+                    Nothing -> success acc oc t'
+            else
+              err acc oc t
 compile (Char Any) !err !success = go
   where
-    go acc t = case Text.drop 1 t of
-      rem
-        | Text.size t > Text.size rem -> success acc rem
-        | otherwise -> err acc rem
+    go acc oc t = case Text.uncons t of
+      Just (c', rem) -> success acc (Just c') rem
+      Nothing -> err acc oc t
 compile (CaptureAs t p) !err !success = go
   where
-    err' _ _ acc0 t0 = err acc0 t0
-    success' _ rem acc0 _ = success (pushCapture t acc0) rem
+    err' _ _ _ acc0 c0 t0 = err acc0 c0 t0
+    success' _ cr rem acc0 _ _ = success (pushCapture t acc0) cr rem
     compiled = compile p err' success'
-    go acc t = compiled acc t acc t
-compile (Capture (Many _ (Char Any))) !_ !success = \acc t -> success (pushCapture t acc) Text.empty
+    go acc c t = compiled acc c t acc c t
+compile (Capture (Many _ (Char Any))) !_ !success = \acc c t ->
+  case Text.unsnoc t of
+    Just (_, c) -> success (pushCapture t acc) (Just c) Text.empty
+    Nothing -> success (pushCapture t acc) c t
 compile (Capture c) !err !success = go
   where
-    err' _ _ acc0 t0 = err acc0 t0
-    success' _ rem acc0 t0 = success (pushCapture (Text.take (Text.size t0 - Text.size rem) t0) acc0) rem
+    err' _ _ _ acc0 c0 t0 = err acc0 c0 t0
+    success' _ cr rem acc0 _ t0 = success (pushCapture (Text.take (Text.size t0 - Text.size rem) t0) acc0) cr rem
     compiled = compile c err' success'
-    go acc t = compiled acc t acc t
+    go acc c t = compiled acc c t acc c t
 compile (Or p1 p2) err success = cp1
   where
     cp2 = compile p2 err success
@@ -151,57 +162,93 @@ compile (Join ps) !err !success = go ps
 compile (Char cp) !err !success = go
   where
     ok = charPatternPred cp
-    go acc t = case Text.uncons t of
-      Just (ch, rem) | ok ch -> success acc rem
-      _ -> err acc t
+    go acc c t = case Text.uncons t of
+      Just (ch, rem) | ok ch -> success acc (Just ch) rem
+      _ -> err acc c t
 compile (Many correct p) !_ !success = case p of
-  Char Any -> (\acc _ -> success acc Text.empty)
+  Char Any ->
+    ( \acc c t -> case Text.unsnoc t of
+        Just (_, c) -> success acc (Just c) Text.empty
+        Nothing -> success acc c t
+    )
   Char cp -> walker (charPatternPred cp)
   p -> go
     where
       go
         | correct = try "Many" (compile p) success success'
         | otherwise = compile p success success'
-      success' acc rem
-        | Text.size rem == 0 = success acc rem
-        | otherwise = go acc rem
+      success' acc c rem =
+        if Text.size rem == 0
+          then
+            success acc c rem
+          else go acc c rem
   where
     walker ok = go
       where
-        go acc t = case Text.unconsChunk t of
-          Nothing -> success acc t
-          Just (Text.chunkToText -> txt, t) -> case DT.dropWhile ok txt of
-            rem
-              | DT.null rem -> go acc t
-              | otherwise ->
-                  -- moving the remainder to the root of the tree is much more efficient
-                  -- since the next uncons will be O(1) rather than O(log n)
-                  -- this can't unbalance the tree too badly since these promoted chunks
-                  -- are being consumed and will get removed by a subsequent uncons
-                  success acc (Text.appendUnbalanced (Text.fromText rem) t)
+        go acc c t = case Text.unconsChunk t of
+          Nothing -> success acc c t
+          Just (Text.chunkToText -> txt, t) -> case DT.span ok txt of
+            (prefix, rem) -> case DT.unsnoc prefix of
+              -- moving the remainder to the root of the tree is much more efficient
+              -- since the next uncons will be O(1) rather than O(log n)
+              -- this can't unbalance the tree too badly since these promoted chunks
+              -- are being consumed and will get removed by a subsequent uncons
+              Just (_, c)
+                | DT.null rem -> go acc (Just c) t
+                | otherwise -> success acc (Just c) (Text.appendUnbalanced (Text.fromText rem) t)
+              Nothing
+                | DT.null rem -> go acc c t
+                | otherwise -> success acc c (Text.appendUnbalanced (Text.fromText rem) t)
     {-# INLINE walker #-}
 compile (Replicate m n p) !err !success = case p of
-  Char Any -> \acc t ->
-    if Text.size t < m
-      then err acc t
-      else success acc (Text.drop n t)
+  Char Any -> \acc oc t ->
+    let sz = Text.size t
+     in if sz < m
+          then err acc oc t
+          else
+            if n < 1
+              then success acc oc t
+              else case Text.uncons (Text.drop (min (n - 1) (sz - 1)) t) of
+                Just (c, rem) -> success acc (Just c) rem
+                Nothing -> success acc oc Text.empty
   Char cp -> dropper (charPatternPred cp)
   _ -> try "Replicate" (go1 m) err (go2 (n - m))
   where
-    go1 0 = \_err success stk rem -> success stk rem
+    go1 0 = \_err success stk oc rem -> success stk oc rem
     go1 n = \err success -> compile p err (go1 (n - 1) err success)
     go2 0 = success
     go2 n = try "Replicate" (compile p) success (go2 (n - 1))
 
-    dropper ok acc t
-      | (i, rest) <- Text.dropWhileMax ok n t, i >= m = success acc rest
-      | otherwise = err acc t
+    dropper ok acc oc t
+      | (i, rest) <- Text.dropWhileMax ok n t,
+        i >= m =
+          let lastDropped = if i > 0 then Text.at (i - 1) t else oc
+           in success acc lastDropped rest
+      | otherwise = err acc oc t
 compile (Lookahead p) !err !success = cp
   where
     cp = lookahead "Lookahead" (compile p) err success
 compile (NegativeLookahead p) !err !success = cp
   where
     cp = lookahead "NegativeLookahead" (compile p) success err
+compile (Lookbehind1 cp) !err !success = \acc oc t ->
+  case oc of
+    Just c ->
+      if charPatternPred cp c
+        then
+          success acc oc t
+        else
+          err acc oc t
+    Nothing -> err acc oc t
+compile (NegativeLookbehind1 cp) !err !success = \acc oc t ->
+  case oc of
+    Just c ->
+      if charPatternPred cp c
+        then
+          err acc oc t
+        else
+          success acc oc t
+    Nothing -> success acc oc t
 
 charInPred, charNotInPred :: [Char] -> Char -> Bool
 charInPred [] = const False
@@ -234,27 +281,27 @@ charClassPred Letter = isLetter
 
 -- runs c and if it fails, restores state to what it was before
 try :: String -> Compiled r -> Compiled r
-try msg c err success stk rem =
-  c err' success' (Mark id rem stk) rem
+try msg c err success stk oc rem =
+  c err' success' (Mark id oc rem stk) oc rem
   where
-    success' stk rem = case stk of
-      Mark caps _ stk -> success (pushCaptures caps stk) rem
+    success' stk oc rem = case stk of
+      Mark caps _ _ stk -> success (pushCaptures caps stk) oc rem
       _ -> error $ "Pattern compiler error in: " <> msg
-    err' stk _ = case stk of
-      Mark _ rem stk -> err stk rem
+    err' stk _ _ = case stk of
+      Mark _ oc rem stk -> err stk oc rem
       _ -> error $ "Pattern compiler error in: " <> msg
 {-# INLINE try #-}
 
 -- runs c and restores state to what it was before,
 -- regardless of whether it succeeds or not
 lookahead :: String -> Compiled r -> Compiled r
-lookahead msg c err success stk rem =
-  c err' success' (Mark id rem stk) rem
+lookahead msg c err success stk oc rem =
+  c err' success' (Mark id oc rem stk) oc rem
   where
-    success' stk _ = case stk of
-      Mark _ rem stk -> success stk rem
+    success' stk _ _ = case stk of
+      Mark caps oc rem stk -> success (pushCaptures caps stk) oc rem
       _ -> error $ "Pattern compiler error in: " <> msg
-    err' stk _ = case stk of
-      Mark _ rem stk -> err stk rem
+    err' stk _ _ = case stk of
+      Mark _ oc rem stk -> err stk oc rem
       _ -> error $ "Pattern compiler error in: " <> msg
 {-# INLINE lookahead #-}

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -1278,6 +1278,8 @@ declareForeigns = do
   declareForeignWrap Untracked direct Char_Class_letter
   declareForeign Untracked 2 Char_Class_is
   declareForeign Untracked 1 Text_patterns_char
+  declareForeign Untracked 1 Text_patterns_lookbehind1
+  declareForeign Untracked 1 Text_patterns_negativeLookbehind1
 
   -- replacements
   declareForeign Untracked 3 Map_insert

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -871,6 +871,10 @@ foreignCallHelper = \case
   Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c
   Text_patterns_char -> mkForeign $ \c ->
     let v = TPat.cpattern (TPat.Char c) in pure v
+  Text_patterns_lookbehind1 -> mkForeign $ \cp ->
+    let v = TPat.cpattern (TPat.Lookbehind1 cp) in pure v
+  Text_patterns_negativeLookbehind1 -> mkForeign $ \cp ->
+    let v = TPat.cpattern (TPat.NegativeLookbehind1 cp) in pure v
   Map_tip -> mkForeign $ \() -> pure Map.empty
   Map_bin -> mkForeign $ \(sz :: Word64, k :: Val, v :: Val, l, r) ->
     pure (Map.Bin (fromIntegral sz) k v l r)

unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs

@@ -256,6 +256,8 @@ data ForeignFunc
   | Char_Class_letter
   | Char_Class_is
   | Text_patterns_char
+  | Text_patterns_lookbehind1
+  | Text_patterns_negativeLookbehind1
   | Map_tip
   | Map_bin
   | Map_insert
@@ -524,6 +526,8 @@ foreignFuncBuiltinName = \case
   Char_Class_letter -> "Char.Class.letter"
   Char_Class_is -> "Char.Class.is"
   Text_patterns_char -> "Text.patterns.char"
+  Text_patterns_lookbehind1 -> "Text.patterns.lookbehind"
+  Text_patterns_negativeLookbehind1 -> "Text.patterns.negativeLookbehind"
   Map_tip -> "Map.Tip"
   Map_bin -> "Map.Bin"
   Map_insert -> "Map.insert"

unison-src/transcripts-manual/gen-racket-libs.output.md

@@ -5,35 +5,32 @@ Next, we'll download the jit project and generate a few Racket files from it.
 ``` ucm
 jit-setup/main> lib.install @unison/internal/releases/0.0.25
 
-  Downloaded 14942 entities.
-
   I installed @unison/internal/releases/0.0.25 as
   unison_internal_0_0_25.
-
 ```
+
 ``` unison
 go = generateSchemeBoot "scheme-libs/racket"
 ```
 
-``` ucm
-
+``` ucm :added-by-ucm
   Loading changes detected in scratch.u.
 
   I found and typechecked these definitions in scratch.u. If you
   do an `add` or `update`, here's how your codebase would
   change:
-  
+
     ⍟ These new definitions are ok to `add`:
     
       go : '{IO, Exception} ()
-
 ```
+
 ``` ucm
 jit-setup/main> run go
 
   ()
-
 ```
+
 After executing this, `scheme-libs/racket` will contain the full
 complement of unison libraries for a given combination of ucm version
 and @unison/internal version.
@@ -59,4 +56,3 @@ raco distribute <output-dir> scheme-libs/racket/unison-runtime
 
 At that point, <output-dir> should contain the executable and all
 dependencies necessary to run it.
-