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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
|
module CASS.Registry
( functionAnalysisInfos, registeredAnalysisNames, registeredAnalysisInfos
, lookupRegAnaWorker, runAnalysisWithWorkers, analyzeMain
) where
import FlatCurry.Types
import FlatCurry.Goodies(progImports)
import IO
import IOExts
import XML
import Analysis.Logging (debugMessage)
import Analysis.Files (getImports, loadCompleteAnalysis)
import Analysis.ProgInfo
import Analysis.Types
import CASS.Configuration(numberOfWorkers)
import CASS.Dependencies(getModulesToAnalyze)
import CASS.ServerFunctions(masterLoop)
import CASS.WorkerFunctions(analysisClient)
import Analysis.Demandedness
import Analysis.Deterministic
import Analysis.Groundness
import Analysis.HigherOrder
import Analysis.Indeterministic
import Analysis.RequiredValue
import qualified Analysis.RequiredValues as RVS
import Analysis.RightLinearity
import Analysis.RootReplaced
import Analysis.SensibleTypes
import Analysis.SolutionCompleteness
import Analysis.Termination
import Analysis.TotallyDefined
import Analysis.TypeUsage
registeredAnalysis :: [RegisteredAnalysis]
registeredAnalysis =
[cassAnalysis "Functionally defined" functionalAnalysis showFunctional
,cassAnalysis "Overlapping rules" overlapAnalysis showOverlap
,cassAnalysis "Deterministic operations" nondetAnalysis showDet
,cassAnalysis "Depends on non-deterministic operations"
nondetDepAnalysis showNonDetDeps
,cassAnalysis "Depends on all non-deterministic operations"
nondetDepAllAnalysis showNonDetDeps
,cassAnalysis "Right-linear operations" rlinAnalysis showRightLinear
,cassAnalysis "Solution completeness" solcompAnalysis showSolComplete
,cassAnalysis "Pattern completeness" patCompAnalysis showComplete
,cassAnalysis "Totally defined operations" totalAnalysis showTotally
,cassAnalysis "Indeterministic operations" indetAnalysis showIndet
,cassAnalysis "Demanded arguments" demandAnalysis showDemand
,cassAnalysis "Groundness" groundAnalysis showGround
,cassAnalysis "Non-determinism effects" ndEffectAnalysis showNDEffect
,cassAnalysis "Higher-order datatypes" hiOrdType showOrder
,cassAnalysis "Higher-order constructors" hiOrdCons showOrder
,cassAnalysis "Higher-order functions" hiOrdFunc showOrder
,cassAnalysis "Productive operations" productivityAnalysis showProductivity
,cassAnalysis "Sensible types" sensibleType showSensible
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
,cassAnalysis "Root cyclic replacements" rootCyclicAnalysis showRootCyclic
,cassAnalysis "Root replacements" rootReplAnalysis showRootRepl
,cassAnalysis "Terminating operations" terminationAnalysis showTermination
,cassAnalysis "Types in values" typesInValuesAnalysis showTypeNames
]
cassAnalysis :: Eq a => String -> Analysis a -> (AOutFormat -> a -> String)
-> RegisteredAnalysis
cassAnalysis title analysis showres =
RegAna (analysisName analysis)
(isFunctionAnalysis analysis)
title
(analyzeAsString analysis showres)
(analysisClient analysis)
data RegisteredAnalysis =
RegAna String
Bool
String
(String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
([String] -> IO ())
regAnaName :: RegisteredAnalysis -> String
regAnaName (RegAna n _ _ _ _) = n
regAnaInfo :: RegisteredAnalysis -> (String,String)
regAnaInfo (RegAna n _ t _ _) = (n,t)
regAnaFunc :: RegisteredAnalysis -> Bool
regAnaFunc (RegAna _ fa _ _ _) = fa
regAnaServer :: RegisteredAnalysis
-> (String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
regAnaServer (RegAna _ _ _ a _) = a
regAnaWorker :: RegisteredAnalysis -> ([String] -> IO ())
regAnaWorker (RegAna _ _ _ _ a) = a
registeredAnalysisNames :: [String]
registeredAnalysisNames = map regAnaName registeredAnalysis
registeredAnalysisInfos :: [(String,String)]
registeredAnalysisInfos = map regAnaInfo registeredAnalysis
functionAnalysisInfos :: [(String,String)]
functionAnalysisInfos = map regAnaInfo (filter regAnaFunc registeredAnalysis)
lookupRegAna :: String -> [RegisteredAnalysis] -> Maybe RegisteredAnalysis
lookupRegAna _ [] = Nothing
lookupRegAna aname (ra@(RegAna raname _ _ _ _) : ras) =
if aname==raname then Just ra else lookupRegAna aname ras
lookupRegAnaServer :: String -> (String -> Bool -> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String))
lookupRegAnaServer aname =
maybe (\_ _ _ _ -> return (Right ("unknown analysis: "++aname)))
regAnaServer
(lookupRegAna aname registeredAnalysis)
lookupRegAnaWorker :: String -> ([String] -> IO ())
lookupRegAnaWorker aname =
maybe (const done) regAnaWorker (lookupRegAna aname registeredAnalysis)
runAnalysisWithWorkers :: String -> AOutFormat -> Bool -> [Handle] -> String
-> IO (Either (ProgInfo String) String)
runAnalysisWithWorkers ananame aoutformat enforce handles moduleName =
(lookupRegAnaServer ananame) moduleName enforce handles (Just aoutformat)
runAnalysisWithWorkersNoLoad :: String -> [Handle] -> String -> IO ()
runAnalysisWithWorkersNoLoad ananame handles moduleName =
(lookupRegAnaServer ananame) moduleName False handles Nothing >> done
analyzeAsString :: Analysis a -> (AOutFormat->a->String) -> String -> Bool
-> [Handle] -> Maybe AOutFormat
-> IO (Either (ProgInfo String) String)
analyzeAsString analysis showres modname enforce handles mbaoutformat = do
analyzeMain analysis modname handles enforce (mbaoutformat /= Nothing) >>=
return . either (Left . mapProgInfo (showres aoutformat)) Right
where
aoutformat = maybe AText id mbaoutformat
analyzeMain :: Analysis a -> String -> [Handle] -> Bool -> Bool
-> IO (Either (ProgInfo a) String)
analyzeMain analysis modname handles enforce load = do
let ananame = analysisName analysis
debugMessage 2 ("Start analysis: "++modname++"/"++ananame)
modulesToDo <- getModulesToAnalyze enforce analysis modname
let numModules = length modulesToDo
workresult <-
if numModules==0
then return Nothing
else do
when (numModules>1) $
debugMessage 1
("Number of modules to be analyzed: " ++ show numModules)
prepareCombinedAnalysis analysis modname (map fst modulesToDo) handles
numworkers <- numberOfWorkers
if numworkers>0
then do debugMessage 2 "Starting master loop"
masterLoop handles [] ananame modname modulesToDo []
else analyzeLocally ananame (map fst modulesToDo)
result <-
maybe (if load
then do debugMessage 3 ("Reading analysis of: "++modname)
loadCompleteAnalysis ananame modname >>= return . Left
else return (Left emptyProgInfo))
(return . Right)
workresult
debugMessage 4 ("Result: " ++ either showProgInfo id result)
return result
analyzeLocally :: String -> [String] -> IO (Maybe String)
analyzeLocally ananame modules = do
debugMessage 3 ("Local analysis of: "++ananame++"/"++show modules)
(lookupRegAnaWorker ananame) modules
return Nothing
prepareCombinedAnalysis:: Analysis a -> String -> [String] -> [Handle] -> IO ()
prepareCombinedAnalysis analysis moduleName depmods handles =
if isCombinedAnalysis analysis
then
if isSimpleAnalysis analysis
then do
importedModules <- getImports moduleName
mapIO_ (\basename ->
mapIO_ (runAnalysisWithWorkersNoLoad basename handles)
(importedModules++[moduleName]))
baseAnaNames
else
mapIO_ (\baseaname ->
mapIO_ (runAnalysisWithWorkersNoLoad baseaname handles) depmods)
baseAnaNames
else done
where
baseAnaNames = baseAnalysisNames analysis
|