diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 47e2f5cded..ac9415f675 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/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 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 diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 8383f0624a..5d45188448 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -241,6 +241,7 @@ 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) = @@ -248,6 +249,20 @@ choices nr path = do (args,_) <- get 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