From 15031a626d9300a6138b70269b31db9c554768e7 Mon Sep 17 00:00:00 2001 From: qrczak Date: Fri, 12 Jan 2001 22:54:23 +0000 Subject: [PATCH] [project @ 2001-01-12 22:54:22 by qrczak] Expand #-constructs only outside Haskell comments and string literals. --- ghc/docs/users_guide/utils.sgml | 21 ++++++------ ghc/utils/hsc2hs/Main.hs | 70 +++++++++++++++++++++++++++++---------- ghc/utils/hsc2hs/template-hsc.h | 8 +++-- 3 files changed, 69 insertions(+), 30 deletions(-) diff --git a/ghc/docs/users_guide/utils.sgml b/ghc/docs/users_guide/utils.sgml index 4117f8d..965115e 100644 --- a/ghc/docs/users_guide/utils.sgml +++ b/ghc/docs/users_guide/utils.sgml @@ -116,7 +116,7 @@ tags: that gets included into the C code to which the Haskell module will be compiled (when compiled via C) and into the C file. These two files are created when the #def construct - is used. + is used (see below). Actually hsc2hs does not output the Haskell file directly. It creates a C program that includes the headers, @@ -230,17 +230,18 @@ tags: Input syntax All special processing is triggered by the - # character. To output a literal - #, write it twice: ##. + # character placed outside Haskell comments + and string literals. To output a literal #, + write it twice: ##. Otherwise # is followed by optional - spaces and tabs, an alphanumeric key that describes the kind of - processing, and its arguments. Arguments look like C expressions - and extend up to the nearest unmatched ), - ], or }, or to the end of - line outside any () [] {} '' "" /* */. Any - character may be preceded by a backslash and will not be treated - specially. + spaces and tabs, an alphanumeric key that describes the + kind of processing, and its arguments. Arguments look + like C expressions separated by commas and extend up to the + nearest unmatched ), ], + or }, or to the end of line outside any + () [] {} '' "" /* */. Any character may be + preceded by a backslash and will not be treated specially. Meanings of specific keys: diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index a6dd69e..3ab4411 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.7 2001/01/11 19:50:19 qrczak Exp $ +-- $Id: Main.hs,v 1.8 2001/01/12 22:54:23 qrczak Exp $ -- -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk) -- @@ -16,11 +16,11 @@ import System (getProgName, getArgs, ExitCode(..), system, exitWith, exitFail import Directory (removeFile) import Parsec import Monad (liftM, liftM2, when) -import Char (ord, intToDigit, isSpace, isAlphaNum, toUpper) +import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper) import List (intersperse) version :: String -version = "0.64" +version = "hsc2hs-0.64" data Flag = Help @@ -58,7 +58,7 @@ main = do case getOpt Permute options args of (flags, _, _) | any isHelp flags -> putStrLn (usageInfo header options) - | any isVersion flags -> putStrLn ("hsc2hs-"++version) + | any isVersion flags -> putStrLn version where isHelp Help = True; isHelp _ = False isVersion Version = True; isVersion _ = False @@ -73,7 +73,7 @@ processFile :: [Flag] -> String -> IO () processFile flags name = do parsed <- parseFromFile parser name case parsed of - Left err -> print err >> exitFailure + Left err -> do print err; exitFailure Right toks -> output flags name toks data Token @@ -84,7 +84,39 @@ parser :: Parser [Token] parser = many (text <|> special) text :: Parser Token -text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#') +text = + liftM (Text . concat) $ many1 + ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{"))) + <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_') + b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\'')) + return (a:b)) + <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\"")) + <|> (do try (string "##"); return "#") + <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'")) + <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a)) + <|> string "-" + <|> (do try (string "{-"); a <- hsComment; return ("{-"++a)) + <|> string "{" + "Haskell source") + +hsComment :: Parser String +hsComment = + ( (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b)) + <|> try (string "-}") + <|> (do char '-'; b <- hsComment; return ('-':b)) + <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b)) + <|> (do char '{'; b <- hsComment; return ('{':b)) + "Haskell comment") + +hsString :: Char -> Parser String +hsString quote = + liftM concat $ many + ( many1 (noneOf (quote:"\n\\")) + <|> (do char '\\'; a <- escape; return ('\\':a)) + "Haskell character or string") + where + escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\")) + <|> (do a <- anyChar; return [a]) special :: Parser Token special = do @@ -97,13 +129,14 @@ special = do return (Special key arg) argument :: Parser String -> Parser String -argument eol = liftM concat $ many +argument eol = + liftM concat $ many ( many1 (noneOf "\n\"\'()/[\\]{}") <|> eol - <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\"")) - <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'")) + <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\"")) + <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'")) <|> (do char '('; a <- nested; char ')'; return ("("++a++")")) - <|> (do try (string "/*"); comment; return " ") + <|> (do try (string "/*"); cComment; return " ") <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ") <|> string "/" <|> (do char '['; a <- nested; char ']'; return ("["++a++"]")) @@ -112,16 +145,17 @@ argument eol = liftM concat $ many "C expression") where nested = argument (string "\n") -comment :: Parser () -comment = (do skipMany1 (noneOf "*"); comment) - <|> (do try (string "*/"); return ()) - <|> (do char '*'; comment) - "C comment" +cComment :: Parser () +cComment = + ( (do skipMany1 (noneOf "*"); cComment) + <|> (do try (string "*/"); return ()) + <|> (do char '*'; cComment) + "C comment") cString :: Char -> Parser String -cString otherQuote = liftM concat $ many - ( many1 (noneOf "\n\\\'\"") - <|> string [otherQuote] +cString quote = + liftM concat $ many + ( many1 (noneOf (quote:"\n\\")) <|> (do char '\\'; a <- anyChar; return ['\\',a]) "C character or string") diff --git a/ghc/utils/hsc2hs/template-hsc.h b/ghc/utils/hsc2hs/template-hsc.h index 43841f0..c235f24 100644 --- a/ghc/utils/hsc2hs/template-hsc.h +++ b/ghc/utils/hsc2hs/template-hsc.h @@ -12,6 +12,7 @@ #endif #if __GLASGOW_HASKELL__ + static int hsc_options_started; static void hsc_begin_options (void) @@ -38,11 +39,14 @@ static void hsc_end_options (void) { if (hsc_options_started) printf (" #-}\n"); } -#else + +#else /* !__GLASGOW_HASKELL__ */ + #define hsc_begin_options() #define hsc_option(s) #define hsc_end_options() -#endif + +#endif /* !__GLASGOW_HASKELL__ */ #define hsc_const(x) \ if ((x) < 0) \ -- 1.7.10.4