From 02428c5b8f19a31faf2e9b719da89700126cb35b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C4=8Cert=C3=ADk?= Date: Tue, 21 Jul 2020 09:02:35 -0600 Subject: Move Haskell based version to bootstrap/ --- Setup.hs | 2 - app/Main.hs | 8 - bootstrap/Setup.hs | 2 + bootstrap/app/Main.hs | 8 + bootstrap/package.yaml | 60 ++++ bootstrap/src/Build.hs | 420 +++++++++++++++++++++++++++ bootstrap/src/Fpm.hs | 720 ++++++++++++++++++++++++++++++++++++++++++++++ bootstrap/stack.yaml | 68 +++++ bootstrap/stack.yaml.lock | 26 ++ package.yaml | 60 ---- src/Build.hs | 420 --------------------------- src/Fpm.hs | 720 ---------------------------------------------- stack.yaml | 68 ----- stack.yaml.lock | 26 -- 14 files changed, 1304 insertions(+), 1304 deletions(-) delete mode 100644 Setup.hs delete mode 100644 app/Main.hs create mode 100644 bootstrap/Setup.hs create mode 100644 bootstrap/app/Main.hs create mode 100644 bootstrap/package.yaml create mode 100644 bootstrap/src/Build.hs create mode 100644 bootstrap/src/Fpm.hs create mode 100644 bootstrap/stack.yaml create mode 100644 bootstrap/stack.yaml.lock delete mode 100644 package.yaml delete mode 100644 src/Build.hs delete mode 100644 src/Fpm.hs delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index 4897901..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Fpm ( getArguments - , start - ) - -main :: IO () -main = getArguments >>= start diff --git a/bootstrap/Setup.hs b/bootstrap/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/bootstrap/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bootstrap/app/Main.hs b/bootstrap/app/Main.hs new file mode 100644 index 0000000..4897901 --- /dev/null +++ b/bootstrap/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Fpm ( getArguments + , start + ) + +main :: IO () +main = getArguments >>= start diff --git a/bootstrap/package.yaml b/bootstrap/package.yaml new file mode 100644 index 0000000..7cf11c6 --- /dev/null +++ b/bootstrap/package.yaml @@ -0,0 +1,60 @@ +name: fpm +version: 0.1.0.0 +github: "githubuser/fpm" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2020 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- containers +- directory +- extra +- filepath +- MissingH +- optparse-applicative +- process +- shake +- split +- text +- tomland >= 1.0 + + +library: + source-dirs: src + +executables: + fpm: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - fpm + +tests: + fpm-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - fpm diff --git a/bootstrap/src/Build.hs b/bootstrap/src/Build.hs new file mode 100644 index 0000000..ffbf264 --- /dev/null +++ b/bootstrap/src/Build.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE MultiWayIf #-} +module Build + ( buildLibrary + , buildProgram + , buildWithScript + ) +where + +import Control.Applicative ( (<|>) ) +import Control.Monad ( filterM ) +import Data.Char ( isAsciiLower + , isDigit + , toLower + ) +import Data.List ( intercalate + , isSuffixOf + ) +import Data.List.Utils ( replace ) +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.Directory ( createDirectoryIfMissing + , makeAbsolute + , withCurrentDirectory + ) +import System.Environment ( setEnv ) +import System.FilePath ( splitDirectories ) +import System.Process ( system ) +import Text.ParserCombinators.ReadP ( ReadP + , char + , eof + , many + , many1 + , option + , readP_to_S + , satisfy + , skipSpaces + , string + ) + +type ModuleName = String + +data LineContents = ModuleUsed ModuleName | Other + +buildProgram + :: FilePath + -> [FilePath] + -> [FilePattern] + -> FilePath + -> FilePath + -> [String] + -> String + -> FilePath + -> [FilePath] + -> IO () +buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory compiler flags programName programSource archives + = do + sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions + canonicalProgramSource <- makeAbsolute $ programDirectory programSource + moduleSourceFiles <- filterM + (\source -> do + canonicalSource <- makeAbsolute source + return $ canonicalProgramSource /= canonicalSource + ) + sourceFiles + let moduleObjectFiles = map + (sourceFileToObjectFile buildDirectory programDirectory) + moduleSourceFiles + let sourceFileLookupMap = createSourceFileLookupMap buildDirectory + programDirectory + moduleSourceFiles + let moduleLookupMap = createModuleLookupMap buildDirectory + programDirectory + moduleSourceFiles + otherModuleMaps <- mapM getLibraryModuleMap libraryDirectories + let allModuleMaps = + moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps + let includeFlags = map ("-I" ++) libraryDirectories + shake shakeOptions { shakeFiles = buildDirectory + , shakeChange = ChangeModtimeAndDigest + , shakeColor = True + , shakeThreads = 0 + , shakeProgress = progressSimple + } + $ do + want [buildDirectory programName <.> exe] + buildDirectory programName <.> exe %> \executable -> do + let objectFile = sourceFileToObjectFile buildDirectory + programDirectory + programSource + let allObjectFiles = objectFile : moduleObjectFiles + need allObjectFiles + need archives + cmd compiler allObjectFiles archives ["-o", executable] flags + buildDirectory (map toLower programSource) -<.> "o" %> \objectFile -> do + let realObjectFile = foldl () "" $ splitDirectories objectFile + let sourceFile = programDirectory programSource + need [sourceFile] + modulesUsed <- liftIO $ getModulesUsed sourceFile + let moduleFilesNeeded = + mapMaybe (`Map.lookup` allModuleMaps) modulesUsed + let includeFlags = map ("-I" ++) libraryDirectories + need moduleFilesNeeded + cmd compiler + ["-c", "-J" ++ buildDirectory] + includeFlags + flags + ["-o", objectFile, sourceFile] + map (\ext -> buildDirectory "*" <.> ext) ["o", "mod"] + &%> \[objectFile, moduleFile] -> do + let realObjectFile = + foldl () "" $ splitDirectories objectFile + let sourceFile = fromMaybe + undefined + (Map.lookup realObjectFile sourceFileLookupMap) + need [sourceFile] + modulesUsed <- liftIO $ getModulesUsed sourceFile + let moduleFilesNeeded = + mapMaybe (`Map.lookup` allModuleMaps) modulesUsed + let includeFlags = map ("-I" ++) libraryDirectories + need moduleFilesNeeded + cmd compiler + ["-c", "-J" ++ buildDirectory] + includeFlags + flags + ["-o", objectFile, sourceFile] + +buildLibrary + :: FilePath + -> [FilePattern] + -> FilePath + -> FilePath + -> [String] + -> String + -> [FilePath] + -> IO (FilePath) +buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags libraryName otherLibraryDirectories + = do + sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions + let sourceFileLookupMap = + createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles + let moduleLookupMap = + createModuleLookupMap buildDirectory libraryDirectory sourceFiles + otherModuleMaps <- mapM getLibraryModuleMap otherLibraryDirectories + let allModuleMaps = + moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps + let archiveFile = buildDirectory "lib" ++ 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 realObjectFile = + foldl () "" $ splitDirectories objectFile + let sourceFile = fromMaybe + undefined + (Map.lookup realObjectFile sourceFileLookupMap) + need [sourceFile] + modulesUsed <- liftIO $ getModulesUsed sourceFile + let moduleFilesNeeded = + mapMaybe (`Map.lookup` allModuleMaps) modulesUsed + let includeFlags = map ("-I" ++) otherLibraryDirectories + need moduleFilesNeeded + cmd compiler + ["-c", "-J" ++ buildDirectory] + includeFlags + flags + ["-o", objectFile, sourceFile] + archiveFile %> \a -> do + let objectFiles = Map.keys sourceFileLookupMap + need objectFiles + cmd "ar" ["rs"] a objectFiles + want [archiveFile] + return 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 '_' + +buildWithScript + :: String + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> String + -> [FilePath] + -> IO (FilePath) +buildWithScript script projectDirectory buildDirectory compiler flags libraryName otherLibraryDirectories + = do + absoluteBuildDirectory <- makeAbsolute buildDirectory + createDirectoryIfMissing True absoluteBuildDirectory + absoluteLibraryDirectories <- mapM makeAbsolute otherLibraryDirectories + setEnv "FC" compiler + setEnv "FFLAGS" (intercalate " " flags) + setEnv "BUILD_DIR" $ unWindowsPath absoluteBuildDirectory + setEnv + "INCLUDE_DIRS" + (intercalate " " (map unWindowsPath absoluteLibraryDirectories)) + let archiveFile = + (unWindowsPath absoluteBuildDirectory) + ++ "/lib" + ++ libraryName + <.> "a" + withCurrentDirectory + projectDirectory + if + | isMakefile script -> system + ("make -f " ++ script ++ " " ++ archiveFile) + | otherwise -> system (script ++ " " ++ archiveFile) + return archiveFile + +isMakefile :: String -> Bool +isMakefile script | script == "Makefile" = True + | script == "makefile" = True + | ".mk" `isSuffixOf` script = True + | otherwise = False + +unWindowsPath :: String -> String +unWindowsPath = changeSeparators . removeDriveLetter + +removeDriveLetter :: String -> String +removeDriveLetter path | ':' `elem` path = (tail . dropWhile (/= ':')) path + | otherwise = path + +changeSeparators :: String -> String +changeSeparators = replace "\\" "/" 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" diff --git a/bootstrap/stack.yaml b/bootstrap/stack.yaml new file mode 100644 index 0000000..68dcaaa --- /dev/null +++ b/bootstrap/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-14.27 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: +- git: https://github.com/kowainik/tomland.git + commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/bootstrap/stack.yaml.lock b/bootstrap/stack.yaml.lock new file mode 100644 index 0000000..15bfc22 --- /dev/null +++ b/bootstrap/stack.yaml.lock @@ -0,0 +1,26 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + cabal-file: + size: 6802 + sha256: 85568a0280115b6e9a9f263cf4cfc72ad5a6eaeb2412875816adb82ea6a405bc + name: tomland + version: 1.3.0.0 + git: https://github.com/kowainik/tomland.git + pantry-tree: + size: 5000 + sha256: 68d6f9a3e4c20cc4645374b30000017a75c4ab1c131590538edad2ea0e4a53bd + commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 + original: + git: https://github.com/kowainik/tomland.git + commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 +snapshots: +- completed: + size: 524996 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml + sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 + original: lts-14.27 diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 7cf11c6..0000000 --- a/package.yaml +++ /dev/null @@ -1,60 +0,0 @@ -name: fpm -version: 0.1.0.0 -github: "githubuser/fpm" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2020 Author name here" - -extra-source-files: -- README.md -- ChangeLog.md - -# Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base >= 4.7 && < 5 -- containers -- directory -- extra -- filepath -- MissingH -- optparse-applicative -- process -- shake -- split -- text -- tomland >= 1.0 - - -library: - source-dirs: src - -executables: - fpm: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - fpm - -tests: - fpm-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - fpm diff --git a/src/Build.hs b/src/Build.hs deleted file mode 100644 index ffbf264..0000000 --- a/src/Build.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module Build - ( buildLibrary - , buildProgram - , buildWithScript - ) -where - -import Control.Applicative ( (<|>) ) -import Control.Monad ( filterM ) -import Data.Char ( isAsciiLower - , isDigit - , toLower - ) -import Data.List ( intercalate - , isSuffixOf - ) -import Data.List.Utils ( replace ) -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.Directory ( createDirectoryIfMissing - , makeAbsolute - , withCurrentDirectory - ) -import System.Environment ( setEnv ) -import System.FilePath ( splitDirectories ) -import System.Process ( system ) -import Text.ParserCombinators.ReadP ( ReadP - , char - , eof - , many - , many1 - , option - , readP_to_S - , satisfy - , skipSpaces - , string - ) - -type ModuleName = String - -data LineContents = ModuleUsed ModuleName | Other - -buildProgram - :: FilePath - -> [FilePath] - -> [FilePattern] - -> FilePath - -> FilePath - -> [String] - -> String - -> FilePath - -> [FilePath] - -> IO () -buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory compiler flags programName programSource archives - = do - sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions - canonicalProgramSource <- makeAbsolute $ programDirectory programSource - moduleSourceFiles <- filterM - (\source -> do - canonicalSource <- makeAbsolute source - return $ canonicalProgramSource /= canonicalSource - ) - sourceFiles - let moduleObjectFiles = map - (sourceFileToObjectFile buildDirectory programDirectory) - moduleSourceFiles - let sourceFileLookupMap = createSourceFileLookupMap buildDirectory - programDirectory - moduleSourceFiles - let moduleLookupMap = createModuleLookupMap buildDirectory - programDirectory - moduleSourceFiles - otherModuleMaps <- mapM getLibraryModuleMap libraryDirectories - let allModuleMaps = - moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps - let includeFlags = map ("-I" ++) libraryDirectories - shake shakeOptions { shakeFiles = buildDirectory - , shakeChange = ChangeModtimeAndDigest - , shakeColor = True - , shakeThreads = 0 - , shakeProgress = progressSimple - } - $ do - want [buildDirectory programName <.> exe] - buildDirectory programName <.> exe %> \executable -> do - let objectFile = sourceFileToObjectFile buildDirectory - programDirectory - programSource - let allObjectFiles = objectFile : moduleObjectFiles - need allObjectFiles - need archives - cmd compiler allObjectFiles archives ["-o", executable] flags - buildDirectory (map toLower programSource) -<.> "o" %> \objectFile -> do - let realObjectFile = foldl () "" $ splitDirectories objectFile - let sourceFile = programDirectory programSource - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) libraryDirectories - need moduleFilesNeeded - cmd compiler - ["-c", "-J" ++ buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - map (\ext -> buildDirectory "*" <.> ext) ["o", "mod"] - &%> \[objectFile, moduleFile] -> do - let realObjectFile = - foldl () "" $ splitDirectories objectFile - let sourceFile = fromMaybe - undefined - (Map.lookup realObjectFile sourceFileLookupMap) - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) libraryDirectories - need moduleFilesNeeded - cmd compiler - ["-c", "-J" ++ buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - -buildLibrary - :: FilePath - -> [FilePattern] - -> FilePath - -> FilePath - -> [String] - -> String - -> [FilePath] - -> IO (FilePath) -buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags libraryName otherLibraryDirectories - = do - sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions - let sourceFileLookupMap = - createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles - let moduleLookupMap = - createModuleLookupMap buildDirectory libraryDirectory sourceFiles - otherModuleMaps <- mapM getLibraryModuleMap otherLibraryDirectories - let allModuleMaps = - moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps - let archiveFile = buildDirectory "lib" ++ 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 realObjectFile = - foldl () "" $ splitDirectories objectFile - let sourceFile = fromMaybe - undefined - (Map.lookup realObjectFile sourceFileLookupMap) - need [sourceFile] - modulesUsed <- liftIO $ getModulesUsed sourceFile - let moduleFilesNeeded = - mapMaybe (`Map.lookup` allModuleMaps) modulesUsed - let includeFlags = map ("-I" ++) otherLibraryDirectories - need moduleFilesNeeded - cmd compiler - ["-c", "-J" ++ buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - archiveFile %> \a -> do - let objectFiles = Map.keys sourceFileLookupMap - need objectFiles - cmd "ar" ["rs"] a objectFiles - want [archiveFile] - return 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 '_' - -buildWithScript - :: String - -> FilePath - -> FilePath - -> FilePath - -> [String] - -> String - -> [FilePath] - -> IO (FilePath) -buildWithScript script projectDirectory buildDirectory compiler flags libraryName otherLibraryDirectories - = do - absoluteBuildDirectory <- makeAbsolute buildDirectory - createDirectoryIfMissing True absoluteBuildDirectory - absoluteLibraryDirectories <- mapM makeAbsolute otherLibraryDirectories - setEnv "FC" compiler - setEnv "FFLAGS" (intercalate " " flags) - setEnv "BUILD_DIR" $ unWindowsPath absoluteBuildDirectory - setEnv - "INCLUDE_DIRS" - (intercalate " " (map unWindowsPath absoluteLibraryDirectories)) - let archiveFile = - (unWindowsPath absoluteBuildDirectory) - ++ "/lib" - ++ libraryName - <.> "a" - withCurrentDirectory - projectDirectory - if - | isMakefile script -> system - ("make -f " ++ script ++ " " ++ archiveFile) - | otherwise -> system (script ++ " " ++ archiveFile) - return archiveFile - -isMakefile :: String -> Bool -isMakefile script | script == "Makefile" = True - | script == "makefile" = True - | ".mk" `isSuffixOf` script = True - | otherwise = False - -unWindowsPath :: String -> String -unWindowsPath = changeSeparators . removeDriveLetter - -removeDriveLetter :: String -> String -removeDriveLetter path | ':' `elem` path = (tail . dropWhile (/= ':')) path - | otherwise = path - -changeSeparators :: String -> String -changeSeparators = replace "\\" "/" diff --git a/src/Fpm.hs b/src/Fpm.hs deleted file mode 100644 index 60f4aac..0000000 --- a/src/Fpm.hs +++ /dev/null @@ -1,720 +0,0 @@ -{-# 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" diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 68dcaaa..0000000 --- a/stack.yaml +++ /dev/null @@ -1,68 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.27 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -extra-deps: -- git: https://github.com/kowainik/tomland.git - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 15bfc22..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,26 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - cabal-file: - size: 6802 - sha256: 85568a0280115b6e9a9f263cf4cfc72ad5a6eaeb2412875816adb82ea6a405bc - name: tomland - version: 1.3.0.0 - git: https://github.com/kowainik/tomland.git - pantry-tree: - size: 5000 - sha256: 68d6f9a3e4c20cc4645374b30000017a75c4ab1c131590538edad2ea0e4a53bd - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 - original: - git: https://github.com/kowainik/tomland.git - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 -snapshots: -- completed: - size: 524996 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml - sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 - original: lts-14.27 -- cgit v1.2.3