diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | app/Main.hs | 50 | ||||
| -rw-r--r-- | example_project/app/Hello_world.f90 | 7 | ||||
| -rw-r--r-- | example_project/src/Hello_m.f90 | 12 | ||||
| -rw-r--r-- | package.yaml | 8 | ||||
| -rw-r--r-- | src/Build.hs | 327 |
6 files changed, 401 insertions, 6 deletions
@@ -1,3 +1,4 @@ .stack-work/ fpm.cabal -*~
\ No newline at end of file +*~ +example_project/build/* diff --git a/app/Main.hs b/app/Main.hs index 9d9c5dc..02d54d6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,24 @@ module Main where -import Options.Applicative +import Build ( buildLibrary + , buildPrograms + ) +import Development.Shake ( FilePattern + , (<//>) + , getDirectoryFilesIO + ) +import Development.Shake.FilePath ( (</>) ) +import Options.Applicative ( Parser + , (<**>) + , command + , execParser + , fullDesc + , info + , header + , helper + , progDesc + , subparser + ) newtype Arguments = Arguments { command' :: Command } @@ -9,13 +27,29 @@ 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" </> "library") + "gfortran" + ["-g", "-Wall", "-Wextra", "-Werror", "-pedantic"] + "library" + buildPrograms "app" + ["build" </> "library"] + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + ("build" </> "app") + "gfortran" + ["-g", "-Wall", "-Wextra", "-Werror", "-pedantic"] getArguments :: IO Arguments getArguments = execParser @@ -41,3 +75,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_project/app/Hello_world.f90 b/example_project/app/Hello_world.f90 new file mode 100644 index 0000000..956a6c2 --- /dev/null +++ b/example_project/app/Hello_world.f90 @@ -0,0 +1,7 @@ +program Hello_world + use Hello_m, only: sayHello + + implicit none + + call sayHello("World") +end program Hello_world diff --git a/example_project/src/Hello_m.f90 b/example_project/src/Hello_m.f90 new file mode 100644 index 0000000..60088a2 --- /dev/null +++ b/example_project/src/Hello_m.f90 @@ -0,0 +1,12 @@ +module Hello_m + implicit none + private + + public :: sayHello +contains + subroutine sayHello(name) + character(len=*), intent(in) :: name + + print *, "Hello, " // name // "!" + end subroutine sayHello +end module Hello_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..813c10e --- /dev/null +++ b/src/Build.hs @@ -0,0 +1,327 @@ +module Build + ( buildLibrary + , buildPrograms + ) +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 + , exe + , 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 + +buildPrograms + :: FilePath + -> [FilePath] + -> [FilePattern] + -> FilePath + -> FilePath + -> [String] + -> IO () +buildPrograms programDirectory libraryDirectories sourceExtensions buildDirectory compiler flags + = do + sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions + let sourceFileLookupMap = createSourceFileLookupMap + buildDirectory + programDirectory + sourceFiles + libraryModuleMaps <- mapM getLibraryModuleMap libraryDirectories + let libraryModuleMap = foldl Map.union Map.empty libraryModuleMaps + let includeFlags = map ("-I" ++) libraryDirectories + archives <- getDirectoriesFiles libraryDirectories [".a"] + let executables = map + (sourceFileToExecutable buildDirectory programDirectory) + sourceFiles + shake shakeOptions { shakeFiles = buildDirectory + , shakeChange = ChangeModtimeAndDigest + , shakeColor = True + , shakeThreads = 0 + , shakeProgress = progressSimple + } + $ do + buildDirectory </> "*" <.> "o" %> \objectFile -> do + let + sourceFile = fromMaybe + undefined + (Map.lookup objectFile sourceFileLookupMap) + need [sourceFile] + modulesUsed <- liftIO $ getModulesUsed sourceFile + let + moduleFilesNeeded = mapMaybe + (`Map.lookup` libraryModuleMap) + modulesUsed + need moduleFilesNeeded + cmd compiler + ["-c"] + includeFlags + flags + ["-o", objectFile, sourceFile] + (`elem` executables) ?> \exe -> do + let objectFile = map toLower exe -<.> "o" + need [objectFile] + need archives + cmd compiler objectFile archives ["-o", exe] flags + want executables + +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 + +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 = + 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 '_' |