impl: move `liftTypedString` to `Language.Haskell.TH.Show`

diff --git a/src/Language/Haskell/TH/Show.hs b/src/Language/Haskell/TH/Show.hs
index 84b511953ac4306ded7ae62ce7365a963c9ca21a..31a050c74776eeebe8a1eec93e42133d6e56b3a1 100644 (file)
--- a/src/Language/Haskell/TH/Show.hs
+++ b/src/Language/Haskell/TH/Show.hs
@@ -40,3 +40,8 @@ instance TH.Quasi ShowQ where
     i <- MT.get
     MT.put (succ i)
     return (TH.mkNameU n i)
+
+-- | Like 'TH.liftString' but on 'TH.Code'.
+-- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
+liftTypedString :: String -> TH.Code TH.Q a
+liftTypedString = TH.unsafeCodeCoerce . TH.liftString

diff --git a/src/Symantic/Parser/Machine/Generate.hs b/src/Symantic/Parser/Machine/Generate.hs
index 038e3a4f4bd6134aa65f33f50430c6ebb801b4f4..aa160be4275cc4a9a78e80a0a46aef0f11d3da02 100644 (file)
--- a/src/Symantic/Parser/Machine/Generate.hs
+++ b/src/Symantic/Parser/Machine/Generate.hs
@@ -321,7 +321,7 @@ instance InstrComment Gen where
   comment msg k = k
     { unGen = \ctx -> {-trace "unGen.comment" $-}
       [||
-        let _ = $$(liftTypedString $ "comment: "<>msg) in
+        let _ = $$(TH.liftTypedString $ "comment: "<>msg) in
         $$(unGen k ctx)
       ||]
     }
@@ -345,7 +345,7 @@ instance InstrValuable Gen where
   lift2Value f k = k
     { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
       [||
-      let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
+      let _ = $$(TH.liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
       $$(unGen k ctx
         { valueStack =
           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
@@ -386,7 +386,7 @@ instance InstrBranchable Gen where
         go x ((p,b):bs') = [||
           if $$(genCode (p Prod..@ x))
           then
-            let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
+            let _ = $$(TH.liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
           else
             let _ = "choicesBranch.else" in
@@ -408,13 +408,13 @@ instance InstrExceptionable Gen where
         $$(raiseException ctx (ExceptionLabel exn))
           (ExceptionLabel $$(TH.liftTyped exn))
           {-failInp-}$$(input ctx)
-          {-farInp-}$$(input ctx)
-          $$(farthestExpecting ctx)
+          {-farFail-}(Just $$(input ctx))
+          {-farExp-}[]
           $$(inputBuffer ctx)
           $$(inputEnded ctx)
       ||]
     }
-  fail fs = Gen
+  fail failMode = Gen
     { genAnalysisByLet = HM.empty
     , genAnalysis = \_final -> GenAnalysis
         { minReads = 0
@@ -423,22 +423,22 @@ instance InstrExceptionable Gen where
         , freeRegs = Set.empty
         }
     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
-      if null fs
-      then [|| -- Raise without updating the farthest error.
-          $$(raiseException ctx ExceptionFailure)
-            ExceptionFailure
-            {-failInp-}$$(input ctx)
-            $$(farthestInput ctx)
-            $$(farthestExpecting ctx)
-            $$(inputBuffer ctx)
-            $$(inputEnded ctx)
-        ||]
-      else raiseFailure ctx [||fs||]
+      case failMode of
+        FailModePreserve -> [|| -- Raise without updating the farthest error.
+            $$(raiseException ctx ExceptionFailure)
+              ExceptionFailure
+              {-failInp-}$$(input ctx)
+              $$(farthestFailure ctx)
+              $$(farthestExpecting ctx)
+              $$(inputBuffer ctx)
+              $$(inputEnded ctx)
+          ||]
+        FailModeNewFailure someFail -> raiseFailure ctx {-someFail-}someFail
     }
   commit exn k = k
     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
       [||
-      let _ = "commit" in
+      let _ = $$(TH.liftTypedString ("commit "<>show exn)) in
       $$(unGen k ctx{onExceptionStackByLabel =
         Map.update (\case
             _r0:|(r1:rs) -> Just (r1:|rs)
@@ -494,7 +494,7 @@ instance InstrInputable Gen where
     { unGen = \ctx ->
         {-trace "unGen.saveInput" $-}
         [||
-        let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
+        let _ = $$(TH.liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
         $$(unGen k ctx
           { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
           })
@@ -509,7 +509,7 @@ instance InstrInputable Gen where
               -- This case should never happen if 'saveInput' is used.
               i -> (genCode i, 0) in
         [||
-        let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
+        let _ = $$(TH.liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
         $$(unGen (checkHorizon k) ctx
           { valueStack = vs
           , input
@@ -623,19 +623,21 @@ instance InstrCallable Gen where
         if isRec
         then GenAnalysis
           { minReads = 0
-          , mayRaise = Map.empty
+          -- Assume 'checkToken' is used, otherwise it would loop
+          , mayRaise = Map.singleton ExceptionFailure ()
           , alwaysRaise = Set.empty
           , freeRegs = Set.empty
           }
         else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
     , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
-      -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in
+      let ks = Map.keys (onExceptionStackByLabel ctx) in
       let subAnalysis = analysisByLet ctx HM.! subName in
       [||
-      -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in
+      let _ = $$(TH.liftTypedString $ "call mayRaise("<>show subName<>")="<>show (Map.keys (mayRaise subAnalysis)) <> " onExceptionStackByLabel="<> show ks) in
       $$(TH.unsafeCodeCoerce $
         giveFreeRegs (freeRegs subAnalysis) $
         return (TH.VarE subName))
+        -- TODO: more readable in a let binding
         {-ok-}$$(onReturnCode k ctx)
         $$(input ctx)
         $$(inputBuffer ctx)
@@ -646,7 +648,7 @@ instance InstrCallable Gen where
           onExceptionStackByLabel ctx
           -- Pass only the labels raised by the 'defLet'.
           `Map.intersection`
-          (mayRaise subAnalysis)
+           (mayRaise subAnalysis)
         )
       ||]
     }
@@ -675,11 +677,6 @@ giveFreeRegs frs k = go (Set.toList frs)
   go [] = k
   go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
 
--- | Like 'TH.liftString' but on 'TH.Code'.
--- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
-liftTypedString :: String -> TH.Code TH.Q a
-liftTypedString = TH.unsafeCodeCoerce . TH.liftString
-
 -- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
 -- which already contains 'CodeQ' terms.
 -- Moreover, only the 'OnException' at the top of the stack
@@ -765,8 +762,8 @@ onExceptionCode ::
   Gen inp (InputPosition inp : vs) a ->
   GenCtx inp vs a -> TH.CodeQ (OnException inp a)
 onExceptionCode resetInput resetCheckedHorizon k ctx = [||
-  let _ = $$(liftTypedString $ "onException") in
-  \ !_exn !failInp !farInp !farExp buf end ->
+  let _ = $$(TH.liftTypedString $ "onException") in
+  \ !_exn !failInp !farFail !farExp buf end ->
     $$(unGen k ctx
       -- Push 'input' and 'checkedHorizon'
       -- as they were when entering the 'catch' or 'iter',
@@ -939,7 +936,7 @@ checkHorizon ok = ok
     if checkedHorizon ctx0 >= 1
     then
       [||
-        let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
+        let _ = $$(TH.liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
         $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
       ||]
     else
@@ -963,7 +960,7 @@ checkHorizon ok = ok
                         , inputBuffer = [||buf||]
                         } in
                   [||
-                    let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
+                    let _ = $$(TH.liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
                     if $$(moreInput ctx) buf
                          $$(if minHoriz > 1
                            then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) $$(input ctx)||]