aboutsummaryrefslogtreecommitdiff
path: root/bootstrap/src/BuildModel.hs
diff options
context:
space:
mode:
Diffstat (limited to 'bootstrap/src/BuildModel.hs')
-rw-r--r--bootstrap/src/BuildModel.hs385
1 files changed, 385 insertions, 0 deletions
diff --git a/bootstrap/src/BuildModel.hs b/bootstrap/src/BuildModel.hs
new file mode 100644
index 0000000..d7b39dc
--- /dev/null
+++ b/bootstrap/src/BuildModel.hs
@@ -0,0 +1,385 @@
+module BuildModel where
+
+import Control.Applicative ( (<|>) )
+import Data.Char ( isAsciiLower
+ , isDigit
+ , toLower
+ )
+import Data.Maybe ( fromMaybe
+ , mapMaybe
+ )
+import Data.List ( intercalate )
+import System.FilePath ( (</>)
+ , (<.>)
+ , splitDirectories
+ )
+import Text.ParserCombinators.ReadP ( ReadP
+ , char
+ , eof
+ , many
+ , many1
+ , option
+ , readP_to_S
+ , satisfy
+ , skipSpaces
+ , string
+ )
+
+data LineContents =
+ ProgramDeclaration
+ | ModuleDeclaration String
+ | ModuleUsed String
+ | ModuleSubprogramDeclaration
+ | SubmoduleDeclaration String String
+ | Other
+
+data RawSource = RawSource {
+ rawSourceFilename :: FilePath
+ , rawSourceContents :: String
+}
+
+data Source =
+ Program
+ { programSourceFileName :: FilePath
+ , programObjectFileName :: FilePath -> FilePath
+ , programModulesUsed :: [String]
+ }
+ | Module
+ { moduleSourceFileName :: FilePath
+ , moduleObjectFileName :: FilePath -> FilePath
+ , moduleModulesUsed :: [String]
+ , moduleName :: String
+ , moduleProducesSmod :: Bool
+ }
+ | Submodule
+ { submoduleSourceFileName :: FilePath
+ , submoduleObjectFileName :: FilePath -> FilePath
+ , submoduleModulesUsed :: [String]
+ , submoduleParentName :: String
+ , submoduleName :: String
+ }
+
+data CompileTimeInfo = CompileTimeInfo {
+ compileTimeInfoSourceFileName :: FilePath
+ , compileTimeInfoObjectFileProduced :: FilePath
+ , compileTimeInfoOtherFilesProduced :: [FilePath]
+ , compileTimeInfoDirectDependencies :: [FilePath]
+}
+
+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
+ }
+ else if hasSubmoduleDeclaration parsedContents
+ then Submodule
+ { submoduleSourceFileName = sourceFileName
+ , submoduleObjectFileName = objectFileName
+ , submoduleModulesUsed = modulesUsed
+ , submoduleParentName = getSubmoduleParentName parsedContents
+ , submoduleName = getSubmoduleName parsedContents
+ }
+ else undefined
+
+getAvailableModules :: [Source] -> [String]
+getAvailableModules = mapMaybe maybeModuleName
+ where
+ maybeModuleName m@(Module{}) = Just $ moduleName m
+ maybeModuleName _ = Nothing
+
+getAllObjectFiles :: FilePath -> [Source] -> [FilePath]
+getAllObjectFiles buildDirectory sources = map getObjectFile sources
+ where
+ getObjectFile p@(Program{} ) = (programObjectFileName p) buildDirectory
+ getObjectFile m@(Module{} ) = (moduleObjectFileName m) buildDirectory
+ getObjectFile s@(Submodule{}) = (submoduleObjectFileName s) buildDirectory
+
+getSourceFileName :: Source -> FilePath
+getSourceFileName p@(Program{}) = programSourceFileName p
+getSourceFileName m@(Module{}) = moduleSourceFileName m
+getSourceFileName s@(Submodule{}) = submoduleSourceFileName s
+
+constructCompileTimeInfo :: Source -> [String] -> FilePath -> CompileTimeInfo
+constructCompileTimeInfo p@(Program{}) availableModules buildDirectory =
+ CompileTimeInfo
+ { compileTimeInfoSourceFileName = programSourceFileName p
+ , compileTimeInfoObjectFileProduced = (programObjectFileName p)
+ buildDirectory
+ , compileTimeInfoOtherFilesProduced = []
+ , compileTimeInfoDirectDependencies = map
+ (\mName -> buildDirectory </> mName <.> "mod")
+ (filter (`elem` availableModules) (programModulesUsed p))
+ }
+constructCompileTimeInfo m@(Module{}) availableModules buildDirectory =
+ CompileTimeInfo
+ { compileTimeInfoSourceFileName = moduleSourceFileName m
+ , compileTimeInfoObjectFileProduced = (moduleObjectFileName m)
+ buildDirectory
+ , compileTimeInfoOtherFilesProduced =
+ (buildDirectory </> moduleName m <.> "mod") : if moduleProducesSmod m
+ then [buildDirectory </> moduleName m <.> "smod"]
+ else []
+ , compileTimeInfoDirectDependencies = map
+ (\mName -> buildDirectory </> mName <.> "mod")
+ (filter (`elem` availableModules) (moduleModulesUsed m))
+ }
+constructCompileTimeInfo s@(Submodule{}) availableModules buildDirectory =
+ CompileTimeInfo
+ { compileTimeInfoSourceFileName = submoduleSourceFileName s
+ , compileTimeInfoObjectFileProduced = (submoduleObjectFileName s)
+ buildDirectory
+ , compileTimeInfoOtherFilesProduced = [ buildDirectory
+ </> submoduleParentName s
+ ++ "@"
+ ++ submoduleName s
+ <.> "smod"
+ ]
+ , compileTimeInfoDirectDependencies =
+ (buildDirectory </> submoduleParentName s <.> "smod")
+ : (map (\mName -> buildDirectory </> mName <.> "mod")
+ (filter (`elem` availableModules) (submoduleModulesUsed s))
+ )
+ }
+
+pathSeparatorsToUnderscores :: FilePath -> FilePath
+pathSeparatorsToUnderscores fileName =
+ intercalate "_" (splitDirectories fileName)
+
+parseContents :: RawSource -> [LineContents]
+parseContents rawSource =
+ let fileLines = lines $ rawSourceContents rawSource
+ in map parseFortranLine fileLines
+
+hasProgramDeclaration :: [LineContents] -> Bool
+hasProgramDeclaration parsedContents = case filter f parsedContents of
+ x : _ -> True
+ _ -> False
+ where
+ f lc = case lc of
+ ProgramDeclaration -> True
+ _ -> False
+
+hasModuleDeclaration :: [LineContents] -> Bool
+hasModuleDeclaration parsedContents = case filter f parsedContents of
+ x : _ -> True
+ _ -> False
+ where
+ f lc = case lc of
+ ModuleDeclaration{} -> True
+ _ -> False
+
+hasSubmoduleDeclaration :: [LineContents] -> Bool
+hasSubmoduleDeclaration parsedContents = case filter f parsedContents of
+ x : _ -> True
+ _ -> False
+ where
+ f lc = case lc of
+ SubmoduleDeclaration{} -> 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
+ contentToMaybeModuleName content = case content of
+ ModuleUsed moduleName -> Just moduleName
+ _ -> Nothing
+
+getModuleName :: [LineContents] -> String
+getModuleName pc = head $ mapMaybe contentToMaybeModuleName pc
+ where
+ contentToMaybeModuleName content = case content of
+ ModuleDeclaration moduleName -> Just moduleName
+ _ -> Nothing
+
+getSubmoduleParentName :: [LineContents] -> String
+getSubmoduleParentName pc = head $ mapMaybe contentToMaybeModuleName pc
+ where
+ contentToMaybeModuleName content = case content of
+ SubmoduleDeclaration submoduleParentName submoduleName ->
+ Just submoduleParentName
+ _ -> Nothing
+
+getSubmoduleName :: [LineContents] -> String
+getSubmoduleName pc = head $ mapMaybe contentToMaybeModuleName pc
+ where
+ contentToMaybeModuleName content = case content of
+ SubmoduleDeclaration submoduleParentName submoduleName ->
+ Just submoduleName
+ _ -> Nothing
+
+readFileLinesIO :: FilePath -> IO [String]
+readFileLinesIO file = do
+ contents <- readFile file
+ return $ lines contents
+
+parseFortranLine :: String -> LineContents
+parseFortranLine line =
+ let line' = map toLower line
+ result = readP_to_S doFortranLineParse line'
+ in getResult result
+ where
+ getResult (_ : (contents, _) : _) = contents
+ getResult [(contents, _) ] = contents
+ getResult [] = Other
+
+doFortranLineParse :: ReadP LineContents
+doFortranLineParse = option Other fortranUsefulContents
+
+fortranUsefulContents :: ReadP LineContents
+fortranUsefulContents =
+ programDeclaration
+ <|> moduleSubprogramDeclaration
+ <|> moduleDeclaration
+ <|> submoduleDeclaration
+ <|> useStatement
+
+programDeclaration :: ReadP LineContents
+programDeclaration = do
+ skipSpaces
+ _ <- string "program"
+ skipAtLeastOneWhiteSpace
+ _ <- validIdentifier
+ return ProgramDeclaration
+
+moduleDeclaration :: ReadP LineContents
+moduleDeclaration = do
+ skipSpaces
+ _ <- string "module"
+ skipAtLeastOneWhiteSpace
+ moduleName <- validIdentifier
+ skipSpaceCommentOrEnd
+ return $ ModuleDeclaration moduleName
+
+submoduleDeclaration :: ReadP LineContents
+submoduleDeclaration = do
+ skipSpaces
+ _ <- string "submodule"
+ parents <- submoduleParents
+ skipSpaces
+ name <- validIdentifier
+ skipSpaceCommentOrEnd
+ return $ SubmoduleDeclaration (intercalate "@" parents) name
+
+submoduleParents :: ReadP [String]
+submoduleParents = do
+ skipSpaces
+ _ <- char '('
+ skipSpaces
+ firstParent <- validIdentifier
+ remainingParents <- many
+ (do
+ skipSpaces
+ _ <- char ':'
+ skipSpaces
+ name <- validIdentifier
+ return name
+ )
+ skipSpaces
+ _ <- char ')'
+ return $ firstParent : remainingParents
+
+useStatement :: ReadP LineContents
+useStatement = do
+ skipSpaces
+ _ <- string "use"
+ skipAtLeastOneWhiteSpace
+ modName <- validIdentifier
+ skipSpaceCommaOrEnd
+ return $ ModuleUsed modName
+
+moduleSubprogramDeclaration :: ReadP LineContents
+moduleSubprogramDeclaration = do
+ skipSpaces
+ skipProcedureQualifiers
+ _ <- string "module"
+ skipAtLeastOneWhiteSpace
+ _ <- string "function" <|> string "subroutine"
+ skipAtLeastOneWhiteSpace
+ return $ ModuleSubprogramDeclaration
+
+skipProcedureQualifiers :: ReadP ()
+skipProcedureQualifiers = do
+ many skipPossibleQualifier
+ return ()
+
+skipPossibleQualifier :: ReadP ()
+skipPossibleQualifier = do
+ _ <- string "pure" <|> string "elemental" <|> string "impure"
+ skipAtLeastOneWhiteSpace
+
+skipAtLeastOneWhiteSpace :: ReadP ()
+skipAtLeastOneWhiteSpace = do
+ _ <- many1 whiteSpace
+ return ()
+
+skipSpaceOrEnd :: ReadP ()
+skipSpaceOrEnd = eof <|> skipAtLeastOneWhiteSpace
+
+skipSpaceCommaOrEnd :: ReadP ()
+skipSpaceCommaOrEnd = eof <|> skipComma <|> skipAtLeastOneWhiteSpace
+
+skipSpaceCommentOrEnd :: ReadP ()
+skipSpaceCommentOrEnd = eof <|> skipComment <|> skipAtLeastOneWhiteSpace
+
+skipComma :: ReadP ()
+skipComma = do
+ _ <- char ','
+ return ()
+
+skipComment :: ReadP ()
+skipComment = do
+ _ <- char '!'
+ return ()
+
+skipAnything :: ReadP ()
+skipAnything = do
+ _ <- many (satisfy (const True))
+ return ()
+
+whiteSpace :: ReadP Char
+whiteSpace = satisfy (`elem` " \t")
+
+validIdentifier :: ReadP String
+validIdentifier = do
+ first <- validFirstCharacter
+ rest <- many validIdentifierCharacter
+ return $ first : rest
+
+validFirstCharacter :: ReadP Char
+validFirstCharacter = alphabet
+
+validIdentifierCharacter :: ReadP Char
+validIdentifierCharacter = alphabet <|> digit <|> underscore
+
+alphabet :: ReadP Char
+alphabet = satisfy isAsciiLower
+
+digit :: ReadP Char
+digit = satisfy isDigit
+
+underscore :: ReadP Char
+underscore = char '_'
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-15 04:34:21 +0000