-
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
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
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
C.hs 10.06 KiB
module C where
{-
The standard mode for hsc2hs: generates a C file which is
compiled and run; the output of that program is the .hs file.
-}
import Data.Char ( isSpace, intToDigit, ord )
import Data.List ( intersperse )
import System.FilePath ( splitFileName )
import HSCParser ( SourcePos(..), Token(..) )
import Flags
outTemplateHeaderCProg :: FilePath -> String
outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n"
outFlagHeaderCProg :: Flag -> String
outFlagHeaderCProg (Include f) = "#include "++f++"\n"
outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
outFlagHeaderCProg _ = ""
outHeaderCProg :: (SourcePos, String, String) -> String
outHeaderCProg (pos, key, arg) = case key of
"include" -> outCLine pos++"#include "++arg++"\n"
"define" -> outCLine pos++"#define "++arg++"\n"
"undef" -> outCLine pos++"#undef "++arg++"\n"
"def" -> case arg of
's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
_ -> ""
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
"let" -> case break (== '=') arg of
(_, "") -> ""
(header, _:body) -> case break isSpace header of
(name, args) ->
outCLine pos++
"#define hsc_"++name++"("++dropWhile isSpace args++") " ++
"hsc_printf ("++joinLines body++");\n"
_ -> ""
where
joinLines = concat . intersperse " \\\n" . lines
outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
outHeaderHs flags inH toks =
case inH of
Nothing -> concatMap outFlag flags++concatMap outSpecial toks
Just _ -> ""
where
outFlag (Define n Nothing) = outOption ("-optc-D"++n)
outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
outFlag _ = ""
outSpecial (pos, key, arg) = case key of
"define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
| otherwise -> ""
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
goodForOptD arg = case arg of
"" -> True
c:_ | isSpace c -> True
'(':_ -> False
_:s -> goodForOptD s
toOptD arg = case break isSpace arg of
(name, "") -> name
(name, _:value) -> name++'=':dropWhile isSpace value
outOption s =
" hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
showCString s++"\");\n"
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 _ (out, (rowSync, colSync)) (Special pos key arg) =
(out . showString str, (rowSync && null str, colSync && null str))
where
str = case key of
"include" -> ""
"define" -> ""
"undef" -> ""
"def" -> ""
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
"let" -> ""
"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
(_, []) -> Nothing
(t, _:afterT) -> case break (== ',') afterT of
(f, afterF) -> let
enums [] = []
enums (_:s) = case break (== ',') s of
(enum, rest) -> let
this = case break (== '=') $ dropWhile isSpace enum of
(name, []) -> (Nothing, name)
(hsName, _:cName) -> (Just hsName, cName)
in this:enums rest
in Just (t, f, enums afterF)
outEnum :: String -> String
outEnum arg = case parseEnum arg of
Nothing -> ""
Just (t,f,enums) ->
flip concatMap enums $ \(maybeHsName, cName) ->
case maybeHsName of
Nothing ->
" hsc_enum ("++t++", "++f++", " ++
"hsc_haskellize (\""++cName++"\"), "++
cName++");\n"
Just hsName ->
" hsc_enum ("++t++", "++f++", " ++
"hsc_printf (\"%s\", \""++hsName++"\"), "++
cName++");\n"
outFlagH :: Flag -> String
outFlagH (Include f) = "#include "++f++"\n"
outFlagH (Define n Nothing) = "#define "++n++" 1\n"
outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
outFlagH _ = ""
outTokenH :: (SourcePos, String, String) -> String
outTokenH (pos, key, arg) =
case key of
"include" -> outCLine pos++"#include "++arg++"\n"
"define" -> outCLine pos++"#define " ++arg++"\n"
"undef" -> outCLine pos++"#undef " ++arg++"\n"
"def" -> outCLine pos++case arg of
's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
'i':'n':'l':'i':'n':'e':' ':_ ->
"#ifdef __GNUC__\n" ++
"extern\n" ++
"#endif\n"++
arg++"\n"
_ -> "extern "++header++";\n"
where header = takeWhile (\c -> c /= '{' && c /= '=') arg
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
outTokenC :: (SourcePos, String, String) -> String
outTokenC (pos, key, arg) =
case key of
"def" -> case arg of
's':'t':'r':'u':'c':'t':' ':_ -> ""
't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
'i':'n':'l':'i':'n':'e':' ':arg' ->
case span (\c -> c /= '{' && c /= '=') arg' of
(header, body) ->
outCLine pos++
"#ifndef __GNUC__\n" ++
"extern inline\n" ++
"#endif\n"++
header++
"\n#ifndef __GNUC__\n" ++
";\n" ++ "#else\n"++
body++
"\n#endif\n"
_ -> outCLine pos++arg++"\n"
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
conditional :: String -> Bool
conditional "if" = True
conditional "ifdef" = True
conditional "ifndef" = True
conditional "elif" = True
conditional "else" = True
conditional "endif" = True
conditional "error" = True
conditional "warning" = True
conditional _ = False
outCLine :: SourcePos -> String
outCLine (SourcePos name line _) =
"#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n"
outHsLine :: SourcePos -> String
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
showCChar '\"' = "\\\""
showCChar '\'' = "\\\'"
showCChar '?' = "\\?"
showCChar '\\' = "\\\\"
showCChar c | c >= ' ' && c <= '~' = [c]
showCChar '\a' = "\\a"
showCChar '\b' = "\\b"
showCChar '\f' = "\\f"
showCChar '\n' = "\\n\"\n \""
showCChar '\r' = "\\r"
showCChar '\t' = "\\t"
showCChar '\v' = "\\v"
showCChar c = ['\\',
intToDigit (ord c `quot` 64),
intToDigit (ord c `quot` 8 `mod` 8),
intToDigit (ord c `mod` 8)]