From 339efd6e4c371366f4541676644b624af51f8097 Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Tue, 27 Oct 2020 17:20:01 -0500 Subject: Change bootstrap command line to be more like the Fortran version --- bootstrap/src/Fpm.hs | 186 ++++++++++++++++++++++++++++++++----------------- bootstrap/test/Spec.hs | 60 ++++++++-------- 2 files changed, 152 insertions(+), 94 deletions(-) diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs index 115b63e..cee04af 100644 --- a/bootstrap/src/Fpm.hs +++ b/bootstrap/src/Fpm.hs @@ -3,7 +3,6 @@ module Fpm ( Arguments(..) - , Command(..) , getArguments , start ) @@ -43,6 +42,7 @@ import Options.Applicative ( Parser , info , long , metavar + , optional , progDesc , strArgument , strOption @@ -67,7 +67,25 @@ import Toml ( TomlCodec ) import qualified Toml -data Arguments = Arguments { command' :: Command, release :: Bool, commandArguments :: String } +data Arguments = + New + { newName :: String + , newWithExecutable :: Bool + , newWithTest :: Bool + , newWithLib :: Bool + } + | Build + { buildRelease :: Bool } + | Run + { runRelease :: Bool + , runTarget :: Maybe String + , runArgs :: Maybe String + } + | Test + { testRelease :: Bool + , testTarget :: Maybe String + , testArgs :: Maybe String + } data TomlSettings = TomlSettings { tomlSettingsProjectName :: String @@ -107,8 +125,6 @@ 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 @@ -118,22 +134,22 @@ data DependencyTree = Dependency { } start :: Arguments -> IO () -start args = case command' args of - New projectName withExecutable withTest -> - createNewProject projectName withExecutable withTest +start args = case args of + New { newName = name, newWithExecutable = withExecutable, newWithTest = withTest, newWithLib = withLib } + -> createNewProject name withExecutable withTest withLib _ -> do fpmContents <- TIO.readFile "fpm.toml" let tomlSettings = Toml.decode settingsCodec fpmContents case tomlSettings of Left err -> print err Right tomlSettings' -> do - appSettings <- toml2AppSettings tomlSettings' (release args) + appSettings <- toml2AppSettings tomlSettings' args app args appSettings app :: Arguments -> AppSettings -> IO () -app args settings = case command' args of - Build -> build settings - Run whichOne -> do +app args settings = case args of + Build{} -> build settings + Run { runTarget = whichOne, runArgs = runArgs } -> do build settings let buildPrefix = appSettingsBuildPrefix settings let @@ -148,10 +164,16 @@ app args settings = case command' args of case canonicalExecutables of [] -> putStrLn "No Executables Found" _ -> case whichOne of - "" -> do + Nothing -> do exitCodes <- mapM system - (map (++ " " ++ commandArguments args) canonicalExecutables) + (map + (++ case runArgs of + Nothing -> "" + Just theArgs -> " " ++ theArgs + ) + canonicalExecutables + ) forM_ exitCodes (\exitCode -> when @@ -161,13 +183,15 @@ app args settings = case command' args of ) (exitWith exitCode) ) - name -> do + Just name -> do case find (name `isSuffixOf`) canonicalExecutables of Nothing -> putStrLn "Executable Not Found" Just specified -> do - exitCode <- system (specified ++ " " ++ (commandArguments args)) + exitCode <- case runArgs of + Nothing -> system specified + Just theArgs -> system (specified ++ " " ++ theArgs) exitWith exitCode - Test whichOne -> do + Test { testTarget = whichOne, testArgs = testArgs } -> do build settings let buildPrefix = appSettingsBuildPrefix settings let @@ -182,10 +206,16 @@ app args settings = case command' args of case canonicalExecutables of [] -> putStrLn "No Tests Found" _ -> case whichOne of - "" -> do + Nothing -> do exitCodes <- mapM system - (map (++ " " ++ commandArguments args) canonicalExecutables) + (map + (++ case testArgs of + Nothing -> "" + Just theArgs -> " " ++ theArgs + ) + canonicalExecutables + ) forM_ exitCodes (\exitCode -> when @@ -195,12 +225,15 @@ app args settings = case command' args of ) (exitWith exitCode) ) - name -> do + Just name -> do case find (name `isSuffixOf`) canonicalExecutables of Nothing -> putStrLn "Test Not Found" Just specified -> do - exitCode <- system (specified ++ " " ++ (commandArguments args)) + exitCode <- case testArgs of + Nothing -> system specified + Just theArgs -> system (specified ++ " " ++ theArgs) exitWith exitCode + _ -> putStrLn "Shouldn't be able to get here" build :: AppSettings -> IO () build settings = do @@ -302,42 +335,61 @@ getArguments = execParser ) 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") - ) +arguments = subparser + ( command + "new" + (info (newArguments <**> helper) + (progDesc "Create a new project in a new directory") + ) + <> command + "build" + (info (buildArguments <**> helper) (progDesc "Build the project")) + <> command + "run" + (info (runArguments <**> helper) (progDesc "Run the executable(s)")) + <> command "test" + (info (testArguments <**> helper) (progDesc "Run the test(s)")) + ) + +newArguments :: Parser Arguments +newArguments = + New + <$> strArgument + ( metavar "NAME" + <> help "Name of new project (must be a valid Fortran identifier)" ) - <*> switch (long "release" <> help "Build in release mode") - <*> strOption - (long "args" <> metavar "ARGS" <> value "" <> help - "Arguments to pass to executables/tests" + <*> switch (long "app" <> help "Include an executable") + <*> switch (long "test" <> help "Include a test") + <*> switch (long "lib" <> help "Include a library") + +buildArguments :: Parser Arguments +buildArguments = Build <$> switch + (long "release" <> help "Build with optimizations instead of debugging") + +runArguments :: Parser Arguments +runArguments = + Run + <$> switch + ( long "release" + <> help "Build with optimizations instead of debugging" ) + <*> optional + (strArgument + (metavar "TARGET" <> help "Name of the executable to run") + ) + <*> optional + (strArgument (metavar "ARGS" <> help "Arguments to the executable")) -runArguments :: Parser Command -runArguments = Run <$> strArgument - (metavar "EXE" <> value "" <> help "Which executable to run") - -testArguments :: Parser Command +testArguments :: Parser Arguments 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") + Test + <$> switch + ( long "release" + <> help "Build with optimizations instead of debugging" + ) + <*> optional + (strArgument (metavar "TARGET" <> help "Name of the test to run")) + <*> optional (strArgument (metavar "ARGS" <> help "Arguments to the test")) getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns @@ -437,8 +489,12 @@ pathVersionCodec :: Toml.TomlCodec PathVersionSpec pathVersionCodec = PathVersionSpec <$> Toml.string "path" .= pathVersionSpecPath -toml2AppSettings :: TomlSettings -> Bool -> IO AppSettings -toml2AppSettings tomlSettings release = do +toml2AppSettings :: TomlSettings -> Arguments -> IO AppSettings +toml2AppSettings tomlSettings args = do + let release = case args of + Build { buildRelease = r } -> r + Run { runRelease = r } -> r + Test { testRelease = r } -> r let projectName = tomlSettingsProjectName tomlSettings let compiler = "gfortran" librarySettings <- getLibrarySettings $ tomlSettingsLibrary tomlSettings @@ -682,19 +738,20 @@ buildDependency buildPrefix compiler flags (Dependency name path sourcePath mBui (map fst transitiveDependencies) return $ (buildPath, thisArchive) : transitiveDependencies -createNewProject :: String -> Bool -> Bool -> IO () -createNewProject projectName withExecutable withTest = do +createNewProject :: String -> Bool -> Bool -> Bool -> IO () +createNewProject projectName withExecutable withTest withLib = do createDirectory projectName writeFile (projectName "fpm.toml") (templateFpmToml projectName) writeFile (projectName "README.md") (templateReadme projectName) writeFile (projectName ".gitignore") "build/*\n" - createDirectory (projectName "src") - writeFile (projectName "src" projectName <.> "f90") - (templateModule projectName) + when withLib $ do + createDirectory (projectName "src") + writeFile (projectName "src" projectName <.> "f90") + (templateModule projectName) when withExecutable $ do createDirectory (projectName "app") writeFile (projectName "app" "main.f90") - (templateProgram projectName) + (templateProgram projectName withLib) when withTest $ do createDirectory (projectName "test") writeFile (projectName "test" "main.f90") templateTest @@ -736,12 +793,11 @@ templateReadme :: String -> String templateReadme projectName = "# " ++ projectName ++ "\n" ++ "\n" ++ "My cool new project!\n" -templateProgram :: String -> String -templateProgram projectName = +templateProgram :: String -> Bool -> String +templateProgram projectName withLib = "program main\n" - ++ " use " - ++ projectName - ++ ", only: say_hello\n" + ++ (if withLib then " use " ++ projectName ++ ", only: say_hello\n" else "" + ) ++ "\n" ++ " implicit none\n" ++ "\n" diff --git a/bootstrap/test/Spec.hs b/bootstrap/test/Spec.hs index 4e660e7..c1f7108 100644 --- a/bootstrap/test/Spec.hs +++ b/bootstrap/test/Spec.hs @@ -1,6 +1,5 @@ import Development.Shake.FilePath ( () ) import Fpm ( Arguments(..) - , Command(..) , start ) import System.Directory ( withCurrentDirectory ) @@ -19,49 +18,52 @@ main = do testHelloWorld :: IO () testHelloWorld = - withCurrentDirectory (example_path "hello_world") $ start $ Arguments - (Run "") - False - "" + withCurrentDirectory (example_path "hello_world") $ start $ Run + { runRelease = False + , runTarget = Nothing + , runArgs = Nothing + } testHelloComplex :: IO () testHelloComplex = - withCurrentDirectory (example_path "hello_complex") $ start $ Arguments - (Test "") - False - "" + withCurrentDirectory (example_path "hello_complex") $ start $ Test + { testRelease = False + , testTarget = Nothing + , testArgs = Nothing + } testHelloFpm :: IO () testHelloFpm = - withCurrentDirectory (example_path "hello_fpm") $ start $ Arguments - (Run "") - False - "" + withCurrentDirectory (example_path "hello_fpm") $ start $ Run + { runRelease = False + , runTarget = Nothing + , runArgs = Nothing + } testCircular :: IO () testCircular = - withCurrentDirectory (example_path "circular_example") $ start $ Arguments - (Test "") - False - "" + withCurrentDirectory (example_path "circular_example") $ start $ Test + { testRelease = False + , testTarget = Nothing + , testArgs = Nothing + } testWithMakefile :: IO () testWithMakefile = - withCurrentDirectory (example_path "with_makefile") $ start $ Arguments - (Build) - False - "" + withCurrentDirectory (example_path "with_makefile") $ start $ Build + { buildRelease = False + } testMakefileComplex :: IO () testMakefileComplex = - withCurrentDirectory (example_path "makefile_complex") $ start $ Arguments - (Run "") - False - "" + withCurrentDirectory (example_path "makefile_complex") $ start $ Run + { runRelease = False + , runTarget = Nothing + , runArgs = Nothing + } testSubmodule :: IO () testSubmodule = - withCurrentDirectory (example_path "submodules") $ start $ Arguments - (Build) - False - "" + withCurrentDirectory (example_path "submodules") $ start $ Build + { buildRelease = False + } -- cgit v1.2.3