diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | app/Main.hs | 29 | ||||
| -rw-r--r-- | example_library/src/example_m.f90 | 6 | ||||
| -rw-r--r-- | package.yaml | 8 | ||||
| -rw-r--r-- | src/Build.hs | 250 |
5 files changed, 291 insertions, 5 deletions
@@ -1,3 +1,4 @@ .stack-work/ fpm.cabal -*~
\ No newline at end of file +*~ +example_library/build/* diff --git a/app/Main.hs b/app/Main.hs index 68cef7c..e1451af 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,10 @@ module Main where +import Build ( buildLibrary ) +import Development.Shake ( FilePattern + , (<//>) + , getDirectoryFilesIO + ) import Options.Applicative ( Parser , (<**>) , command @@ -19,13 +24,23 @@ data Command = Run | Test | Build main :: IO () main = do args <- getArguments - run args + app args -run :: Arguments -> IO () -run args = case command' args of +app :: Arguments -> IO () +app args = case command' args of Run -> putStrLn "Run" Test -> putStrLn "Test" - Build -> putStrLn "Build" + Build -> build + +build :: IO () +build = do + putStrLn "Building" + buildLibrary "src" + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + "build" + "gfortran" + ["-g", "-Wall", "-Wextra", "-Werror", "-pedantic"] + "library" getArguments :: IO Arguments getArguments = execParser @@ -51,3 +66,9 @@ testArguments = pure $ Arguments Test buildArguments :: Parser Arguments buildArguments = pure $ Arguments Build + +getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] +getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns + where + newPatterns = concatMap appendExts dirs + appendExts dir = map ((dir <//> "*") ++) exts diff --git a/example_library/src/example_m.f90 b/example_library/src/example_m.f90 new file mode 100644 index 0000000..947dcfc --- /dev/null +++ b/example_library/src/example_m.f90 @@ -0,0 +1,6 @@ +module example_m + implicit none + private + + integer, public, parameter :: ANSWER = 42 +end module example_m diff --git a/package.yaml b/package.yaml index 2cf73a8..fd12307 100644 --- a/package.yaml +++ b/package.yaml @@ -21,7 +21,15 @@ description: Please see the README on GitHub at <https://github.com/gith dependencies: - base >= 4.7 && < 5 +- containers +- directory +- filepath +- MissingH - optparse-applicative +- process +- shake +- split + library: source-dirs: src 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 '_' |