[parse line pragmas from m4 and cpp properly
John Meacham <john@repetae.net>**20070607045740] hunk ./FrontEnd/Lexer.hs 29
+import FrontEnd.SrcLoc
hunk ./FrontEnd/Lexer.hs 214
-	s <- getInput
-	case s of
-            '{':'-':'#':s
-                | pname `Map.member` pragmas -> return bol
-                | otherwise -> do
-                    addWarn "unknown-pragma" $ "The pragma '" ++ pname ++ "' is unknown"
-                    discard 2
-                    bol <- lexNestedComment bol
-                    lexWhiteSpace bol
-                   where pname =  takeWhile isIdent (dropWhile isSpace s)
-	    '{':'-':_ -> do
-		discard 2
-		bol <- lexNestedComment bol
-		lexWhiteSpace bol
-	    '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do
-		lexWhile (== '-')
-		lexWhile (/= '\n')
-		s' <- getInput
-		case s' of
-		    [] -> fail "Unterminated end-of-line comment"
-		    _ -> do
-			lexNewline
-			lexWhiteSpace True
-	    '\n':_ -> do
-		lexNewline
-		lexWhiteSpace True
-	    '\t':_ -> do
-		lexTab
-		lexWhiteSpace bol
-	    c:_ | isSpace c -> do
-		discard 1
-		lexWhiteSpace bol
-	    _ -> return bol
+    let linePragma = do
+            lexWhile (`elem` " \r\t")
+            v <- lexDecimal
+            lexWhile (`elem` " \r\t")
+            s <- getInput
+            fn <- case s of
+                '"':_ -> do
+                    discard 1
+                    StringTok s <- lexString
+                    return (Just s)
+                _ -> return Nothing
+            setFilePos (fromInteger v - 1) 1 fn
+            lexWhiteSpace False
+    s <- getInput
+    case s of
+        '{':'-':'#':s
+            | pname `Map.member` pragmas -> return bol
+            | otherwise -> do
+                addWarn "unknown-pragma" $ "The pragma '" ++ pname ++ "' is unknown"
+                discard 2
+                bol <- lexNestedComment bol
+                lexWhiteSpace bol
+               where pname =  takeWhile isIdent (dropWhile isSpace s)
+        '{':'-':_ -> do
+            discard 2
+            bol <- lexNestedComment bol
+            lexWhiteSpace bol
+        '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do
+            lexWhile (== '-')
+            lexWhile (/= '\n')
+            s' <- getInput
+            case s' of
+                [] -> fail "Unterminated end-of-line comment"
+                _ -> do
+                    lexNewline
+                    lexWhiteSpace True
+        '\n':'#':' ':ns -> discard 2 >> linePragma
+        '\n':'#':'l':'i':'n':'e':' ':ns -> discard 6 >> linePragma
+        '\n':_ -> do
+            lexNewline
+            lexWhiteSpace True
+        '\t':_ -> do
+            lexTab
+            lexWhiteSpace bol
+        c:_ | isSpace c -> do
+            discard 1
+            lexWhiteSpace bol
+        _ -> return bol
+
+setFilePos :: Int -> Int -> Maybe String -> Lex a ()
+setFilePos line column ms = do
+    sl <- getSrcLoc
+    let sl' = sl { srcLocLine = line, srcLocColumn = column }
+    case ms of
+        Just fn -> setSrcLoc sl' { srcLocFileName = fn }
+        Nothing -> setSrcLoc sl'
+
hunk ./FrontEnd/ParseMonad.hs 22
-		getSrcLoc, pushCurrentContext, popContext,thenP,returnP,
+		getSrcLoc, setSrcLoc, pushCurrentContext, popContext,thenP,returnP,
hunk ./FrontEnd/ParseMonad.hs 191
+
+setSrcLoc :: SrcLoc -> Lex a ()
+setSrcLoc srcloc = Lex $ \cont -> P $ \r x l _ -> runP (cont ()) r x l srcloc
+
hunk ./FrontEnd/ParseMonad.hs 198
-lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+1)
+lexNewline = Lex $ \cont -> P $ \(_:r) _x y loc -> runP (cont ()) r 1 (y+1) loc { srcLocLine = srcLocLine loc + 1 }
hunk ./FrontEnd/ParseMonad.hs 255
-startToken = Lex $ \cont -> P $ \s x y _ stk mode ->
-	let loc = SrcLoc {
-		srcLocFileName = parseFilename mode,
-		srcLocLine = y,
-		srcLocColumn = x
-	} in
+startToken = Lex $ \cont -> P $ \s x y oloc stk mode ->
+	let loc = oloc { srcLocColumn = x } in
hunk ./FrontEnd/Syn/Options.hs 34
-comment = line +++ block where
+comment = plone +++ pline +++ line +++ block where
hunk ./FrontEnd/Syn/Options.hs 38
+        return ()
+    pline = do
+        string "# "
+        manyTill get (char '\n')
+        return ()
+    plone = do
+        string "#line "
+        manyTill get (char '\n')
hunk ./FrontEnd/Unlit.hs 21
+classify (('#':'l':'i':'n':'e':' ':x):xs)      = (case words x of
+                                (line:file:_) | all isDigit line
+                                   -> Include (read line) file
+                                _  -> Pre x
+                             ) : classify xs
hunk ./Ho/Build.hs 348
-    ls <- replicateM 10 (ioM $ hGetLine fh)
+    ls <- replicateM 15 (ioM $ hGetLine fh)
hunk ./Ho/Build.hs 356
-        _ | fopts FO.Cpp -> filterInput "cpp" ["-D__JHC__","-P","-CC","-traditional"] fh
-          | fopts FO.M4 ->  filterInput "m4" ["-D__JHC__"] fh
+        _ | fopts FO.Cpp -> hClose fh >> readSystem "cpp" ["-D__JHC__","-CC","-traditional", "--", fn]
+          | fopts FO.M4 ->  hClose fh >> readSystem "m4" ["-D__JHC__", "-s", fn]
hunk ./Ho/Build.hs 359
-    let s' = if "shl." `isPrefixOf` reverse fn  then unlit fn s else s
+    let s' = if "shl." `isPrefixOf` reverse fn  then unlit fn s'' else s''
+        s'' = case s of
+            '#':' ':_   -> '\n':s                --  line pragma
+            '#':'l':'i':'n':'e':' ':_  -> '\n':s --  line pragma
+            '#':'!':_ -> dropWhile (/= '\n') s   --  hashbang
+            _ -> s
hunk ./Util/FilterInput.hs 1
-module Util.FilterInput (filterInput) where
+module Util.FilterInput (filterInput,readSystem) where
hunk ./Util/FilterInput.hs 21
-    when (ret /= Just (Exited ExitSuccess)) $ putErrDie "cpp exited abnormally"
+    when (ret /= Just (Exited ExitSuccess)) $ putErrDie (prog ++ " exited abnormally")
hunk ./Util/FilterInput.hs 27
+readSystem :: String -> [String] -> IO String
+readSystem prog args = do
+    (rfd,wfd) <- createPipe
+    pid <- forkProcess (do dupAndClose wfd stdOutput
+                           executeFile prog True args Nothing
+                           putErrDie "exec failed")
+    closeFd wfd
+    str <- hGetContents =<< fdToHandle rfd
+    ret <- length str `seq` getProcessStatus True False pid
+    when (ret /= Just (Exited ExitSuccess)) $ putErrDie (prog ++ " exited abnormally")
+    return str
+
+