aboutsummaryrefslogtreecommitdiff
path: root/bootstrap/src
diff options
context:
space:
mode:
Diffstat (limited to 'bootstrap/src')
-rw-r--r--bootstrap/src/Build.hs379
-rw-r--r--bootstrap/src/BuildModel.hs403
-rw-r--r--bootstrap/src/Fpm.hs18
3 files changed, 505 insertions, 295 deletions
diff --git a/bootstrap/src/Build.hs b/bootstrap/src/Build.hs
index cdcbb02..083e646 100644
--- a/bootstrap/src/Build.hs
+++ b/bootstrap/src/Build.hs
@@ -6,20 +6,19 @@ module Build
)
where
-import Control.Applicative ( (<|>) )
-import Control.Monad ( filterM )
-import Data.Char ( isAsciiLower
- , isDigit
- , toLower
+import BuildModel ( CompileTimeInfo(..)
+ , RawSource(..)
+ , Source(..)
+ , constructCompileTimeInfo
+ , getAllObjectFiles
+ , getAvailableModules
+ , getSourceFileName
+ , processRawSource
)
import Data.List ( intercalate
, isSuffixOf
)
import Data.List.Utils ( replace )
-import qualified Data.Map as Map
-import Data.Maybe ( fromMaybe
- , mapMaybe
- )
import Development.Shake ( FilePattern
, Change(ChangeModtimeAndDigest)
, cmd
@@ -36,39 +35,20 @@ import Development.Shake ( FilePattern
, shakeThreads
, want
, (<//>)
- , (&%>)
, (%>)
- , (?>)
+ , (&?>)
)
-import Development.Shake.FilePath ( dropExtension
- , exe
- , makeRelative
+import Development.Shake.FilePath ( exe
+ , splitDirectories
, (</>)
, (<.>)
- , (-<.>)
)
+import System.Environment ( setEnv )
+import System.Process ( system )
import System.Directory ( createDirectoryIfMissing
, makeAbsolute
, withCurrentDirectory
)
-import System.Environment ( setEnv )
-import System.FilePath ( splitDirectories )
-import System.Process ( system )
-import Text.ParserCombinators.ReadP ( ReadP
- , char
- , eof
- , many
- , many1
- , option
- , readP_to_S
- , satisfy
- , skipSpaces
- , string
- )
-
-type ModuleName = String
-
-data LineContents = ModuleUsed ModuleName | Other
buildProgram
:: FilePath
@@ -81,29 +61,23 @@ buildProgram
-> FilePath
-> [FilePath]
-> IO ()
-buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory compiler flags programName programSource archives
+buildProgram programDirectory' libraryDirectories sourceExtensions buildDirectory' compiler flags programName programSource archives
= do
- sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions
- canonicalProgramSource <- makeAbsolute $ programDirectory </> programSource
- moduleSourceFiles <- filterM
- (\source -> do
- canonicalSource <- makeAbsolute source
- return $ canonicalProgramSource /= canonicalSource
- )
- sourceFiles
- let moduleObjectFiles = map
- (sourceFileToObjectFile buildDirectory programDirectory)
- moduleSourceFiles
- let sourceFileLookupMap = createSourceFileLookupMap buildDirectory
- programDirectory
- moduleSourceFiles
- let moduleLookupMap = createModuleLookupMap buildDirectory
- programDirectory
- moduleSourceFiles
- otherModuleMaps <- mapM getLibraryModuleMap libraryDirectories
- let allModuleMaps =
- moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps
+ let programDirectory = foldl1 (</>) (splitDirectories programDirectory')
+ let buildDirectory = foldl1 (</>) (splitDirectories buildDirectory')
let includeFlags = map ("-I" ++) libraryDirectories
+ sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions
+ rawSources <- mapM sourceFileToRawSource sourceFiles
+ let sources' = map processRawSource rawSources
+ let isThisProgramOrNotProgram p@(Program{}) =
+ programSourceFileName p == programDirectory </> programSource
+ isThisProgramOrNotProgram _ = True
+ let sources = filter isThisProgramOrNotProgram sources'
+ let availableModules = getAvailableModules sources
+ let compileTimeInfo = map
+ (\s -> constructCompileTimeInfo s availableModules buildDirectory)
+ sources
+ let objectFiles = getAllObjectFiles buildDirectory sources
shake shakeOptions { shakeFiles = buildDirectory
, shakeChange = ChangeModtimeAndDigest
, shakeColor = True
@@ -111,47 +85,28 @@ buildProgram programDirectory libraryDirectories sourceExtensions buildDirectory
, shakeProgress = progressSimple
}
$ do
+ let infoToRule cti =
+ let obj = compileTimeInfoObjectFileProduced cti
+ other = compileTimeInfoOtherFilesProduced cti
+ directDependencies = compileTimeInfoDirectDependencies cti
+ sourceFile = compileTimeInfoSourceFileName cti
+ fileMatcher f =
+ let realf = foldl1 (</>) (splitDirectories f)
+ in if realf == obj || realf `elem` other
+ then Just (obj : other)
+ else Nothing
+ in fileMatcher &?> \(objectFile : _) -> do
+ need (sourceFile : directDependencies)
+ cmd compiler
+ ["-c", "-J" ++ buildDirectory]
+ includeFlags
+ flags
+ ["-o", objectFile, sourceFile]
want [buildDirectory </> programName <.> exe]
buildDirectory </> programName <.> exe %> \executable -> do
- let objectFile = sourceFileToObjectFile buildDirectory
- programDirectory
- programSource
- let allObjectFiles = objectFile : moduleObjectFiles
- need allObjectFiles
- need archives
- cmd compiler allObjectFiles archives ["-o", executable] flags
- buildDirectory </> (map toLower programSource) -<.> "o" %> \objectFile -> do
- let realObjectFile = foldl (</>) "" $ splitDirectories objectFile
- let sourceFile = programDirectory </> programSource
- need [sourceFile]
- modulesUsed <- liftIO $ getModulesUsed sourceFile
- let moduleFilesNeeded =
- mapMaybe (`Map.lookup` allModuleMaps) modulesUsed
- let includeFlags = map ("-I" ++) libraryDirectories
- need moduleFilesNeeded
- cmd compiler
- ["-c", "-J" ++ buildDirectory]
- includeFlags
- flags
- ["-o", objectFile, sourceFile]
- map (\ext -> buildDirectory </> "*" <.> ext) ["o", "mod"]
- &%> \[objectFile, moduleFile] -> do
- let realObjectFile =
- foldl (</>) "" $ splitDirectories objectFile
- let sourceFile = fromMaybe
- undefined
- (Map.lookup realObjectFile sourceFileLookupMap)
- need [sourceFile]
- modulesUsed <- liftIO $ getModulesUsed sourceFile
- let moduleFilesNeeded =
- mapMaybe (`Map.lookup` allModuleMaps) modulesUsed
- let includeFlags = map ("-I" ++) libraryDirectories
- need moduleFilesNeeded
- cmd compiler
- ["-c", "-J" ++ buildDirectory]
- includeFlags
- flags
- ["-o", objectFile, sourceFile]
+ need objectFiles
+ cmd compiler objectFiles archives ["-o", executable] flags
+ mapM_ infoToRule compileTimeInfo
buildLibrary
:: FilePath
@@ -164,14 +119,15 @@ buildLibrary
-> IO (FilePath)
buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags libraryName otherLibraryDirectories
= do
+ let includeFlags = map ("-I" ++) otherLibraryDirectories
sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions
- let sourceFileLookupMap =
- createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles
- let moduleLookupMap =
- createModuleLookupMap buildDirectory libraryDirectory sourceFiles
- otherModuleMaps <- mapM getLibraryModuleMap otherLibraryDirectories
- let allModuleMaps =
- moduleLookupMap `Map.union` foldl Map.union Map.empty otherModuleMaps
+ rawSources <- mapM sourceFileToRawSource sourceFiles
+ let sources = map processRawSource rawSources
+ let availableModules = getAvailableModules sources
+ let compileTimeInfo = map
+ (\s -> constructCompileTimeInfo s availableModules buildDirectory)
+ sources
+ let objectFiles = getAllObjectFiles buildDirectory sources
let archiveFile = buildDirectory </> "lib" ++ libraryName <.> "a"
shake shakeOptions { shakeFiles = buildDirectory
, shakeChange = ChangeModtimeAndDigest
@@ -180,196 +136,30 @@ buildLibrary libraryDirectory sourceExtensions buildDirectory compiler flags lib
, shakeProgress = progressSimple
}
$ do
- map (\ext -> buildDirectory </> "*" <.> ext) ["o", "mod"]
- &%> \[objectFile, moduleFile] -> do
- let realObjectFile =
- foldl (</>) "" $ splitDirectories objectFile
- let sourceFile = fromMaybe
- undefined
- (Map.lookup realObjectFile sourceFileLookupMap)
- need [sourceFile]
- modulesUsed <- liftIO $ getModulesUsed sourceFile
- let moduleFilesNeeded =
- mapMaybe (`Map.lookup` allModuleMaps) modulesUsed
- let includeFlags = map ("-I" ++) otherLibraryDirectories
- need moduleFilesNeeded
- cmd compiler
- ["-c", "-J" ++ buildDirectory]
- includeFlags
- flags
- ["-o", objectFile, sourceFile]
+ let infoToRule cti =
+ let obj = compileTimeInfoObjectFileProduced cti
+ other = compileTimeInfoOtherFilesProduced cti
+ directDependencies = compileTimeInfoDirectDependencies cti
+ sourceFile = compileTimeInfoSourceFileName cti
+ fileMatcher f =
+ let realf = foldl1 (</>) (splitDirectories f)
+ in if realf == obj || realf `elem` other
+ then Just (obj : other)
+ else Nothing
+ in fileMatcher &?> \(objectFile : _) -> do
+ need (sourceFile : directDependencies)
+ cmd compiler
+ ["-c", "-J" ++ buildDirectory]
+ includeFlags
+ flags
+ ["-o", objectFile, sourceFile]
+ want [archiveFile]
archiveFile %> \a -> do
- let objectFiles = Map.keys sourceFileLookupMap
need objectFiles
cmd "ar" ["rs"] a objectFiles
- want [archiveFile]
+ mapM_ infoToRule compileTimeInfo
return archiveFile
--- A little wrapper around getDirectoryFiles so we can get files from multiple directories
-getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath]
-getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns
- where
- newPatterns = concatMap appendExts dirs
- appendExts dir = map ((dir <//> "*") ++) exts
-
-getLibraryModuleMap :: FilePath -> IO (Map.Map ModuleName FilePath)
-getLibraryModuleMap libraryDirectory = do
- moduleFiles <- getDirectoriesFiles [libraryDirectory] ["*.mod"]
- let moduleMap = foldl
- Map.union
- Map.empty
- (map (\m -> Map.singleton (moduleFileToModuleName m) m) moduleFiles)
- return moduleMap
- where
- moduleFileToModuleName moduleFile =
- map toLower $ dropExtension (makeRelative libraryDirectory moduleFile)
-
-createSourceFileLookupMap
- :: FilePath -> FilePath -> [FilePath] -> Map.Map FilePath FilePath
-createSourceFileLookupMap buildDirectory libraryDirectory sourceFiles = foldl
- Map.union
- Map.empty
- (map (createSourceToObjectMap buildDirectory libraryDirectory) sourceFiles)
-
-createModuleLookupMap
- :: FilePath -> FilePath -> [FilePath] -> Map.Map ModuleName FilePath
-createModuleLookupMap buildDirectory libraryDirectory sourceFiles = foldl
- Map.union
- Map.empty
- (map (createSourceToModuleMap buildDirectory libraryDirectory) sourceFiles)
-
-createSourceToModuleMap
- :: FilePath -> FilePath -> FilePath -> Map.Map ModuleName FilePath
-createSourceToModuleMap buildDirectory libraryDirectory sourceFile =
- Map.singleton
- (sourceFileToModuleName libraryDirectory sourceFile)
- (sourceFileToModFile buildDirectory libraryDirectory sourceFile)
-
-sourceFileToModuleName :: FilePath -> FilePath -> ModuleName
-sourceFileToModuleName libraryDirectory sourceFile =
- map toLower $ pathSeparatorsToUnderscores
- (dropExtension (makeRelative libraryDirectory sourceFile))
-
-createSourceToObjectMap
- :: FilePath -> FilePath -> FilePath -> Map.Map FilePath FilePath
-createSourceToObjectMap buildDirectory libraryDirectory sourceFile =
- Map.singleton
- (sourceFileToObjectFile buildDirectory libraryDirectory sourceFile)
- sourceFile
-
-sourceFileToObjectFile :: FilePath -> FilePath -> FilePath -> FilePath
-sourceFileToObjectFile buildDirectory libraryDirectory sourceFile =
- (foldl (</>) "" $ splitDirectories buildDirectory)
- </> map
- toLower
- (pathSeparatorsToUnderscores
- (makeRelative libraryDirectory sourceFile)
- )
- -<.> "o"
-
-sourceFileToExecutable :: FilePath -> FilePath -> FilePath -> FilePath
-sourceFileToExecutable buildDirectory appDirectory sourceFile =
- buildDirectory
- </> pathSeparatorsToUnderscores (makeRelative appDirectory sourceFile)
- -<.> exe
-
-sourceFileToModFile :: FilePath -> FilePath -> FilePath -> FilePath
-sourceFileToModFile buildDirectory libraryDirectory sourceFile =
- buildDirectory
- </> map
- toLower
- (pathSeparatorsToUnderscores
- (makeRelative libraryDirectory sourceFile)
- )
- -<.> "mod"
-
-pathSeparatorsToUnderscores :: FilePath -> FilePath
-pathSeparatorsToUnderscores fileName =
- intercalate "_" (splitDirectories fileName)
-
-getModulesUsed :: FilePath -> IO [ModuleName]
-getModulesUsed sourceFile = do
- fileLines <- readFileLinesIO sourceFile
- let lineContents = map parseFortranLine fileLines
- return $ contentsToModuleNames lineContents
-
-contentsToModuleNames :: [LineContents] -> [ModuleName]
-contentsToModuleNames = mapMaybe contentToMaybeModuleName
- where
- contentToMaybeModuleName content = case content of
- ModuleUsed moduleName -> Just moduleName
- _ -> 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 = useStatement
-
-useStatement :: ReadP LineContents
-useStatement = do
- skipSpaces
- _ <- string "use"
- skipAtLeastOneWhiteSpace
- modName <- validIdentifier
- skipSpaceCommaOrEnd
- return $ ModuleUsed modName
-
-skipAtLeastOneWhiteSpace :: ReadP ()
-skipAtLeastOneWhiteSpace = do
- _ <- many1 whiteSpace
- return ()
-
-skipSpaceOrEnd :: ReadP ()
-skipSpaceOrEnd = eof <|> skipAtLeastOneWhiteSpace
-
-skipSpaceCommaOrEnd :: ReadP ()
-skipSpaceCommaOrEnd = eof <|> skipComma <|> skipAtLeastOneWhiteSpace
-
-skipComma :: ReadP ()
-skipComma = do
- _ <- char ','
- 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 '_'
-
buildWithScript
:: String
-> FilePath
@@ -387,12 +177,11 @@ buildWithScript script projectDirectory buildDirectory compiler flags libraryNam
setEnv "FC" compiler
setEnv "FFLAGS" (intercalate " " flags)
setEnv "BUILD_DIR" $ unWindowsPath absoluteBuildDirectory
- setEnv
- "INCLUDE_DIRS"
- (intercalate " " (map unWindowsPath absoluteLibraryDirectories))
+ setEnv "INCLUDE_DIRS"
+ (intercalate " " (map unWindowsPath absoluteLibraryDirectories))
let archiveFile =
(unWindowsPath absoluteBuildDirectory)
- ++ "/lib"
+ ++ "/lib"
++ libraryName
<.> "a"
withCurrentDirectory
@@ -403,6 +192,18 @@ buildWithScript script projectDirectory buildDirectory compiler flags libraryNam
| otherwise -> system (script ++ " " ++ archiveFile)
return archiveFile
+-- A little wrapper around getDirectoryFiles so we can get files from multiple directories
+getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath]
+getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns
+ where
+ newPatterns = concatMap appendExts dirs
+ appendExts dir = map ((dir <//> "*") ++) exts
+
+sourceFileToRawSource :: FilePath -> IO RawSource
+sourceFileToRawSource sourceFile = do
+ contents <- readFile sourceFile
+ return $ RawSource sourceFile contents
+
isMakefile :: String -> Bool
isMakefile script | script == "Makefile" = True
| script == "makefile" = True
diff --git a/bootstrap/src/BuildModel.hs b/bootstrap/src/BuildModel.hs
new file mode 100644
index 0000000..95d3cac
--- /dev/null
+++ b/bootstrap/src/BuildModel.hs
@@ -0,0 +1,403 @@
+module BuildModel where
+
+import Control.Applicative ( (<|>) )
+import Control.Monad ( when )
+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 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]
+ , submoduleBaseModuleName :: 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
+ , submoduleBaseModuleName = getSubmoduleBaseModuleName
+ parsedContents
+ , 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
+ </> submoduleBaseModuleName 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
+
+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 baseModuleName submoduleParentName submoduleName ->
+ Just submoduleParentName
+ _ -> Nothing
+
+getSubmoduleName :: [LineContents] -> String
+getSubmoduleName pc = head $ mapMaybe contentToMaybeModuleName pc
+ where
+ contentToMaybeModuleName content = case content of
+ SubmoduleDeclaration baseModuleName 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
+ when (moduleName == "procedure") (fail "")
+ skipSpaceCommentOrEnd
+ return $ ModuleDeclaration moduleName
+
+submoduleDeclaration :: ReadP LineContents
+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 (head parents) parentName 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 '_'
diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs
index d9de668..115b63e 100644
--- a/bootstrap/src/Fpm.hs
+++ b/bootstrap/src/Fpm.hs
@@ -616,12 +616,15 @@ fetchDependency name version = do
putStrLn "Simple dependencies are not yet supported :("
undefined
GitVersion versionSpec -> do
- system
- ("git init " ++ clonePath)
+ system ("git init " ++ clonePath)
case gitVersionSpecRef versionSpec of
Just ref -> do
system
- ("git -C " ++ clonePath ++ " fetch " ++ gitVersionSpecUrl versionSpec ++ " "
+ ( "git -C "
+ ++ clonePath
+ ++ " fetch "
+ ++ gitVersionSpecUrl versionSpec
+ ++ " "
++ (case ref of
Tag tag -> tag
Branch branch -> branch
@@ -630,9 +633,12 @@ fetchDependency name version = do
)
Nothing -> do
system
- ("git -C " ++ clonePath ++ " fetch " ++ gitVersionSpecUrl versionSpec)
- system
- ("git -C " ++ clonePath ++ " checkout -qf FETCH_HEAD")
+ ( "git -C "
+ ++ clonePath
+ ++ " fetch "
+ ++ gitVersionSpecUrl versionSpec
+ )
+ system ("git -C " ++ clonePath ++ " checkout -qf FETCH_HEAD")
return (name, clonePath)
PathVersion versionSpec -> return (name, pathVersionSpecPath versionSpec)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-15 05:41:50 +0000