avoid using withState

src/compiler/api/GF/Compile/Compute/Concrete2.hs

@@ -4,7 +4,7 @@ module GF.Compile.Compute.Concrete2
            (Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions,
             ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
             mapVariants, unvariants, variants2consts, consts2variants,
-            runEvalM, runEvalMWithOpts, stdPredef, globals, withState,
+            runEvalM, runEvalMWithOpts, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
@@ -729,9 +729,6 @@ runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) ->
   where
     init = State cs Map.empty []
 
-withState :: State -> EvalM a -> EvalM a
-withState state (EvalM f) = EvalM $ \g k _ r ws -> f g k state r ws
-
 reset :: EvalM a -> EvalM [a]
 reset (EvalM f) = EvalM $ \g k state r ws ->
   case f g (\x state xs ws -> Success (x:xs) ws) state [] ws of
@@ -769,7 +766,7 @@ variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs ->
                      Fail    msg msgs -> Fail msg msgs
                      Success ts  msgs -> backtrack g (j+1) xs choices metas opts ts msgs
 
-try :: (a -> EvalM b) -> ([(b,State)] -> EvalM b) -> [a] -> EvalM b
+try :: (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
 try f select xs = EvalM (\g k state r msgs ->
   let (res,msgs') = backtrack g xs state [] msgs
   in case select res of
@@ -778,7 +775,7 @@ try f select xs = EvalM (\g k state r msgs ->
     backtrack g []     state res msgs = (res,msgs)
     backtrack g (x:xs) state res msgs =
       case f x of
-        EvalM f -> case f g (\x state res msgs -> Success ((x,state):res) msgs) state res msgs of
+        EvalM f -> case f g (\y state ys msgs -> Success (y:ys) msgs) state res msgs of
                      Fail msg _       -> backtrack g xs state res msgs
                      Success res msgs -> backtrack g xs state res msgs
 

src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs

@@ -518,45 +518,32 @@ resolveOverloads scope c t0 q args mb_ty = do
     minimum g []                    = (maxBound,err)
       where
         err = evalError (pp "Overload resolution failed")
-    minimum g (tty@((t,ty),state):ttys) =
+    minimum g (tty@(t,ty):ttys) =
-      let ty'      = zonk ty
+      let a        = arity ty
-          a        = arity ty'
           (a',res) = minimum g ttys
       in case compare a a' of
            GT -> (a',res)
-           EQ -> (a',join t ty' state res)
+           EQ -> (a',join t ty res)
-           LT -> (a ,one  t ty' state)
+           LT -> (a ,one  t ty)
       where
         arity :: Value -> Int
         arity (VProd _ _ _ ty) = 1 + arity ty
         arity _                = 0
 
-        zonk :: Value -> Value
+        one t ty = do
-        zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
-        zonk (VMeta i vs)         =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g v vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g v vs)
-            _                             -> VMeta i (map zonk vs)
-        zonk (VSusp i k vs)      =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g (k v) vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g (k v) vs)
-            _                             -> VSusp i k (map zonk vs)
-        zonk v                   = v
-
-        one t ty state = do
-          t <- withState state (zonkTerm [] t)
           return ([t],ty)
 
-        join t ty state res = do
+        join t ty res = do
-          t <- withState state (zonkTerm [] t)
           (ts,ty') <- res
           unify scope ty ty'
           return (t:ts,ty)
 
 reapply2 :: Scope -> Choice -> Term -> Value -> [(Term,Value,Value)] -> Maybe Rho -> EvalM (Term,Rho)
-reapply2 scope c fun fun_ty []                                mb_ty = instSigma scope c fun fun_ty mb_ty
+reapply2 scope c fun fun_ty []                                mb_ty = do
+  (t,ty) <- instSigma scope c fun fun_ty mb_ty
+  t  <- zonkTerm (scopeVars scope) t
+  ty <- zonkValue ty
+  return (t,ty)
 reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Implicit arg case
   (bt, x, arg_ty', res_ty) <- unifyFun scope fun_ty
   unless (bt == Implicit) $