1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
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
| Other
data RawSource = RawSource {
rawSourceFilename :: FilePath
, rawSourceContents :: String
}
data Source =
Program
{ programSourceFileName :: FilePath
, programObjectFileName :: FilePath -> FilePath
, programModulesUsed :: [String]
}
| Module
{ moduleSourceFileName :: FilePath
}
processRawSource :: RawSource -> Source
processRawSource rawSource =
let sourceFileName = rawSourceFilename rawSource
parsedContents = parseContents rawSource
in if hasProgramDeclaration parsedContents
then Program
{ programSourceFileName = sourceFileName
, programObjectFileName = \buildDirectory ->
buildDirectory
</> (pathSeparatorsToUnderscores
sourceFileName
)
<.> "o"
, programModulesUsed = getModulesUsed parsedContents
}
else if hasModuleDeclaration parsedContents
then Module { moduleSourceFileName = sourceFileName }
else undefined
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
getModulesUsed :: [LineContents] -> [String]
getModulesUsed = 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 =
programDeclaration <|> moduleDeclaration <|> useStatement
programDeclaration :: ReadP LineContents
programDeclaration = do
skipSpaces
_ <- string "program"
skipAtLeastOneWhiteSpace
_ <- validIdentifier
return ProgramDeclaration
moduleDeclaration :: ReadP LineContents
moduleDeclaration = do
skipSpaces
_ <- string "module"
skipAtLeastOneWhiteSpace
moduleName <- validIdentifier
return $ ModuleDeclaration moduleName
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 '_'
|
