Changeset 3644

Timestamp:

05/22/05 15:48:36 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

5201

Message:

* first step in making legible stack trace in error

messages -- VError now carries [Pos], not Exp

Location:

src/Pugs

Files:

• AST/Internals.hs (modified) (2 diffs)
• Parser.hs (modified) (2 diffs)
• Pretty.hs (modified) (2 diffs)
• Prim.hs (modified) (4 diffs)
• Prim/List.hs (modified) (1 diff)

src/Pugs/AST/Internals.hs

@@ -513 +513 @@
     | VBlock    !VBlock
     | VJunc     !VJunc       -- ^ Junction value
-    | VError    !VStr !Exp
+    | VError    !VStr ![Pos] -- ^ Error
     | VHandle   !VHandle     -- ^ File handle
     | VSocket   !VSocket     -- ^ Socket handle
@@ -1071 +1071 @@
     fail str = do
         pos <- asks envPos
-        shiftT . const . return $ VError str (NonTerm pos)
+        shiftT . const . return $ VError str [pos]
 
 instance MonadTrans EvalT where

src/Pugs/Parser.hs

@@ -1771 +1771 @@
     sym  <- choice . map symbol $ words " ... ??? !!! "
     pos2 <- getPosition
-    return . Val $ VError sym (NonTerm (mkPos pos1 pos2))
+    return . Val $ VError sym [mkPos pos1 pos2]
 
 methOps             :: a -> [b]
@@ -1785 +1785 @@
 runRule :: Env -> (Env -> a) -> RuleParser Env -> FilePath -> String -> a
 runRule env f p name str = f $ case ( runParser p env name str ) of
-    Left err    -> env { envBody = Val $ VError msg (NonTerm (mkPos pos pos)) }
+    Left err    -> env { envBody = Val $ VError msg [mkPos pos pos] }
         where
         pos = errorPos err

src/Pugs/Pretty.hs

@@ -29 +29 @@
 
 instance Pretty Exp where
-    format (Val (VError msg (NonTerm pos))) = text "Syntax error at" <+> (format pos) <+> format msg
-    format (NonTerm pos) = format pos
+    format (NonTerm pos) = text "Syntax error at" <+> format pos
     format (Val v) = format v
     format (Syn x vs) = text "Syn" <+> format x <+> (braces $ vcat (punctuate (text ";") (map format vs)))
@@ -116 +115 @@
     format (VCode _) = text "sub {...}"
     format (VBlock _) = text "{...}"
-    format (VError x y@(NonTerm _))
+    format (VError x posList)
         -- Is this correct? Does this work on win32, too?
         | last x == '\n' = text . init $ x
-        | otherwise      = text "*** Error:" <+> (text x <+> (text "at" <+> format y))
-    format (VError x _) = text "*** Error:" <+> text x
+        | otherwise      = text "***" <+>
+            (text x <+> (text "at" <+> vcat (map format posList)))
 --  format (VArray x) = format (VList $ Array.elems x)
 --  format (VHash h) = braces $ (joinList $ text ", ") $

src/Pugs/Prim.hs

@@ -236 +236 @@
 op1 "eval_yaml" = evalYaml
 op1 "defined" = op1Cast (VBool . defined)
-op1 "last" = \v -> return (VError "cannot last() outside a loop" (Val v))
-op1 "next" = \v -> return (VError "cannot next() outside a loop" (Val v))
-op1 "redo" = \v -> return (VError "cannot redo() outside a loop" (Val v))
+op1 "last" = const $ fail "cannot last() outside a loop"
+op1 "next" = const $ fail "cannot next() outside a loop"
+op1 "redo" = const $ fail "cannot redo() outside a loop"
 op1 "return" = op1Return . op1ShiftOut
 op1 "yield" = op1Yield . op1ShiftOut
@@ -267 +267 @@
     errh <- readVar "$*ERR"
     pos  <- asks envPos
-    op2 "say" errh $ VList [ VStr $ pretty (VError (errmsg strs) (NonTerm pos)) ]
+    op2 "say" errh $ VList [ VStr $ pretty (VError (errmsg strs) [pos]) ]
     where
     errmsg "" = "Warning: something's wrong"
@@ -275 +275 @@
     throw <- fromVal =<< readVar "$?FAIL_SHOULD_DIE"
     pos   <- asks envPos
-    let msg = pretty (VError (errmsg strs) (NonTerm pos)) ++ "\n"
+    let msg = pretty (VError (errmsg strs) [pos]) ++ "\n"
     if throw
         -- "use fatal" is in effect, so die.
@@ -863 +863 @@
     = fmap VList $ mapM (op2 op x) y'
     | otherwise
-    = return $ VError "Hyper OP only works on lists" (Val VUndef)
+    = fail "Hyper OP only works on lists"
     where
     hyperLists [] [] = return []

src/Pugs/Prim/List.hs

@@ -43 +43 @@
     then return $ head $ Set.elems set
     else return undef
-op1Pick v = return $ VError "pick not defined" (Val v)
+op1Pick v = retError "pick not defined" v
 
 op1Sum :: Val -> Eval Val