1module C where
2
3{-
4The standard mode for hsc2hs: generates a C file which is
5compiled and run; the output of that program is the .hs file.
6-}
7
8import Data.Char                ( isSpace, intToDigit, ord )
9import Data.List                ( intersperse )
10import System.FilePath          ( splitFileName )
11
12import HSCParser                ( SourcePos(..), Token(..) )
13import Flags
14
15outTemplateHeaderCProg :: FilePath -> String
16outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n"
17
18outFlagHeaderCProg :: Flag -> String
19outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
20outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++" 1\n"
21outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
22outFlagHeaderCProg _                     = ""
23
24outHeaderCProg :: (SourcePos, String, String) -> String
25outHeaderCProg (pos, key, arg) = case key of
26    "include"           -> outCLine pos++"#include "++arg++"\n"
27    "define"            -> outCLine pos++"#define "++arg++"\n"
28    "undef"             -> outCLine pos++"#undef "++arg++"\n"
29    "def"               -> case arg of
30        's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
31        't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
32        _ -> ""
33    _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
34    "let"               -> case break (== '=') arg of
35        (_,      "")     -> ""
36        (header, _:body) -> case break isSpace header of
37            (name, args) ->
38                outCLine pos++
39                "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
40                "hsc_printf ("++joinLines body++");\n"
41    _ -> ""
42   where
43    joinLines = concat . intersperse " \\\n" . lines
44
45outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
46outHeaderHs flags inH toks =
47    case inH of
48        Nothing -> concatMap outFlag flags++concatMap outSpecial toks
49        Just _  -> ""
50    where
51    outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
52    outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
53    outFlag _                    = ""
54    outSpecial (pos, key, arg) = case key of
55        "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
56                 | otherwise       -> ""
57        _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
58        _                          -> ""
59    goodForOptD arg = case arg of
60        ""              -> True
61        c:_ | isSpace c -> True
62        '(':_           -> False
63        _:s             -> goodForOptD s
64    toOptD arg = case break isSpace arg of
65        (name, "")      -> name
66        (name, _:value) -> name++'=':dropWhile isSpace value
67    outOption s =
68        "    hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
69                  showCString s++"\");\n"
70
71outTokenHs :: Bool                      -- ^ enable COLUMN pragmas?
72           -> (ShowS, (Bool, Bool))
73           -> Token
74           -> (ShowS, (Bool, Bool))
75outTokenHs enableCol (out, state) (Text pos txt) =
76    (out . showString str, state')
77    where
78    (str, state') = outTextHs state pos txt outText outHsLine
79                              (if enableCol then outHsColumn else const "")
80    outText s = "    hsc_fputs (\""++showCString s++"\", hsc_stdout());\n"
81outTokenHs _ (out, (rowSync, colSync)) (Special pos key arg) =
82    (out . showString str, (rowSync && null str, colSync && null str))
83    where
84    str = case key of
85        "include"           -> ""
86        "define"            -> ""
87        "undef"             -> ""
88        "def"               -> ""
89        _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
90        "let"               -> ""
91        "enum"              -> outCLine pos++outEnum arg
92        _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
93
94-- | Output a 'Text' 'Token' literally, making use of the three given output
95-- functions.  The state contains @(lineSync, colSync)@, which indicate
96-- whether the line number and column number in the input are synchronized
97-- with those of the output.
98outTextHs :: (Bool, Bool)               -- ^ state @(lineSync, colSync)@
99          -> SourcePos                  -- ^ original position of the token
100          -> String                     -- ^ text of the token
101          -> (String -> String)         -- ^ output text
102          -> (SourcePos -> String)      -- ^ output LINE pragma
103          -> (Int -> String)            -- ^ output COLUMN pragma
104          -> (String, (Bool, Bool))
105outTextHs (lineSync, colSync) pos@(SourcePos _ _ col) txt
106          outText outLine outColumn =
107    -- Ensure COLUMN pragmas are always inserted right before an identifier.
108    -- They are never inserted in the middle of whitespace, as that could ruin
109    -- the indentation.
110    case break (== '\n') spaces of
111        (_, "") ->
112            case break (== '\n') rest of
113                ("", _) ->
114                    ( outText spaces
115                    , (lineSync, colSync) )
116                (_, "") ->
117                    ( (outText spaces++
118                       updateCol++
119                       outText rest)
120                    , (lineSync, True) )
121                (firstRest, nl:restRest) ->
122                    ( (outText spaces++
123                       updateCol++
124                       outText (firstRest++[nl])++
125                       updateLine++
126                       outText restRest)
127                    , (True, True) )
128        (firstSpaces, nl:restSpaces) ->
129            ( (outText (firstSpaces++[nl])++
130               updateLine++
131               outText (restSpaces++rest))
132            , (True, True) )
133    where
134    (spaces, rest) = span isSpace txt
135    updateLine | lineSync   = ""
136               | otherwise = outLine pos
137    updateCol | colSync   = ""
138              | otherwise = outColumn (col + length spaces)
139
140parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
141parseEnum arg =
142    case break (== ',') arg of
143        (_, [])        -> Nothing
144        (t, _:afterT) -> case break (== ',') afterT of
145            (f, afterF) -> let
146                enums []    = []
147                enums (_:s) = case break (== ',') s of
148                    (enum, rest) -> let
149                        this = case break (== '=') $ dropWhile isSpace enum of
150                            (name, []) -> (Nothing, name)
151                            (hsName, _:cName) -> (Just hsName, cName)
152                        in this:enums rest
153                in Just (t, f, enums afterF)
154
155outEnum :: String -> String
156outEnum arg = case parseEnum arg of
157    Nothing -> ""
158    Just (t,f,enums) ->
159        flip concatMap enums $ \(maybeHsName, cName) ->
160            case maybeHsName of
161               Nothing ->
162                    "    hsc_enum ("++t++", "++f++", " ++
163                    "hsc_haskellize (\""++cName++"\"), "++
164                    cName++");\n"
165               Just hsName ->
166                    "    hsc_enum ("++t++", "++f++", " ++
167                    "hsc_printf (\"%s\", \""++hsName++"\"), "++
168                    cName++");\n"
169
170outFlagH :: Flag -> String
171outFlagH (Include  f)          = "#include "++f++"\n"
172outFlagH (Define   n Nothing)  = "#define "++n++" 1\n"
173outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
174outFlagH _                     = ""
175
176outTokenH :: (SourcePos, String, String) -> String
177outTokenH (pos, key, arg) =
178    case key of
179        "include" -> outCLine pos++"#include "++arg++"\n"
180        "define"  -> outCLine pos++"#define " ++arg++"\n"
181        "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
182        "def"     -> outCLine pos++case arg of
183            's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
184            't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
185            'i':'n':'l':'i':'n':'e':' ':_ ->
186                "#ifdef __GNUC__\n" ++
187                "extern\n" ++
188                "#endif\n"++
189                arg++"\n"
190            _ -> "extern "++header++";\n"
191          where header = takeWhile (\c -> c /= '{' && c /= '=') arg
192        _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
193        _ -> ""
194
195outTokenC :: (SourcePos, String, String) -> String
196outTokenC (pos, key, arg) =
197    case key of
198        "def" -> case arg of
199            's':'t':'r':'u':'c':'t':' ':_ -> ""
200            't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
201            'i':'n':'l':'i':'n':'e':' ':arg' ->
202                case span (\c -> c /= '{' && c /= '=') arg' of
203                (header, body) ->
204                    outCLine pos++
205                    "#ifndef __GNUC__\n" ++
206                    "extern inline\n" ++
207                    "#endif\n"++
208                    header++
209                    "\n#ifndef __GNUC__\n" ++
210                    ";\n" ++
211                    "#else\n"++
212                    body++
213                    "\n#endif\n"
214            _ -> outCLine pos++arg++"\n"
215        _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
216        _ -> ""
217
218conditional :: String -> Bool
219conditional "if"      = True
220conditional "ifdef"   = True
221conditional "ifndef"  = True
222conditional "elif"    = True
223conditional "else"    = True
224conditional "endif"   = True
225conditional "error"   = True
226conditional "warning" = True
227conditional _         = False
228
229outCLine :: SourcePos -> String
230outCLine (SourcePos name line _) =
231    "#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n"
232
233outHsLine :: SourcePos -> String
234outHsLine (SourcePos name line _) =
235    "    hsc_line ("++show (line + 1)++", \""++
236    (showCString . showCString) name ++ "\");\n"
237
238outHsColumn :: Int -> String
239outHsColumn column =
240    "    hsc_column ("++show column++");\n"
241
242showCString :: String -> String
243showCString = concatMap showCChar
244    where
245    showCChar '\"' = "\\\""
246    showCChar '\'' = "\\\'"
247    showCChar '?'  = "\\?"
248    showCChar '\\' = "\\\\"
249    showCChar c | c >= ' ' && c <= '~' = [c]
250    showCChar '\a' = "\\a"
251    showCChar '\b' = "\\b"
252    showCChar '\f' = "\\f"
253    showCChar '\n' = "\\n\"\n           \""
254    showCChar '\r' = "\\r"
255    showCChar '\t' = "\\t"
256    showCChar '\v' = "\\v"
257    showCChar c    = ['\\',
258                      intToDigit (ord c `quot` 64),
259                      intToDigit (ord c `quot` 8 `mod` 8),
260                      intToDigit (ord c          `mod` 8)]
261