From c12f49bb34bc3f23452f985d9b7348826c72e151 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Thu, 18 Jun 2020 20:34:22 -0700 Subject: Enable fpm to create a new package --- src/Fpm.hs | 111 +++++++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 100 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Fpm.hs b/src/Fpm.hs index 10335c0..1a0e886 100644 --- a/src/Fpm.hs +++ b/src/Fpm.hs @@ -13,7 +13,9 @@ import Build ( buildLibrary , buildProgram , buildWithScript ) -import Control.Monad.Extra ( concatMapM ) +import Control.Monad.Extra ( concatMapM + , when + ) import Data.List ( isSuffixOf , find , nub @@ -47,7 +49,8 @@ import Options.Applicative ( Parser , switch , value ) -import System.Directory ( doesDirectoryExist +import System.Directory ( createDirectory + , doesDirectoryExist , doesFileExist , makeAbsolute , withCurrentDirectory @@ -100,7 +103,7 @@ data GitRef = Tag String | Branch String | Commit String deriving Show data PathVersionSpec = PathVersionSpec { pathVersionSpecPath :: String } deriving Show -data Command = Run String | Test String | Build +data Command = Run String | Test String | Build | New String Bool Bool data DependencyTree = Dependency { dependencyName :: String @@ -111,14 +114,17 @@ data DependencyTree = Dependency { } start :: Arguments -> IO () -start args = 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 +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 @@ -279,6 +285,8 @@ arguments = <> 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")) ) <*> switch (long "release" <> help "Build in release mode") <*> strOption @@ -297,6 +305,13 @@ testArguments = 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 @@ -629,3 +644,77 @@ buildDependency buildPrefix compiler flags (Dependency name path sourcePath mBui 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" -- cgit v1.2.3 From 8d3fd33ece5efc285e138d96d17b0aaa294c6444 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Fri, 19 Jun 2020 07:55:00 -0700 Subject: Improve `fpm new` help description Co-authored-by: Laurence Kedward --- src/Fpm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Fpm.hs b/src/Fpm.hs index 1a0e886..60f4aac 100644 --- a/src/Fpm.hs +++ b/src/Fpm.hs @@ -286,7 +286,7 @@ arguments = <> command "build" (info buildArguments (progDesc "Build the executable")) <> command "new" - (info newArguments (progDesc "Create a new project")) + (info newArguments (progDesc "Create a new project in a new directory")) ) <*> switch (long "release" <> help "Build in release mode") <*> strOption -- cgit v1.2.3