From 1830d3e9bedb9da860de9682b43696fd6172f34f Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Tue, 20 Oct 2020 16:48:19 -0500 Subject: Utilize new model for build process --- bootstrap/src/Build.hs | 360 +++++++++++-------------------------------------- 1 file changed, 79 insertions(+), 281 deletions(-) (limited to 'bootstrap/src/Build.hs') diff --git a/bootstrap/src/Build.hs b/bootstrap/src/Build.hs index cdcbb02..fb5f2a9 100644 --- a/bootstrap/src/Build.hs +++ b/bootstrap/src/Build.hs @@ -6,25 +6,22 @@ module Build ) where -import Control.Applicative ( (<|>) ) -import Control.Monad ( filterM ) -import Data.Char ( isAsciiLower - , isDigit - , toLower +import BuildModel ( CompileTimeInfo(..) + , RawSource(..) + , Source(..) + , constructCompileTimeInfo + , getAllObjectFiles + , getAvailableModules + , processRawSource ) import Data.List ( intercalate , isSuffixOf ) import Data.List.Utils ( replace ) -import qualified Data.Map as Map -import Data.Maybe ( fromMaybe - , mapMaybe - ) import Development.Shake ( FilePattern , Change(ChangeModtimeAndDigest) , cmd , getDirectoryFilesIO - , liftIO , need , progressSimple , shake @@ -36,39 +33,19 @@ import Development.Shake ( FilePattern , shakeThreads , want , () - , (&%>) , (%>) - , (?>) + , (&?>) ) -import Development.Shake.FilePath ( dropExtension - , exe - , makeRelative +import Development.Shake.FilePath ( exe , () , (<.>) - , (-<.>) ) +import System.Environment ( setEnv ) +import System.Process ( system ) import System.Directory ( createDirectoryIfMissing , makeAbsolute , withCurrentDirectory ) -import System.Environment ( setEnv ) -import System.FilePath ( splitDirectories ) -import System.Process ( system ) -import Text.ParserCombinators.ReadP ( ReadP - , char - , eof - , many - , many1 - , option - , readP_to_S - , satisfy - , skipSpaces - , string - ) - -type ModuleName = String - -data LineContents = ModuleUsed ModuleName | Other buildProgram :: FilePath @@ -83,27 +60,19 @@ buildProgram -> IO () buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory compiler flags programName programSource archives = do - sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions - canonicalProgramSource <- makeAbsolute $ programDirectory programSource - moduleSourceFiles <- filterM - (\source -> do - canonicalSource <- makeAbsolute source - return $ canonicalProgramSource /= canonicalSource - ) - sourceFiles - let moduleObjectFiles = map - (sourceFileToObjectFile buildDirectory programDirectory) - moduleSourceFiles - let sourceFileLookupMap = createSourceFileLookupMap buildDirectory - programDirectory - moduleSourceFiles - let moduleLookupMap = createModuleLookupMap buildDirectory - programDirectory - moduleSourceFiles - otherModuleMaps <- mapM getLibraryModuleMap libraryDirectories - let allModuleMaps = - moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps let includeFlags = map ("-I" ++) libraryDirectories + sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions + rawSources <- mapM sourceFileToRawSource sourceFiles + let sources' = map processRawSource rawSources + let isThisProgramOrNotProgram p@(Program{}) = + programSourceFileName p == programDirectory programSource + isThisProgramOrNotProgram _ = True + let sources = filter isThisProgramOrNotProgram sources' + let availableModules = getAvailableModules sources + let compileTimeInfo = map + (\s -> constructCompileTimeInfo s availableModules buildDirectory) + sources + let objectFiles = getAllObjectFiles buildDirectory sources shake shakeOptions { shakeFiles = buildDirectory , shakeChange = ChangeModtimeAndDigest , shakeColor = True @@ -111,47 +80,29 @@ buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory , shakeProgress = progressSimple } $ do - want [buildDirectory programName <.> exe] - buildDirectory programName <.> exe %> \executable -> do - let objectFile = sourceFileToObjectFile buildDirectory - programDirectory - programSource - let allObjectFiles = objectFile : moduleObjectFiles - need allObjectFiles - need archives - cmd compiler allObjectFiles archives ["-o", executable] flags - buildDirectory (map toLower programSource) -<.> "o" %> \objectFile -> do - let realObjectFile = foldl () "" $ splitDirectories objectFile - let sourceFile = programDirectory programSource - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) libraryDirectories - need moduleFilesNeeded - cmd compiler - ["-c", "-J" ++ buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - map (\ext -> buildDirectory "*" <.> ext) ["o", "mod"] - &%> \[objectFile, moduleFile] -> do - let realObjectFile = - foldl () "" $ splitDirectories objectFile - let sourceFile = fromMaybe - undefined - (Map.lookup realObjectFile sourceFileLookupMap) - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) libraryDirectories - need moduleFilesNeeded + let + infoToRule cti = + let + obj = compileTimeInfoObjectFileProduced cti + other = compileTimeInfoOtherFilesProduced cti + directDependencies = compileTimeInfoDirectDependencies cti + sourceFile = compileTimeInfoSourceFileName cti + fileMatcher f = if f == obj || f `elem` other + then Just (obj : other) + else Nothing + in + fileMatcher &?> \(objectFile : _) -> do + need (sourceFile : directDependencies) cmd compiler ["-c", "-J" ++ buildDirectory] includeFlags flags ["-o", objectFile, sourceFile] + want [buildDirectory programName <.> exe] + buildDirectory programName <.> exe %> \executable -> do + need objectFiles + cmd compiler objectFiles archives ["-o", executable] flags + mapM_ infoToRule compileTimeInfo buildLibrary :: FilePath @@ -164,14 +115,15 @@ buildLibrary -> IO (FilePath) buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags libraryName otherLibraryDirectories = do + let includeFlags = map ("-I" ++) otherLibraryDirectories sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions - let sourceFileLookupMap = - createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles - let moduleLookupMap = - createModuleLookupMap buildDirectory libraryDirectory sourceFiles - otherModuleMaps <- mapM getLibraryModuleMap otherLibraryDirectories - let allModuleMaps = - moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps + rawSources <- mapM sourceFileToRawSource sourceFiles + let sources = map processRawSource rawSources + let availableModules = getAvailableModules sources + let compileTimeInfo = map + (\s -> constructCompileTimeInfo s availableModules buildDirectory) + sources + let objectFiles = getAllObjectFiles buildDirectory sources let archiveFile = buildDirectory "lib" ++ libraryName <.> "a" shake shakeOptions { shakeFiles = buildDirectory , shakeChange = ChangeModtimeAndDigest @@ -180,196 +132,31 @@ buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags lib , shakeProgress = progressSimple } $ do - map (\ext -> buildDirectory "*" <.> ext) ["o", "mod"] - &%> \[objectFile, moduleFile] -> do - let realObjectFile = - foldl () "" $ splitDirectories objectFile - let sourceFile = fromMaybe - undefined - (Map.lookup realObjectFile sourceFileLookupMap) - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) otherLibraryDirectories - need moduleFilesNeeded + let + infoToRule cti = + let + obj = compileTimeInfoObjectFileProduced cti + other = compileTimeInfoOtherFilesProduced cti + directDependencies = compileTimeInfoDirectDependencies cti + sourceFile = compileTimeInfoSourceFileName cti + fileMatcher f = if f == obj || f `elem` other + then Just (obj : other) + else Nothing + in + fileMatcher &?> \(objectFile : _) -> do + need (sourceFile : directDependencies) cmd compiler ["-c", "-J" ++ buildDirectory] includeFlags flags ["-o", objectFile, sourceFile] + want [archiveFile] archiveFile %> \a -> do - let objectFiles = Map.keys sourceFileLookupMap need objectFiles cmd "ar" ["rs"] a objectFiles - want [archiveFile] + mapM_ infoToRule compileTimeInfo return archiveFile --- A little wrapper around getDirectoryFiles so we can get files from multiple directories -getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] -getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns - where - newPatterns = concatMap appendExts dirs - appendExts dir = map ((dir "*") ++) exts - -getLibraryModuleMap :: FilePath -> IO (Map.Map ModuleName FilePath) -getLibraryModuleMap libraryDirectory = do - moduleFiles <- getDirectoriesFiles [libraryDirectory] ["*.mod"] - let moduleMap = foldl - Map.union - Map.empty - (map (\m -> Map.singleton (moduleFileToModuleName m) m) moduleFiles) - return moduleMap - where - moduleFileToModuleName moduleFile = - map toLower $ dropExtension (makeRelative libraryDirectory moduleFile) - -createSourceFileLookupMap - :: FilePath -> FilePath -> [FilePath] -> Map.Map FilePath FilePath -createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles = foldl - Map.union - Map.empty - (map (createSourceToObjectMap buildDirectory libraryDirectory) sourceFiles) - -createModuleLookupMap - :: FilePath -> FilePath -> [FilePath] -> Map.Map ModuleName FilePath -createModuleLookupMap buildDirectory libraryDirectory sourceFiles = foldl - Map.union - Map.empty - (map (createSourceToModuleMap buildDirectory libraryDirectory) sourceFiles) - -createSourceToModuleMap - :: FilePath -> FilePath -> FilePath -> Map.Map ModuleName FilePath -createSourceToModuleMap buildDirectory libraryDirectory sourceFile = - Map.singleton - (sourceFileToModuleName libraryDirectory sourceFile) - (sourceFileToModFile buildDirectory libraryDirectory sourceFile) - -sourceFileToModuleName :: FilePath -> FilePath -> ModuleName -sourceFileToModuleName libraryDirectory sourceFile = - map toLower $ pathSeparatorsToUnderscores - (dropExtension (makeRelative libraryDirectory sourceFile)) - -createSourceToObjectMap - :: FilePath -> FilePath -> FilePath -> Map.Map FilePath FilePath -createSourceToObjectMap buildDirectory libraryDirectory sourceFile = - Map.singleton - (sourceFileToObjectFile buildDirectory libraryDirectory sourceFile) - sourceFile - -sourceFileToObjectFile :: FilePath -> FilePath -> FilePath -> FilePath -sourceFileToObjectFile buildDirectory libraryDirectory sourceFile = - (foldl () "" $ splitDirectories buildDirectory) - map - toLower - (pathSeparatorsToUnderscores - (makeRelative libraryDirectory sourceFile) - ) - -<.> "o" - -sourceFileToExecutable :: FilePath -> FilePath -> FilePath -> FilePath -sourceFileToExecutable buildDirectory appDirectory sourceFile = - buildDirectory - pathSeparatorsToUnderscores (makeRelative appDirectory sourceFile) - -<.> exe - -sourceFileToModFile :: FilePath -> FilePath -> FilePath -> FilePath -sourceFileToModFile buildDirectory libraryDirectory sourceFile = - buildDirectory - map - toLower - (pathSeparatorsToUnderscores - (makeRelative libraryDirectory sourceFile) - ) - -<.> "mod" - -pathSeparatorsToUnderscores :: FilePath -> FilePath -pathSeparatorsToUnderscores fileName = - intercalate "_" (splitDirectories fileName) - -getModulesUsed :: FilePath -> IO [ModuleName] -getModulesUsed sourceFile = do - fileLines <- readFileLinesIO sourceFile - let lineContents = map parseFortranLine fileLines - return $ contentsToModuleNames lineContents - -contentsToModuleNames :: [LineContents] -> [ModuleName] -contentsToModuleNames = mapMaybe contentToMaybeModuleName - where - contentToMaybeModuleName content = case content of - ModuleUsed moduleName -> Just moduleName - _ -> Nothing - -readFileLinesIO :: FilePath -> IO [String] -readFileLinesIO file = do - contents <- readFile file - return $ lines contents - -parseFortranLine :: String -> LineContents -parseFortranLine line = - let line' = map toLower line - result = readP_to_S doFortranLineParse line' - in getResult result - where - getResult (_ : (contents, _) : _) = contents - getResult [(contents, _) ] = contents - getResult [] = Other - -doFortranLineParse :: ReadP LineContents -doFortranLineParse = option Other fortranUsefulContents - -fortranUsefulContents :: ReadP LineContents -fortranUsefulContents = useStatement - -useStatement :: ReadP LineContents -useStatement = do - skipSpaces - _ <- string "use" - skipAtLeastOneWhiteSpace - modName <- validIdentifier - skipSpaceCommaOrEnd - return $ ModuleUsed modName - -skipAtLeastOneWhiteSpace :: ReadP () -skipAtLeastOneWhiteSpace = do - _ <- many1 whiteSpace - return () - -skipSpaceOrEnd :: ReadP () -skipSpaceOrEnd = eof <|> skipAtLeastOneWhiteSpace - -skipSpaceCommaOrEnd :: ReadP () -skipSpaceCommaOrEnd = eof <|> skipComma <|> skipAtLeastOneWhiteSpace - -skipComma :: ReadP () -skipComma = do - _ <- char ',' - return () - -whiteSpace :: ReadP Char -whiteSpace = satisfy (`elem` " \t") - -validIdentifier :: ReadP String -validIdentifier = do - first <- validFirstCharacter - rest <- many validIdentifierCharacter - return $ first : rest - -validFirstCharacter :: ReadP Char -validFirstCharacter = alphabet - -validIdentifierCharacter :: ReadP Char -validIdentifierCharacter = alphabet <|> digit <|> underscore - -alphabet :: ReadP Char -alphabet = satisfy isAsciiLower - -digit :: ReadP Char -digit = satisfy isDigit - -underscore :: ReadP Char -underscore = char '_' - buildWithScript :: String -> FilePath @@ -387,12 +174,11 @@ buildWithScript script projectDirectory buildDirectory compiler flags libraryNam setEnv "FC" compiler setEnv "FFLAGS" (intercalate " " flags) setEnv "BUILD_DIR" $ unWindowsPath absoluteBuildDirectory - setEnv - "INCLUDE_DIRS" - (intercalate " " (map unWindowsPath absoluteLibraryDirectories)) + setEnv "INCLUDE_DIRS" + (intercalate " " (map unWindowsPath absoluteLibraryDirectories)) let archiveFile = (unWindowsPath absoluteBuildDirectory) - ++ "/lib" + ++ "/lib" ++ libraryName <.> "a" withCurrentDirectory @@ -403,6 +189,18 @@ buildWithScript script projectDirectory buildDirectory compiler flags libraryNam | otherwise -> system (script ++ " " ++ archiveFile) return archiveFile +-- A little wrapper around getDirectoryFiles so we can get files from multiple directories +getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] +getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns + where + newPatterns = concatMap appendExts dirs + appendExts dir = map ((dir "*") ++) exts + +sourceFileToRawSource :: FilePath -> IO RawSource +sourceFileToRawSource sourceFile = do + contents <- readFile sourceFile + return $ RawSource sourceFile contents + isMakefile :: String -> Bool isMakefile script | script == "Makefile" = True | script == "makefile" = True -- cgit v1.2.3