diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Build.hs | 250 |
1 files changed, 250 insertions, 0 deletions
diff --git a/src/Build.hs b/src/Build.hs new file mode 100644 index 0000000..b1cd141 --- /dev/null +++ b/src/Build.hs @@ -0,0 +1,250 @@ +module Build + ( buildLibrary + ) +where + +import Control.Applicative ( (<|>) ) +import Data.Char ( isAsciiLower + , isDigit + , toLower + ) +import Data.List ( intercalate ) +import qualified Data.Map as Map +import Data.Maybe ( fromMaybe + , mapMaybe + ) +import Development.Shake ( FilePattern + , Change(ChangeModtimeAndDigest) + , cmd + , getDirectoryFilesIO + , liftIO + , need + , progressSimple + , shake + , shakeChange + , shakeColor + , shakeFiles + , shakeOptions + , shakeProgress + , shakeThreads + , want + , (<//>) + , (&%>) + , (%>) + ) +import Development.Shake.FilePath ( dropExtension + , makeRelative + , (</>) + , (<.>) + , (-<.>) + ) +import System.FilePath ( splitDirectories ) +import Text.ParserCombinators.ReadP ( ReadP + , char + , eof + , many + , many1 + , option + , readP_to_S + , satisfy + , skipSpaces + , string + ) + +type ModuleName = String + +data LineContents = ModuleUsed ModuleName | Other + +buildLibrary + :: FilePath + -> [FilePattern] + -> FilePath + -> FilePath + -> [String] + -> String + -> IO () +buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags libraryName + = do + sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions + let sourceFileLookupMap = createSourceFileLookupMap + buildDirectory + libraryDirectory + sourceFiles + let moduleLookupMap = createModuleLookupMap buildDirectory + libraryDirectory + sourceFiles + let archiveFile = buildDirectory </> libraryName <.> "a" + shake shakeOptions { shakeFiles = buildDirectory + , shakeChange = ChangeModtimeAndDigest + , shakeColor = True + , shakeThreads = 0 + , shakeProgress = progressSimple + } + $ do + map (\ext -> buildDirectory </> "*" <.> ext) ["o", "mod"] + &%> \[objectFile, moduleFile] -> do + let + sourceFile = fromMaybe + undefined + (Map.lookup objectFile sourceFileLookupMap + ) + need [sourceFile] + modulesUsed <- liftIO $ getModulesUsed sourceFile + let + moduleFilesNeeded = mapMaybe + (`Map.lookup` moduleLookupMap) + modulesUsed + need moduleFilesNeeded + cmd compiler + ["-c", "-J" ++ buildDirectory] + flags + ["-o", objectFile, sourceFile] + archiveFile %> \a -> do + let objectFiles = Map.keys sourceFileLookupMap + need objectFiles + cmd "ar" ["rs"] a objectFiles + want [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 + +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 = + buildDirectory + </> pathSeparatorsToUnderscores + (makeRelative libraryDirectory sourceFile) + -<.> "o" + +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 '_' |