diff options
Diffstat (limited to 'bootstrap/src/Fpm.hs')
| -rw-r--r-- | bootstrap/src/Fpm.hs | 720 |
1 files changed, 720 insertions, 0 deletions
diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs new file mode 100644 index 0000000..60f4aac --- /dev/null +++ b/bootstrap/src/Fpm.hs @@ -0,0 +1,720 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Fpm + ( Arguments(..) + , Command(..) + , getArguments + , start + ) +where + +import Build ( buildLibrary + , buildProgram + , buildWithScript + ) +import Control.Monad.Extra ( concatMapM + , when + ) +import Data.List ( 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 + ) +import Options.Applicative ( Parser + , (<**>) + , (<|>) + , command + , execParser + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , strArgument + , strOption + , subparser + , switch + , value + ) +import System.Directory ( createDirectory + , doesDirectoryExist + , doesFileExist + , makeAbsolute + , withCurrentDirectory + ) +import System.Process ( runCommand + , system + ) +import Toml ( TomlCodec + , (.=) + ) +import qualified Toml + +data Arguments = Arguments { command' :: Command, release :: Bool, commandArguments :: String } + +data TomlSettings = TomlSettings { + tomlSettingsProjectName :: String + , tomlSettingsLibrary :: (Maybe Library) + , tomlSettingsExecutables :: [Executable] + , tomlSettingsTests :: [Executable] + , tomlSettingsDependencies :: (Map.Map String Version) + , tomlSettingsDevDependencies :: (Map.Map String Version) +} + +data AppSettings = AppSettings { + appSettingsCompiler :: String + , appSettingsProjectName :: String + , appSettingsBuildPrefix :: String + , appSettingsFlags :: [String] + , appSettingsLibrary :: (Maybe Library) + , appSettingsExecutables :: [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 Command = Run String | Test String | Build | New String Bool Bool + +data DependencyTree = Dependency { + dependencyName :: String + , dependencyPath :: FilePath + , dependencySourcePath :: FilePath + , dependencyBuildScript :: Maybe String + , dependencyDependencies :: [DependencyTree] +} + +start :: Arguments -> IO () +start args = case command' args of + New projectName withExecutable withTest -> + createNewProject projectName withExecutable withTest + _ -> 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' (release args) + app args appSettings + +app :: Arguments -> AppSettings -> IO () +app args settings = case command' args of + Build -> build settings + Run whichOne -> do + build settings + let buildPrefix = appSettingsBuildPrefix settings + let + executableNames = 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" + _ -> case whichOne of + "" -> mapM_ + system + (map (++ " " ++ commandArguments args) canonicalExecutables) + name -> do + case find (name `isSuffixOf`) canonicalExecutables of + Nothing -> putStrLn "Executable Not Found" + Just specified -> do + system (specified ++ " " ++ (commandArguments args)) + return () + Test whichOne -> 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" + _ -> case whichOne of + "" -> mapM_ + system + (map (++ " " ++ commandArguments args) canonicalExecutables) + name -> do + case find (name `isSuffixOf`) canonicalExecutables of + Nothing -> putStrLn "Test Not Found" + Just specified -> do + system (specified ++ " " ++ (commandArguments args)) + return () + +build :: AppSettings -> IO () +build settings = do + let compiler = appSettingsCompiler settings + let projectName = appSettingsProjectName settings + let buildPrefix = appSettingsBuildPrefix settings + let flags = appSettingsFlags settings + let executables = appSettingsExecutables settings + let tests = appSettingsTests settings + mainDependencyTrees <- fetchDependencies (appSettingsDependencies settings) + builtDependencies <- buildDependencies buildPrefix + compiler + flags + 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) + compiler + flags + projectName + (map fst builtDependencies) + Nothing -> buildLibrary librarySourceDir' + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + (buildPrefix </> projectName) + compiler + flags + 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 compiler flags + buildProgram + sourceDir + ((map fst executableDepends) ++ (map fst localDependencies)) + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + (buildPrefix </> sourceDir) + compiler + flags + name + mainFile + ((map snd executableDepends) ++ (map snd localDependencies)) + ) + executables + devDependencies <- + fetchExecutableDependencies maybeTree (appSettingsDevDependencies settings) + >>= buildDependencies buildPrefix compiler flags + mapM_ + (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> + do + localDependencies <- + fetchExecutableDependencies maybeTree dependencies + >>= buildDependencies buildPrefix compiler flags + buildProgram + sourceDir + ( (map fst executableDepends) + ++ (map fst devDependencies) + ++ (map fst localDependencies) + ) + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + (buildPrefix </> sourceDir) + compiler + flags + 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 = + Arguments + <$> subparser + ( command "run" (info runArguments (progDesc "Run the executable")) + <> command "test" (info testArguments (progDesc "Run the tests")) + <> command "build" + (info buildArguments (progDesc "Build the executable")) + <> command "new" + (info newArguments (progDesc "Create a new project in a new directory")) + ) + <*> switch (long "release" <> help "Build in release mode") + <*> strOption + (long "args" <> metavar "ARGS" <> value "" <> help + "Arguments to pass to executables/tests" + ) + +runArguments :: Parser Command +runArguments = Run <$> strArgument + (metavar "EXE" <> value "" <> help "Which executable to run") + +testArguments :: Parser Command +testArguments = + Test <$> strArgument (metavar "TEST" <> value "" <> help "Which test to run") + +buildArguments :: Parser Command +buildArguments = pure Build + +newArguments :: Parser Command +newArguments = + New + <$> strArgument (metavar "NAME" <> help "Name of new project") + <*> switch (long "with-executable" <> help "Include an executable") + <*> switch (long "with-test" <> help "Include a test") + +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 "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 -> Bool -> IO AppSettings +toml2AppSettings tomlSettings release = do + let projectName = tomlSettingsProjectName tomlSettings + let compiler = "gfortran" + librarySettings <- getLibrarySettings $ tomlSettingsLibrary tomlSettings + executableSettings <- getExecutableSettings + (tomlSettingsExecutables tomlSettings) + projectName + testSettings <- getTestSettings $ tomlSettingsTests tomlSettings + buildPrefix <- makeBuildPrefix compiler release + let dependencies = tomlSettingsDependencies tomlSettings + let devDependencies = tomlSettingsDevDependencies tomlSettings + return AppSettings + { appSettingsCompiler = compiler + , appSettingsProjectName = projectName + , appSettingsBuildPrefix = buildPrefix + , appSettingsFlags = if release + then + [ "-Wall" + , "-Wextra" + , "-Wimplicit-interface" + , "-fPIC" + , "-fmax-errors=1" + , "-O3" + , "-march=native" + , "-ffast-math" + , "-funroll-loops" + ] + else + [ "-Wall" + , "-Wextra" + , "-Wimplicit-interface" + , "-fPIC" + , "-fmax-errors=1" + , "-g" + , "-fbounds-check" + , "-fcheck-array-temporaries" + , "-fbacktrace" + ] + , appSettingsLibrary = librarySettings + , appSettingsExecutables = executableSettings + , appSettingsTests = testSettings + , appSettingsDependencies = dependencies + , appSettingsDevDependencies = devDependencies + } + +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 + +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 :: String -> Bool -> IO String +makeBuildPrefix compiler release = + -- TODO Figure out what other info should be part of this + -- Probably version, and make sure to not include path to the compiler + return $ "build" </> compiler ++ "_" ++ if release then "release" else "debug" + +{- + 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 clone " ++ gitVersionSpecUrl versionSpec ++ " " ++ clonePath) + case gitVersionSpecRef versionSpec of + Just ref -> withCurrentDirectory clonePath $ do + system + ( "git checkout " + ++ (case ref of + Tag tag -> tag + Branch branch -> branch + Commit commit -> commit + ) + ) + return (name, clonePath) + Nothing -> 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 + -> String + -> [String] + -> [DependencyTree] + -> IO [(FilePath, FilePath)] +buildDependencies buildPrefix compiler flags dependencies = do + built <- concatMapM (buildDependency buildPrefix compiler flags) dependencies + return $ reverse (nub (reverse built)) + +buildDependency + :: String -> String -> [String] -> DependencyTree -> IO [(FilePath, FilePath)] +buildDependency buildPrefix compiler flags (Dependency name path sourcePath mBuildScript dependencies) + = do + transitiveDependencies <- buildDependencies buildPrefix + compiler + flags + dependencies + let buildPath = buildPrefix </> name + thisArchive <- case mBuildScript of + Just script -> buildWithScript script + path + buildPath + compiler + flags + name + (map fst transitiveDependencies) + Nothing -> buildLibrary sourcePath + [".f90", ".f", ".F", ".F90", ".f95", ".f03"] + buildPath + compiler + flags + name + (map fst transitiveDependencies) + return $ (buildPath, thisArchive) : transitiveDependencies + +createNewProject :: String -> Bool -> Bool -> IO () +createNewProject projectName withExecutable withTest = do + createDirectory projectName + writeFile (projectName </> "fpm.toml") (templateFpmToml projectName) + writeFile (projectName </> "README.md") (templateReadme projectName) + writeFile (projectName </> ".gitignore") "build/*\n" + createDirectory (projectName </> "src") + writeFile (projectName </> "src" </> projectName <.> "f90") + (templateModule projectName) + when withExecutable $ do + createDirectory (projectName </> "app") + writeFile (projectName </> "app" </> "main.f90") + (templateProgram projectName) + 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 -> String +templateProgram projectName = + "program main\n" + ++ " use " + ++ projectName + ++ ", only: say_hello\n" + ++ "\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" |