Improve error messages for str pattern matching

src/compiler/GF/Compile/Compute/Concrete.hs

@@ -24,6 +24,7 @@ import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
 import GF.Text.Pretty
 import qualified Data.Map as Map
 import Debug.Trace(trace)
+import GHC.Stack (HasCallStack)
 
 -- * Main entry points
 
@@ -497,10 +498,10 @@ vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
               -- Left i  -> "variable #" <> pp i <+> "is out of scope"
 
 -- | Convert a value back to a term
-value2term :: GLocation -> [Ident] -> Value -> Term
+value2term :: HasCallStack => GLocation -> [Ident] -> Value -> Term
 value2term = value2term' False
 
-value2term' :: Bool -> p -> [Ident] -> Value -> Term
+value2term' :: HasCallStack => Bool -> GLocation -> [Ident] -> Value -> Term
 value2term' stop loc xs v0 =
   case v0 of
     VApp pre vs    -> applyMany (Q (cPredef,predefName pre)) vs
@@ -536,9 +537,10 @@ value2term' stop loc xs v0 =
     v2txs = value2term' stop loc
     v2t' x f = v2txs (x:xs) (bind f (gen xs))
 
+    var :: HasCallStack => Int -> Term
     var j
       | j<length xs = Vr (reverse xs !! j)
-      | otherwise   = error ("variable #"++show j++" is out of scope")
+      | otherwise   = Error ("variable #"++show j++" is out of scope in expression " ++ show v0 ++ " with context " ++show (reverse xs))
 
 
     pushs xs e = foldr push e xs
@@ -584,7 +586,11 @@ mf <# mx  = ap mf mx
 
 both f (x,y) = (,) # f x <# f y
 
+bugloc :: (HasCallStack, Pretty a, Pretty b) => L a -> b -> c
 bugloc loc s = ppbug $ ppL loc s
 
+bug :: (HasCallStack, Pretty a) => a -> b
 bug msg = ppbug msg
+
+ppbug :: (HasCallStack, Pretty a) => a -> b
 ppbug doc = error $ render $ hang "Internal error in Compute.Concrete:" 4 doc

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -241,13 +241,28 @@ choices nr path = do (args,_) <- get
                                                      values          -> let path = reversePath rpath
                                                                         in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
                                                                                                                     | (value,index) <- values])
+    descend (CStr _)     CNil              rpath = bug $ "descend CStr: "++ show rpath ++ matchStrErr
     descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
 
     updateEnv path value gr c (args,seq) =
       case updateNthM (restrictProtoFCat path value) nr args of
         Just args -> c value (args,seq)
         Nothing   -> bug "conflict in updateEnv"
 
+-- | Error message for pattern matching a runtime string
+matchStrErr :: String
+matchStrErr = unlines [ "" -- add more helpful output
+            ,""
+            ,"1) Check that you are not trying to pattern match a /runtime string/."
+            ,"   These are illegal:"
+            ,"     lin Test foo = case foo.s of {"
+            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
+            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
+            ,""
+            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
+            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
+            ]
+
 -- | the argument should be a parameter type and then
 -- the function returns all possible values.
 getAllParamValues :: Type -> CnvMonad [Term]
@@ -620,21 +635,6 @@ mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
 bug msg = ppbug msg
 ppbug msg = error completeMsg
  where
-  originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
-  completeMsg =
-    case render msg of -- the error message for pattern matching a runtime string
-      "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
-        -> unlines [originalMsg -- add more helpful output
-            ,""
-            ,"1) Check that you are not trying to pattern match a /runtime string/."
-            ,"   These are illegal:"
-            ,"     lin Test foo = case foo.s of {"
-            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
-            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
-            ,""
-            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
-            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
-            ]
-      _ -> originalMsg -- any other message: just print it as is
+  completeMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
 
 ppU = ppTerm Unqualified