diff options
Diffstat (limited to 'bootstrap')
| -rw-r--r-- | bootstrap/package.yaml | 11 | ||||
| -rw-r--r-- | bootstrap/src/Build.hs | 379 | ||||
| -rw-r--r-- | bootstrap/src/BuildModel.hs | 403 | ||||
| -rw-r--r-- | bootstrap/src/Fpm.hs | 18 | ||||
| -rw-r--r-- | bootstrap/stack.yaml | 6 | ||||
| -rw-r--r-- | bootstrap/stack.yaml.lock | 23 | ||||
| l--------- | bootstrap/test | 1 | ||||
| -rw-r--r-- | bootstrap/test/Spec.hs | 67 | ||||
| l--------- | bootstrap/test/example_packages | 1 | ||||
| -rw-r--r-- | bootstrap/unit_test/ModuleSourceConstructionTest.hs | 83 | ||||
| -rw-r--r-- | bootstrap/unit_test/ModuleToCompileInfoTest.hs | 70 | ||||
| -rw-r--r-- | bootstrap/unit_test/ProgramSourceConstructionTest.hs | 69 | ||||
| -rw-r--r-- | bootstrap/unit_test/ProgramToCompileInfoTest.hs | 68 | ||||
| -rw-r--r-- | bootstrap/unit_test/SubmoduleSourceConstructionTest.hs | 79 | ||||
| -rw-r--r-- | bootstrap/unit_test/SubmoduleToCompileInfoTest.hs | 75 | ||||
| -rw-r--r-- | bootstrap/unit_test/Trimmer.hs | 1 |
16 files changed, 1055 insertions, 299 deletions
diff --git a/bootstrap/package.yaml b/bootstrap/package.yaml index ec5ecf2..26a7f74 100644 --- a/bootstrap/package.yaml +++ b/bootstrap/package.yaml @@ -58,3 +58,14 @@ tests: - -with-rtsopts=-N dependencies: - fpm + fpm-unittest: + main: Trimmer.hs + source-dirs: unit_test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - fpm + - hedge + - hedge-trimmer 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) diff --git a/bootstrap/stack.yaml b/bootstrap/stack.yaml index 68dcaaa..7147c40 100644 --- a/bootstrap/stack.yaml +++ b/bootstrap/stack.yaml @@ -42,6 +42,12 @@ packages: extra-deps: - git: https://github.com/kowainik/tomland.git commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 +- git: https://gitlab.com/everythingfunctional/hedge.git + commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 + subdirs: + - . + - hedge-trimmer +- quickcheck-with-counterexamples-1.2 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/bootstrap/stack.yaml.lock b/bootstrap/stack.yaml.lock index 15bfc22..0ca18ae 100644 --- a/bootstrap/stack.yaml.lock +++ b/bootstrap/stack.yaml.lock @@ -5,9 +5,6 @@ packages: - completed: - cabal-file: - size: 6802 - sha256: 85568a0280115b6e9a9f263cf4cfc72ad5a6eaeb2412875816adb82ea6a405bc name: tomland version: 1.3.0.0 git: https://github.com/kowainik/tomland.git @@ -18,6 +15,26 @@ packages: original: git: https://github.com/kowainik/tomland.git commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 +- completed: + subdir: hedge-trimmer + name: hedge-trimmer + version: 1.0.0.0 + git: https://gitlab.com/everythingfunctional/hedge.git + pantry-tree: + size: 226 + sha256: 19972f5b81c7627d6b66c852dfb7e0e67b3931ed4f418663c152717ce4ea267e + commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 + original: + subdir: hedge-trimmer + git: https://gitlab.com/everythingfunctional/hedge.git + commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 +- completed: + hackage: quickcheck-with-counterexamples-1.2@sha256:d322d79008602df26f5eb4e1379e5b58bf1a92604df8601e71e200cfc3e847a3,1688 + pantry-tree: + size: 724 + sha256: 0046517e3cc2adebfce19d4aad05a06dcf55ec9e572fa1c661ba9abe81386484 + original: + hackage: quickcheck-with-counterexamples-1.2 snapshots: - completed: size: 524996 diff --git a/bootstrap/test b/bootstrap/test deleted file mode 120000 index 419df4f..0000000 --- a/bootstrap/test +++ /dev/null @@ -1 +0,0 @@ -../test
\ No newline at end of file diff --git a/bootstrap/test/Spec.hs b/bootstrap/test/Spec.hs new file mode 100644 index 0000000..4e660e7 --- /dev/null +++ b/bootstrap/test/Spec.hs @@ -0,0 +1,67 @@ +import Development.Shake.FilePath ( (</>) ) +import Fpm ( Arguments(..) + , Command(..) + , start + ) +import System.Directory ( withCurrentDirectory ) + +example_path = "test" </> "example_packages" + +main :: IO () +main = do + testHelloWorld + testHelloComplex + testHelloFpm + testCircular + testWithMakefile + testMakefileComplex + testSubmodule + +testHelloWorld :: IO () +testHelloWorld = + withCurrentDirectory (example_path </> "hello_world") $ start $ Arguments + (Run "") + False + "" + +testHelloComplex :: IO () +testHelloComplex = + withCurrentDirectory (example_path </> "hello_complex") $ start $ Arguments + (Test "") + False + "" + +testHelloFpm :: IO () +testHelloFpm = + withCurrentDirectory (example_path </> "hello_fpm") $ start $ Arguments + (Run "") + False + "" + +testCircular :: IO () +testCircular = + withCurrentDirectory (example_path </> "circular_example") $ start $ Arguments + (Test "") + False + "" + +testWithMakefile :: IO () +testWithMakefile = + withCurrentDirectory (example_path </> "with_makefile") $ start $ Arguments + (Build) + False + "" + +testMakefileComplex :: IO () +testMakefileComplex = + withCurrentDirectory (example_path </> "makefile_complex") $ start $ Arguments + (Run "") + False + "" + +testSubmodule :: IO () +testSubmodule = + withCurrentDirectory (example_path </> "submodules") $ start $ Arguments + (Build) + False + "" diff --git a/bootstrap/test/example_packages b/bootstrap/test/example_packages new file mode 120000 index 0000000..b7c12dc --- /dev/null +++ b/bootstrap/test/example_packages @@ -0,0 +1 @@ +../../example_packages
\ No newline at end of file diff --git a/bootstrap/unit_test/ModuleSourceConstructionTest.hs b/bootstrap/unit_test/ModuleSourceConstructionTest.hs new file mode 100644 index 0000000..b98e9d3 --- /dev/null +++ b/bootstrap/unit_test/ModuleSourceConstructionTest.hs @@ -0,0 +1,83 @@ +module ModuleSourceConstructionTest + ( test + ) +where + +import BuildModel ( RawSource(..) + , Source(..) + , processRawSource + ) +import Hedge ( Result + , Test + , assertEquals + , assertThat + , fail' + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a module" + exampleModule + [ whenTransformed + "processed to a source" + processRawSource + [ then' "it is a Module" checkIsModule + , then' "its source file name is the same as the original" + checkModuleSourceFileName + , then' + "its object file name is the 'flattened' path of the source file with '.o' appeneded" + 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" + , " implicit none" + , " interface" + , " pure module function some_func()" + , " integer :: some_func" + , " end function" + , " end interface" + , "end module" + ] + +moduleSourceFileName' :: String +moduleSourceFileName' = "some" </> "file" </> "somewhere.f90" + +checkIsModule :: Source -> Result +checkIsModule Module{} = assertThat True +checkIsModule _ = assertThat False + +checkModuleSourceFileName :: Source -> Result +checkModuleSourceFileName m@(Module{}) = + assertEquals moduleSourceFileName' $ moduleSourceFileName m +checkModuleSourceFileName _ = fail' "wasn't a Module" + +checkModuleObjectFileName :: Source -> Result +checkModuleObjectFileName m@(Module{}) = + assertEquals ("." </> "some_file_somewhere.f90.o") + $ (moduleObjectFileName m) "." +checkModuleObjectFileName _ = fail' "wasn't a Module" + +checkModuleModulesUsed :: Source -> Result +checkModuleModulesUsed m@(Module{}) = + assertEquals ["module1", "module2"] $ moduleModulesUsed m +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" diff --git a/bootstrap/unit_test/ModuleToCompileInfoTest.hs b/bootstrap/unit_test/ModuleToCompileInfoTest.hs new file mode 100644 index 0000000..5a1f0a8 --- /dev/null +++ b/bootstrap/unit_test/ModuleToCompileInfoTest.hs @@ -0,0 +1,70 @@ +module ModuleToCompileInfoTest + ( test + ) +where + +import BuildModel ( CompileTimeInfo(..) + , Source(..) + , constructCompileTimeInfo + ) +import Hedge ( Result + , Test + , assertEquals + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a module and available modules" + (exampleModule, availableModules) + [ whenTransformed + "its compileTimeInfo is determined" + doCompileTimeTransformation + [ then' "it stil knows the original source file" checkSourceFileName + , then' "it knows what object file will be produced" checkObjectFileName + , then' "the mod and smod files are also produced" checkOtherFilesProduced + , then' "the direct dependencies are only the available modules used" + checkDirectDependencies + ] + ] + +exampleModule :: Source +exampleModule = Module + { moduleSourceFileName = moduleSourceFileName' + , moduleObjectFileName = \bd -> bd </> "some_file_somewhere.f90.o" + , moduleModulesUsed = ["module1", "module2", "module3"] + , moduleName = "some_module" + , moduleProducesSmod = True + } + +moduleSourceFileName' :: FilePath +moduleSourceFileName' = "some" </> "file" </> "somewhere.f90" + +availableModules :: [String] +availableModules = ["module1", "module3"] + +doCompileTimeTransformation :: (Source, [String]) -> CompileTimeInfo +doCompileTimeTransformation (programSource, otherSources) = + constructCompileTimeInfo programSource otherSources "build_dir" + +checkSourceFileName :: CompileTimeInfo -> Result +checkSourceFileName cti = + assertEquals moduleSourceFileName' (compileTimeInfoSourceFileName cti) + +checkObjectFileName :: CompileTimeInfo -> Result +checkObjectFileName cti = assertEquals + ("build_dir" </> "some_file_somewhere.f90.o") + (compileTimeInfoObjectFileProduced cti) + +checkOtherFilesProduced :: CompileTimeInfo -> Result +checkOtherFilesProduced cti = assertEquals + ["build_dir" </> "some_module.mod", "build_dir" </> "some_module.smod"] + (compileTimeInfoOtherFilesProduced cti) + +checkDirectDependencies :: CompileTimeInfo -> Result +checkDirectDependencies cti = assertEquals + ["build_dir" </> "module1.mod", "build_dir" </> "module3.mod"] + (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/ProgramSourceConstructionTest.hs b/bootstrap/unit_test/ProgramSourceConstructionTest.hs new file mode 100644 index 0000000..6369965 --- /dev/null +++ b/bootstrap/unit_test/ProgramSourceConstructionTest.hs @@ -0,0 +1,69 @@ +module ProgramSourceConstructionTest + ( test + ) +where + +import BuildModel ( RawSource(..) + , Source(..) + , processRawSource + ) +import Hedge ( Result + , Test + , assertEquals + , assertThat + , fail' + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a program" + exampleProgram + [ whenTransformed + "processed to a source" + processRawSource + [ then' "it is a Program" checkIsProgram + , then' "its source file name is the same as the original" + checkProgramSourceFileName + , then' + "its object file name is the 'flattened' path of the source file with '.o' appended" + checkProgramObjectFileName + , then' "it knows what modules it uses directly" checkProgramModulesUsed + ] + ] + +exampleProgram :: RawSource +exampleProgram = RawSource programSourceFileName' $ unlines + [ "program some_program" + , " use module1" + , " USE MODULE2" + , " implicit none" + , " print *, \"Hello, World!\"" + , "end program" + ] + +programSourceFileName' :: String +programSourceFileName' = "some" </> "file" </> "somewhere.f90" + +checkIsProgram :: Source -> Result +checkIsProgram Program{} = assertThat True +checkIsProgram _ = assertThat False + +checkProgramSourceFileName :: Source -> Result +checkProgramSourceFileName p@(Program{}) = + assertEquals programSourceFileName' $ programSourceFileName p +checkProgramSourceFileName _ = fail' "wasn't a Program" + +checkProgramObjectFileName :: Source -> Result +checkProgramObjectFileName p@(Program{}) = + assertEquals ("." </> "some_file_somewhere.f90.o") + $ (programObjectFileName p) "." +checkProgramObjectFileName _ = fail' "wasn't a Program" + +checkProgramModulesUsed :: Source -> Result +checkProgramModulesUsed p@(Program{}) = + assertEquals ["module1", "module2"] $ programModulesUsed p +checkProgramModulesUsed _ = fail' "wasn't a Program" diff --git a/bootstrap/unit_test/ProgramToCompileInfoTest.hs b/bootstrap/unit_test/ProgramToCompileInfoTest.hs new file mode 100644 index 0000000..f17a3df --- /dev/null +++ b/bootstrap/unit_test/ProgramToCompileInfoTest.hs @@ -0,0 +1,68 @@ +module ProgramToCompileInfoTest + ( test + ) +where + +import BuildModel ( CompileTimeInfo(..) + , Source(..) + , constructCompileTimeInfo + ) +import Hedge ( Result + , Test + , assertEmpty + , assertEquals + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a program and available modules" + (exampleProgram, availableModules) + [ whenTransformed + "its compileTimeInfo is determined" + doCompileTimeTransformation + [ then' "it still knows the original source file" checkSourceFileName + , then' "it knows what object file will be produced" checkObjectFileName + , then' "there are no other files produced" checkOtherFilesProduced + , then' "the direct dependencies are only the available modules used" + checkDirectDependencies + ] + ] + +exampleProgram :: Source +exampleProgram = Program + { programSourceFileName = programSourceFileName' + , programObjectFileName = \bd -> bd </> "some_file_somewhere.f90.o" + , programModulesUsed = ["module1", "module2", "module3"] + } + +programSourceFileName' :: FilePath +programSourceFileName' = "some" </> "file" </> "somewhere.f90" + +availableModules :: [String] +availableModules = ["module1", "module3"] + +doCompileTimeTransformation :: (Source, [String]) -> CompileTimeInfo +doCompileTimeTransformation (programSource, otherSources) = + constructCompileTimeInfo programSource otherSources "build_dir" + +checkSourceFileName :: CompileTimeInfo -> Result +checkSourceFileName cti = + assertEquals programSourceFileName' (compileTimeInfoSourceFileName cti) + +checkObjectFileName :: CompileTimeInfo -> Result +checkObjectFileName cti = assertEquals + ("build_dir" </> "some_file_somewhere.f90.o") + (compileTimeInfoObjectFileProduced cti) + +checkOtherFilesProduced :: CompileTimeInfo -> Result +checkOtherFilesProduced cti = + assertEmpty (compileTimeInfoOtherFilesProduced cti) + +checkDirectDependencies :: CompileTimeInfo -> Result +checkDirectDependencies cti = assertEquals + ["build_dir" </> "module1.mod", "build_dir" </> "module3.mod"] + (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs b/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs new file mode 100644 index 0000000..d07a6ed --- /dev/null +++ b/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs @@ -0,0 +1,79 @@ +module SubmoduleSourceConstructionTest + ( test + ) +where + +import BuildModel ( RawSource(..) + , Source(..) + , processRawSource + ) +import Hedge ( Result + , Test + , assertEquals + , assertThat + , fail' + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a submodule" + exampleSubmodule + [ whenTransformed + "processed to a source" + processRawSource + [ then' "it is a Submodule" checkIsSubmodule + , then' "its source file name is the same as the original" + checkSubmoduleSourceFileName + , then' + "its object file name is the 'flattened' path of the source file with '.o' appeneded" + checkSubmoduleObjectFileName + , then' "it knows what modules it uses directly" checkSubmoduleModulesUsed + , then' "it knows its parent's name" checkSubmoduleParentName + , then' "it knows its name" checkSubmoduleName + ] + ] + +exampleSubmodule :: RawSource +exampleSubmodule = RawSource submoduleSourceFileName' $ unlines + [ "submodule (some_module:parent) child" + , " use module1" + , " USE MODULE2" + , " implicit none" + , "end submodule" + ] + +submoduleSourceFileName' :: String +submoduleSourceFileName' = "some" </> "file" </> "somewhere.f90" + +checkIsSubmodule :: Source -> Result +checkIsSubmodule Submodule{} = assertThat True +checkIsSubmodule _ = assertThat False + +checkSubmoduleSourceFileName :: Source -> Result +checkSubmoduleSourceFileName s@(Submodule{}) = + assertEquals submoduleSourceFileName' $ submoduleSourceFileName s +checkSubmoduleSourceFileName _ = fail' "wasn't a Submodule" + +checkSubmoduleObjectFileName :: Source -> Result +checkSubmoduleObjectFileName s@(Submodule{}) = + assertEquals ("." </> "some_file_somewhere.f90.o") + $ (submoduleObjectFileName s) "." +checkSubmoduleObjectFileName _ = fail' "wasn't a Submodule" + +checkSubmoduleModulesUsed :: Source -> Result +checkSubmoduleModulesUsed s@(Submodule{}) = + assertEquals ["module1", "module2"] $ submoduleModulesUsed s +checkSubmoduleModulesUsed _ = fail' "wasn't a Submodule" + +checkSubmoduleParentName :: Source -> Result +checkSubmoduleParentName s@(Submodule{}) = + assertEquals "some_module@parent" (submoduleParentName s) +checkSubmoduleParentName _ = fail' "wasn't a Submodule" + +checkSubmoduleName :: Source -> Result +checkSubmoduleName s@(Submodule{}) = assertEquals "child" $ submoduleName s +checkSubmoduleName _ = fail' "wasn't a Submodule" diff --git a/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs b/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs new file mode 100644 index 0000000..d5d3ad8 --- /dev/null +++ b/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs @@ -0,0 +1,75 @@ +module SubmoduleToCompileInfoTest + ( test + ) +where + +import BuildModel ( CompileTimeInfo(..) + , Source(..) + , constructCompileTimeInfo + ) +import Hedge ( Result + , Test + , assertEquals + , givenInput + , then' + , whenTransformed + ) +import System.FilePath ( (</>) ) + +test :: IO (Test ()) +test = return $ givenInput + "a submodule and available modules" + (exampleSubmodule, availableModules) + [ whenTransformed + "its compileTimeInfo is determined" + doCompileTimeTransformation + [ then' "it still knows the original source file" checkSourceFileName + , then' "it knows what object file will be produced" checkObjectFileName + , then' "the smod file is also produced" checkOtherFilesProduced + , then' + "the direct dependencies are the parent smod and the available modules used" + checkDirectDependencies + ] + ] + +exampleSubmodule :: Source +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" + } + +submoduleSourceFileName' :: FilePath +submoduleSourceFileName' = "some" </> "file" </> "somewhere.f90" + +availableModules :: [String] +availableModules = ["module1", "module3"] + +doCompileTimeTransformation :: (Source, [String]) -> CompileTimeInfo +doCompileTimeTransformation (programSource, otherSources) = + constructCompileTimeInfo programSource otherSources "build_dir" + +checkSourceFileName :: CompileTimeInfo -> Result +checkSourceFileName cti = + assertEquals submoduleSourceFileName' (compileTimeInfoSourceFileName cti) + +checkObjectFileName :: CompileTimeInfo -> Result +checkObjectFileName cti = assertEquals + ("build_dir" </> "some_file_somewhere.f90.o") + (compileTimeInfoObjectFileProduced cti) + +checkOtherFilesProduced :: CompileTimeInfo -> Result +checkOtherFilesProduced cti = assertEquals + ["build_dir" </> "base_module@some_submodule.smod"] + (compileTimeInfoOtherFilesProduced cti) + +checkDirectDependencies :: CompileTimeInfo -> Result +checkDirectDependencies cti = assertEquals + [ "build_dir" </> "base_module@parent.smod" + , "build_dir" </> "module1.mod" + , "build_dir" </> "module3.mod" + ] + (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/Trimmer.hs b/bootstrap/unit_test/Trimmer.hs new file mode 100644 index 0000000..4e0f91d --- /dev/null +++ b/bootstrap/unit_test/Trimmer.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hedge-trimmer #-} |