diff options
Diffstat (limited to 'bootstrap/src/Fpm.hs')
| -rw-r--r-- | bootstrap/src/Fpm.hs | 1227 |
1 files changed, 0 insertions, 1227 deletions
diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs deleted file mode 100644 index 56e2d90..0000000 --- a/bootstrap/src/Fpm.hs +++ /dev/null @@ -1,1227 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Fpm - ( Arguments(..) - , getArguments - , start - ) -where - -import Build ( CompilerSettings(..) - , buildLibrary - , buildProgram - , buildWithScript - ) -import Control.Monad.Extra ( concatMapM - , forM_ - , when - ) -import Data.Hashable ( hash ) -import Data.List ( intercalate - , isInfixOf - , isSuffixOf - , find - , nub - ) -import qualified Data.Map as Map -import qualified Data.Text.IO as TIO -import Development.Shake ( FilePattern - , (<//>) - , getDirectoryFilesIO - ) -import Development.Shake.FilePath ( (</>) - , (<.>) - , exe - , splitDirectories - ) -import Numeric ( showHex ) -import Options.Applicative ( Parser - , (<**>) - , (<|>) - , auto - , command - , execParser - , fullDesc - , header - , help - , helper - , info - , long - , many - , metavar - , option - , optional - , progDesc - , short - , showDefault - , strArgument - , strOption - , subparser - , switch - , value - ) -import System.Directory ( createDirectory - , doesDirectoryExist - , doesFileExist - , makeAbsolute - , withCurrentDirectory - ) -import System.Exit ( ExitCode(..) - , exitWith - ) -import System.Process ( readProcess - , readProcessWithExitCode - , system - ) -import Toml ( TomlCodec - , (.=) - ) -import qualified Toml - -data Arguments = - New - { newName :: String - , newWithExecutable :: Bool - , newWithTest :: Bool - , newWithLib :: Bool - } - | Build - { buildRelease :: Bool - , buildCompiler :: FilePath - , buildFlags :: [String] - } - | Run - { runRelease :: Bool - , runExample :: Bool - , runCompiler :: FilePath - , runFlags :: [String] - , runRunner :: Maybe String - , runTarget :: Maybe String - , runArgs :: Maybe [String] - } - | Test - { testRelease :: Bool - , testCompiler :: FilePath - , testFlags :: [String] - , testRunner :: Maybe String - , testTarget :: Maybe String - , testArgs :: Maybe [String] - } - -data TomlSettings = TomlSettings { - tomlSettingsProjectName :: String - , tomlSettingsLibrary :: (Maybe Library) - , tomlSettingsExecutables :: [Executable] - , tomlSettingsExamples :: [Executable] - , tomlSettingsTests :: [Executable] - , tomlSettingsDependencies :: (Map.Map String Version) - , tomlSettingsDevDependencies :: (Map.Map String Version) -} - -data AppSettings = AppSettings { - appSettingsCompiler :: CompilerSettings - , appSettingsProjectName :: String - , appSettingsBuildPrefix :: String - , appSettingsLibrary :: (Maybe Library) - , appSettingsExecutables :: [Executable] - , appSettingsExamples :: [Executable] - , appSettingsTests :: [Executable] - , appSettingsDependencies :: (Map.Map String Version) - , appSettingsDevDependencies :: (Map.Map String Version) -} - -data Library = Library { librarySourceDir :: String, libraryBuildScript :: Maybe String } - -data Executable = Executable { - executableSourceDir :: String - , executableMainFile :: String - , executableName :: String - , executableDependencies :: (Map.Map String Version) -} deriving Show - -data Version = SimpleVersion String | GitVersion GitVersionSpec | PathVersion PathVersionSpec deriving Show - -data GitVersionSpec = GitVersionSpec { gitVersionSpecUrl :: String, gitVersionSpecRef :: Maybe GitRef } deriving Show - -data GitRef = Tag String | Branch String | Commit String deriving Show - -data PathVersionSpec = PathVersionSpec { pathVersionSpecPath :: String } deriving Show - -data DependencyTree = Dependency { - dependencyName :: String - , dependencyPath :: FilePath - , dependencySourcePath :: FilePath - , dependencyBuildScript :: Maybe String - , dependencyDependencies :: [DependencyTree] -} - -start :: Arguments -> IO () -start args = case args of - New { newName = name, newWithExecutable = withExecutable, newWithTest = withTest, newWithLib = withLib } - -> createNewProject name withExecutable withTest withLib - _ -> do - fpmContents <- TIO.readFile "fpm.toml" - let tomlSettings = Toml.decode settingsCodec fpmContents - case tomlSettings of - Left err -> print err - Right tomlSettings' -> do - appSettings <- toml2AppSettings tomlSettings' args - app args appSettings - -app :: Arguments -> AppSettings -> IO () -app args settings = case args of - Build{} -> build settings - Run { runTarget = whichOne, runArgs = runArgs, runRunner = runner, runExample = runExample } -> do - build settings - let buildPrefix = appSettingsBuildPrefix settings - let - executableNames = if runExample - then - map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir </> name - ) - (appSettingsExamples settings) - else - map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir </> name - ) - (appSettingsExecutables settings) - let executables = - map (buildPrefix </>) $ map (flip (<.>) exe) executableNames - canonicalExecutables <- mapM makeAbsolute executables - case canonicalExecutables of - [] -> putStrLn "No Executables Found" - _ -> - let commandPrefix = case runner of - Nothing -> "" - Just r -> r ++ " " - commandSufix = case runArgs of - Nothing -> "" - Just a -> " " ++ (intercalate " " a) - in case whichOne of - Nothing -> do - exitCodes <- mapM - system - (map (\exe -> commandPrefix ++ exe ++ commandSufix) - canonicalExecutables - ) - forM_ - exitCodes - (\exitCode -> when - (case exitCode of - ExitSuccess -> False - _ -> True - ) - (exitWith exitCode) - ) - Just name -> do - case find (name `isSuffixOf`) canonicalExecutables of - Nothing -> putStrLn "Executable Not Found" - Just specified -> do - exitCode <- system - (commandPrefix ++ specified ++ commandSufix) - exitWith exitCode - Test { testTarget = whichOne, testArgs = testArgs, testRunner = runner } -> - do - build settings - let buildPrefix = appSettingsBuildPrefix settings - let - executableNames = map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir </> name - ) - (appSettingsTests settings) - let executables = - map (buildPrefix </>) $ map (flip (<.>) exe) executableNames - canonicalExecutables <- mapM makeAbsolute executables - case canonicalExecutables of - [] -> putStrLn "No Tests Found" - _ -> - let commandPrefix = case runner of - Nothing -> "" - Just r -> r ++ " " - commandSufix = case testArgs of - Nothing -> "" - Just a -> " " ++ (intercalate " " a) - in case whichOne of - Nothing -> do - exitCodes <- mapM - system - (map (\exe -> commandPrefix ++ exe ++ commandSufix) - canonicalExecutables - ) - forM_ - exitCodes - (\exitCode -> when - (case exitCode of - ExitSuccess -> False - _ -> True - ) - (exitWith exitCode) - ) - Just name -> do - case find (name `isSuffixOf`) canonicalExecutables of - Nothing -> putStrLn "Test Not Found" - Just specified -> do - exitCode <- system - (commandPrefix ++ specified ++ commandSufix) - exitWith exitCode - _ -> putStrLn "Shouldn't be able to get here" - -build :: AppSettings -> IO () -build settings = do - let compilerSettings = appSettingsCompiler settings - let projectName = appSettingsProjectName settings - let buildPrefix = appSettingsBuildPrefix settings - let executables = appSettingsExecutables settings - let examples = appSettingsExamples settings - let tests = appSettingsTests settings - mainDependencyTrees <- fetchDependencies (appSettingsDependencies settings) - builtDependencies <- buildDependencies buildPrefix - compilerSettings - mainDependencyTrees - (executableDepends, maybeTree) <- case appSettingsLibrary settings of - Just librarySettings -> do - let librarySourceDir' = librarySourceDir librarySettings - let thisDependencyTree = Dependency - { dependencyName = projectName - , dependencyPath = "." - , dependencySourcePath = librarySourceDir' - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = mainDependencyTrees - } - thisArchive <- case libraryBuildScript librarySettings of - Just script -> buildWithScript script - "." - (buildPrefix </> projectName) - compilerSettings - projectName - (map fst builtDependencies) - Nothing -> buildLibrary librarySourceDir' - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix </> projectName) - compilerSettings - projectName - (map fst builtDependencies) - return - $ ( (buildPrefix </> projectName, thisArchive) : builtDependencies - , Just thisDependencyTree - ) - Nothing -> do - return (builtDependencies, Nothing) - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ((map fst executableDepends) ++ (map fst localDependencies)) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix </> sourceDir) - compilerSettings - name - mainFile - ((map snd executableDepends) ++ (map snd localDependencies)) - ) - executables - devDependencies <- - fetchExecutableDependencies maybeTree (appSettingsDevDependencies settings) - >>= buildDependencies buildPrefix compilerSettings - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ( (map fst executableDepends) - ++ (map fst devDependencies) - ++ (map fst localDependencies) - ) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix </> sourceDir) - compilerSettings - name - mainFile - ( (map snd executableDepends) - ++ (map snd devDependencies) - ++ (map snd localDependencies) - ) - ) - examples - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ( (map fst executableDepends) - ++ (map fst devDependencies) - ++ (map fst localDependencies) - ) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix </> sourceDir) - compilerSettings - name - mainFile - ( (map snd executableDepends) - ++ (map snd devDependencies) - ++ (map snd localDependencies) - ) - ) - tests - -getArguments :: IO Arguments -getArguments = execParser - (info - (arguments <**> helper) - (fullDesc <> progDesc "Work with Fortran projects" <> header - "fpm - A Fortran package manager and build system" - ) - ) - -arguments :: Parser Arguments -arguments = subparser - ( command - "new" - (info (newArguments <**> helper) - (progDesc "Create a new project in a new directory") - ) - <> command - "build" - (info (buildArguments <**> helper) (progDesc "Build the project")) - <> command - "run" - (info (runArguments <**> helper) (progDesc "Run the executable(s)")) - <> command "test" - (info (testArguments <**> helper) (progDesc "Run the test(s)")) - ) - -newArguments :: Parser Arguments -newArguments = - New - <$> strArgument - ( metavar "NAME" - <> help "Name of new project (must be a valid Fortran identifier)" - ) - <*> switch (long "app" <> help "Include an executable") - <*> switch (long "test" <> help "Include a test") - <*> switch (long "lib" <> help "Include a library") - -buildArguments :: Parser Arguments -buildArguments = - Build - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - -runArguments :: Parser Arguments -runArguments = - Run - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> switch - ( long "example" - <> help "Run example programs instead of applications" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - <*> optional - (strOption - (long "runner" <> metavar "RUNNER" <> help - "specify a command to be used to run the executable(s)" - ) - ) - <*> optional - (strOption - (long "target" <> metavar "TARGET" <> help - "Name of the executable to run" - ) - ) - <*> optional - (many - (strArgument - ( metavar "ARGS" - <> help "Arguments to the executable(s) (should follow '--')" - ) - ) - ) - -testArguments :: Parser Arguments -testArguments = - Test - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - <*> optional - (strOption - (long "runner" <> metavar "RUNNER" <> help - "specify a command to be used to run the test(s)" - ) - ) - <*> optional - (strOption - (long "target" <> metavar "TARGET" <> help "Name of the test to run" - ) - ) - <*> optional - (many - (strArgument - ( metavar "ARGS" - <> help "Arguments to the test(s) (should follow '--')" - ) - ) - ) - -getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] -getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns - where - newPatterns = concatMap appendExts dirs - appendExts dir = map ((dir <//> "*") ++) exts - -settingsCodec :: TomlCodec TomlSettings -settingsCodec = - TomlSettings - <$> Toml.string "name" - .= tomlSettingsProjectName - <*> Toml.dioptional (Toml.table libraryCodec "library") - .= tomlSettingsLibrary - <*> Toml.list executableCodec "executable" - .= tomlSettingsExecutables - <*> Toml.list executableCodec "example" - .= tomlSettingsExamples - <*> Toml.list executableCodec "test" - .= tomlSettingsTests - <*> Toml.tableMap Toml._KeyString versionCodec "dependencies" - .= tomlSettingsDependencies - <*> Toml.tableMap Toml._KeyString versionCodec "dev-dependencies" - .= tomlSettingsDevDependencies - -libraryCodec :: TomlCodec Library -libraryCodec = - Library - <$> Toml.string "source-dir" - .= librarySourceDir - <*> Toml.dioptional (Toml.string "build-script") - .= libraryBuildScript - -executableCodec :: TomlCodec Executable -executableCodec = - Executable - <$> Toml.string "source-dir" - .= executableSourceDir - <*> Toml.string "main" - .= executableMainFile - <*> Toml.string "name" - .= executableName - <*> Toml.tableMap Toml._KeyString versionCodec "dependencies" - .= executableDependencies - -matchSimpleVersion :: Version -> Maybe String -matchSimpleVersion = \case - SimpleVersion v -> Just v - _ -> Nothing - -matchGitVersion :: Version -> Maybe GitVersionSpec -matchGitVersion = \case - GitVersion v -> Just v - _ -> Nothing - -matchPathVersion :: Version -> Maybe PathVersionSpec -matchPathVersion = \case - PathVersion v -> Just v - _ -> Nothing - -matchTag :: GitRef -> Maybe String -matchTag = \case - Tag v -> Just v - _ -> Nothing - -matchBranch :: GitRef -> Maybe String -matchBranch = \case - Branch v -> Just v - _ -> Nothing - -matchCommit :: GitRef -> Maybe String -matchCommit = \case - Commit v -> Just v - _ -> Nothing - -versionCodec :: Toml.Key -> Toml.TomlCodec Version -versionCodec key = - Toml.dimatch matchSimpleVersion SimpleVersion (Toml.string key) - <|> Toml.dimatch matchGitVersion GitVersion (Toml.table gitVersionCodec key) - <|> Toml.dimatch matchPathVersion - PathVersion - (Toml.table pathVersionCodec key) - -gitVersionCodec :: Toml.TomlCodec GitVersionSpec -gitVersionCodec = - GitVersionSpec - <$> Toml.string "git" - .= gitVersionSpecUrl - <*> Toml.dioptional gitRefCodec - .= gitVersionSpecRef - -gitRefCodec :: Toml.TomlCodec GitRef -gitRefCodec = - Toml.dimatch matchTag Tag (Toml.string "tag") - <|> Toml.dimatch matchBranch Branch (Toml.string "branch") - <|> Toml.dimatch matchCommit Commit (Toml.string "rev") - -pathVersionCodec :: Toml.TomlCodec PathVersionSpec -pathVersionCodec = - PathVersionSpec <$> Toml.string "path" .= pathVersionSpecPath - -toml2AppSettings :: TomlSettings -> Arguments -> IO AppSettings -toml2AppSettings tomlSettings args = do - let release = case args of - Build { buildRelease = r } -> r - Run { runRelease = r } -> r - Test { testRelease = r } -> r - let projectName = tomlSettingsProjectName tomlSettings - let compiler = case args of - Build { buildCompiler = c } -> c - Run { runCompiler = c } -> c - Test { testCompiler = c } -> c - let specifiedFlags = case args of - Build { buildFlags = f } -> f - Run { runFlags = f } -> f - Test { testFlags = f } -> f - when (release && (length specifiedFlags > 0)) $ do - putStrLn "--release and --flag are mutually exclusive" - exitWith (ExitFailure 1) - librarySettings <- getLibrarySettings $ tomlSettingsLibrary tomlSettings - executableSettings <- getExecutableSettings - (tomlSettingsExecutables tomlSettings) - projectName - exampleSettings <- getExampleSettings $ tomlSettingsExamples tomlSettings - testSettings <- getTestSettings $ tomlSettingsTests tomlSettings - compilerSettings <- defineCompilerSettings specifiedFlags compiler release - buildPrefix <- makeBuildPrefix (compilerSettingsCompiler compilerSettings) - (compilerSettingsFlags compilerSettings) - let dependencies = tomlSettingsDependencies tomlSettings - let devDependencies = tomlSettingsDevDependencies tomlSettings - return AppSettings { appSettingsCompiler = compilerSettings - , appSettingsProjectName = projectName - , appSettingsBuildPrefix = buildPrefix - , appSettingsLibrary = librarySettings - , appSettingsExecutables = executableSettings - , appSettingsExamples = exampleSettings - , appSettingsTests = testSettings - , appSettingsDependencies = dependencies - , appSettingsDevDependencies = devDependencies - } - -defineCompilerSettings :: [String] -> FilePath -> Bool -> IO CompilerSettings -defineCompilerSettings specifiedFlags compiler release - | "gfortran" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-O3" - , "-march=native" - , "-funroll-loops" - , "-fcoarray=single" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-fbacktrace" - , "-fcoarray=single" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "caf" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-O3" - , "-march=native" - , "-funroll-loops" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-fbacktrace" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "f95" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-O3" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-funroll-loops" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-Wno-maybe-uninitialized" - , "-Wno-uninitialized" - , "-fbacktrace" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "nvfortran" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Mbackslash" - ] - else - [ "-Minform=inform" - , "-Mbackslash" - , "-g" - , "-Mbounds" - , "-Mchkptr" - , "-Mchkstk" - , "-traceback" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "ifort" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-fp-model", "precise" - , "-pc", "64" - , "-align", "all" - , "-error-limit", "1" - , "-reentrancy", "threaded" - , "-nogen-interfaces" - , "-assume", "byterecl" - , "-assume", "nounderscore" - ] - else - [ "-warn", "all" - , "-check:all:noarg_temp_created" - , "-error-limit", "1" - , "-O0" - , "-g" - , "-assume", "byterecl" - , "-traceback" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "ifx" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "pgfortran" `isInfixOf` compiler || "pgf90" `isInfixOf` compiler || "pgf95" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "flang" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "lfc" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-M" - , compilerSettingsIncludeFlag = "-I" - } - | "nagfor" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-O4" - , "-coarray=single" - , "-PIC" - ] - else - [ "-g" - , "-C=all" - , "-O0" - , "-gline" - , "-coarray=single" - , "-PIC" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-mdir" - , compilerSettingsIncludeFlag = "-I" - } - | "crayftn" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "xlf90" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-qmoddir" - , compilerSettingsIncludeFlag = "-I" - } - | otherwise - = do - putStrLn $ "Sorry, compiler is currently unsupported: " ++ compiler - exitWith (ExitFailure 1) - -getLibrarySettings :: Maybe Library -> IO (Maybe Library) -getLibrarySettings maybeSettings = case maybeSettings of - Just settings -> return maybeSettings - Nothing -> do - defaultExists <- doesDirectoryExist "src" - if defaultExists - then return - (Just - (Library { librarySourceDir = "src", libraryBuildScript = Nothing }) - ) - else return Nothing - -getExecutableSettings :: [Executable] -> String -> IO [Executable] -getExecutableSettings [] projectName = do - defaultDirectoryExists <- doesDirectoryExist "app" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("app" </> "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "app" - , executableMainFile = "main.f90" - , executableName = projectName - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getExecutableSettings executables _ = return executables - -getExampleSettings :: [Executable] -> IO [Executable] -getExampleSettings [] = do - defaultDirectoryExists <- doesDirectoryExist "example" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("example" </> "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "example" - , executableMainFile = "main.f90" - , executableName = "demo" - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getExampleSettings examples = return examples - -getTestSettings :: [Executable] -> IO [Executable] -getTestSettings [] = do - defaultDirectoryExists <- doesDirectoryExist "test" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("test" </> "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "test" - , executableMainFile = "main.f90" - , executableName = "runTests" - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getTestSettings tests = return tests - -makeBuildPrefix :: FilePath -> [String] -> IO FilePath -makeBuildPrefix compiler flags = do - -- TODO Figure out what other info should be part of this - -- Probably version, and make sure to not include path to the compiler - versionInfo <- do - (exitCode, stdout, stderr) <- readProcessWithExitCode compiler - ["--version"] - [] - case exitCode of - ExitSuccess -> case stdout of - "" -> return stderr -- Guess this compiler outputs version info to stderr instead? - _ -> return stdout - _ -> do -- guess this compiler doesn't support the --version option. let's try -version - (exitCode, stdout, stderr) <- readProcessWithExitCode compiler - ["-version"] - [] - case exitCode of - ExitSuccess -> case stdout of - "" -> return stderr -- Guess this compiler outputs version info to stderr instead? - _ -> return stdout - _ -> return "" -- Don't know how to get version info, we'll let defineCompilerSettings report it as unsupported - let compilerName = last (splitDirectories compiler) - let versionHash = abs (hash versionInfo) - let flagsHash = abs (hash flags) - return - $ "build" - </> compilerName - ++ "_" - ++ showHex versionHash "" - ++ "_" - ++ showHex flagsHash "" - -{- - Fetching the dependencies is done on a sort of breadth first approach. All - of the dependencies are fetched before doing the transitive dependencies. - This means that the top level dependencies dictate which version is fetched. - The fetchDependency function is idempotent, so we don't have to worry about - dealing with half fetched, or adding dependencies. - TODO check for version compatibility issues --} -fetchDependencies :: Map.Map String Version -> IO [DependencyTree] -fetchDependencies dependencies = do - theseDependencies <- mapM (uncurry fetchDependency) (Map.toList dependencies) - mapM fetchTransitiveDependencies theseDependencies - where - fetchTransitiveDependencies :: (String, FilePath) -> IO DependencyTree - fetchTransitiveDependencies (name, path) = do - tomlSettings <- Toml.decodeFile settingsCodec (path </> "fpm.toml") - librarySettingsM <- withCurrentDirectory path - $ getLibrarySettings (tomlSettingsLibrary tomlSettings) - case librarySettingsM of - Just librarySettings -> do - newDependencies <- fetchDependencies - (tomlSettingsDependencies tomlSettings) - return $ Dependency - { dependencyName = name - , dependencyPath = path - , dependencySourcePath = path </> (librarySourceDir librarySettings) - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = newDependencies - } - Nothing -> do - putStrLn $ "No library found in " ++ name - undefined - -fetchExecutableDependencies - :: (Maybe DependencyTree) -> Map.Map String Version -> IO [DependencyTree] -fetchExecutableDependencies maybeProjectTree dependencies = - case maybeProjectTree of - Just projectTree@(Dependency name _ _ _ _) -> - if name `Map.member` dependencies {- map contains this project-} - then fmap (projectTree :) - (fetchDependencies (Map.delete name dependencies)) {- fetch the other dependencies and include the project tree in the result -} - else do {- fetch all the dependencies, passing the project tree on down -} - theseDependencies <- mapM (uncurry fetchDependency) - (Map.toList dependencies) - mapM fetchTransitiveDependencies theseDependencies - Nothing -> fetchDependencies dependencies - where - fetchTransitiveDependencies :: (String, FilePath) -> IO DependencyTree - fetchTransitiveDependencies (name, path) = do - tomlSettings <- Toml.decodeFile settingsCodec (path </> "fpm.toml") - librarySettingsM <- withCurrentDirectory path - $ getLibrarySettings (tomlSettingsLibrary tomlSettings) - case librarySettingsM of - Just librarySettings -> do - newDependencies <- fetchExecutableDependencies - maybeProjectTree - (tomlSettingsDependencies tomlSettings) - return $ Dependency - { dependencyName = name - , dependencyPath = path - , dependencySourcePath = path </> (librarySourceDir librarySettings) - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = newDependencies - } - Nothing -> do - putStrLn $ "No library found in " ++ name - undefined - -fetchDependency :: String -> Version -> IO (String, FilePath) -fetchDependency name version = do - let clonePath = "build" </> "dependencies" </> name - alreadyFetched <- doesDirectoryExist clonePath - if alreadyFetched - then return (name, clonePath) - else case version of - SimpleVersion _ -> do - putStrLn "Simple dependencies are not yet supported :(" - undefined - GitVersion versionSpec -> do - system ("git init " ++ clonePath) - case gitVersionSpecRef versionSpec of - Just ref -> do - system - ( "git -C " - ++ clonePath - ++ " fetch " - ++ gitVersionSpecUrl versionSpec - ++ " " - ++ (case ref of - Tag tag -> tag - Branch branch -> branch - Commit commit -> commit - ) - ) - Nothing -> do - system - ( "git -C " - ++ clonePath - ++ " fetch " - ++ gitVersionSpecUrl versionSpec - ) - system ("git -C " ++ clonePath ++ " checkout -qf FETCH_HEAD") - return (name, clonePath) - PathVersion versionSpec -> return (name, pathVersionSpecPath versionSpec) - -{- - Bulding the dependencies is done on a depth first basis to ensure all of - the transitive dependencies have been built before trying to build this one --} -buildDependencies - :: String -> CompilerSettings -> [DependencyTree] -> IO [(FilePath, FilePath)] -buildDependencies buildPrefix compilerSettings dependencies = do - built <- concatMapM (buildDependency buildPrefix compilerSettings) - dependencies - return $ reverse (nub (reverse built)) - -buildDependency - :: String -> CompilerSettings -> DependencyTree -> IO [(FilePath, FilePath)] -buildDependency buildPrefix compilerSettings (Dependency name path sourcePath mBuildScript dependencies) - = do - transitiveDependencies <- buildDependencies buildPrefix - compilerSettings - dependencies - let buildPath = buildPrefix </> name - thisArchive <- case mBuildScript of - Just script -> buildWithScript script - path - buildPath - compilerSettings - name - (map fst transitiveDependencies) - Nothing -> buildLibrary sourcePath - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - buildPath - compilerSettings - name - (map fst transitiveDependencies) - return $ (buildPath, thisArchive) : transitiveDependencies - -createNewProject :: String -> Bool -> Bool -> Bool -> IO () -createNewProject projectName withExecutable withTest withLib = do - createDirectory projectName - writeFile (projectName </> "fpm.toml") (templateFpmToml projectName) - writeFile (projectName </> "README.md") (templateReadme projectName) - writeFile (projectName </> ".gitignore") "build/*\n" - when withLib $ do - createDirectory (projectName </> "src") - writeFile (projectName </> "src" </> projectName <.> "f90") - (templateModule projectName) - when withExecutable $ do - createDirectory (projectName </> "app") - writeFile (projectName </> "app" </> "main.f90") - (templateProgram projectName withLib) - when withTest $ do - createDirectory (projectName </> "test") - writeFile (projectName </> "test" </> "main.f90") templateTest - withCurrentDirectory projectName $ do - system "git init" - return () - -templateFpmToml :: String -> String -templateFpmToml projectName = - "name = \"" - ++ projectName - ++ "\"\n" - ++ "version = \"0.1.0\"\n" - ++ "license = \"license\"\n" - ++ "author = \"Jane Doe\"\n" - ++ "maintainer = \"jane.doe@example.com\"\n" - ++ "copyright = \"2020 Jane Doe\"\n" - -templateModule :: String -> String -templateModule projectName = - "module " - ++ projectName - ++ "\n" - ++ " implicit none\n" - ++ " private\n" - ++ "\n" - ++ " public :: say_hello\n" - ++ "contains\n" - ++ " subroutine say_hello\n" - ++ " print *, \"Hello, " - ++ projectName - ++ "!\"\n" - ++ " end subroutine say_hello\n" - ++ "end module " - ++ projectName - ++ "\n" - -templateReadme :: String -> String -templateReadme projectName = - "# " ++ projectName ++ "\n" ++ "\n" ++ "My cool new project!\n" - -templateProgram :: String -> Bool -> String -templateProgram projectName withLib = - "program main\n" - ++ (if withLib then " use " ++ projectName ++ ", only: say_hello\n" else "" - ) - ++ "\n" - ++ " implicit none\n" - ++ "\n" - ++ " call say_hello\n" - ++ "end program main\n" - -templateTest :: String -templateTest = - "program main\n" - ++ " implicit none\n" - ++ "\n" - ++ " print *, \"Put some tests in here!\"\n" - ++ "end program main\n" |