From bd27ae8161860f9a40c3953e20001af1f450d5f4 Mon Sep 17 00:00:00 2001
From: Brad Richardson <everythingfunctional@protonmail.com>
Date: Thu, 15 Oct 2020 11:07:47 -0500
Subject: Add test for whether a module produces a .smod file

---
 bootstrap/src/BuildModel.hs                        | 43 +++++++++++++++++++---
 .../unit_test/ModuleSourceConstructionTest.hs      | 17 ++++++++-
 2 files changed, 53 insertions(+), 7 deletions(-)

(limited to 'bootstrap')

diff --git a/bootstrap/src/BuildModel.hs b/bootstrap/src/BuildModel.hs
index baefda9..dc57f81 100644
--- a/bootstrap/src/BuildModel.hs
+++ b/bootstrap/src/BuildModel.hs
@@ -29,6 +29,7 @@ data LineContents =
     ProgramDeclaration
   | ModuleDeclaration String
   | ModuleUsed String
+  | ModuleSubprogramDeclaration
   | Other
 
 data RawSource = RawSource {
@@ -47,6 +48,7 @@ data Source =
     , moduleObjectFileName :: FilePath -> FilePath
     , moduleModulesUsed :: [String]
     , moduleName :: String
+    , moduleProducesSmod :: Bool
     }
 
 processRawSource :: RawSource -> Source
@@ -62,11 +64,13 @@ processRawSource rawSource =
                      , programModulesUsed    = modulesUsed
                      }
         else if hasModuleDeclaration parsedContents
-          then Module { moduleSourceFileName = sourceFileName
-                      , moduleObjectFileName = objectFileName
-                      , moduleModulesUsed    = modulesUsed
-                      , moduleName           = getModuleName parsedContents
-                      }
+          then Module
+            { moduleSourceFileName = sourceFileName
+            , moduleObjectFileName = objectFileName
+            , moduleModulesUsed    = modulesUsed
+            , moduleName           = getModuleName parsedContents
+            , moduleProducesSmod = hasModuleSubprogramDeclaration parsedContents
+            }
           else undefined
 
 pathSeparatorsToUnderscores :: FilePath -> FilePath
@@ -96,6 +100,15 @@ hasModuleDeclaration parsedContents = case filter f parsedContents of
     ModuleDeclaration{} -> True
     _                   -> False
 
+hasModuleSubprogramDeclaration :: [LineContents] -> Bool
+hasModuleSubprogramDeclaration parsedContents = case filter f parsedContents of
+  x : _ -> True
+  _     -> False
+ where
+  f lc = case lc of
+    ModuleSubprogramDeclaration -> True
+    _                           -> False
+
 getModulesUsed :: [LineContents] -> [String]
 getModulesUsed = mapMaybe contentToMaybeModuleName
  where
@@ -130,7 +143,10 @@ doFortranLineParse = option Other fortranUsefulContents
 
 fortranUsefulContents :: ReadP LineContents
 fortranUsefulContents =
-  programDeclaration <|> moduleDeclaration <|> useStatement
+  programDeclaration
+    <|> moduleSubprogramDeclaration
+    <|> moduleDeclaration
+    <|> useStatement
 
 programDeclaration :: ReadP LineContents
 programDeclaration = do
@@ -158,6 +174,16 @@ useStatement = do
   skipSpaceCommaOrEnd
   return $ ModuleUsed modName
 
+moduleSubprogramDeclaration :: ReadP LineContents
+moduleSubprogramDeclaration = do
+  skipAnything
+  _ <- string "module"
+  skipAtLeastOneWhiteSpace
+  skipAnything
+  _ <- string "function" <|> string "subroutine"
+  skipAtLeastOneWhiteSpace
+  return $ ModuleSubprogramDeclaration
+
 skipAtLeastOneWhiteSpace :: ReadP ()
 skipAtLeastOneWhiteSpace = do
   _ <- many1 whiteSpace
@@ -182,6 +208,11 @@ skipComment = do
   _ <- char '!'
   return ()
 
+skipAnything :: ReadP ()
+skipAnything = do
+  _ <- many (satisfy (const True))
+  return ()
+
 whiteSpace :: ReadP Char
 whiteSpace = satisfy (`elem` " \t")
 
diff --git a/bootstrap/unit_test/ModuleSourceConstructionTest.hs b/bootstrap/unit_test/ModuleSourceConstructionTest.hs
index 26f08b2..b98e9d3 100644
--- a/bootstrap/unit_test/ModuleSourceConstructionTest.hs
+++ b/bootstrap/unit_test/ModuleSourceConstructionTest.hs
@@ -33,12 +33,23 @@ test = return $ givenInput
         checkModuleObjectFileName
       , then' "it knows what modules it uses directly" checkModuleModulesUsed
       , then' "it knows its name"                      checkModuleName
+      , then' "it can tell that it will produce a '.smod' file" checkSmod
       ]
   ]
 
 exampleModule :: RawSource
 exampleModule = RawSource moduleSourceFileName' $ unlines
-  ["module some_module", "  use module1", "USE MODULE2", "end module"]
+  [ "module some_module"
+  , "  use module1"
+  , "  USE MODULE2"
+  , "  implicit none"
+  , "  interface"
+  , "    pure module function some_func()"
+  , "      integer :: some_func"
+  , "    end function"
+  , "  end interface"
+  , "end module"
+  ]
 
 moduleSourceFileName' :: String
 moduleSourceFileName' = "some" </> "file" </> "somewhere.f90"
@@ -66,3 +77,7 @@ checkModuleModulesUsed _ = fail' "wasn't a Module"
 checkModuleName :: Source -> Result
 checkModuleName m@(Module{}) = assertEquals "some_module" $ moduleName m
 checkModuleName _            = fail' "wasn't a Module"
+
+checkSmod :: Source -> Result
+checkSmod m@(Module{}) = assertThat $ moduleProducesSmod m
+checkSmod _ = fail' "wasn't a Module"
-- 
cgit v1.2.3