From 5271a0583a29cae8e9014518cf0b1361f3193a26 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 23 Jul 2008 15:50:21 +0000 Subject: [PATCH] Use the upstream hsc2hs repo --- darcs-all | 9 +- utils/hsc2hs/LICENSE | 31 -- utils/hsc2hs/Main.hs | 915 ------------------------------------------- utils/hsc2hs/Makefile | 7 - utils/hsc2hs/Makefile.inc | 7 - utils/hsc2hs/Makefile.nhc98 | 48 --- utils/hsc2hs/hsc2hs.cabal | 41 -- utils/hsc2hs/hsc2hs.sh | 2 - utils/hsc2hs/hsc2hs.wrapper | 13 - utils/hsc2hs/template-hsc.h | 105 ----- 10 files changed, 8 insertions(+), 1170 deletions(-) delete mode 100644 utils/hsc2hs/LICENSE delete mode 100644 utils/hsc2hs/Main.hs delete mode 100644 utils/hsc2hs/Makefile delete mode 100644 utils/hsc2hs/Makefile.inc delete mode 100644 utils/hsc2hs/Makefile.nhc98 delete mode 100644 utils/hsc2hs/hsc2hs.cabal delete mode 100644 utils/hsc2hs/hsc2hs.sh delete mode 100644 utils/hsc2hs/hsc2hs.wrapper delete mode 100644 utils/hsc2hs/template-hsc.h diff --git a/darcs-all b/darcs-all index 82245fb..bd8d712 100644 --- a/darcs-all +++ b/darcs-all @@ -2,7 +2,7 @@ use strict; -my @top_dirs = ("nofib", "testsuite"); +my @top_dirs = ("nofib", "testsuite", "utils/hsc2hs"); # Figure out where to get the other repositories from, # based on where this GHC repo came from. @@ -10,6 +10,7 @@ my $defaultrepo = `cat _darcs/prefs/defaultrepo`; chomp $defaultrepo; my $defaultrepo_base; my $defaultrepo_lib; +my $hsc2hs_repo_loc; if ($defaultrepo =~ /^...*:/) { # HTTP or SSH @@ -18,12 +19,14 @@ if ($defaultrepo =~ /^...*:/) { $defaultrepo_base = $defaultrepo; $defaultrepo_base =~ s#/[^/]+/?$##; $defaultrepo_lib = "$defaultrepo_base/packages"; + $hsc2hs_repo_loc = $defaultrepo_base; } elsif ($defaultrepo =~ /^(\.\.)?\//) { # Local filesystem, either absolute or relative path # (assumes a checked-out tree): $defaultrepo_base = $defaultrepo; $defaultrepo_lib = "$defaultrepo/libraries"; + $hsc2hs_repo_loc = "$defaultrepo_base/utils"; } else { die "Couldn't work out defaultrepo"; @@ -116,6 +119,10 @@ sub darcsget { darcsgetpackage($nofib, $r_flags, $defaultrepo_base, "nofib"); darcsgetpackage($testsuite, $r_flags, $defaultrepo_base, "testsuite"); + chdir "utils"; + darcsgetpackage(1 , $r_flags, $hsc2hs_repo_loc, "hsc2hs"); + chdir ".."; + chdir "libraries"; my @packages; diff --git a/utils/hsc2hs/LICENSE b/utils/hsc2hs/LICENSE deleted file mode 100644 index b5059b7..0000000 --- a/utils/hsc2hs/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -The Glasgow Haskell Compiler License - -Copyright 2002, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs deleted file mode 100644 index 4a899c7..0000000 --- a/utils/hsc2hs/Main.hs +++ /dev/null @@ -1,915 +0,0 @@ -{-# OPTIONS -cpp #-} -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - ------------------------------------------------------------------------- --- Program for converting .hsc files to .hs files, by converting the --- file into a C program which is run to generate the Haskell source. --- Certain items known only to the C compiler can then be used in --- the Haskell module; for example #defined constants, byte offsets --- within structures, etc. --- --- See the documentation in the Users' Guide for more details. - -#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) -#include "../../includes/ghcconfig.h" -#endif - -import Control.Monad ( MonadPlus(..), liftM, liftM2, when ) -import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit, - toUpper, intToDigit, ord ) -import Data.List ( intersperse, isSuffixOf ) -import System.Cmd ( system, rawSystem ) -import System.Console.GetOpt - -#if defined(mingw32_HOST_OS) -import Foreign -import Foreign.C.String -#endif -import System.Directory ( removeFile, doesFileExist, findExecutable ) -import System.Environment ( getProgName, getArgs ) -import System.Exit ( ExitCode(..), exitWith ) -import System.IO ( hPutStr, hPutStrLn, stderr ) - -#if __GLASGOW_HASKELL__ >= 604 -import System.Process ( runProcess, waitForProcess ) -import System.IO ( openFile, IOMode(..), hClose ) -#define HAVE_runProcess -#endif - -import IO ( bracket_ ) -import Distribution.Text - -#if ! BUILD_NHC -import Paths_hsc2hs ( getDataFileName, version ) -import Data.Version ( showVersion ) -#else -import System.Directory ( getCurrentDirectory ) -getDataFileName s = do here <- getCurrentDirectory - return (here++"/"++s) -version = "0.67" -- TODO!!! -showVersion = id -#endif - -#ifdef __GLASGOW_HASKELL__ -default_compiler = "ghc" -#else -default_compiler = "gcc" -#endif - -versionString :: String -versionString = "hsc2hs version " ++ showVersion version ++ "\n" - -data Flag - = Help - | Version - | Template String - | Compiler String - | Linker String - | CompFlag String - | LinkFlag String - | NoCompile - | Include String - | Define String (Maybe String) - | Output String - | Verbose - -template_flag :: Flag -> Bool -template_flag (Template _) = True -template_flag _ = False - -include :: String -> Flag -include s@('\"':_) = Include s -include s@('<' :_) = Include s -include s = Include ("\""++s++"\"") - -define :: String -> Flag -define s = case break (== '=') s of - (name, []) -> Define name Nothing - (name, _:value) -> Define name (Just value) - -options :: [OptDescr Flag] -options = [ - Option ['o'] ["output"] (ReqArg Output "FILE") - "name of main output file", - Option ['t'] ["template"] (ReqArg Template "FILE") - "template file", - Option ['c'] ["cc"] (ReqArg Compiler "PROG") - "C compiler to use", - Option ['l'] ["ld"] (ReqArg Linker "PROG") - "linker to use", - Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG") - "flag to pass to the C compiler", - Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR") - "passed to the C compiler", - Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG") - "flag to pass to the linker", - Option ['i'] ["include"] (ReqArg include "FILE") - "as if placed in the source", - Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]") - "as if placed in the source", - Option [] ["no-compile"] (NoArg NoCompile) - "stop after writing *_hsc_make.c", - Option ['v'] ["verbose"] (NoArg Verbose) - "dump commands to stderr", - Option ['?'] ["help"] (NoArg Help) - "display this help and exit", - Option ['V'] ["version"] (NoArg Version) - "output version information and exit" ] - -main :: IO () -main = do - prog <- getProgramName - let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" - args <- getArgs - let (flags, files, errs) = getOpt Permute options args - - -- If there is no Template flag explicitly specified, try - -- to find one. We first look near the executable. This only - -- works on Win32 or Hugs (getExecDir). If this finds a template - -- file then it's certainly the one we want, even if hsc2hs isn't - -- installed where we told Cabal it would be installed. - -- - -- Next we try the location we told Cabal about. - -- - -- If neither of the above work, then hopefully we're on Unix and - -- there's a wrapper script which specifies an explicit template flag. - flags_w_tpl0 <- - if any template_flag flags then return flags - else do mb_path <- getExecDir "/bin/hsc2hs.exe" - mb_templ1 <- - case mb_path of - Nothing -> return Nothing - Just path -> do - -- Euch, this is horrible. Unfortunately - -- Paths_hsc2hs isn't too useful for a - -- relocatable binary, though. - let templ1 = path ++ "/hsc2hs-" ++ display Paths_hsc2hs.version ++ "/template-hsc.h" - exists1 <- doesFileExist templ1 - if exists1 - then return (Just templ1) - else return Nothing - case mb_templ1 of - Just templ1 -> return (Template templ1 : flags) - Nothing -> do - templ2 <- getDataFileName "template-hsc.h" - exists2 <- doesFileExist templ2 - if exists2 then return (Template templ2 : flags) - else return flags - - -- take only the last --template flag on the cmd line - let - (before,tpl:after) = break template_flag (reverse flags_w_tpl0) - flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after) - - case (files, errs) of - (_, _) - | any isHelp flags_w_tpl -> bye (usageInfo header options) - | any isVersion flags_w_tpl -> bye versionString - where - isHelp Help = True; isHelp _ = False - isVersion Version = True; isVersion _ = False - ((_:_), []) -> mapM_ (processFile flags_w_tpl) files - (_, _ ) -> die (concat errs ++ usageInfo header options) - -getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` "-bin") getProgName - where str `withoutSuffix` suff - | suff `isSuffixOf` str = take (length str - length suff) str - | otherwise = str - -bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess - -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - -processFile :: [Flag] -> String -> IO () -processFile flags name - = do let file_name = dosifyPath name - s <- readFile file_name - case parser of - Parser p -> case p (SourcePos file_name 1) s of - Success _ _ _ toks -> output flags file_name toks - Failure (SourcePos name' line) msg -> - die (name'++":"++show line++": "++msg++"\n") - ------------------------------------------------------------------------- --- A deterministic parser which remembers the text which has been parsed. - -newtype Parser a = Parser (SourcePos -> String -> ParseResult a) - -data ParseResult a = Success !SourcePos String String a - | Failure !SourcePos String - -data SourcePos = SourcePos String !Int - -updatePos :: SourcePos -> Char -> SourcePos -updatePos pos@(SourcePos name line) ch = case ch of - '\n' -> SourcePos name (line + 1) - _ -> pos - -instance Monad Parser where - return a = Parser $ \pos s -> Success pos [] s a - Parser m >>= k = - Parser $ \pos s -> case m pos s of - Success pos' out1 s' a -> case k a of - Parser k' -> case k' pos' s' of - Success pos'' out2 imp'' b -> - Success pos'' (out1++out2) imp'' b - Failure pos'' msg -> Failure pos'' msg - Failure pos' msg -> Failure pos' msg - fail msg = Parser $ \pos _ -> Failure pos msg - -instance MonadPlus Parser where - mzero = fail "mzero" - Parser m `mplus` Parser n = - Parser $ \pos s -> case m pos s of - success@(Success _ _ _ _) -> success - Failure _ _ -> n pos s - -getPos :: Parser SourcePos -getPos = Parser $ \pos s -> Success pos [] s pos - -setPos :: SourcePos -> Parser () -setPos pos = Parser $ \_ s -> Success pos [] s () - -message :: Parser a -> String -> Parser a -Parser m `message` msg = - Parser $ \pos s -> case m pos s of - success@(Success _ _ _ _) -> success - Failure pos' _ -> Failure pos' msg - -catchOutput_ :: Parser a -> Parser String -catchOutput_ (Parser m) = - Parser $ \pos s -> case m pos s of - Success pos' out s' _ -> Success pos' [] s' out - Failure pos' msg -> Failure pos' msg - -fakeOutput :: Parser a -> String -> Parser a -Parser m `fakeOutput` out = - Parser $ \pos s -> case m pos s of - Success pos' _ s' a -> Success pos' out s' a - Failure pos' msg -> Failure pos' msg - -lookAhead :: Parser String -lookAhead = Parser $ \pos s -> Success pos [] s s - -satisfy :: (Char -> Bool) -> Parser Char -satisfy p = - Parser $ \pos s -> case s of - c:cs | p c -> Success (updatePos pos c) [c] cs c - _ -> Failure pos "Bad character" - -char_ :: Char -> Parser () -char_ c = do - satisfy (== c) `message` (show c++" expected") - return () - -anyChar_ :: Parser () -anyChar_ = do - satisfy (const True) `message` "Unexpected end of file" - return () - -any2Chars_ :: Parser () -any2Chars_ = anyChar_ >> anyChar_ - -many :: Parser a -> Parser [a] -many p = many1 p `mplus` return [] - -many1 :: Parser a -> Parser [a] -many1 p = liftM2 (:) p (many p) - -many_ :: Parser a -> Parser () -many_ p = many1_ p `mplus` return () - -many1_ :: Parser a -> Parser () -many1_ p = p >> many_ p - -manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String -manySatisfy = many . satisfy -manySatisfy1 = many1 . satisfy - -manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser () -manySatisfy_ = many_ . satisfy -manySatisfy1_ = many1_ . satisfy - ------------------------------------------------------------------------- --- Parser of hsc syntax. - -data Token - = Text SourcePos String - | Special SourcePos String String - -parser :: Parser [Token] -parser = do - pos <- getPos - t <- catchOutput_ text - s <- lookAhead - rest <- case s of - [] -> return [] - _:_ -> liftM2 (:) (special `fakeOutput` []) parser - return (if null t then rest else Text pos t : rest) - -text :: Parser () -text = do - s <- lookAhead - case s of - [] -> return () - c:_ | isAlpha c || c == '_' -> do - anyChar_ - manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') - text - c:_ | isHsSymbol c -> do - symb <- catchOutput_ (manySatisfy_ isHsSymbol) - case symb of - "#" -> return () - '-':'-':symb' | all (== '-') symb' -> do - return () `fakeOutput` symb - manySatisfy_ (/= '\n') - text - _ -> do - return () `fakeOutput` unescapeHashes symb - text - '\"':_ -> do anyChar_; hsString '\"'; text - '\'':_ -> do anyChar_; hsString '\''; text - '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text - _:_ -> do anyChar_; text - -hsString :: Char -> Parser () -hsString quote = do - s <- lookAhead - case s of - [] -> return () - c:_ | c == quote -> anyChar_ - '\\':c:_ - | isSpace c -> do - anyChar_ - manySatisfy_ isSpace - char_ '\\' `mplus` return () - hsString quote - | otherwise -> do any2Chars_; hsString quote - _:_ -> do anyChar_; hsString quote - -hsComment :: Parser () -hsComment = do - s <- lookAhead - case s of - [] -> return () - '-':'}':_ -> any2Chars_ - '{':'-':_ -> do any2Chars_; hsComment; hsComment - _:_ -> do anyChar_; hsComment - -linePragma :: Parser () -linePragma = do - char_ '#' - manySatisfy_ isSpace - satisfy (\c -> c == 'L' || c == 'l') - satisfy (\c -> c == 'I' || c == 'i') - satisfy (\c -> c == 'N' || c == 'n') - satisfy (\c -> c == 'E' || c == 'e') - manySatisfy1_ isSpace - line <- liftM read $ manySatisfy1 isDigit - manySatisfy1_ isSpace - char_ '\"' - name <- manySatisfy (/= '\"') - char_ '\"' - manySatisfy_ isSpace - char_ '#' - char_ '-' - char_ '}' - setPos (SourcePos name (line - 1)) - -isHsSymbol :: Char -> Bool -isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True -isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True -isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True -isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True -isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True -isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True -isHsSymbol '~' = True -isHsSymbol _ = False - -unescapeHashes :: String -> String -unescapeHashes [] = [] -unescapeHashes ('#':'#':s) = '#' : unescapeHashes s -unescapeHashes (c:s) = c : unescapeHashes s - -lookAheadC :: Parser String -lookAheadC = liftM joinLines lookAhead - where - joinLines [] = [] - joinLines ('\\':'\n':s) = joinLines s - joinLines (c:s) = c : joinLines s - -satisfyC :: (Char -> Bool) -> Parser Char -satisfyC p = do - s <- lookAhead - case s of - '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p - _ -> satisfy p - -charC_ :: Char -> Parser () -charC_ c = do - satisfyC (== c) `message` (show c++" expected") - return () - -anyCharC_ :: Parser () -anyCharC_ = do - satisfyC (const True) `message` "Unexpected end of file" - return () - -any2CharsC_ :: Parser () -any2CharsC_ = anyCharC_ >> anyCharC_ - -manySatisfyC :: (Char -> Bool) -> Parser String -manySatisfyC = many . satisfyC - -manySatisfyC_ :: (Char -> Bool) -> Parser () -manySatisfyC_ = many_ . satisfyC - -special :: Parser Token -special = do - manySatisfyC_ (\c -> isSpace c && c /= '\n') - s <- lookAheadC - case s of - '{':_ -> do - anyCharC_ - manySatisfyC_ isSpace - sp <- keyArg (== '\n') - charC_ '}' - return sp - _ -> keyArg (const False) - -keyArg :: (Char -> Bool) -> Parser Token -keyArg eol = do - pos <- getPos - key <- keyword `message` "hsc keyword or '{' expected" - manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c') - arg <- catchOutput_ (argument eol) - return (Special pos key arg) - -keyword :: Parser String -keyword = do - c <- satisfyC (\c' -> isAlpha c' || c' == '_') - cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_') - return (c:cs) - -argument :: (Char -> Bool) -> Parser () -argument eol = do - s <- lookAheadC - case s of - [] -> return () - c:_ | eol c -> do anyCharC_; argument eol - '\n':_ -> return () - '\"':_ -> do anyCharC_; cString '\"'; argument eol - '\'':_ -> do anyCharC_; cString '\''; argument eol - '(':_ -> do anyCharC_; nested ')'; argument eol - ')':_ -> return () - '/':'*':_ -> do any2CharsC_; cComment; argument eol - '/':'/':_ -> do - any2CharsC_; manySatisfyC_ (/= '\n'); argument eol - '[':_ -> do anyCharC_; nested ']'; argument eol - ']':_ -> return () - '{':_ -> do anyCharC_; nested '}'; argument eol - '}':_ -> return () - _:_ -> do anyCharC_; argument eol - -nested :: Char -> Parser () -nested c = do argument (== '\n'); charC_ c - -cComment :: Parser () -cComment = do - s <- lookAheadC - case s of - [] -> return () - '*':'/':_ -> do any2CharsC_ - _:_ -> do anyCharC_; cComment - -cString :: Char -> Parser () -cString quote = do - s <- lookAheadC - case s of - [] -> return () - c:_ | c == quote -> anyCharC_ - '\\':_:_ -> do any2CharsC_; cString quote - _:_ -> do anyCharC_; cString quote - ------------------------------------------------------------------------- --- Write the output files. - -splitName :: String -> (String, String) -splitName name = - case break (== '/') name of - (file, []) -> ([], file) - (dir, sep:rest) -> (dir++sep:restDir, restFile) - where - (restDir, restFile) = splitName rest - -splitExt :: String -> (String, String) -splitExt name = - case break (== '.') name of - (base, []) -> (base, []) - (base, sepRest@(sep:rest)) - | null restExt -> (base, sepRest) - | otherwise -> (base++sep:restBase, restExt) - where - (restBase, restExt) = splitExt rest - -output :: [Flag] -> String -> [Token] -> IO () -output flags name toks = do - - (outName, outDir, outBase) <- case [f | Output f <- flags] of - [] -> if not (null ext) && last ext == 'c' - then return (dir++base++init ext, dir, base) - else - if ext == ".hs" - then return (dir++base++"_out.hs", dir, base) - else return (dir++base++".hs", dir, base) - where - (dir, file) = splitName name - (base, ext) = splitExt file - [f] -> let - (dir, file) = splitName f - (base, _) = splitExt file - in return (f, dir, base) - _ -> onlyOne "output file" - - let cProgName = outDir++outBase++"_hsc_make.c" - oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" -#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) --- This is a real hack, but the quoting mechanism used for calling the C preprocesseor --- via GHC has changed a few times, so this seems to be the only way... :-P * * * - ++ ".exe" -#endif - outHFile = outBase++"_hsc.h" - outHName = outDir++outHFile - outCName = outDir++outBase++"_hsc.c" - - beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags - - let execProgName - | null outDir = dosifyPath ("./" ++ progName) - | otherwise = progName - - let specials = [(pos, key, arg) | Special pos key arg <- toks] - - let needsC = any (\(_, key, _) -> key == "def") specials - needsH = needsC - - let includeGuard = map fixChar outHName - where - fixChar c | isAlphaNum c = toUpper c - | otherwise = '_' - - compiler <- case [c | Compiler c <- flags] of - [] -> do - mb_path <- findExecutable default_compiler - case mb_path of - Nothing -> die ("Can't find "++default_compiler++"\n") - Just path -> return path - cs -> return (last cs) - - linker <- case [l | Linker l <- flags] of - [] -> return compiler - ls -> return (last ls) - - writeFile cProgName $ - concatMap outFlagHeaderCProg flags++ - concatMap outHeaderCProg specials++ - "\nint main (int argc, char *argv [])\n{\n"++ - outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ - outHsLine (SourcePos name 0)++ - concatMap outTokenHs toks++ - " return 0;\n}\n" - - -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code, - -- so we use something slightly more complicated. :-P - when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $ - exitWith ExitSuccess - - rawSystemL ("compiling " ++ cProgName) beVerbose compiler - ( ["-c"] - ++ [f | CompFlag f <- flags] - ++ [cProgName] - ++ ["-o", oProgName] - ) - finallyRemove cProgName $ do - - rawSystemL ("linking " ++ oProgName) beVerbose linker - ( [f | LinkFlag f <- flags] - ++ [oProgName] - ++ ["-o", progName] - ) - finallyRemove oProgName $ do - - rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName - finallyRemove progName $ do - - when needsH $ writeFile outHName $ - "#ifndef "++includeGuard++"\n" ++ - "#define "++includeGuard++"\n" ++ - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ - "#include \n" ++ - "#endif\n" ++ - "#include \n" ++ - "#if __NHC__\n" ++ - "#undef HsChar\n" ++ - "#define HsChar int\n" ++ - "#endif\n" ++ - concatMap outFlagH flags++ - concatMap outTokenH specials++ - "#endif\n" - - when needsC $ writeFile outCName $ - "#include \""++outHFile++"\"\n"++ - concatMap outTokenC specials - -- NB. outHFile not outHName; works better when processed - -- by gcc or mkdependC. - -rawSystemL :: String -> Bool -> FilePath -> [String] -> IO () -rawSystemL action flg prog args = do - let cmdLine = prog++" "++unwords args - when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) - exitStatus <- rawSystem prog args - case exitStatus of - ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n" - _ -> return () - -rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO () -rawSystemWithStdOutL action flg prog args outFile = do - let cmdLine = prog++" "++unwords args++" >"++outFile - when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) -#ifndef HAVE_runProcess - exitStatus <- system cmdLine -#else - hOut <- openFile outFile WriteMode - process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing - exitStatus <- waitForProcess process - hClose hOut -#endif - case exitStatus of - ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n" - _ -> return () - --- delay the cleanup of generated files until the end; attempts to --- get around intermittent failure to delete files which has --- just been exec'ed by a sub-process (Win32 only.) -finallyRemove :: FilePath -> IO a -> IO a -finallyRemove fp act = - bracket_ (return fp) - (const $ noisyRemove fp) - act - where - noisyRemove fpath = - catch (removeFile fpath) - (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e)) - -onlyOne :: String -> IO a -onlyOne what = die ("Only one "++what++" may be specified\n") - -outFlagHeaderCProg :: Flag -> String -outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n" -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++") " ++ - "printf ("++joinLines body++");\n" - _ -> "" - where - joinLines = concat . intersperse " \\\n" . lines - -outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String -outHeaderHs flags inH toks = - "#if " ++ - "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ - " printf (\"{-# OPTIONS -optc-D" ++ - "__GLASGOW_HASKELL__=%d #-}\\n\", " ++ - "__GLASGOW_HASKELL__);\n" ++ - "#endif\n"++ - case inH of - Nothing -> concatMap outFlag flags++concatMap outSpecial toks - Just f -> outInclude ("\""++f++"\"") - where - outFlag (Include f) = outInclude f - 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 - "include" -> outInclude arg - "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 = - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ - " printf (\"{-# OPTIONS %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#else\n"++ - " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#endif\n" - outInclude s = - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ - " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#else\n"++ - " printf (\"{-# INCLUDE %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#endif\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 - where - outText s = " fputs (\""++showCString s++"\", stdout);\n" -outTokenHs (Special pos key arg) = - 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" - -outEnum :: String -> String -outEnum arg = - case break (== ',') arg of - (_, []) -> "" - (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, []) -> - " hsc_enum ("++t++", "++f++", " ++ - "hsc_haskellize (\""++name++"\"), "++ - name++");\n" - (hsName, _:cName) -> - " hsc_enum ("++t++", "++f++", " ++ - "printf (\"%s\", \""++hsName++"\"), "++ - cName++");\n" - in this++enums rest - in enums afterF - -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 (splitName name))++"\"\n" - -outHsLine :: SourcePos -> String -outHsLine (SourcePos name line) = - " hsc_line ("++show (line + 1)++", \""++ - showCString name++"\");\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)] - ------------------------------------------ --- Modified version from ghc/compiler/SysTools --- Convert paths foo/baz to foo\baz on Windows - -subst :: Char -> Char -> String -> String -#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) -subst a b = map (\x -> if x == a then b else x) -#else -subst _ _ = id -#endif - -dosifyPath :: String -> String -dosifyPath = subst '/' '\\' - --- (getExecDir cmd) returns the directory in which the current --- executable, which should be called 'cmd', is running --- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, --- you'll get "/a/b/c" back as the result -getExecDir :: String -> IO (Maybe String) -getExecDir cmd = - getExecPath >>= maybe (return Nothing) removeCmdSuffix - where unDosifyPath = subst '\\' '/' - initN n = reverse . drop n . reverse - removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath - -getExecPath :: IO (Maybe String) -#if defined(mingw32_HOST_OS) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -#else -getExecPath = return Nothing -#endif - diff --git a/utils/hsc2hs/Makefile b/utils/hsc2hs/Makefile deleted file mode 100644 index 1856d27..0000000 --- a/utils/hsc2hs/Makefile +++ /dev/null @@ -1,7 +0,0 @@ - -TOP=../.. -ENABLE_SHELL_WRAPPERS = YES - -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/cabal.mk - diff --git a/utils/hsc2hs/Makefile.inc b/utils/hsc2hs/Makefile.inc deleted file mode 100644 index 91ac818..0000000 --- a/utils/hsc2hs/Makefile.inc +++ /dev/null @@ -1,7 +0,0 @@ -ifeq "" "${MKDIR}" -MKDIR:=$(shell pwd) -#MKDIR:=$(PWD) -else -MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) -endif -include ${MKDIR}/Makefile.inc diff --git a/utils/hsc2hs/Makefile.nhc98 b/utils/hsc2hs/Makefile.nhc98 deleted file mode 100644 index a35a0dc..0000000 --- a/utils/hsc2hs/Makefile.nhc98 +++ /dev/null @@ -1,48 +0,0 @@ -include Makefile.inc - -OBJDIR = ${BUILDDIR}/obj/hsc2hs -TARGET = ${DST}/hsc2hs$(EXE) - -SRCS = Main.hs -FROMC = ../libraries/base/System/Console/GetOpt.$C \ - ../libraries/base/Data/List.$C \ - ../libraries/base/System/Cmd.$C - -ifeq "$(findstring ghc, ${HC})" "ghc" -HFLAGS = $(shell $(LOCAL)fixghc $(GHCSYM) -package base -package lang ) -export HFLAGS -endif -ifeq "$(findstring hbc, ${HC})" "hbc" -HFLAGS = -export HFLAGS -endif -ifeq "$(findstring nhc98, ${HC})" "nhc98" -HFLAGS = -package base +CTS -H4M -CTS -export HFLAGS -endif - -all: $(TARGET) -install: $(TARGET) -cfiles: cleanC $(SRCS) - $(HMAKE) -hc=$(LOCAL)nhc98 -package base -C Main.hs -clean: - -rm -f *.hi *.o $(OBJDIR)/*.o -cleanC: clean - -rm -f *.hc *.c -realclean: clean cleanC - -rm -f $(OBJDIR)/Main$(EXE) - -$(TARGET): $(OBJDIR) $(SRCS) - $(HMAKE) -hc=$(HC) Main -d$(OBJDIR) -DBUILD_NHC \ - $(shell echo "${BUILDOPTS}") $(HFLAGS) $(CYGFLAG) - mv $(OBJDIR)/Main$(EXE) $(TARGET) - $(STRIP) $(TARGET) - -$(OBJDIR): - mkdir -p $(OBJDIR) - -fromC: $(OBJDIR) - cp $(FROMC) . - $(LOCAL)nhc98 -cpp -o $(TARGET) -d$(OBJDIR) *.$C - $(STRIP) $(TARGET) - diff --git a/utils/hsc2hs/hsc2hs.cabal b/utils/hsc2hs/hsc2hs.cabal deleted file mode 100644 index 8d06366..0000000 --- a/utils/hsc2hs/hsc2hs.cabal +++ /dev/null @@ -1,41 +0,0 @@ -Name: hsc2hs -Version: 0.67 -Copyright: 2000, Marcin Kowalczyk -Build-Depends: base, directory, process -License: BSD3 -License-File: LICENSE -Author: Marcin Kowalczyk -Maintainer: cvs-fptools@haskell.org -Synopsis: A preprocessor that helps with writing Haskell bindings to C code -Description: - The hsc2hs program can be used to automate some parts of the - process of writing Haskell bindings to C code. It reads an - almost-Haskell source file with embedded special constructs, and - outputs a real Haskell file with these constructs processed, based - on information taken from some C headers. The extra constructs - provide Haskell counterparts of C types, values of C constants, - including sizes of C types, and access to fields of C structs. - . - For more details, see - http://www.haskell.org/ghc/docs/latest/html/users_guide/hsc2hs.html -Category: Development -Data-Files: template-hsc.h -build-type: Simple -cabal-version: >=1.2 - -Flag base3 - Description: Choose the new smaller, split-up base package. - -Executable hsc2hs - Main-Is: Main.hs - -- needed for ReadP (used by Data.Version) - Hugs-Options: -98 - Extensions: CPP, ForeignFunctionInterface - if flag(base3) - Build-Depends: base >= 3 && < 4, - directory >= 1 && < 1.1, - process >= 1 && < 1.1 - else - Build-Depends: base < 3 - Build-Depends: haskell98, Cabal - diff --git a/utils/hsc2hs/hsc2hs.sh b/utils/hsc2hs/hsc2hs.sh deleted file mode 100644 index 62b5a58..0000000 --- a/utils/hsc2hs/hsc2hs.sh +++ /dev/null @@ -1,2 +0,0 @@ -tflag="--template=$HSC2HS_DIR/template-hsc.h" -$HSC2HS_BINDIR/$HS_PROG $tflag $HSC2HS_EXTRA "$@" diff --git a/utils/hsc2hs/hsc2hs.wrapper b/utils/hsc2hs/hsc2hs.wrapper deleted file mode 100644 index 60d7f96..0000000 --- a/utils/hsc2hs/hsc2hs.wrapper +++ /dev/null @@ -1,13 +0,0 @@ - -tflag="--template=$datadir/template-hsc.h" -for arg do - case "$arg" in - -c*) HSC2HS_EXTRA=;; - --cc=*) HSC2HS_EXTRA=;; - -t*) tflag=;; - --template=*) tflag=;; - --) break;; - esac -done - -exec $executablename $tflag $HSC2HS_EXTRA ${1+"$@"} diff --git a/utils/hsc2hs/template-hsc.h b/utils/hsc2hs/template-hsc.h deleted file mode 100644 index bdc34ed..0000000 --- a/utils/hsc2hs/template-hsc.h +++ /dev/null @@ -1,105 +0,0 @@ -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409 -#include -#endif -#include - -#include -#include -#include -#include -#include - -#ifndef offsetof -#define offsetof(t, f) ((size_t) &((t *)0)->f) -#endif - -#if __NHC__ -#define hsc_line(line, file) \ - printf ("# %d \"%s\"\n", line, file); -#else -#define hsc_line(line, file) \ - printf ("{-# LINE %d \"%s\" #-}\n", line, file); -#endif - -#define hsc_const(x) \ - if ((x) < 0) \ - printf ("%ld", (long)(x)); \ - else \ - printf ("%lu", (unsigned long)(x)); - -#define hsc_const_str(x) \ - { \ - const char *s = (x); \ - printf ("\""); \ - while (*s != '\0') \ - { \ - if (*s == '"' || *s == '\\') \ - printf ("\\%c", *s); \ - else if (*s >= 0x20 && *s <= 0x7E) \ - printf ("%c", *s); \ - else \ - printf ("\\%d%s", \ - (unsigned char) *s, \ - s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \ - ++s; \ - } \ - printf ("\""); \ - } - -#define hsc_type(t) \ - if ((t)(int)(t)1.4 == (t)1.4) \ - printf ("%s%d", \ - (t)(-1) < (t)0 ? "Int" : "Word", \ - sizeof (t) * 8); \ - else \ - printf ("%s", \ - sizeof (t) > sizeof (double) ? "LDouble" : \ - sizeof (t) == sizeof (double) ? "Double" : \ - "Float"); - -#define hsc_peek(t, f) \ - printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", (long) offsetof (t, f)); - -#define hsc_poke(t, f) \ - printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", (long) offsetof (t, f)); - -#define hsc_ptr(t, f) \ - printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", (long) offsetof (t, f)); - -#define hsc_offset(t, f) \ - printf("(%ld)", (long) offsetof (t, f)); - -#define hsc_size(t) \ - printf("(%ld)", (long) sizeof(t)); - -#define hsc_enum(t, f, print_name, x) \ - print_name; \ - printf (" :: %s\n", #t); \ - print_name; \ - printf (" = %s ", #f); \ - if ((x) < 0) \ - printf ("(%ld)\n", (long)(x)); \ - else \ - printf ("%lu\n", (unsigned long)(x)); - -#define hsc_haskellize(x) \ - { \ - const char *s = (x); \ - int upper = 0; \ - if (*s != '\0') \ - { \ - putchar (tolower (*s)); \ - ++s; \ - while (*s != '\0') \ - { \ - if (*s == '_') \ - upper = 1; \ - else \ - { \ - putchar (upper ? toupper (*s) : tolower (*s)); \ - upper = 0; \ - } \ - ++s; \ - } \ - } \ - } -- 1.7.10.4