Implement interface to TOML-Fortran and reading of fpm.toml

Author: awvwgk

fpm/fpm.toml

@@ -4,3 +4,6 @@ license = "MIT"
 author = "fpm maintainers"
 maintainer = ""
 copyright = "2020 fpm contributors"
+
+[dependencies]
+toml-f = { git = "https://github.com/toml-f/toml-f" }

fpm/src/fpm.f90

@@ -1,5 +1,7 @@
 module fpm
 use environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS
+use fpm_config, only : get_package_data, package_t
+use fpm_error, only : error_t
 implicit none
 private
 public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test
@@ -85,34 +87,53 @@ logical function str_ends_with(s, e) result(r)
 end if
 end function
 
-subroutine package_name(name)
-character(:), allocatable, intent(out) :: name
-! Currrently a heuristic. We should update this to read the name from fpm.toml
-if (exists("src/fpm.f90")) then
-    name = "fpm"
-else
-    name = "hello_world"
-end if
-end subroutine
-
 subroutine cmd_build()
+type(package_t) :: package
+type(error_t), allocatable :: error
 type(string_t), allocatable :: files(:)
-character(:), allocatable :: basename, pkg_name, linking
+character(:), allocatable :: basename, linking
 integer :: i, n
-print *, "# Building project"
-call list_files("src", files)
+call get_package_data(package, "fpm.toml", error)
+if (allocated(error)) then
+    print '(a)', error%message
+    error stop 1
+end if
+
+! Populate library in case we find the default src directory
+if (.not.allocated(package%library) .and. exists("src")) then
+    allocate(package%library)
+    package%library%source_dir = "src"
+end if
+
+! Populate executable in case we find the default app directory
+if (.not.allocated(package%executable) .and. exists("app")) then
+    allocate(package%executable(1))
+    package%executable(1)%name = package%name
+    package%executable(1)%source_dir = "app"
+    package%executable(1)%main = "main.f90"
+end if
+
 linking = ""
-do i = 1, size(files)
-    if (str_ends_with(files(i)%s, ".f90")) then
-        n = len(files(i)%s)
-        basename = files(i)%s(1:n-4)
-        call run("gfortran -c src/" // basename // ".f90 -o " // basename // ".o")
-        linking = linking // " " // basename // ".o"
-    end if
+if (allocated(package%library)) then
+    call list_files(package%library%source_dir, files)
+    do i = 1, size(files)
+        if (str_ends_with(files(i)%s, ".f90")) then
+            n = len(files(i)%s)
+            basename = files(i)%s
+            call run("gfortran -c " // package%library%source_dir // "/" // &
+               & basename // " -o " // basename // ".o")
+            linking = linking // " " // basename // ".o"
+        end if
+    end do
+end if
+
+do i = 1, size(package%executable)
+    basename = package%executable(i)%main
+    call run("gfortran -c " // package%executable(i)%source_dir // "/" // &
+       & basename // " -o " // basename // ".o")
+    call run("gfortran " // basename // ".o " // linking // " -o " // &
+       & package%executable(i)%name)
 end do
-call run("gfortran -c app/main.f90 -o main.o")
-call package_name(pkg_name)
-call run("gfortran main.o " // linking // " -o " // pkg_name)
 end subroutine
 
 subroutine cmd_install()

fpm/src/fpm_config.f90

@@ -0,0 +1,43 @@
+!> Package configuration data
+module fpm_config
+   use fpm_config_package, only : package_t, new_package
+   use fpm_error, only : error_t, fatal_error, file_not_found_error
+   use fpm_toml, only : toml_table, read_package_file
+   implicit none
+   private
+
+   public :: get_package_data
+   public :: package_t
+
+
+contains
+
+
+!> Obtain package meta data from an configuation file
+subroutine get_package_data(package, file, error)
+
+   !> Parsed package meta data
+   type(package_t), intent(out) :: package
+
+   !> Name of the package configuration file
+   character(len=*), intent(in) :: file
+
+   !> Error status of the operation
+   type(error_t), allocatable, intent(out) :: error
+
+   type(toml_table), allocatable :: table
+
+   call read_package_file(table, file, error)
+   if (allocated(error)) return
+
+   if (.not.allocated(table)) then
+      call fatal_error(error, "Unclassified error while reading: '"//file//"'")
+      return
+   end if
+
+   call new_package(package, table, error)
+
+end subroutine get_package_data
+
+
+end module fpm_config

fpm/src/fpm_config_dependency.f90

@@ -0,0 +1,230 @@
+!> Implementation of the meta data for dependencies.
+!
+!  A dependency table can currently have the following fields
+!
+!  ```toml
+!  [dependencies]
+!  "dep1" = { git = "url" }
+!  "dep2" = { git = "url", branch = "name" }
+!  "dep3" = { git = "url", tag = "name" }
+!  "dep4" = { git = "url", rev = "sha1" }
+!  "dep0" = { path = "path" }
+!  ```
+module fpm_config_dependency
+   use fpm_error, only : error_t, syntax_error
+   use fpm_git, only : git_target_t, git_target_tag, git_target_branch, &
+      & git_target_revision, git_target_default
+   use fpm_toml, only : toml_table, toml_key, toml_stat, get_value
+   implicit none
+   private
+
+   public :: dependency_t, new_dependency, new_dependencies
+
+
+   !> Configuration meta data for a dependency
+   type :: dependency_t
+
+      !> Name of the dependency
+      character(len=:), allocatable :: name
+
+      !> Local target
+      character(len=:), allocatable :: path
+
+      !> Git descriptor
+      type(git_target_t), allocatable :: git
+
+   contains
+
+      !> Print information on this instance
+      procedure :: info
+
+   end type dependency_t
+
+
+contains
+
+
+!> Construct a new dependency configuration from a TOML data structure
+subroutine new_dependency(self, table, error)
+
+   !> Instance of the dependency configuration
+   type(dependency_t), intent(out) :: self
+
+   !> Instance of the TOML data structure
+   type(toml_table), intent(inout) :: table
+
+   !> Error handling
+   type(error_t), allocatable, intent(out) :: error
+
+   character(len=:), allocatable :: url, obj
+   integer :: stat
+
+   call check(table, error)
+   if (allocated(error)) return
+
+   call table%get_key(self%name)
+
+   call get_value(table, "path", url)
+   if (allocated(url)) then
+      call move_alloc(url, self%path)
+   else
+      call get_value(table, "git", url)
+
+      call get_value(table, "tag", obj)
+      if (allocated(obj)) then
+         self%git = git_target_tag(url, obj)
+      end if
+
+      if (.not.allocated(self%git)) then
+         call get_value(table, "branch", obj)
+         if (allocated(obj)) then
+            self%git = git_target_branch(url, obj)
+         end if
+      end if
+
+      if (.not.allocated(self%git)) then
+         call get_value(table, "revision", obj)
+         if (allocated(obj)) then
+            self%git = git_target_revision(url, obj)
+         end if
+      end if
+
+      if (.not.allocated(self%git)) then
+         self%git = git_target_default(url)
+      end if
+
+   end if
+
+end subroutine new_dependency
+
+
+!> Check local schema for allowed entries
+subroutine check(table, error)
+
+   !> Instance of the TOML data structure
+   type(toml_table), intent(inout) :: table
+
+   !> Error handling
+   type(error_t), allocatable, intent(out) :: error
+
+   character(len=:), allocatable :: name
+   type(toml_key), allocatable :: list(:)
+   logical :: url_present, git_target_present
+   integer :: ikey
+
+   url_present = .false.
+   git_target_present = .false.
+
+   call table%get_key(name)
+   call table%get_keys(list)
+
+   if (.not.allocated(list)) then
+      call syntax_error(error, "Dependency "//name//" does not provide sufficient entries")
+      return
+   end if
+
+   do ikey = 1, size(list)
+      select case(list(ikey)%key)
+      case default
+         call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name)
+         exit
+
+      case("git", "path")
+         if (url_present) then
+            call syntax_error(error, "Dependency "//name//" cannot have both git and path entries")
+            exit
+         end if
+         url_present = .true.
+
+      case("branch", "rev", "tag")
+         if (git_target_present) then
+            call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present")
+            exit
+         end if
+         git_target_present = .true.
+
+      end select
+   end do
+   if (allocated(error)) return
+
+   if (.not.url_present .and. git_target_present) then
+      call syntax_error(error, "Dependency "//name//" uses a local path, therefore no git identifiers are allowed")
+   end if
+
+end subroutine check
+
+
+!> Construct new dependency array from a TOML data structure
+subroutine new_dependencies(deps, table, error)
+
+   !> Instance of the dependency configuration
+   type(dependency_t), allocatable, intent(out) :: deps(:)
+
+   !> Instance of the TOML data structure
+   type(toml_table), intent(inout) :: table
+
+   !> Error handling
+   type(error_t), allocatable, intent(out) :: error
+
+   class(toml_table), pointer :: node
+   type(toml_key), allocatable :: list(:)
+   integer :: idep, stat
+
+   call table%get_keys(list)
+   ! An empty table is okay
+   if (.not.allocated(list)) return
+
+   allocate(deps(size(list)))
+   do idep = 1, size(list)
+      call get_value(table, list(idep)%key, node, stat=stat)
+      if (stat /= toml_stat%success) then
+         call syntax_error(error, "Dependency "//list(idep)%key//" must be a table entry")
+         exit
+      end if
+      call new_dependency(deps(idep), node, error)
+      if (allocated(error)) exit
+   end do
+
+end subroutine new_dependencies
+
+
+!> Write information on instance
+subroutine info(self, unit, verbosity)
+
+   !> Instance of the dependency configuration
+   class(dependency_t), intent(in) :: self
+
+   !> Unit for IO
+   integer, intent(in) :: unit
+
+   !> Verbosity of the printout
+   integer, intent(in), optional :: verbosity
+
+   integer :: pr
+   character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)'
+
+   if (present(verbosity)) then
+      pr = verbosity
+   else
+      pr = 1
+   end if
+
+   write(unit, fmt) "Dependency"
+   if (allocated(self%name)) then
+      write(unit, fmt) "- name", self%name
+   end if
+
+   if (allocated(self%git)) then
+      write(unit, fmt) "- kind", "git"
+      call self%git%info(unit, pr - 1)
+   end if
+
+   if (allocated(self%path)) then
+      write(unit, fmt) "- kind", "local"
+      write(unit, fmt) "- path", self%path
+   end if
+
+end subroutine info
+
+
+end module fpm_config_dependency