Import from darcs

Author: chrisdone

Main.hs

@@ -0,0 +1,6 @@
+
+module Main where
+
+import qualified Make.Main
+
+main = Make.Main.main

Make/CMake.hs

@@ -0,0 +1,126 @@
+
+module Make.CMake(cmake) where
+
+import Make.Useful
+import qualified Data.Map as Map
+import System.Time
+
+
+type Files = Map.Map String (CalendarTime, [FilePath])
+type Dates = Map.Map String CalendarTime
+
+
+cmake :: String -> FilePath -> FilePath -> IO ()
+cmake name dir output = do
+    ghc <- ask "ghc"
+    (_, allfiles) <- getContentsRec dir
+    cfiles <- return $ filter (not . isPrefixOf "hat/") $ filter (".c" `isSuffixOf`) allfiles
+    
+    -- ensure that each file is in the list
+    files <- loadFiles name
+    files <- removeFiles dir files
+    files <- addFiles dir files cfiles
+    saveFiles name files
+    let dates = dateMap files
+
+    ensureDirectory $ "obj" </> name
+    obj <- mapM (buildFile dir ("obj" </> name) dates) cfiles
+    systemSuccess ("ERROR: " ++ output ++ " failed to link") $
+        ghc ++ " " ++ unwords obj ++ " -o " ++ output
+    return ()
+
+
+buildFile :: String -> FilePath -> Dates -> FilePath -> IO FilePath
+buildFile dir output dates file = do
+    ghc <- ask "ghc"
+    let out = output </> takeFileName file ++ ".o"
+    done <- doesFileExist out
+    done <- if not done then return False else do
+        let lastTime = Map.lookup file dates
+        time <- getModificationTime out
+        time <- toCalendarTime time
+        return $ isJust lastTime && time > fromJust (lastTime)
+
+    when (not done) $ do
+        putStrLn $ "Compiling " ++ file
+        systemSuccess ("ERROR: " ++ file ++ " failed to compile") $
+            ghc ++ " " ++ (dir </> file) ++ " -Isrc/runtime/BCKernel -Isrc/runtime/BCKernel/msvc/gmp" ++
+                   " -Idepends/ctypes/libffi_msvc -c -o " ++ out
+    return out
+
+
+
+-- for each file give the newest file it depends on
+-- be stupid, just find a fixed point
+-- also handles circular dependancies correctly
+dateMap :: Files -> Map.Map String CalendarTime
+dateMap files = fix (Map.map fst files)
+    where
+        fix dates = if dates == dates2 then dates else fix dates2 
+            where dates2 = Map.mapWithKey (calc dates) dates
+
+        calc dates file time = maximum (time : map f deps)
+            where
+                f dep = Map.findWithDefault time dep dates
+                deps = snd $ Map.findWithDefault (time,[]) file files 
+
+
+removeFiles :: String -> Files -> IO Files
+removeFiles dir files = filterM check (Map.toAscList files) >>= return . Map.fromAscList
+    where
+        check (file, (modify,_)) = do
+            exists <- doesFileExist (dir </> file)
+            if not exists then return False else do
+                time <- getModificationTime (dir </> file)
+                time <- toCalendarTime time
+                return $ time == modify
+
+
+
+addFiles :: String -> Files -> [FilePath] -> IO Files
+addFiles dir files [] = return files
+addFiles dir files (t:odo)
+    | t `Map.member` files = addFiles dir files odo
+    | otherwise = do
+        time <- getModificationTime (dir </> t)
+        time <- toCalendarTime time
+        incs <- readIncludes dir t
+        addFiles dir (Map.insert t (time,incs) files) (incs++odo)
+
+
+-- from a file, what does it include
+readIncludes :: FilePath -> FilePath -> IO [FilePath]
+readIncludes dir file = readFile (dir </> file) >>= return . map relative . concatMap (f 0) . lines
+    where
+        f 0 x | "#" `isPrefixOf` x2 = f 1 $ trim $ tail x2
+            where x2 = ltrim x
+
+        f 1 x | "include " `isPrefixOf` x = f 2 $ drop 8 x
+
+        f 2 x | n >= 3 && head x == '\"' && last x == '\"' = [take (n-2) $ tail x]
+            where n = length x
+
+        f _ _ = []
+        
+        relative inc = useSlash $ unwords $ collapse $ words $ useSpace $ dropFileName file </> inc
+            where
+                useSlash = replace ' ' '/'
+                useSpace = replace '/' ' '
+                
+                collapse (x:"..":xs) = collapse xs
+                collapse (x:xs) = x : collapse xs
+                collapse [] = []
+        
+
+
+loadFiles :: String -> IO Files
+loadFiles name = do
+    let file = "obj/cmake_cache_" ++ name ++ ".txt"
+    b <- doesFileExist file
+    if b then readFile file >>= return . read else return Map.empty
+
+
+saveFiles :: String -> Files -> IO ()
+saveFiles name files = do
+    let file = "obj/cmake_cache_" ++ name ++ ".txt"
+    writeFile file (show files)

Make/Compile.hs

@@ -0,0 +1,90 @@
+
+module Make.Compile(
+    ensureYhc, ensureYhi, ensureLibraries,
+    yhc, yhi, libraries
+    ) where
+
+import Make.Useful
+import Make.CMake
+
+
+
+ensureYhc = do
+    b <- doesFileExist (exe_ "inst/bin/yhc")
+    when (not b) yhc
+
+ensureYhi = do
+    b <- doesFileExist (exe_ "inst/bin/yhi")
+    when (not b) yhi
+
+ensureLibraries = do
+    b <- doesFileExist "inst/lib/list.txt"
+    when (not b) libraries
+
+
+yhc = do
+    rel <- liftM (== "release") $ ask "type"
+    (ghc:_) <- demand ["ghc","filepath","mtl","cpphs","uniplate"]
+    demandExtra "compiler" "http://darcs.haskell.org/york-compiler98/"
+
+    let obj = "obj/yhc/" ++ if rel then "release" else "normal"
+    ensureDirectory "obj/yhc" >> ensureDirectory obj
+
+    systemSuccess "ERROR: yhc failed to compile" $
+        "ghc extra/compiler/MainYhc.hs --make " ++
+        "-iextra/compiler -isrc/libraries/core " ++
+        "-odir " ++ obj ++ " -hidir " ++ obj ++ " -o " ++ exe_ "inst/bin/yhc" ++
+        if rel then " -O" else ""
+
+
+yhi = do
+    ensureInst "bin"
+    createConfigure
+    cmake "yhi" "src/runtime/BCKernel" "inst/bin/yhi"
+
+
+createConfigure = do
+    let dest = "src/runtime/BCKernel/config.h"
+        src = "Make/src/config.h"
+    rebuild <- shouldBuild src dest
+    same <- if rebuild then return False else do
+        txt <- readFile dest
+        let (line0:line1:_) = lines txt
+        (line2,_) <- replaceVars line0
+        return $ line1 == line2
+    
+    when (not same) $ do
+        txt <- readFile src
+        (txt2, used) <- replaceVars txt
+        let used2 = snub used
+            line0 = unwords $ "/*" : map (\(a,b) -> a ++ "=" ++ "%(" ++ a ++ ")") used2 ++ ["*/"]
+            line1 = unwords $ "/*" : map (\(a,b) -> a ++ "=" ++ b) used2 ++ ["*/"]
+        writeFile dest (line0 ++ "\n" ++ line1 ++ "\n" ++ txt2)
+
+
+replaceVars :: String -> IO (String, [(String,String)])
+replaceVars str = do
+    let (skip,deal) = break (== '%') str
+    if null deal then return (skip,[]) else do
+        let (a,_:b) = break (== ')') $ drop 2 deal
+        val <- ask a
+        val <- return $ if null val then "0" else val
+        (str,bind) <- replaceVars b
+        return (skip++val++str, (a,val):bind)
+
+
+libraries = ensureInst "lib"
+
+
+
+ensureInst x = ensureDirectory "inst" >> ensureDirectory ("inst/" ++ x)
+
+
+demandExtra folder repo = do
+    let out = "extra" </> folder
+    b <- doesDirectoryExist out
+    when (not b) $ do
+        ensureDirectory "extra"
+        [darcs] <- demand ["darcs"]
+        systemSuccess "failed to download extra" $
+            darcs ++ " get --partial --repo-name=extra/" ++ folder ++ " " ++ repo

Make/Configure.hs

@@ -0,0 +1,147 @@
+
+module Make.Configure(configure, ensureConfigure) where
+
+import Make.Profile
+import Make.Useful
+import Make.Depends
+import System.Info
+
+
+ensureConfigure :: IO ()
+ensureConfigure = do
+    valid <- ask "valid"
+    when (null valid) configure
+
+
+typeSizes = ["char","short","int","long","long long","float","double","void*"]
+
+
+configure :: IO ()
+configure = do
+        conf "os" getOS
+        conf "arch" getArch
+
+        confProg "ghc"      $ version [6,6]
+        confProg "ghc-pkg"  $ version [6,4,1]
+        confProg "haddock"  $ version [0,8]
+        confProg "darcs"    $ version [1,0,4]
+        confProg "hscolour" $ version [1,0,4]
+
+        conf "bigendian" getEndian
+        mapM (\x -> conf (filter isAlpha x) (getTypeSize x)) typeSizes
+
+        confHsPackage "filepath" [1,0]
+        confHsPackage "cpphs"    [1,3]
+        confHsPackage "mtl"      [1,0]
+        confHsPackage "uniplate" [1,0]
+
+        setProfile "valid" "1"
+        saveProfile
+    where
+        conf name val = do
+            ans <- ask ('!':name)
+            res <- if null ans then val else return ans
+            putStrLn $ "set " ++ name ++ "=" ++
+                       (if null res then " (blank)" else res) ++
+                       (if null ans then "" else " (user-supplied)")
+            setProfile name res
+
+        confProg name test = do
+            ans <- ask ('!':name)
+            let res = if null ans then name else ans
+            b <- test name res
+            conf name (return $ if b then res else "")
+        
+        confHsPackage name test = do
+            b <- checkHsPackage name test
+            b <- if b then return b else do
+                    b2 <- dependsHsPackage name
+                    if b2 then checkHsPackage name test else return False
+            conf name (return $ if b then "1" else "")
+
+
+
+getOS :: IO String
+getOS = return $ if os == "mingw32" then "win" else os
+
+getArch :: IO String
+getArch = return arch
+
+
+
+-- give an error message if the program given has a lower version
+-- or doesn't run
+version :: [Int] -> String -> String -> IO Bool
+version ver name exe = do
+    -- can't use System.Process because WinHugs 2006
+    let output = "obj/configure_" ++ name ++ ".txt"
+    systemPipeCont (exe ++ " --version") output
+        (do putStrLn $ "WARNING: " ++ name ++ " failed to run: " ++ exe ++ " --version"
+            return False)
+        $ \s -> do
+            let real = parseVersion s
+                success = real >= ver
+            when (not success) $ putStrLn $
+                "WARNING: " ++ name ++ " too old, expected " ++ showVersion ver ++
+                ", found " ++ showVersion real ++ ": " ++ exe
+            return success
+
+
+showVersion :: [Int] -> String
+showVersion = concat . intersperse "." . map show
+
+parseVersion :: String -> [Int]
+parseVersion = map read . words . map (\x -> if x == '.' then ' ' else x) .
+               takeWhile (\x -> isDigit x || x == '.') . dropWhile (not . isDigit)
+
+
+getEndian :: IO String
+getEndian = runC "endian" "Make/src/endian.c" []
+
+
+getTypeSize :: String -> IO String
+getTypeSize name = runC nam "Make/src/typesize.c" [("TYPE",name)]
+    where nam = filter isAlpha name
+
+
+
+
+-- run a C program, return the first line
+runC :: String -> FilePath -> [(String,String)] -> IO String
+runC name file defines = do
+    let nam = "obj/configure_" ++ name
+        defs = unwords ["-optc \"-D" ++ a ++ ['='|not (null b)] ++ b ++ "\"" | (a,b) <- defines]
+    ghc <- ask "ghc"
+    if null ghc
+        then do putStrLn $ "WARNING: " ++ name ++ " skipping, no ghc found" 
+                return []
+        else systemSuccessCont
+            (ghc ++ " " ++ defs ++ " " ++ file ++ " -o " ++ nam ++ " -odir obj")
+            (do putStrLn $ "WARNING: " ++ name ++ " failed to compile test" ; return "") $ do
+            systemPipeCont (slashes nam) (nam ++ ".txt")
+                (do putStrLn $ "WARNING: " ++ name ++ " failed to run test" ; return "") return
+
+
+loadPackageList :: String -> IO [(String,[Int])]
+loadPackageList name = do
+    ghc_pkg <- ask "ghc-pkg"
+    systemPipeCont (ghc_pkg ++ " list --simple-output") ("obj/package_" ++ name ++ ".txt")
+        (do putStrLn $ "WARNING: ghc-pkg could not be queried: " ++ ghc_pkg; return [])
+        (return . map f . filter ('-' `elem`) . words)
+    where
+        f x = (reverse b, parseVersion $ reverse a)
+            where (a,_:b) = break (== '-') $ reverse x
+
+
+checkHsPackage :: String -> [Int] -> IO Bool
+checkHsPackage name ver = do
+    pkg <- loadPackageList name
+    let real = maximum $ [] : [b | (a,b) <- pkg, a == name]
+    if null real then do
+        when (not $ null pkg) $ putStrLn $ "WARNING: package " ++ name ++ " not found"
+        return False
+     else if real < ver then do
+        putStrLn $ "WARNING: package " ++ name ++ " is too old, expected " ++ showVersion ver ++ ", found " ++ showVersion real
+        return False
+     else
+        return True