diff options
Diffstat (limited to 'src/GF/Compile/TC.hs')
| -rw-r--r-- | src/GF/Compile/TC.hs | 18 |
1 files changed, 9 insertions, 9 deletions
diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs index fabe7e2a1..4508c8a17 100644 --- a/src/GF/Compile/TC.hs +++ b/src/GF/Compile/TC.hs @@ -58,7 +58,7 @@ lookupConst :: Theory -> QIdent -> Err Val lookupConst th f = th f lookupVar :: Env -> Ident -> Err Val -lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) +lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g) -- wild card IW: no error produced, ?0 instead. type TCEnv = (Int,Env,Env) @@ -130,7 +130,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do (t',cs) <- checkExp th (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) return (AAbs x a' t', cs) - _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ + _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) Prod x a b -> do testErr (typ == vType) "expected Type" @@ -146,7 +146,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do r <- mapM (checkAssign th tenv ys) xs let (xs,css) = unzip r return (AR xs, concat css) - _ -> prtBad ("record type expected for" +++ prt e +++ "instead of") typ + _ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) return (AP r' l typ,cs) @@ -181,8 +181,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of (a',csa) <- checkExp th tenv t (VClos env a) b' <- whnf $ VClos ((x,VClos rho t):env) b return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot infer type of expression" e + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e)) checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) checkLabelling th tenv (lbl,typ) = do @@ -224,7 +224,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ let tenv' = (length binds, sigma ++ rho, binds ++ gamma) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt - _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ + _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ)) [] -> do (e,cs) <- checkExp th tenv t ty return (([],e),cs) @@ -242,7 +242,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ PFloat n -> (EFloat n : ps, i, g, k) PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') where (xss,j,g',k') = foldr p2t ([],i,g,k) xs - _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch") upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables @@ -280,8 +280,8 @@ checkPatt th tenv exp val = do (a',_,csa) <- checkExpP tenv t (VClos env a) b' <- whnf $ VClos ((x,VClos rho t):env) b return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot typecheck pattern" exp + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) -- auxiliaries |