From 2573315e014303cda41682003bafa7e0a6f00167 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Tue, 25 Feb 2020 14:27:08 -0800 Subject: Add explicit import --- app/Main.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 9d9c5dc..68cef7c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,16 @@ module Main where -import Options.Applicative +import Options.Applicative ( Parser + , (<**>) + , command + , execParser + , fullDesc + , info + , header + , helper + , progDesc + , subparser + ) newtype Arguments = Arguments { command' :: Command } -- cgit v1.2.3 From 775841b8437adf4f400a21fa939156dc6ef48cc2 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Thu, 27 Feb 2020 10:22:38 -0800 Subject: Enable building a library --- .gitignore | 3 +- app/Main.hs | 29 ++++- example_library/src/example_m.f90 | 6 + package.yaml | 8 ++ src/Build.hs | 250 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 291 insertions(+), 5 deletions(-) create mode 100644 example_library/src/example_m.f90 create mode 100644 src/Build.hs diff --git a/.gitignore b/.gitignore index 50e5ce9..39e2861 100644 --- a/.gitignore +++ b/.gitignore @@ -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 = 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 '_' -- cgit v1.2.3 From d4c0aea26050b32bf394eabe91c95ab56113ce1a Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Thu, 27 Feb 2020 21:01:13 -0800 Subject: Enable building executables --- .gitignore | 2 +- app/Main.hs | 13 ++++++- example_library/src/example_m.f90 | 6 --- example_project/app/hello_world.f90 | 7 ++++ example_project/src/hello_m.f90 | 12 ++++++ src/Build.hs | 74 +++++++++++++++++++++++++++++++++++++ 6 files changed, 105 insertions(+), 9 deletions(-) delete mode 100644 example_library/src/example_m.f90 create mode 100644 example_project/app/hello_world.f90 create mode 100644 example_project/src/hello_m.f90 diff --git a/.gitignore b/.gitignore index 39e2861..e125769 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ .stack-work/ fpm.cabal *~ -example_library/build/* +example_project/build/* diff --git a/app/Main.hs b/app/Main.hs index e1451af..02d54d6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,13 @@ module Main where -import Build ( buildLibrary ) +import Build ( buildLibrary + , buildPrograms + ) import Development.Shake ( FilePattern , () , getDirectoryFilesIO ) +import Development.Shake.FilePath ( () ) import Options.Applicative ( Parser , (<**>) , command @@ -37,10 +40,16 @@ build = do putStrLn "Building" buildLibrary "src" [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - "build" + ("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 diff --git a/example_library/src/example_m.f90 b/example_library/src/example_m.f90 deleted file mode 100644 index 947dcfc..0000000 --- a/example_library/src/example_m.f90 +++ /dev/null @@ -1,6 +0,0 @@ -module example_m - implicit none - private - - integer, public, parameter :: ANSWER = 42 -end module example_m diff --git a/example_project/app/hello_world.f90 b/example_project/app/hello_world.f90 new file mode 100644 index 0000000..b95062d --- /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..a341602 --- /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/src/Build.hs b/src/Build.hs index b1cd141..fa0fa96 100644 --- a/src/Build.hs +++ b/src/Build.hs @@ -1,5 +1,6 @@ module Build ( buildLibrary + , buildPrograms ) where @@ -31,8 +32,10 @@ import Development.Shake ( FilePattern , () , (&%>) , (%>) + , (?>) ) import Development.Shake.FilePath ( dropExtension + , exe , makeRelative , () , (<.>) @@ -55,6 +58,59 @@ 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 = exe -<.> "o" + need [objectFile] + need archives + cmd compiler objectFile archives ["-o", exe] flags + want executables + buildLibrary :: FilePath -> [FilePattern] @@ -112,6 +168,18 @@ getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns 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 @@ -152,6 +220,12 @@ sourceFileToObjectFile buildDirectory libraryDirectory sourceFile = (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 -- cgit v1.2.3 From 8d8b6ace5f0c2d208e5bfccecd70b6082832bc3e Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Fri, 28 Feb 2020 07:48:45 -0800 Subject: Enable capitalization of source files --- example_project/app/Hello_world.f90 | 7 +++++++ example_project/app/hello_world.f90 | 7 ------- example_project/src/Hello_m.f90 | 12 ++++++++++++ example_project/src/hello_m.f90 | 12 ------------ src/Build.hs | 9 ++++++--- 5 files changed, 25 insertions(+), 22 deletions(-) create mode 100644 example_project/app/Hello_world.f90 delete mode 100644 example_project/app/hello_world.f90 create mode 100644 example_project/src/Hello_m.f90 delete mode 100644 example_project/src/hello_m.f90 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/app/hello_world.f90 b/example_project/app/hello_world.f90 deleted file mode 100644 index b95062d..0000000 --- a/example_project/app/hello_world.f90 +++ /dev/null @@ -1,7 +0,0 @@ -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/example_project/src/hello_m.f90 b/example_project/src/hello_m.f90 deleted file mode 100644 index a341602..0000000 --- a/example_project/src/hello_m.f90 +++ /dev/null @@ -1,12 +0,0 @@ -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/src/Build.hs b/src/Build.hs index fa0fa96..813c10e 100644 --- a/src/Build.hs +++ b/src/Build.hs @@ -105,7 +105,7 @@ buildPrograms programDirectory libraryDirectories sourceExtensions buildDirector flags ["-o", objectFile, sourceFile] (`elem` executables) ?> \exe -> do - let objectFile = exe -<.> "o" + let objectFile = map toLower exe -<.> "o" need [objectFile] need archives cmd compiler objectFile archives ["-o", exe] flags @@ -216,8 +216,11 @@ createSourceToObjectMap buildDirectory libraryDirectory sourceFile = sourceFileToObjectFile :: FilePath -> FilePath -> FilePath -> FilePath sourceFileToObjectFile buildDirectory libraryDirectory sourceFile = buildDirectory - pathSeparatorsToUnderscores - (makeRelative libraryDirectory sourceFile) + map + toLower + (pathSeparatorsToUnderscores + (makeRelative libraryDirectory sourceFile) + ) -<.> "o" sourceFileToExecutable :: FilePath -> FilePath -> FilePath -> FilePath -- cgit v1.2.3