diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 42d53c3c2..d15d57001 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -107,6 +107,7 @@ appPredefined t = case t of (K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse (K s) | f == cToUpper -> retb $ K $ map toUpper s (K s) | f == cToLower -> retb $ K $ map toLower s + (K s) | f == cError -> retb $ Error s _ -> retb t diff --git a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs index 91fffbc5a..da93ec5f9 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs @@ -44,7 +44,7 @@ import Text.PrettyPrint type Comp a = Identity a -- inherit Haskell's laziness errr = err runtime_error return -- convert interpreter error to run-time error no_error = err fail return -- failure caused by interpreter/type checker bug (?) -runtime_error = return . predef_error -- run-time error term +runtime_error = return . Error -- run-time error term -- | computation of concrete syntax terms into normal form -- used mainly for partial evaluation @@ -59,7 +59,8 @@ computeTermOpt gr = comput True where -- full = True means full evaluation under Abs comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging - case t of + --trace ("comput "++show (map fst g)++" "++take 65 (show t)) $ + case t of Q (p,c) | p == cPredef -> return t -- qualified constant | otherwise -> look (p,c) @@ -104,6 +105,7 @@ computeTermOpt gr = comput True where h' <- hnf g h as' <- mapM (comp g) as case h' of + Error{} -> return h' _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') c@(QC _) -> do return $ mkApp c as' @@ -131,6 +133,7 @@ computeTermOpt gr = comput True where P t l -> do -- t.l t' <- comp g t case t' of + Error{} -> return t' FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants -- (r| r').l R r -> project l r --{...}.l @@ -164,6 +167,8 @@ computeTermOpt gr = comput True where x <- comp g x0 y <- comp g y0 case (x,y) of + (Error{},_) -> return x + (_,Error{}) -> return y (FV ks,_) -> do -- (k|k') + y kys <- mapM (comp g . flip Glue y) ks return $ variants kys @@ -208,6 +213,8 @@ computeTermOpt gr = comput True where a' <- comp g a b' <- comp g b case (a',b') of + (Error{},_) -> return a' + (_,Error{}) -> return b' (Alts _ _, K d) -> errr $ checks [do -- pre {...} ++ "d" as <- strsFromTerm a' -- this may fail when compiling opers return $ variants [ @@ -234,6 +241,8 @@ computeTermOpt gr = comput True where r' <- comp g r s' <- comp g s case (r',s') of + (Error{},_) -> return r' + (_,Error{}) -> return s' (R rs, R ss) -> errr $ plusRecord r' s' (RecType rs, RecType ss) -> errr $ plusRecType r' s' _ -> return $ ExtR r' s' @@ -258,10 +267,11 @@ computeTermOpt gr = comput True where f' <- hnf g f a' <- comp g a case (f',a') of + (Error{},_) -> return f' (Abs _ x b, FV as) -> -- (\x -> b) (variants {...}) - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants + liftM variants $ mapM (\c -> comp (ext x c g) b) as + (_, FV as) -> liftM variants $ mapM (\c -> comp g (App f' c)) as + (FV fs, _) -> liftM variants $ mapM (\c -> comp g (App c a')) fs (Abs _ x b,_) -> comp (ext x a' g) b -- (\x -> b) a -- normal beta conv. (QC _,_) -> returnC $ App f' a' -- (C a') -- constructor application @@ -271,7 +281,7 @@ computeTermOpt gr = comput True where _ -> case appPredefined (App f' a') of Ok (t',b) -> if b then return t' else comp g t' - Bad s -> fail s + Bad s -> runtime_error s hnf, comp :: Substitution -> Term -> Comp Term hnf = comput False @@ -329,6 +339,7 @@ computeTermOpt gr = comput True where _ -> case t' of + Error{} -> return t' FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants T _ [(PW,c)] -> comp g c -- (\\_ => c) ! v' @@ -488,10 +499,17 @@ getArgType t = case t of T (TComp ty) _ -> return ty _ -> fail (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) - checkPredefError :: SourceGrammar -> Term -> Err Term +checkPredefError sgr t = + case t of + Error s -> fail ("Error: "++s) + _ -> return t + +{- +-- Old checkPredefError sgr t = case t of App (Q (mod,f)) s | mod == cPredef && f == cError -> fail $ showTerm sgr TermPrintOne Unqualified s _ -> composOp (checkPredefError sgr) t predef_error s = App (Q (cPredef,cError)) (K s) +-} diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 686164539..ae29ab6d5 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -161,7 +161,7 @@ data Term = | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ - + | Error String -- ^ error values returned by Predef.error deriving (Show, Eq, Ord) data Patt = diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index ef31af3bb..5fa9121fc 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -192,6 +192,7 @@ ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) ppTerm q d (ELincat cat t) = prec d 4 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t) ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t) +ppTerm q d (Error s) = prec d 4 (text "Predef.error" <+> str s) ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e