Add test with submodule example project and fix .smod naming convention

Author: everythingfunctional

bootstrap/src/BuildModel.hs

@@ -1,6 +1,7 @@
 module BuildModel where
 
 import           Control.Applicative            ( (<|>) )
+import           Control.Monad                  ( when )
 import           Data.Char                      ( isAsciiLower
                                                 , isDigit
                                                 , toLower
@@ -30,7 +31,7 @@ data LineContents =
   | ModuleDeclaration String
   | ModuleUsed String
   | ModuleSubprogramDeclaration
-  | SubmoduleDeclaration String String
+  | SubmoduleDeclaration String String String
   | Other
 
 data RawSource = RawSource {
@@ -55,6 +56,7 @@ data Source =
     { submoduleSourceFileName :: FilePath
     , submoduleObjectFileName :: FilePath -> FilePath
     , submoduleModulesUsed :: [String]
+    , submoduleBaseModuleName :: String
     , submoduleParentName :: String
     , submoduleName :: String
     }
@@ -68,33 +70,37 @@ data CompileTimeInfo = CompileTimeInfo {
 
 processRawSource :: RawSource -> Source
 processRawSource rawSource =
-  let sourceFileName = rawSourceFilename rawSource
-      parsedContents = parseContents rawSource
-      objectFileName =
-          \bd -> bd </> (pathSeparatorsToUnderscores sourceFileName) <.> "o"
-      modulesUsed = getModulesUsed parsedContents
-  in  if hasProgramDeclaration parsedContents
-        then Program { programSourceFileName = sourceFileName
-                     , programObjectFileName = objectFileName
-                     , programModulesUsed    = modulesUsed
-                     }
-        else if hasModuleDeclaration parsedContents
-          then Module
-            { moduleSourceFileName = sourceFileName
-            , moduleObjectFileName = objectFileName
-            , moduleModulesUsed    = modulesUsed
-            , moduleName           = getModuleName parsedContents
-            , moduleProducesSmod = hasModuleSubprogramDeclaration parsedContents
+  let
+    sourceFileName = rawSourceFilename rawSource
+    parsedContents = parseContents rawSource
+    objectFileName =
+      \bd -> bd </> (pathSeparatorsToUnderscores sourceFileName) <.> "o"
+    modulesUsed = getModulesUsed parsedContents
+  in
+    if hasProgramDeclaration parsedContents
+      then Program { programSourceFileName = sourceFileName
+                   , programObjectFileName = objectFileName
+                   , programModulesUsed    = modulesUsed
+                   }
+      else if hasModuleDeclaration parsedContents
+        then Module
+          { moduleSourceFileName = sourceFileName
+          , moduleObjectFileName = objectFileName
+          , moduleModulesUsed    = modulesUsed
+          , moduleName           = getModuleName parsedContents
+          , moduleProducesSmod   = hasModuleSubprogramDeclaration parsedContents
+          }
+        else if hasSubmoduleDeclaration parsedContents
+          then Submodule
+            { submoduleSourceFileName = sourceFileName
+            , submoduleObjectFileName = objectFileName
+            , submoduleModulesUsed    = modulesUsed
+            , submoduleBaseModuleName = getSubmoduleBaseModuleName
+                                          parsedContents
+            , submoduleParentName     = getSubmoduleParentName parsedContents
+            , submoduleName           = getSubmoduleName parsedContents
             }
-          else if hasSubmoduleDeclaration parsedContents
-            then Submodule
-              { submoduleSourceFileName = sourceFileName
-              , submoduleObjectFileName = objectFileName
-              , submoduleModulesUsed    = modulesUsed
-              , submoduleParentName     = getSubmoduleParentName parsedContents
-              , submoduleName           = getSubmoduleName parsedContents
-              }
-            else undefined
+          else undefined
 
 getAvailableModules :: [Source] -> [String]
 getAvailableModules = mapMaybe maybeModuleName
@@ -110,8 +116,8 @@ getAllObjectFiles buildDirectory sources = map getObjectFile sources
   getObjectFile s@(Submodule{}) = (submoduleObjectFileName s) buildDirectory
 
 getSourceFileName :: Source -> FilePath
-getSourceFileName p@(Program{}) = programSourceFileName p
-getSourceFileName m@(Module{}) = moduleSourceFileName m
+getSourceFileName p@(Program{}  ) = programSourceFileName p
+getSourceFileName m@(Module{}   ) = moduleSourceFileName m
 getSourceFileName s@(Submodule{}) = submoduleSourceFileName s
 
 constructCompileTimeInfo :: Source -> [String] -> FilePath -> CompileTimeInfo
@@ -144,7 +150,7 @@ constructCompileTimeInfo s@(Submodule{}) availableModules buildDirectory =
     , compileTimeInfoObjectFileProduced = (submoduleObjectFileName s)
                                             buildDirectory
     , compileTimeInfoOtherFilesProduced = [ buildDirectory
-                                            </> submoduleParentName s
+                                            </> submoduleBaseModuleName s
                                             ++  "@"
                                             ++  submoduleName s
                                             <.> "smod"
@@ -215,19 +221,27 @@ getModuleName pc = head $ mapMaybe contentToMaybeModuleName pc
     ModuleDeclaration moduleName -> Just moduleName
     _                            -> Nothing
 
+getSubmoduleBaseModuleName :: [LineContents] -> String
+getSubmoduleBaseModuleName pc = head $ mapMaybe contentToMaybeModuleName pc
+ where
+  contentToMaybeModuleName content = case content of
+    SubmoduleDeclaration baseModuleName submoduleParentName submoduleName ->
+      Just baseModuleName
+    _ -> Nothing
+
 getSubmoduleParentName :: [LineContents] -> String
 getSubmoduleParentName pc = head $ mapMaybe contentToMaybeModuleName pc
  where
   contentToMaybeModuleName content = case content of
-    SubmoduleDeclaration submoduleParentName submoduleName ->
+    SubmoduleDeclaration baseModuleName submoduleParentName submoduleName ->
       Just submoduleParentName
     _ -> Nothing
 
 getSubmoduleName :: [LineContents] -> String
 getSubmoduleName pc = head $ mapMaybe contentToMaybeModuleName pc
  where
   contentToMaybeModuleName content = case content of
-    SubmoduleDeclaration submoduleParentName submoduleName ->
+    SubmoduleDeclaration baseModuleName submoduleParentName submoduleName ->
       Just submoduleName
     _ -> Nothing
 
@@ -271,6 +285,7 @@ moduleDeclaration = do
   _ <- string "module"
   skipAtLeastOneWhiteSpace
   moduleName <- validIdentifier
+  when (moduleName == "procedure") (fail "")
   skipSpaceCommentOrEnd
   return $ ModuleDeclaration moduleName
 
@@ -279,10 +294,13 @@ submoduleDeclaration = do
   skipSpaces
   _       <- string "submodule"
   parents <- submoduleParents
+  let parentName = case parents of
+        (baseModule : []) -> baseModule
+        (multiple       ) -> (head multiple) ++ "@" ++ (last multiple)
   skipSpaces
   name <- validIdentifier
   skipSpaceCommentOrEnd
-  return $ SubmoduleDeclaration (intercalate "@" parents) name
+  return $ SubmoduleDeclaration (head parents) parentName name
 
 submoduleParents :: ReadP [String]
 submoduleParents = do

bootstrap/test/Spec.hs

@@ -15,27 +15,53 @@ main = do
   testCircular
   testWithMakefile
   testMakefileComplex
+  testSubmodule
 
 testHelloWorld :: IO ()
 testHelloWorld =
-  withCurrentDirectory (example_path </> "hello_world") $ start $ Arguments (Run "") False ""
+  withCurrentDirectory (example_path </> "hello_world") $ start $ Arguments
+    (Run "")
+    False
+    ""
 
 testHelloComplex :: IO ()
 testHelloComplex =
-  withCurrentDirectory (example_path </> "hello_complex") $ start $ Arguments (Test "") False ""
+  withCurrentDirectory (example_path </> "hello_complex") $ start $ Arguments
+    (Test "")
+    False
+    ""
 
 testHelloFpm :: IO ()
 testHelloFpm =
-    withCurrentDirectory (example_path </> "hello_fpm") $ start $ Arguments (Run "") False ""
+  withCurrentDirectory (example_path </> "hello_fpm") $ start $ Arguments
+    (Run "")
+    False
+    ""
 
 testCircular :: IO ()
 testCircular =
-    withCurrentDirectory (example_path </> "circular_example") $ start $ Arguments (Test "") False ""
+  withCurrentDirectory (example_path </> "circular_example") $ start $ Arguments
+    (Test "")
+    False
+    ""
 
 testWithMakefile :: IO ()
 testWithMakefile =
-    withCurrentDirectory (example_path </> "with_makefile") $ start $ Arguments (Build) False ""
+  withCurrentDirectory (example_path </> "with_makefile") $ start $ Arguments
+    (Build)
+    False
+    ""
 
 testMakefileComplex :: IO ()
 testMakefileComplex =
-    withCurrentDirectory (example_path </> "makefile_complex") $ start $ Arguments (Run "") False ""
+  withCurrentDirectory (example_path </> "makefile_complex") $ start $ Arguments
+    (Run "")
+    False
+    ""
+
+testSubmodule :: IO ()
+testSubmodule =
+  withCurrentDirectory (example_path </> "submodules") $ start $ Arguments
+    (Build)
+    False
+    ""

bootstrap/unit_test/SubmoduleToCompileInfoTest.hs

@@ -37,6 +37,7 @@ exampleSubmodule = Submodule
   { submoduleSourceFileName = submoduleSourceFileName'
   , submoduleObjectFileName = \bd -> bd </> "some_file_somewhere.f90.o"
   , submoduleModulesUsed    = ["module1", "module2", "module3"]
+  , submoduleBaseModuleName = "base_module"
   , submoduleParentName     = "base_module@parent"
   , submoduleName           = "some_submodule"
   }
@@ -62,7 +63,7 @@ checkObjectFileName cti = assertEquals
 
 checkOtherFilesProduced :: CompileTimeInfo -> Result
 checkOtherFilesProduced cti = assertEquals
-  ["build_dir" </> "base_module@parent@some_submodule.smod"]
+  ["build_dir" </> "base_module@some_submodule.smod"]
   (compileTimeInfoOtherFilesProduced cti)
 
 checkDirectDependencies :: CompileTimeInfo -> Result