Track column numbers
authorPhil Ruffwind <rf@rufflewind.com>
Wed, 15 Mar 2017 15:54:45 +0000 (11:54 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 15 Mar 2017 15:54:45 +0000 (11:54 -0400)
Summary:
Keep track of column numbers and inform GHC whenever the column number
could be potentially desynchronized from the original source code.  This
should fix GHC #13388 on Trac.

Test Plan: validate

Reviewers: O25 HSC2HS, hvr, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D3314

C.hs
CrossCodegen.hs
DirectCodegen.hs
Flags.hs
HSCParser.hs
Main.hs
template-hsc.h

diff --git a/C.hs b/C.hs
index f742be7..3ac3843 100644 (file)
--- a/C.hs
+++ b/C.hs
@@ -68,18 +68,20 @@ outHeaderHs flags inH toks =
         "    hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
                   showCString s++"\");\n"
 
-outTokenHs :: Token -> String
-outTokenHs (Text pos txt) =
-    case break (== '\n') txt of
-        (allTxt, [])       -> outText allTxt
-        (first, _:rest) ->
-            outText (first++"\n")++
-            outHsLine pos++
-            outText rest
+outTokenHs :: Bool                      -- ^ enable COLUMN pragmas?
+           -> (ShowS, (Bool, Bool))
+           -> Token
+           -> (ShowS, (Bool, Bool))
+outTokenHs enableCol (out, state) (Text pos txt) =
+    (out . showString str, state')
     where
+    (str, state') = outTextHs state pos txt outText outHsLine
+                              (if enableCol then outHsColumn else const "")
     outText s = "    hsc_fputs (\""++showCString s++"\", hsc_stdout());\n"
-outTokenHs (Special pos key arg) =
-    case key of
+outTokenHs _ (out, (rowSync, colSync)) (Special pos key arg) =
+    (out . showString str, (rowSync && null str, colSync && null str))
+    where
+    str = case key of
         "include"           -> ""
         "define"            -> ""
         "undef"             -> ""
@@ -89,6 +91,52 @@ outTokenHs (Special pos key arg) =
         "enum"              -> outCLine pos++outEnum arg
         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 
+-- | Output a 'Text' 'Token' literally, making use of the three given output
+-- functions.  The state contains @(lineSync, colSync)@, which indicate
+-- whether the line number and column number in the input are synchronized
+-- with those of the output.
+outTextHs :: (Bool, Bool)               -- ^ state @(lineSync, colSync)@
+          -> SourcePos                  -- ^ original position of the token
+          -> String                     -- ^ text of the token
+          -> (String -> String)         -- ^ output text
+          -> (SourcePos -> String)      -- ^ output LINE pragma
+          -> (Int -> String)            -- ^ output COLUMN pragma
+          -> (String, (Bool, Bool))
+outTextHs (lineSync, colSync) pos@(SourcePos _ _ col) txt
+          outText outLine outColumn =
+    -- Ensure COLUMN pragmas are always inserted right before an identifier.
+    -- They are never inserted in the middle of whitespace, as that could ruin
+    -- the indentation.
+    case break (== '\n') spaces of
+        (_, "") ->
+            case break (== '\n') rest of
+                ("", _) ->
+                    ( outText spaces
+                    , (lineSync, colSync) )
+                (_, "") ->
+                    ( (outText spaces++
+                       updateCol++
+                       outText rest)
+                    , (lineSync, True) )
+                (firstRest, nl:restRest) ->
+                    ( (outText spaces++
+                       updateCol++
+                       outText (firstRest++[nl])++
+                       updateLine++
+                       outText restRest)
+                    , (True, True) )
+        (firstSpaces, nl:restSpaces) ->
+            ( (outText (firstSpaces++[nl])++
+               updateLine++
+               outText (restSpaces++rest))
+            , (True, True) )
+    where
+    (spaces, rest) = span isSpace txt
+    updateLine | lineSync   = ""
+               | otherwise = outLine pos
+    updateCol | colSync   = ""
+              | otherwise = outColumn (col + length spaces)
+
 parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
 parseEnum arg =
     case break (== ',') arg of
@@ -179,14 +227,18 @@ conditional "warning" = True
 conditional _         = False
 
 outCLine :: SourcePos -> String
-outCLine (SourcePos name line) =
+outCLine (SourcePos name line _) =
     "#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n"
 
 outHsLine :: SourcePos -> String
-outHsLine (SourcePos name line) =
+outHsLine (SourcePos name line _) =
     "    hsc_line ("++show (line + 1)++", \""++
     (showCString . showCString) name ++ "\");\n"
 
+outHsColumn :: Int -> String
+outHsColumn column =
+    "    hsc_column ("++show column++");\n"
+
 showCString :: String -> String
 showCString = concatMap showCChar
     where
index 7b26dc7..1312b91 100644 (file)
@@ -97,7 +97,7 @@ testFail' :: String -> TestMonad a
 testFail' s = TestMonad (\_ c -> return (Left s, c))
 
 testFail :: SourcePos -> String -> TestMonad a
-testFail (SourcePos file line) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)
+testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)
 
 -- liftIO for TestMonad
 liftTestIO :: IO a -> TestMonad a
@@ -137,7 +137,7 @@ testLog' :: String -> TestMonad ()
 testLog' s = testLog s (return ())
 
 testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a
-testLogAtPos (SourcePos file line) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a
+testLogAtPos (SourcePos file line _) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a
 
 -- Given a list of file suffixes, will generate a list of filenames
 -- which are all unique and have the given suffixes. On exit from this
@@ -192,58 +192,63 @@ diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad ()
 diagnose inputFilename output input = do
     checkValidity input
     output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n")
-    loop (zipFromList input)
+    loop (True, True) (zipFromList input)
 
     where
-    loop (End _) = return ()
-    loop (Zipper z@ZCursor {zCursor=Special _ key _}) =
+    loop _ (End _) = return ()
+    loop state@(lineSync, colSync)
+         (Zipper z@ZCursor {zCursor=Special _ key _}) =
         case key of
             _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do
                 condHolds <- checkConditional z
                 if condHolds
-                    then loop (zNext z)
-                    else loop =<< (either testFail' return (skipFalseConditional (zNext z)))
-            "endif" -> loop (zNext z)
+                    then loop state (zNext z)
+                    else loop state =<< either testFail' return
+                                               (skipFalseConditional (zNext z))
+            "endif" -> loop state (zNext z)
             _ -> do
-                outputSpecial output z
-                loop (zNext z)
-    loop (Zipper z@ZCursor {zCursor=Text pos txt}) = do
-        outputText output pos txt
-        loop (zNext z)
-
-outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad ()
-outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line)  key value}) =
+                sync <- outputSpecial output z
+                loop (lineSync && sync, colSync && sync) (zNext z)
+    loop state (Zipper z@ZCursor {zCursor=Text pos txt}) = do
+        state' <- outputText state output pos txt
+        loop state' (zNext z)
+
+outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool
+outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _)  key value}) =
     case key of
-       "const" -> outputConst value show
-       "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
-       "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
+       "const" -> outputConst value show >> return False
+       "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
+       "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
        "alignment" -> outputConst (alignment value)
-                                  (\i -> "(" ++ show i ++ ")")
+                                  (\i -> "(" ++ show i ++ ")") >> return False
        "peek" -> outputConst ("offsetof(" ++ value ++ ")")
-                             (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")")
+                             (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False
        "poke" -> outputConst ("offsetof(" ++ value ++ ")")
-                             (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")")
+                             (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False
        "ptr" -> outputConst ("offsetof(" ++ value ++ ")")
-                            (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")")
-       "type" -> computeType z >>= output
-       "enum" -> computeEnum z >>= output
+                            (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False
+       "type" -> computeType z >>= output >> return False
+       "enum" -> computeEnum z >>= output >> return False
        "error" -> testFail pos ("#error " ++ value)
-       "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value)
-       "include" -> return ()
-       "define" -> return ()
-       "undef" -> return ()
+       "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) >> return True
+       "include" -> return True
+       "define" -> return True
+       "undef" -> return True
        _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode")
     where outputConst value' formatter = computeConst z value' >>= (output . formatter)
 outputSpecial _ _ = error "outputSpecial's argument isn't a Special"
 
-outputText :: (String -> TestMonad ()) -> SourcePos -> String -> TestMonad ()
-outputText output (SourcePos file line) txt =
-    case break (=='\n') txt of
-        (noNewlines, []) -> output noNewlines
-        (firstLine, _:restOfLines) ->
-            output (firstLine ++ "\n" ++
-                    "{-# LINE " ++ show (line+1) ++ " \"" ++ file ++ "\" #-}\n" ++
-                    restOfLines)
+outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String
+           -> TestMonad (Bool, Bool)
+outputText state output pos txt = do
+    enableCol <- fmap cColumn testGetConfig
+    let outCol col | enableCol = "{-# COLUMN " ++ show col ++ " #-}"
+                   | otherwise = ""
+    let outLine (SourcePos file line _) = "{-# LINE " ++ show (line + 1) ++
+                                          " \"" ++ file ++ "\" #-}\n"
+    let (s, state') = outTextHs state pos txt id outLine outCol
+    output s
+    return state'
 
 -- Bleh, messy. For each test we're compiling, we have a specific line of
 -- code that may cause compiler errors -- that's the test we want to perform.
index 2a88784..9bfdd42 100644 (file)
@@ -7,6 +7,7 @@ compiled and run; the output of that program is the .hs file.
 -}
 
 import Data.Char                ( isAlphaNum, toUpper )
+import Data.Foldable            ( foldl' )
 import Control.Monad            ( when, forM_ )
 
 import System.Exit              ( ExitCode(..), exitWith )
@@ -23,6 +24,7 @@ outputDirect config outName outDir outBase name toks = do
 
     let beVerbose    = cVerbose config
         flags        = cFlags config
+        enableCol    = cColumn config
         cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
         progName     = outDir++outBase++"_hsc_make"
@@ -53,7 +55,7 @@ outputDirect config outName outDir outBase name toks = do
                       | otherwise    = '_'
 
     when (cCrossSafe config) $
-        forM_ specials (\ (SourcePos file line,key,_) ->
+        forM_ specials (\ (SourcePos file line _,key,_) ->
             when (not $ key `elem` ["const","offset","size","alignment","peek","poke","ptr",
                                     "type","enum","error","warning","include","define","undef",
                                     "if","ifdef","ifndef", "elif","else","endif"]) $
@@ -65,8 +67,8 @@ outputDirect config outName outDir outBase name toks = do
         concatMap outHeaderCProg specials++
         "\nint main (void)\n{\n"++
         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
-        outHsLine (SourcePos name 0)++
-        concatMap outTokenHs toks++
+        outHsLine (SourcePos name 0 1)++
+        fst (foldl' (outTokenHs enableCol) (id, (True, True)) toks) ""++
         "    return 0;\n}\n"
 
     when (cNoCompile config) $ exitWith ExitSuccess
index 20758fa..b436672 100644 (file)
--- a/Flags.hs
+++ b/Flags.hs
@@ -19,6 +19,7 @@ data ConfigM m = Config {
                      cNoCompile :: Bool,
                      cCrossCompile :: Bool,
                      cCrossSafe :: Bool,
+                     cColumn :: Bool,
                      cVerbose :: Bool,
                      cFlags :: [Flag]
                  }
@@ -41,6 +42,7 @@ emptyMode = UseConfig $ Config {
                             cNoCompile    = False,
                             cCrossCompile = False,
                             cCrossSafe    = False,
+                            cColumn       = False,
                             cVerbose      = False,
                             cFlags        = []
                         }
@@ -81,6 +83,8 @@ options = [
         "restrict .hsc directives to those supported by --cross-compile",
     Option ['k'] ["keep-files"] (NoArg (withConfig $ setKeepFiles True))
         "do not remove temporary files",
+    Option [] ["column"]     (NoArg (withConfig $ setColumn True))
+        "annotate output with COLUMN pragmas (requires GHC 8.2)",
     Option ['v'] ["verbose"]    (NoArg  (withConfig $ setVerbose True))
         "dump commands to stderr",
     Option ['?'] ["help"]       (NoArg  (setMode Help))
@@ -123,6 +127,9 @@ setCrossCompile b c = c { cCrossCompile = b }
 setCrossSafe :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setCrossSafe b c = c { cCrossSafe = b }
 
+setColumn :: Bool -> ConfigM Maybe -> ConfigM Maybe
+setColumn b c = c { cColumn = b }
+
 setVerbose :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setVerbose v c = c { cVerbose = v }
 
index b09213b..b2ef799 100644 (file)
@@ -9,17 +9,17 @@ import Data.Char                ( isAlpha, isAlphaNum, isSpace, isDigit )
 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
 
 runParser :: Parser a -> String -> String -> ParseResult a
-runParser (Parser p) file_name = p (SourcePos file_name 1)
+runParser (Parser p) file_name = p (SourcePos file_name 1 1)
 
 data ParseResult a = Success !SourcePos String String a
                    | Failure !SourcePos String
 
-data SourcePos = SourcePos String !Int
+data SourcePos = SourcePos String !Int !Int
 
 updatePos :: SourcePos -> Char -> SourcePos
-updatePos pos@(SourcePos name line) ch = case ch of
-    '\n' -> SourcePos name (line + 1)
-    _    -> pos
+updatePos (SourcePos name line col) ch = case ch of
+    '\n' -> SourcePos name (line + 1) 1
+    _    -> SourcePos name line (col + 1)
 
 instance Functor Parser where
     fmap = liftM
@@ -125,6 +125,10 @@ data Token
     = Text    SourcePos String
     | Special SourcePos String String
 
+tokenIsSpecial :: Token -> Bool
+tokenIsSpecial (Text    {}) = False
+tokenIsSpecial (Special {}) = True
+
 parser :: Parser [Token]
 parser = do
     pos <- getPos
@@ -157,7 +161,9 @@ text = do
                     text
         '\"':_    -> do anyChar_; hsString '\"'; text
         '\'':_    -> do anyChar_; hsString '\''; text
-        '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
+        '{':'-':_ -> do any2Chars_; linePragma `mplus`
+                                    columnPragma `mplus`
+                                    hsComment; text
         _:_       -> do anyChar_; text
 
 hsString :: Char -> Parser ()
@@ -202,7 +208,26 @@ linePragma = do
     char_ '#'
     char_ '-'
     char_ '}'
-    setPos (SourcePos name (line - 1))
+    setPos (SourcePos name (line - 1) 1)
+
+columnPragma :: Parser ()
+columnPragma = do
+    char_ '#'
+    manySatisfy_ isSpace
+    satisfy_ (\c -> c == 'C' || c == 'c')
+    satisfy_ (\c -> c == 'O' || c == 'o')
+    satisfy_ (\c -> c == 'L' || c == 'l')
+    satisfy_ (\c -> c == 'U' || c == 'u')
+    satisfy_ (\c -> c == 'M' || c == 'm')
+    satisfy_ (\c -> c == 'N' || c == 'n')
+    manySatisfy1_ isSpace
+    column <- liftM read $ manySatisfy1 isDigit
+    manySatisfy_ isSpace
+    char_ '#'
+    char_ '-'
+    char_ '}'
+    SourcePos name line _ <- getPos
+    setPos (SourcePos name line column)
 
 isHsSymbol :: Char -> Bool
 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$'  = True
diff --git a/Main.hs b/Main.hs
index 40e52dc..08dab3f 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -98,6 +98,7 @@ processFiles configM files usage = do
                      cNoCompile    = cNoCompile configM,
                      cCrossCompile = cCrossCompile configM,
                      cCrossSafe    = cCrossSafe configM,
+                     cColumn       = cColumn configM,
                      cVerbose      = cVerbose configM,
                      cFlags        = cFlags configM ++ extraFlags
                  }
@@ -200,8 +201,8 @@ parseFile name
        let s' = filter ('\r' /=) s
        case runParser parser name s' of
          Success _ _ _ toks -> return toks
-         Failure (SourcePos name' line) msg ->
-           die (name'++":"++show line++": "++msg++"\n")
+         Failure (SourcePos name' line col) msg ->
+           die (name'++":"++show line++":"++show col++": "++msg++"\n")
 
 getLibDir :: IO (Maybe String)
 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
index edc90c2..71832f5 100644 (file)
@@ -26,9 +26,12 @@ void *hsc_stdout(void);
 #if __NHC__
 #define hsc_line(line, file) \
     hsc_printf ("# %d \"%s\"\n", line, file);
+#define hsc_column(column)
 #else
 #define hsc_line(line, file) \
     hsc_printf ("{-# LINE %d \"%s\" #-}\n", line, file);
+#define hsc_column(column) \
+    hsc_printf ("{-# COLUMN %d #-}", column);
 #endif
 
 #define hsc_const(x...)                               \