--
-----------------------------------------------------------------------------
+-- with path so that ghc -M can find config.h
+#include "../includes/config.h"
+
module Main (main) where
import Package
import RegexString
import Concurrent
+#ifndef mingw32_TARGET_OS
import Posix
+#endif
+import Directory
import IOExts
import Exception
import Dynamic
import IO
+import Monad
import Array
import List
import System
import Maybe
import Char
+#ifdef mingw32_TARGET_OS
+foreign import "_getpid" getProcessID :: IO Int
+#endif
+
#define GLOBAL_VAR(name,value,ty) \
name = global (value) :: IORef (ty); \
{-# NOINLINE name #-}
-- mkDLL
-- java generation
-- user ways
--- Win32 support
+-- Win32 support: proper signal handling
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
+-- reading the package configuration file is too slow
-----------------------------------------------------------------------------
-- Differences vs. old driver:
-----------------------------------------------------------------------------
-- non-configured things
-_Haskell1Version = "5" -- i.e., Haskell 98
+cHaskell1Version = "5" -- i.e., Haskell 98
-----------------------------------------------------------------------------
-- Usage Message
exitWith ExitSuccess
long_usage = do
- let usage_dir = findFile "ghc-usage.txt" (_GHC_DRIVER_DIR++"/ghc-usage.txt")
- usage <- readFile (usage_dir++"/ghc-usage.txt")
+ let usage_file = "ghc-usage.txt"
+ usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
+ usage <- readFile usage_path
dump usage
exitWith ExitSuccess
where
dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
dump (c:s) = hPutChar stderr c >> dump s
+version_str = cProjectVersion ++
+ ( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= ""
+ then '.':cProjectPatchLevel
+ else "")
+ -- umm, isn't the patchlevel included in the version number? --SDM
+
-----------------------------------------------------------------------------
-- Phases
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
- | As
| SplitAs
+ | As
| Ln
- deriving (Eq,Ord,Enum,Ix,Show,Bounded)
-
-initial_phase = Unlit
+ deriving (Eq)
-----------------------------------------------------------------------------
-- Errors
| PhaseFailed String ExitCode
| Interrupted
| NoInputFiles
+ | OtherError String
deriving Eq
GLOBAL_VAR(prog_name, "ghc", String)
(map (showString . wayName . lkupWay) ws)
showBarf (NoInputFiles)
= showString "no input files"
+showBarf (OtherError str)
+ = showString str
barfKindTc = mkTyCon "BarfKind"
-- Temporary files
GLOBAL_VAR(files_to_clean, [], [String])
+GLOBAL_VAR(keep_tmp_files, False, Bool)
cleanTempFiles :: IO ()
cleanTempFiles = do
+ forget_it <- readIORef keep_tmp_files
+ unless forget_it $ do
+
fs <- readIORef files_to_clean
verb <- readIORef verbose
let blowAway f =
- (do on verb (hPutStrLn stderr ("removing: " ++ f))
+ (do when verb (hPutStrLn stderr ("removing: " ++ f))
if '*' `elem` f then system ("rm -f " ++ f) >> return ()
- else removeLink f)
+ else removeFile f)
`catchAllIO`
- (\e -> on verb (hPutStrLn stderr
+ (\e -> when verb (hPutStrLn stderr
("warning: can't remove tmp file" ++ f)))
mapM_ blowAway fs
GLOBAL_VAR(stop_after, Ln, Phase)
-end_phase_flag :: String -> Maybe Phase
-end_phase_flag "-M" = Just MkDependHS
-end_phase_flag "-E" = Just Cpp
-end_phase_flag "-C" = Just Hsc
-end_phase_flag "-S" = Just Mangle
-end_phase_flag "-c" = Just As
-end_phase_flag _ = Nothing
+endPhaseFlag :: String -> Maybe Phase
+endPhaseFlag "-M" = Just MkDependHS
+endPhaseFlag "-E" = Just Cpp
+endPhaseFlag "-C" = Just Hsc
+endPhaseFlag "-S" = Just Mangle
+endPhaseFlag "-c" = Just As
+endPhaseFlag _ = Nothing
getStopAfter :: [String]
-> IO ( [String] -- rest of command line
, Phase -- stop after phase
+ , String -- "stop after" flag
, Bool -- do linking?
)
getStopAfter flags
- = case my_partition end_phase_flag flags of
- ([] , rest) -> return (rest, As, True)
- ([one], rest) -> return (rest, one, False)
+ = case my_partition endPhaseFlag flags of
+ ([] , rest) -> return (rest, As, "", True)
+ ([(flag,one)], rest) -> return (rest, one, flag, False)
(_ , rest) -> throwDyn AmbiguousPhase
-----------------------------------------------------------------------------
-- Cpp-related flags
GLOBAL_VAR(cpp_flag, False, Bool)
hs_source_cpp_opts = global
- [ "-D__HASKELL1__="++_Haskell1Version
- , "-D__GLASGOW_HASKELL__="++_ProjectVersionInt
+ [ "-D__HASKELL1__="++cHaskell1Version
+ , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
]
-- Misc
GLOBAL_VAR(dry_run, False, Bool)
GLOBAL_VAR(recomp, True, Bool)
-GLOBAL_VAR(tmp_prefix, _TMPDIR, String)
+GLOBAL_VAR(tmp_prefix, cTMPDIR, String)
GLOBAL_VAR(stolen_x86_regs, 4, Int)
-GLOBAL_VAR(static, True, Bool) -- ToDo: not for mingw32
+#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
+GLOBAL_VAR(static, True, Bool)
+#else
+GLOBAL_VAR(static, False, Bool)
+#endif
GLOBAL_VAR(collect_ghc_timing, False, Bool)
GLOBAL_VAR(do_asm_mangling, True, Bool)
+GLOBAL_VAR(excess_precision, False, Bool)
-----------------------------------------------------------------------------
-- Splitting object files (for libraries)
GLOBAL_VAR(n_split_files, 0, Int)
can_split :: Bool
-can_split = prefixMatch "i386" _TARGETPLATFORM
- || prefixMatch "alpha" _TARGETPLATFORM
- || prefixMatch "hppa" _TARGETPLATFORM
- || prefixMatch "m68k" _TARGETPLATFORM
- || prefixMatch "mips" _TARGETPLATFORM
- || prefixMatch "powerpc" _TARGETPLATFORM
- || prefixMatch "rs6000" _TARGETPLATFORM
- || prefixMatch "sparc" _TARGETPLATFORM
+can_split = prefixMatch "i386" cTARGETPLATFORM
+ || prefixMatch "alpha" cTARGETPLATFORM
+ || prefixMatch "hppa" cTARGETPLATFORM
+ || prefixMatch "m68k" cTARGETPLATFORM
+ || prefixMatch "mips" cTARGETPLATFORM
+ || prefixMatch "powerpc" cTARGETPLATFORM
+ || prefixMatch "rs6000" cTARGETPLATFORM
+ || prefixMatch "sparc" cTARGETPLATFORM
-----------------------------------------------------------------------------
-- Compiler output options
| HscAsm
| HscJava
-GLOBAL_VAR(hsc_lang, if _GhcWithNativeCodeGen == "YES" &&
- prefixMatch "i386" _TARGETPLATFORM
+GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
+ (prefixMatch "i386" cTARGETPLATFORM ||
+ prefixMatch "sparc" cTARGETPLATFORM)
then HscAsm
else HscC,
HscLang)
odir_opt <- readIORef output_dir
case odir_opt of
Nothing -> return f
- Just d -> return (newdir f d)
+ Just d -> return (newdir d f)
osuf_ify :: String -> IO String
osuf_ify f = do
osuf_opt <- readIORef output_suf
case osuf_opt of
Nothing -> return f
- Just s -> return (newsuf f s)
+ Just s -> return (newsuf s f)
-----------------------------------------------------------------------------
-- Hi Files
setOptLevel [c] | isDigit c = do
let level = ord c - ord '0'
writeIORef opt_level level
- on (level >= 1) go_via_C
+ when (level >= 1) go_via_C
setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
go_via_C = do
-----------------------------------------------------------------------------
-- Packages
+GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
+
+listPackages :: IO ()
+listPackages = do
+ details <- readIORef package_details
+ hPutStr stdout (listPkgs details)
+ hPutChar stdout '\n'
+ exitWith ExitSuccess
+
+newPackage :: IO ()
+newPackage = do
+ checkConfigAccess
+ details <- readIORef package_details
+ hPutStr stdout "Reading package info from stdin... "
+ stuff <- getContents
+ let new_pkg = read stuff :: (String,Package)
+ catchAll new_pkg
+ (\e -> throwDyn (OtherError "parse error in package info"))
+ hPutStrLn stdout "done."
+ if (fst new_pkg `elem` map fst details)
+ then throwDyn (OtherError ("package `" ++ fst new_pkg ++
+ "' already installed"))
+ else do
+ conf_file <- readIORef package_config
+ savePackageConfig conf_file
+ maybeRestoreOldConfig conf_file $ do
+ writeNewConfig conf_file ( ++ [new_pkg])
+ exitWith ExitSuccess
+
+deletePackage :: String -> IO ()
+deletePackage pkg = do
+ checkConfigAccess
+ details <- readIORef package_details
+ if (pkg `notElem` map fst details)
+ then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
+ else do
+ conf_file <- readIORef package_config
+ savePackageConfig conf_file
+ maybeRestoreOldConfig conf_file $ do
+ writeNewConfig conf_file (filter ((/= pkg) . fst))
+ exitWith ExitSuccess
+
+checkConfigAccess :: IO ()
+checkConfigAccess = do
+ conf_file <- readIORef package_config
+ access <- getPermissions conf_file
+ unless (writable access)
+ (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
+
+maybeRestoreOldConfig :: String -> IO () -> IO ()
+maybeRestoreOldConfig conf_file io
+ = catchAllIO io (\e -> do
+ hPutStr stdout "\nWARNING: an error was encountered while the new \n\
+ \configuration was being written. Attempting to \n\
+ \restore the old configuration... "
+ system ("cp " ++ conf_file ++ ".old " ++ conf_file)
+ hPutStrLn stdout "done."
+ throw e
+ )
+
+writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
+writeNewConfig conf_file fn = do
+ hPutStr stdout "Writing new package config file... "
+ old_details <- readIORef package_details
+ h <- openFile conf_file WriteMode
+ hPutStr h (dumpPackages (fn old_details))
+ hClose h
+ hPutStrLn stdout "done."
+
+savePackageConfig :: String -> IO ()
+savePackageConfig conf_file = do
+ hPutStr stdout "Saving old package config file... "
+ -- mv rather than cp because we've already done an hGetContents
+ -- on this file so we won't be able to open it for writing
+ -- unless we move the old one out of the way...
+ system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
+ hPutStrLn stdout "done."
+
-- package list is maintained in dependency order
packages = global ["std", "rts", "gmp"] :: IORef [String]
-- comma in value, so can't use macro, grrr
Nothing -> throwDyn (UnknownPackage package)
Just details -> do
ps <- readIORef packages
- if package `elem` ps
- then return ()
- else do mapM_ addPackage (package_deps details)
- ps <- readIORef packages
- writeIORef packages (package:ps)
+ unless (package `elem` ps) $ do
+ mapM_ addPackage (package_deps details)
+ ps <- readIORef packages
+ writeIORef packages (package:ps)
getPackageImportPath :: IO [String]
getPackageImportPath = do
getPackageIncludePath = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (nub (filter (not.null) (map include_dir ps')))
+ return (nub (filter (not.null) (concatMap include_dirs ps')))
-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String]
getPackageCIncludes = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (reverse (nub (filter (not.null) (map c_include ps'))))
+ return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
ps' <- getPackageDetails ps
tag <- readIORef build_tag
let suffix = if null tag then "" else '_':tag
- return (concat (map libraries ps'))
+ return (concat (
+ map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
+ ))
getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_ghc_opts ps')
+ return (concatMap extra_ghc_opts ps')
getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_cc_opts ps')
+ return (concatMap extra_cc_opts ps')
getPackageExtraLdOpts :: IO [String]
getPackageExtraLdOpts = do
ps <- readIORef packages
ps' <- getPackageDetails ps
- return (map extra_ld_opts ps')
+ return (concatMap extra_ld_opts ps')
+getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do
pkg_details <- readIORef package_details
- let getDetails p = case lookup p pkg_details of
- Just details -> return details
- Nothing -> error "getPackageDetails"
- mapM getDetails ps
+ return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
data WayName
= WayProf
| WayUnreg
+ | WayDll
| WayTicky
| WayPar
| WayGran
GLOBAL_VAR(ways, [] ,[WayName])
+-- ToDo: allow WayDll with any other allowed combination
+
allowed_combinations =
[ [WayProf,WayUnreg],
[WayProf,WaySMP] -- works???
[ (WayProf, Way "p" "Profiling"
[ "-fscc-profiling"
, "-DPROFILING"
- , "-optc-DPROFILING" ]),
+ , "-optc-DPROFILING"
+ , "-fvia-C" ]),
(WayTicky, Way "t" "Ticky-ticky Profiling"
[ "-fticky-ticky"
, "-DTICKY_TICKY"
- , "-optc-DTICKY_TICKY" ]),
+ , "-optc-DTICKY_TICKY"
+ , "-fvia-C" ]),
(WayUnreg, Way "u" "Unregisterised"
[ "-optc-DNO_REGS"
, "-optc-DUSE_MINIINTERPRETER"
, "-fno-asm-mangling"
- , "-funregisterised" ]),
+ , "-funregisterised"
+ , "-fvia-C" ]),
+
+ (WayDll, Way "dll" "DLLized"
+ [ ]),
(WayPar, Way "mp" "Parallel"
[ "-fstack-check"
, "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
- , "-package concurrent" ]),
+ , "-package concurrent"
+ , "-fvia-C" ]),
(WayGran, Way "mg" "Gransim"
[ "-fstack-check"
, "-fgransim"
, "-D__GRANSIM__"
, "-optc-DGRAN"
- , "-package concurrent" ]),
+ , "-package concurrent"
+ , "-fvia-C" ]),
- (WaySMP, Way "s" "SMP"
+ (WaySMP, Way "s" "SMP"
[ "-fsmp"
, "-optc-pthread"
, "-optl-pthread"
- , "-optc-DSMP" ]),
+ , "-optc-DSMP"
+ , "-fvia-C" ]),
(WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]),
(WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]),
-----------------------------------------------------------------------------
-- Programs for particular phases
-GLOBAL_VAR(pgm_dep, findFile "mkdependHS" _GHC_MKDEPENDHS, String)
-GLOBAL_VAR(pgm_L, findFile "unlit" _GHC_UNLIT, String)
-GLOBAL_VAR(pgm_P, findFile "hscpp" _GHC_HSCPP, String)
-GLOBAL_VAR(pgm_C, findFile "hsc" _GHC_HSC, String)
-GLOBAL_VAR(pgm_c, _GCC, String)
-GLOBAL_VAR(pgm_m, findFile "ghc-asm" _GHC_MANGLER, String)
-GLOBAL_VAR(pgm_s, findFile "ghc-split" _GHC_SPLIT, String)
-GLOBAL_VAR(pgm_a, _GCC, String)
-GLOBAL_VAR(pgm_l, _GCC, String)
+GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String)
+GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
+GLOBAL_VAR(pgm_P, cRAWCPP, String)
+GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
+GLOBAL_VAR(pgm_c, cGCC, String)
+GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
+GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
+GLOBAL_VAR(pgm_a, cGCC, String)
+GLOBAL_VAR(pgm_l, cGCC, String)
-----------------------------------------------------------------------------
-- Options for particular phases
-- )
machdepCCOpts
- | prefixMatch "alpha" _TARGETPLATFORM
+ | prefixMatch "alpha" cTARGETPLATFORM
= return ( ["-static"], [] )
- | prefixMatch "hppa" _TARGETPLATFORM
+ | prefixMatch "hppa" cTARGETPLATFORM
-- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
-- (very nice, but too bad the HP /usr/include files don't agree.)
= return ( ["-static", "-D_HPUX_SOURCE"], [] )
- | prefixMatch "m68k" _TARGETPLATFORM
+ | prefixMatch "m68k" cTARGETPLATFORM
-- -fno-defer-pop : for the .hc files, we want all the pushing/
-- popping of args to routines to be explicit; if we let things
-- be deferred 'til after an STGJUMP, imminent death is certain!
-- as on iX86, where we *do* steal the frame pointer [%ebp].)
= return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
- | prefixMatch "i386" _TARGETPLATFORM
+ | prefixMatch "i386" cTARGETPLATFORM
-- -fno-defer-pop : basically the same game as for m68k
--
-- -fomit-frame-pointer : *must* in .hc files; because we're stealing
"-DSTOLEN_X86_REGS="++show n_regs ]
)
- | prefixMatch "mips" _TARGETPLATFORM
+ | prefixMatch "mips" cTARGETPLATFORM
= return ( ["static"], [] )
- | prefixMatch "powerpc" _TARGETPLATFORM || prefixMatch "rs6000" _TARGETPLATFORM
+ | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
= return ( ["static"], ["-finhibit-size-directive"] )
| otherwise
-- let-no-escape always on for now
verb <- is_verbose
- let hi_vers = "-fhi-version="++_ProjectVersionInt
+ let hi_vers = "-fhi-version="++cProjectVersionInt
static <- (do s <- readIORef static; if s then return "-static" else return "")
l <- readIORef hsc_lang
l <- hGetLine h
case () of
() | null l -> look h
+ | prefixMatch "#" l -> look h
| prefixMatch "{-# LINE" l -> look h
| Just (opts:_) <- matchRegex optionRegex l
-> return (words opts)
get_source_files :: [String] -> ([String],[String])
get_source_files = partition (('-' /=) . head)
-suffixes :: [(String,Phase)]
-suffixes =
- [ ("lhs", Unlit)
- , ("hs", Cpp)
- , ("hc", HCc)
- , ("c", Cc)
- , ("raw_s", Mangle)
- , ("s", As)
- , ("S", As)
- , ("o", Ln)
- ]
-
-phase_input_ext Unlit = "lhs"
-phase_input_ext Cpp = "lpp"
-phase_input_ext Hsc = "cpp"
-phase_input_ext HCc = "hc"
-phase_input_ext Cc = "c"
-phase_input_ext Mangle = "raw_s"
-phase_input_ext SplitMangle = "split_s" -- not really generated
-phase_input_ext As = "s"
-phase_input_ext SplitAs = "split_s" -- not really generated
-phase_input_ext Ln = "o"
-
-find_phase :: String -> ([(Phase,String)], [String])
- -> ([(Phase,String)], [String])
-find_phase f (phase_srcs, unknown_srcs)
- = case lookup ext suffixes of
- Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
- Nothing -> (phase_srcs, f:unknown_srcs)
- where (basename,ext) = split_filename f
-
-
-find_phases srcs = (phase_srcs, unknown_srcs)
- where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
-
main =
-- all error messages are propagated as exceptions
my_catchDyn (\dyn -> case dyn of
do
-- install signal handlers
main_thread <- myThreadId
+
+#ifndef mingw32_TARGET_OS
let sig_handler = Catch (raiseInThread main_thread
(DynException (toDyn Interrupted)))
installHandler sigQUIT sig_handler Nothing
installHandler sigINT sig_handler Nothing
+#endif
pgm <- getProgName
writeIORef prog_name pgm
argv' <- setTopDir argv
-- read the package configuration
- let conf = findFile "package.conf" (_GHC_DRIVER_DIR++"/package.conf.inplace")
- contents <- readFile conf
+ conf_file <- readIORef package_config
+ contents <- readFile conf_file
writeIORef package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
- (flags2, stop_phase, do_linking) <- getStopAfter argv'
+ (flags2, stop_phase, stop_flag, do_linking) <- getStopAfter argv'
-- process all the other arguments, and get the source files
srcs <- processArgs flags2 []
more_opts <- findBuildTag
_ <- processArgs more_opts []
+ -- get the -v flag
+ verb <- readIORef verbose
+
+ when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+
if stop_phase == MkDependHS -- mkdependHS is special
then do_mkdependHS flags2 srcs
else do
- -- for each source file, find which phase to start at
- let (phase_srcs, unknown_srcs) = find_phases srcs
+ -- for each source file, find which phases to run
+ pipelines <- mapM (genPipeline stop_phase stop_flag) srcs
+ let src_pipelines = zip srcs pipelines
o_file <- readIORef output_file
- if isJust o_file && not do_linking && length phase_srcs > 1
+ if isJust o_file && not do_linking && length srcs > 1
then throwDyn MultipleSrcsOneOutput
else do
- if null unknown_srcs && null phase_srcs
- then throwDyn NoInputFiles
- else do
+ if null srcs then throwDyn NoInputFiles else do
- -- if we have unknown files, and we're not doing linking, complain
- -- (otherwise pass them through to the linker).
- if not (null unknown_srcs) && not do_linking
- then throwDyn (UnknownFileType (head unknown_srcs))
- else do
+ let compileFile (src, phases) =
+ run_pipeline phases src do_linking True orig_base
+ where (orig_base, _) = splitFilename src
- let compileFile :: (Phase, String) -> IO String
- compileFile (phase, src) = do
- let (orig_base, _) = split_filename src
- if phase < Ln -- anything to do?
- then run_pipeline stop_phase do_linking True orig_base (phase,src)
- else return src
+ o_files <- mapM compileFile src_pipelines
- o_files <- mapM compileFile phase_srcs
-
- if do_linking
- then do_link o_files unknown_srcs
- else return ()
+ when do_linking (do_link o_files)
+-----------------------------------------------------------------------------
+-- genPipeline
+--
+-- Herein is all the magic about which phases to run in which order, whether
+-- the intermediate files should be in /tmp or in the current directory,
+-- what the suffix of the intermediate files should be, etc.
-- The following compilation pipeline algorithm is fairly hacky. A
-- better way to do this would be to express the whole comilation as a
-- that the C compiler from the first comilation can be overlapped
-- with the hsc comilation for the second file.
-run_pipeline
- :: Phase -- phase to end on (never Linker)
- -> Bool -- doing linking afterward?
- -> Bool -- take into account -o when generating output?
- -> String -- original basename (eg. Main)
- -> (Phase, String) -- phase to run, input file
- -> IO String -- return final filename
-
-run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
- | phase > last_phase = return input_fn
- | otherwise
- = do
+data IntermediateFileType
+ = Temporary
+ | Persistent
+ deriving (Eq)
+
+-- the first compilation phase for a given file is determined
+-- by its suffix.
+startPhase "lhs" = Unlit
+startPhase "hs" = Cpp
+startPhase "hc" = HCc
+startPhase "c" = Cc
+startPhase "raw_s" = Mangle
+startPhase "s" = As
+startPhase "S" = As
+startPhase "o" = Ln
+
+genPipeline
+ :: Phase -- stop after this phase
+ -> String -- "stop after" flag (for error messages)
+ -> String -- original filename
+ -> IO [ -- list of phases to run for this file
+ (Phase,
+ IntermediateFileType, -- keep the output from this phase?
+ String) -- output file suffix
+ ]
+
+genPipeline stop_after stop_after_flag filename
+ = do
+ split <- readIORef split_object_files
+ mangle <- readIORef do_asm_mangling
+ lang <- readIORef hsc_lang
+ keep_hc <- readIORef keep_hc_files
+ keep_raw_s <- readIORef keep_raw_s_files
+ keep_s <- readIORef keep_s_files
- let (basename,ext) = split_filename input_fn
+ let
+ ----------- ----- ---- --- -- -- - - -
+ start_phase = startPhase suffix
- split <- readIORef split_object_files
- mangle <- readIORef do_asm_mangling
- lang <- readIORef hsc_lang
+ (basename, suffix) = splitFilename filename
- -- figure out what the next phase is. This is
- -- straightforward, apart from the fact that hsc can generate
- -- either C or assembler direct, and assembly mangling is
- -- optional.
- let next_phase =
- case phase of
- Hsc -> case lang of
- HscC -> HCc
- HscAsm -> As
+ haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
+ c_ish_file = suffix `elem` [ "c", "s", "S" ] -- maybe .cc et al.??
- HCc | mangle -> Mangle
- | otherwise -> As
+ pipeline
+ | haskell_ish_file =
+ case lang of
+ HscC | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
+ SplitMangle, SplitAs ]
+ | mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
+ | split -> not_valid
+ | otherwise -> [ Unlit, Cpp, Hsc, HCc, As ]
- Cc -> As
- As -> Ln
+ HscAsm | split -> not_valid
+ | otherwise -> [ Unlit, Cpp, Hsc, As ]
- Mangle | not split -> As
- SplitMangle -> SplitAs
-
- _ -> succ phase
+ HscJava | split -> not_valid
+ | otherwise -> error "not implemented: compiling via Java"
+
+ | c_ish_file = [ Cc, As ]
+ | otherwise = [ ] -- just pass this file through to the linker
+
+ -- ToDo: this is somewhat cryptic
+ not_valid = throwDyn (OtherError ("invalid option combination"))
+ ----------- ----- ---- --- -- -- - - -
+
+ -- this shouldn't happen.
+ if start_phase /= Ln && start_phase `notElem` pipeline
+ then throwDyn (OtherError ("can't find starting phase for "
+ ++ filename))
+ else do
+
+ -- this might happen, eg. ghc -S Foo.o
+ if stop_after /= As && stop_after `notElem` pipeline
+ then throwDyn (OtherError ("flag " ++ stop_after_flag
+ ++ " is incompatible with source file "
+ ++ filename))
+ else do
- -- filename extension for the output
- let new_ext = phase_input_ext next_phase
- -- Figure out what the output from this pass should be called.
+ let
+ ----------- ----- ---- --- -- -- - - -
+ annotatePipeline
+ :: [Phase] -> Phase
+ -> [(Phase, IntermediateFileType, String{-file extension-})]
+ annotatePipeline [] _ = []
+ annotatePipeline (Ln:_) _ = []
+ annotatePipeline (phase:next_phase:ps) stop =
+ (phase, keep_this_output, phase_input_ext next_phase)
+ : annotatePipeline (next_phase:ps) stop
+ where
+ keep_this_output
+ | phase == stop = Persistent
+ | otherwise =
+ case next_phase of
+ Ln -> Persistent
+ Mangle | keep_raw_s -> Persistent
+ As | keep_s -> Persistent
+ HCc | keep_hc -> Persistent
+ _other -> Temporary
+
+ -- add information about output files to the pipeline
+ -- the suffix on an output file is determined by the next phase
+ -- in the pipeline, so we add linking to the end of the pipeline
+ -- to force the output from the final phase to be a .o file.
+ annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_after
+
+ phase_ne p (p1,_,_) = (p1 /= p)
+ ----------- ----- ---- --- -- -- - - -
+
+ return $
+ dropWhile (phase_ne start_phase) .
+ foldr (\p ps -> if phase_ne stop_after p then p:ps else [p]) []
+ $ annotated_pipeline
+
+
+
+-- the output suffix for a given phase is uniquely determined by
+-- the input requirements of the next phase.
+phase_input_ext Unlit = "lhs"
+phase_input_ext Cpp = "lpp"
+phase_input_ext Hsc = "cpp"
+phase_input_ext HCc = "hc"
+phase_input_ext Cc = "c"
+phase_input_ext Mangle = "raw_s"
+phase_input_ext SplitMangle = "split_s" -- not really generated
+phase_input_ext As = "s"
+phase_input_ext SplitAs = "split_s" -- not really generated
+phase_input_ext Ln = "o"
- -- If we're keeping the output from this phase, then we just save
- -- it in the current directory, otherwise we generate a new temp file.
- keep_s <- readIORef keep_s_files
- keep_raw_s <- readIORef keep_raw_s_files
- keep_hc <- readIORef keep_hc_files
- let keep_this_output =
- case next_phase of
- Ln -> True
- Mangle | keep_raw_s -> True -- first enhancement :)
- As | keep_s -> True
- Cc | keep_hc -> True
- _other -> False
+run_pipeline
+ :: [ (Phase, IntermediateFileType, String) ] -- phases to run
+ -> String -- input file
+ -> Bool -- doing linking afterward?
+ -> Bool -- take into account -o when generating output?
+ -> String -- original basename (eg. Main)
+ -> IO String -- return final filename
+
+run_pipeline [] input_fn _ _ _ = return input_fn
+run_pipeline ((phase, keep, o_suffix):phases)
+ input_fn do_linking use_ofile orig_basename
+ = do
output_fn <-
- (if phase == last_phase && not do_linking && use_ofile
+ (if null phases && not do_linking && use_ofile
then do o_file <- readIORef output_file
case o_file of
Just s -> return s
Nothing -> do
- f <- odir_ify (orig_basename ++ '.':new_ext)
+ f <- odir_ify (orig_basename ++ '.':o_suffix)
osuf_ify f
- -- .o files are always kept. .s files and .hc file may be kept.
- else if keep_this_output
- then odir_ify (orig_basename ++ '.':new_ext)
- else do filename <- newTempName new_ext
+ else if keep == Persistent
+ then odir_ify (orig_basename ++ '.':o_suffix)
+ else do filename <- newTempName o_suffix
add files_to_clean filename
return filename
)
run_phase phase orig_basename input_fn output_fn
- run_pipeline last_phase do_linking use_ofile
- orig_basename (next_phase, output_fn)
+ -- sadly, ghc -E is supposed to write the file to stdout. We
+ -- generate <file>.cpp, so we also have to cat the file here.
+ when (null phases && phase == Cpp) $
+ run_something "Dump pre-processed file to stdout"
+ ("cat " ++ output_fn)
+
+ run_pipeline phases output_fn do_linking use_ofile orig_basename
-- find a temporary name that doesn't already exist.
findTempName tmp_dir x
where findTempName tmp_dir x = do
let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
- b <- fileExist filename
+ b <- doesFileExist filename
if b then findTempName tmp_dir (x+1)
else return filename
do_mkdependHS :: [String] -> [String] -> IO ()
do_mkdependHS cmd_opts srcs = do
- -- ToDo: push (@MkDependHS_flags, "-o$Osuffix") if $Osuffix;
- -- # They're not (currently) needed, but we need to quote any -#include options
- -- foreach (@Cmd_opts) {
- -- s/-#include.*$/'$&'/g;
- -- };
+ -- HACK
+ let quote_include_opt o | prefixMatch "-#include" o = "'" ++ o ++ "'"
+ | otherwise = o
mkdependHS <- readIORef pgm_dep
mkdependHS_opts <- getOpts opt_dep
(unwords (mkdependHS :
mkdependHS_opts
++ hs_src_cpp_opts
- ++ ("--" : cmd_opts )
+ ++ ("--" : map quote_include_opt cmd_opts )
++ ("--" : srcs)
))
= do unlit <- readIORef pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
- ("echo '{-# LINE 1 \"" ++input_fn++"\" -}' > "++output_fn++" && "
+ ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
-------------------------------------------------------------------------------
--- HsCpp phase
+-- Cpp phase
run_phase Cpp basename input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
++ include_paths
++ hs_src_cpp_opts
++ hscpp_opts
- ++ [ input_fn, ">>", output_fn ]
+ ++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
run_something "Inefective C pre-processor"
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the import path, since this is
-- what gcc does, and it's probably what you want.
- let (root,dir) = break (=='/') (reverse basename)
- current_dir = if null dir then "." else reverse dir
+ let current_dir = getdir basename
paths <- readIORef include_paths
writeIORef include_paths (current_dir : paths)
add files_to_clean tmp_stub_h
add files_to_clean tmp_stub_c
+ -- figure out where to put the .hi file
+ ohi <- readIORef output_hi
+ hisuf <- readIORef hi_suf
+ let hi_flags = case ohi of
+ Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
+ Just fn -> [ "-hifile="++fn ]
+
+ -- run the compiler!
run_something "Haskell Compiler"
(unwords (hsc : input_fn : (
hsc_opts
- ++ [ hi_flag, " -ofile="++output_fn ]
- ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ]
+ ++ hi_flags
+ ++ [
+ "-ofile="++output_fn,
+ "-F="++tmp_stub_c,
+ "-FH="++tmp_stub_h
+ ]
++ stat_opts
)))
- -- Copy the .hi file into the current dir if it changed
- on doing_hi
- (do ohi <- readIORef output_hi
- hisuf <- readIORef hi_suf
- let hi_target = case ohi of
- Nothing -> basename ++ '.':hisuf
- Just fn -> fn
- new_hi_file <- fileExist tmp_hi_file
- on new_hi_file
- (run_something "Copy hi file"
- (unwords ["mv", tmp_hi_file, hi_target]))
- )
-
-- Generate -Rghc-timing info
- on (timing) (
+ when (timing) (
run_something "Generate timing stats"
- (findFile "ghc-stats" _GHC_STATS ++ ' ':stat_file)
+ (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
)
-- Deal with stubs
let stub_c = basename ++ "_stub.c"
-- copy .h_stub file into current dir if present
- b <- fileExist tmp_stub_h
- on b (do
+ b <- doesFileExist tmp_stub_h
+ when b (do
run_something "Copy stub .h file"
("cp " ++ tmp_stub_h ++ ' ':stub_h)
])
-- compile the _stub.c file w/ gcc
- run_pipeline As False{-no linking-}
+ pipeline <- genPipeline As "" stub_c
+ run_pipeline pipeline stub_c False{-no linking-}
False{-no -o option-}
(basename++"_stub")
- (Cc, stub_c)
add ld_inputs (basename++"_stub.o")
)
run_phase cc_phase basename input_fn output_fn
| cc_phase == Cc || cc_phase == HCc
= do cc <- readIORef pgm_c
- cc_opts <- getOpts opt_c
+ cc_opts <- (getOpts opt_c)
cmdline_include_dirs <- readIORef include_paths
- -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
let hcc = cc_phase == HCc
pkg_extra_cc_opts <- getPackageExtraCcOpts
+ excessPrecision <- readIORef excess_precision
+
run_something "C Compiler"
(unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
++ md_c_flags
then md_regd_c_flags
else [])
++ [ verb, "-S", "-Wimplicit", opt_flag ]
- ++ [ "-D__GLASGOW_HASKELL__="++_ProjectVersionInt ]
+ ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
+#ifdef mingw32_TARGET_OS
+ ++ [" -mno-cygwin"]
+#endif
+ ++ (if excessPrecision then [] else [ "-ffloat-store" ])
++ include_paths
++ pkg_extra_cc_opts
-- ++ [">", ccout]
= do mangler <- readIORef pgm_m
mangler_opts <- getOpts opt_m
machdep_opts <-
- if (prefixMatch "i386" _TARGETPLATFORM)
+ if (prefixMatch "i386" cTARGETPLATFORM)
then do n_regs <- readIORef stolen_x86_regs
return [ show n_regs ]
else return []
split_s_prefix <- readIORef split_prefix
n <- readIORef n_split_files
-
+
odir <- readIORef output_dir
let real_odir = case odir of
Nothing -> basename
Just d -> d
-
+
let assemble_file n = do
let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
let output_o = newdir real_odir
(basename ++ "__" ++ show n ++ ".o")
+ real_o <- osuf_ify output_o
run_something "Assembler"
(unwords (as : as_opts
- ++ [ "-c", "-o ", output_o, input_s ]
+ ++ [ "-c", "-o", real_o, input_s ]
))
mapM_ assemble_file [1..n]
-----------------------------------------------------------------------------
-- Linking
-do_link :: [String] -> [String] -> IO ()
-do_link o_files unknown_srcs = do
+do_link :: [String] -> IO ()
+do_link o_files = do
ln <- readIORef pgm_l
verb <- is_verbose
o_file <- readIORef output_file
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
- let pkg_lib_opts = map ("-l"++) pkg_libs
+ let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
libs <- readIORef cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
-- probably _stub.o files
extra_ld_inputs <- readIORef ld_inputs
+ -- opts from -optl-<blah>
+ extra_ld_opts <- getOpts opt_l
+
run_something "Linker"
(unwords
([ ln, verb, "-o", output_fn ]
- -- ToDo: -u <blah> options
++ o_files
- ++ unknown_srcs
++ extra_ld_inputs
++ lib_path_opts
++ lib_opts
++ pkg_lib_path_opts
++ pkg_lib_opts
++ pkg_extra_ld_opts
+ ++ extra_ld_opts
)
)
run_something phase_name cmd
= do
verb <- readIORef verbose
- if verb then do
+ when verb $ do
putStr phase_name
putStrLn ":"
putStrLn cmd
- else
- return ()
+ hFlush stdout
-- test for -n flag
n <- readIORef dry_run
- if n then return () else do
+ unless n $ do
-- and run it!
- exit_code <- system cmd `catchAllIO`
+#ifndef mingw32_TARGET_OS
+ exit_code <- system cmd `catchAllIO`
+ (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+#else
+ tmp <- newTempName "sh"
+ h <- openFile tmp WriteMode
+ hPutStrLn h cmd
+ hClose h
+ exit_code <- system ("sh - " ++ tmp) `catchAllIO`
(\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ removeFile tmp
+#endif
if exit_code /= ExitSuccess
then throwDyn (PhaseFailed phase_name exit_code)
- else do on verb (putStr "\n")
+ else do when verb (putStr "\n")
return ()
-----------------------------------------------------------------------------
| AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn
| PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn
+-- note that ordering is important in the following list: any flag which
+-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
+-- flags further down the list with the same prefix.
+
opts =
[ ------- help -------------------------------------------------------
( "?" , NoArg long_usage)
------- version ----------------------------------------------------
- , ( "-version" , NoArg (do hPutStrLn stderr (_ProjectName
- ++ ", version " ++ _ProjectVersion
- ++ ", patchlevel " ++ _ProjectPatchLevel)
- exitWith ExitSuccess))
+ , ( "-version" , NoArg (do hPutStrLn stdout (cProjectName
+ ++ ", version " ++ version_str)
+ exitWith ExitSuccess))
+ , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
+ exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
, ( "v" , NoArg (writeIORef verbose True) )
, ( "no-recomp" , NoArg (writeIORef recomp False) )
------- ways --------------------------------------------------------
- , ( "prof" , NoArg (add ways WayProf) )
- , ( "unreg" , NoArg (add ways WayUnreg) )
- , ( "ticky" , NoArg (add ways WayTicky) )
- , ( "parallel" , NoArg (add ways WayPar) )
- , ( "gransim" , NoArg (add ways WayGran) )
- , ( "smp" , NoArg (add ways WaySMP) )
- , ( "debug" , NoArg (add ways WayDebug) )
+ , ( "prof" , NoArg (addNoDups ways WayProf) )
+ , ( "unreg" , NoArg (addNoDups ways WayUnreg) )
+ , ( "dll" , NoArg (addNoDups ways WayDll) )
+ , ( "ticky" , NoArg (addNoDups ways WayTicky) )
+ , ( "parallel" , NoArg (addNoDups ways WayPar) )
+ , ( "gransim" , NoArg (addNoDups ways WayGran) )
+ , ( "smp" , NoArg (addNoDups ways WaySMP) )
+ , ( "debug" , NoArg (addNoDups ways WayDebug) )
-- ToDo: user ways
------- Interface files ---------------------------------------------
------- Miscellaneous -----------------------------------------------
, ( "cpp" , NoArg (writeIORef cpp_flag True) )
- , ( "#include" , SepArg (add cmdline_hc_includes) )
+ , ( "#include" , HasArg (add cmdline_hc_includes) )
+ , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef output_dir . Just) )
, ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) )
, ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) )
, ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) )
+ , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
, ( "split-objs" , NoArg (if can_split
then do writeIORef split_object_files True
- writeIORef hsc_lang HscC
add opt_C "-fglobalise-toplev-names"
add opt_c "-DUSE_SPLIT_MARKERS"
else hPutStrLn stderr
, ( "package" , HasArg (addPackage) )
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
+ , ( "-list-packages" , NoArg (listPackages) )
+ , ( "-add-package" , NoArg (newPackage) )
+ , ( "-delete-package" , SepArg (deletePackage) )
+
------- Specific phases --------------------------------------------
, ( "pgmdep" , HasArg (writeIORef pgm_dep) )
, ( "pgmL" , HasArg (writeIORef pgm_L) )
, ( "optdep" , HasArg (add opt_dep) )
, ( "optL" , HasArg (add opt_L) )
, ( "optP" , HasArg (add opt_P) )
- , ( "optC" , HasArg (add opt_C) )
, ( "optCrts" , HasArg (add opt_Crts) )
+ , ( "optC" , HasArg (add opt_C) )
, ( "optc" , HasArg (add opt_c) )
, ( "optm" , HasArg (add opt_m) )
, ( "opta" , HasArg (add opt_a) )
, ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
+ , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) )
, ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
- , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling True) )
+ , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
, ( "fmax-simplifier-iterations",
Prefix (writeIORef opt_MaxSimplifierIterations . read) )
- , ( "fusagesp", NoArg (do writeIORef opt_UsageSPInf True
- add opt_C "-fusagesp-on") )
+ , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True
+ add opt_C "-fusagesp-on") )
+
+ , ( "fexcess-precision" , NoArg (do writeIORef excess_precision True
+ add opt_C "-fexcess-precision"))
-- flags that are "active negatives"
, ( "fno-implicit-prelude" , PassFlag (add opt_C) )
findArg :: String -> (String,OptKind)
findArg arg
- = case [ (rest,k) | (pat,k) <- opts,
- Just rest <- [my_prefix_match pat arg],
- is_prefix k || null rest ] of
+ = case [ (remove_spaces rest, k) | (pat,k) <- opts,
+ Just rest <- [my_prefix_match pat arg],
+ is_prefix k || null rest ] of
[] -> throwDyn (UnknownFlag ('-':arg))
(one:_) -> one
writeSizeOpt :: IORef Integer -> Integer -> IO ()
writeSizeOpt ref new = do
current <- readIORef ref
- if (new > current)
- then writeIORef ref new
- else return ()
+ when (new > current) $
+ writeIORef ref new
floatOpt :: IORef Double -> String -> IO ()
floatOpt ref str
-----------------------------------------------------------------------------
-- Finding files in the installation
-GLOBAL_VAR(topDir, _libdir, String)
+GLOBAL_VAR(topDir, clibdir, String)
-- grab the last -B option on the command line, and
-- set topDir to its value.
setTopDir args = do
let (minusbs, others) = partition (prefixMatch "-B") args
(case minusbs of
- [] -> writeIORef topDir _libdir
+ [] -> writeIORef topDir clibdir
some -> writeIORef topDir (drop 2 (last some)))
return others
findFile name alt_path = unsafePerformIO (do
top_dir <- readIORef topDir
let installed_file = top_dir ++ '/':name
- let inplace_file = top_dir ++ '/':_CURRENT_DIR ++ '/':alt_path
- b <- fileExist inplace_file
+ let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
+ b <- doesFileExist inplace_file
if b then return inplace_file
else return installed_file
)
-----------------------------------------------------------------------------
-- Utils
-my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
+my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
my_partition p [] = ([],[])
my_partition p (a:as)
= let (bs,cs) = my_partition p as in
case p a of
Nothing -> (bs,a:cs)
- Just b -> (b:bs,cs)
+ Just b -> ((a,b):bs,cs)
my_prefix_match :: String -> String -> Maybe String
my_prefix_match [] rest = Just rest
later = flip finally
-on b io = if b then io >> return (error "on") else return (error "on")
-
my_catch = flip catchAllIO
my_catchDyn = flip catchDyn
global :: a -> IORef a
global a = unsafePerformIO (newIORef a)
-split_filename :: String -> (String,String)
-split_filename f = (reverse rev_basename, reverse rev_ext)
- where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
+splitFilename :: String -> (String,String)
+splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
+ where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
+ stripDot ('.':xs) = xs
+ stripDot xs = xs
split :: Char -> String -> [String]
split c s = case rest of
xs <- readIORef var
writeIORef var (x:xs)
+addNoDups :: Eq a => IORef [a] -> a -> IO ()
+addNoDups var x = do
+ xs <- readIORef var
+ unless (x `elem` xs) $ writeIORef var (x:xs)
+
remove_suffix :: String -> Char -> String
remove_suffix s c
| null pre = reverse suf
newsuf :: String -> String -> String
newsuf suf s = remove_suffix s '.' ++ suf
+-- getdir strips the filename off the input string, returning the directory.
+getdir :: String -> String
+getdir s = if null dir then "." else init dir
+ where dir = take_longest_prefix s '/'
+
newdir :: String -> String -> String
newdir dir s = dir ++ '/':drop_longest_prefix s '/'
+
+remove_spaces :: String -> String
+remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
projects / ghc-hetmet.git / blobdiff