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
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
-----------------------------------------------------------------------------
-- Definition of the various analyses contained in the browser.
--
-- To modify or extend the analysis functionality of the browser,
-- add access to a new analysis here and recompile the browser.
-----------------------------------------------------------------------------

module BrowserAnalysis
  ( moduleAnalyses, allFunctionAnalyses, functionAnalyses
  , viewDependencyGraph )
 where

import FileGoodies ( stripSuffix )
import List        ( intersperse, nub, (\\) )

import FlatCurry.Types
import FlatCurry.Goodies (funcName)
import FlatCurry.Show    (showFlatFunc, showFlatProg)

import Analysis.Types (AOutFormat(..))
import CASS.Server    (analyzeFunctionForBrowser)
import CASS.Registry  (functionAnalysisInfos)
import AddTypes

import AnalysisTypes
import Imports
import CurryBrowseAnalysis.Overlapping
import CurryBrowseAnalysis.PatternComplete
import CurryBrowseAnalysis.SolutionComplete
import CurryBrowseAnalysis.Nondeterminism
import CurryBrowseAnalysis.Dependency
import CurryBrowseAnalysis.Indeterminism
import CurryBrowseAnalysis.CalledByAnalysis
import CurryBrowseAnalysis.Linearity

import ShowFlatCurry
import ShowDotGraph

infix 1 `showWith`,`showWithMsg`

-------------------------------------------------------------------------------
-- The list of all available analyses for individual modules.
-- Each analysis must return a string representation of its analysis result
-- or an IO action to show the result.
moduleAnalyses :: [(String, ModuleAnalysis ModuleAnalysisResult)]
moduleAnalyses =
 [("Interface",
   InterfaceAnalysis (\int -> ContentsResult CurryProg (showInterface False int)))
  --("Write Interface",
  -- InterfaceAnalysis (\int -> ModuleAction (putStrLn (showInterface False int)))),
  --("Read source file",
  -- SourceCodeAnalysis (\fname -> readFile fname >>= \prog ->
  --                               return (ContentsResult CurryProg prog))),
  ,("Curry code (generated from FlatCurry)",
   FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryModule prog)))
  ,("Source program with type signatures added", SourceCodeAnalysis addTypes)
  ,("FlatCurry code",
   FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showFlatCurry prog)))
  ,("FlatCurry expression",
   FlatCurryAnalysis (\prog -> ContentsResult FlatCurryExp (showFlatProg prog)))
  ]

addTypes :: String -> IO ModuleAnalysisResult
addTypes fname
 | take 7 (reverse fname) == "yrrucl."
  = return (ContentsResult OtherText "Can't add types to literate programs")
 | otherwise
  = do prog <- addTypeSignatures (stripSuffix fname)
       return (ContentsResult CurryProg prog)

-----------------------------------------------------------------------------
-- The list of all available analyses for individual functions.
-- Each analysis must return a string or an IO action representation of its
-- analysis result.
functionAnalyses :: [(String, FunctionAnalysis AnalysisResult)]
functionAnalyses =
 [("Curry code",        LocalAnalysis     (MsgResult . showFuncDeclAsCurry)),
  --("Print Curry code",  withAction (LocalAnalysis (putStr . showFuncDeclAsCurry))),
  --("Print func name",   withAction (GlobalAnalysis printFuncName)),
  ("FlatCurry code",    LocalAnalysis     (MsgResult . showFuncDeclAsFlatCurry)),
  ("FlatCurry expression",LocalAnalysis   (MsgResult . showFlatFunc)),
  ("Calls directly",    LocalAnalysis     callsDirectly `showWithMsg`
       showQDep "Calls the following functions directly in the right-hand sides:"),
  ("Depends on",        GlobalAnalysis    indirectlyDependent `showWithMsg`
       showQDep "Depends on the following functions:"),
  ("Depends on externals", GlobalAnalysis  externalDependent `showWithMsg`
       showQDep "Depends on the following external functions:"),
  ("Dependency graph (DOT)", withAction (GlobalAnalysis viewFuncDepGraphs)),
  ("Local dependency graph (DOT)", withAction (GlobalAnalysis viewFuncLocalDepGraphs)),
  ("Called by",         GlobalAnalysis    calledBy `showWithMsg`
       showDep "Is called by the following functions of the current module:")] ++
 map (\ (aname,atitle) -> (atitle++" (CASS)", withCASS aname))
     functionAnalysisInfos ++
 [("Overlapping rules",
   LocalAnalysis     isOverlappingFunction   `showWithMsg` showOverlap),
  ("Right-linear rules",
   LocalAnalysis     hasRightLinearRules     `showWithMsg` showLinear),
  ("Right-linearity",
   GlobalAnalysis    analyseRightLinearity   `showWithMsg` showLinearity),
  ("Pattern completeness",
   LocalDataAnalysis analyseCompleteness     `showWithMsg` showComplete),
  ("Totally defined",
   GlobalDataAnalysis analyseTotallyDefined  `showWithMsg` showComplete),
  ("Solution complete",
   GlobalAnalysis    analyseSolutionComplete `showWithMsg` showOpComplete),
  ("Nondeterministic",
   GlobalAnalysis    analyseNondeterminism   `showWithMsg` showNondet),
  ("Set-valued",        GlobalAnalysis    analyseSetValued `showWithMsg` showSetValued),
  ("Purity",            GlobalAnalysis    analyseIndeterminism `showWithMsg` showIndet)]

-----------------------------------------------------------------------------
-- The list of all available analyses for sets of functions.
-- Each analysis must return a short(!) string representation (no more than a few chars)
-- of its analysis result that is prefixed to the function name in the list
-- of function. The second (String) component of each analysis entry is a short
-- explanation of the used prefixes.
allFunctionAnalyses :: [(String, String, FunctionAnalysis String)]
allFunctionAnalyses =
 [("Overlapping rules",
   "Meaning of function markings:\n\n"++
   "OVL>>>  : defining rules overlap\n\n"++
   "unmarked: no overlapping rules",
   LocalAnalysis     isOverlappingFunction `showWith` showBool "OVL>>>" ""),
  ("Pattern completeness",
   "Meaning of function markings:\n\n"++
   "INCMP>>> : possibly incompletely defined operation\n\n"++
   "unmarked : completely defined operation",
   LocalDataAnalysis analyseCompleteness   `showWith` showCompleteS),
  ("Totally defined",
   "Meaning of function markings:\n\n"++
   "PARTIAL>>> : possibly partially defined operation\n\n"++
   "unmarked : totally defined operation",
   GlobalDataAnalysis analyseTotallyDefined `showWith` showTotally),
  ("Solution complete",
   "Meaning of function markings:\n\n"++
   "SUSP>>> : operation may suspend\n\n"++
   "unmarked: operation does not suspend",
   GlobalAnalysis    analyseSolutionComplete `showWith` showBool "" "SUSP>>>"),
  ("Nondeterministic",
   "Meaning of function markings:\n\n"++
   "ND>>>   : nondeterministic operation\n\n"++
   "unmarked: deterministic operation",
   GlobalAnalysis    analyseNondeterminism `showWith` showBool "ND>>>" ""),
  ("Right-linearity",
   "Meaning of function markings:\n\n"++
   "RL>>>   : defined by right-linear rules and depend only on\n"++
   "          right-linear functions\n\n"++
   "unmarked: possibly non-right-linear",
   GlobalAnalysis    analyseRightLinearity `showWith` showBool "RL>>>" ""),
  ("Set-valued",
   "Meaning of function markings:\n\n"++
   "SET>>>  : set-valued operation\n\n"++
   "unmarked: single-valued operation",
   GlobalAnalysis    analyseSetValued      `showWith` showBool "SET>>>" ""),
  ("Purity",
   "Meaning of function markings:\n\n"++
   "IMP>>>  : impure (indeterministic) operation\n\n"++
   "unmarked: referentially transparent operation",
   GlobalAnalysis    analyseIndeterminism  `showWith` showBool "IMP>>>" "")]

-- This function is useful to integrate an existing program analysis
-- into the browser by providing a transformation of the analysis results
-- into strings:
showWith :: FunctionAnalysis a -> (a->String) -> FunctionAnalysis String
showWith (LocalAnalysis ana) showresult =
   LocalAnalysis (\f -> showresult (ana f))
showWith (LocalDataAnalysis ana) showresult =
   LocalDataAnalysis (\types f -> showresult (ana types f))
showWith (GlobalAnalysis ana) showresult =
   GlobalAnalysis (\funs -> map (\(name,res)->(name,showresult res)) (ana funs))
showWith (GlobalDataAnalysis ana) showresult =
   GlobalDataAnalysis (\types funs -> map (\(name,res)->(name,showresult res))
                                          (ana types funs))

showWithMsg :: FunctionAnalysis a -> (a->String) -> FunctionAnalysis AnalysisResult
showWithMsg (LocalAnalysis ana) showresult =
   LocalAnalysis (\f -> MsgResult (showresult (ana f)))
showWithMsg (LocalDataAnalysis ana) showresult =
   LocalDataAnalysis (\types f -> MsgResult (showresult (ana types f)))
showWithMsg (GlobalAnalysis ana) showresult =
   GlobalAnalysis (\funs -> map (\(name,res)->(name,MsgResult (showresult res)))
                                (ana funs))
showWithMsg (GlobalDataAnalysis ana) showresult =
   GlobalDataAnalysis (\types funs -> map (\(name,res)->(name,MsgResult (showresult res)))
                                          (ana types funs))

-- Shows a Boolean result:
showBool :: String -> String -> Bool -> String
showBool t _ True  = t
showBool _ f False = f

-- Shows the result of the overlapping analysis.
showOverlap :: Bool -> String
showOverlap True  = "Overlapping"
showOverlap False = "Not Overlapping"

-- Shows the result of the right-linear rules analysis.
showLinear :: Bool -> String
showLinear True  = "Defined by right-linear rules"
showLinear False = "Definition contains non-right-linear rules"

-- Shows the result of the right-linearity analysis.
showLinearity :: Bool -> String
showLinearity True  = "Defined by functions with right-linear rules"
showLinearity False = "Defined by functions containing non-right-linear rules"

-- Shows the result of the completeness analysis.
showComplete :: CompletenessType -> String
showComplete Complete     = "completely defined (i.e., reducible on all constructors)"
showComplete InComplete   = "incompletely defined"
showComplete InCompleteOr =
                    "incompletely defined in each disjunction (but might be complete)"

showCompleteS :: CompletenessType -> String
showCompleteS Complete     = ""
showCompleteS InComplete   = "INCMP>>>"
showCompleteS InCompleteOr = "INCMP>>>"

-- Shows the result of the totally-defined analysis.
showTotallyDefined :: CompletenessType -> String
showTotallyDefined Complete     = "totally defined (i.e., reducible to a value)"
showTotallyDefined InComplete   = "partially defined"
showTotallyDefined InCompleteOr = "partially defined"

showTotally :: CompletenessType -> String
showTotally Complete     = ""
showTotally InComplete   = "PARTIAL>>>"
showTotally InCompleteOr = "PARTIAL>>>"

-- Shows the result of the operational completeness analysis.
showOpComplete :: Bool -> String
showOpComplete True  = "All solutions can be computed"
showOpComplete False = "Evaluation might suspend"

-- Shows the result of the indeterminism analysis.
showIndet :: Bool -> String
showIndet True  = "Impure (indeterministic) operation"
showIndet False = "Referentially transparent"

-- Shows the result of the non-determinism analysis.
showNondet :: Bool -> String
showNondet True  = "Operation might be nondeterministic"
showNondet False = "Deterministic operation"

-- Shows the result of the set-valued analysis.
showSetValued :: Bool -> String
showSetValued True  = "Operation might be set-valued"
showSetValued False = "Single-valued operation"

-- Shows the result of a dependency analysis with title.
showQDep :: String -> [QName] -> String
showQDep title fnames = title ++ "\n" ++ unlines (map (\(m,n)->m++"."++n) fnames)

-- Shows the result of a dependency analysis with title without qualifiers.
showDep :: String -> [QName] -> String
showDep title fnames = title ++ "\n" ++ unlines (map snd fnames)

-- Visualize the result of the dependency graph analysis.
viewFuncDepGraphs :: [FuncDecl] -> [(QName,IO ())]
viewFuncDepGraphs fdecls =
  map (\(f,fgraph)->(f,showDGraph f (isExternal fdecls) fgraph))
      (dependencyGraphs fdecls)

isExternal :: [FuncDecl] -> QName -> Bool
isExternal [] _ = True -- this case should not occur
isExternal (Func g _ _ _ rule : gs) f = if f==g then isExternalRule rule
                                                else isExternal gs f
 where
   isExternalRule (Rule _ _) = False
   isExternalRule (External _) = True

-- Visualize the result of the local dependency graph analysis.
viewFuncLocalDepGraphs :: [FuncDecl] -> [(QName,IO ())]
viewFuncLocalDepGraphs fdecls =
  map (\(f,fgraph)->(f,showDGraph f (\(m,_)->m/=fst f) fgraph))
      (localDependencyGraphs fdecls)

showDGraph :: QName -> (QName->Bool) -> [(QName,[QName])] -> IO ()
showDGraph (mod,_) isExt fnames =
   viewDependencyGraph
       (map (\(f,gs)->(showLocalName f,
                       if isExt f then extAttrs else [],
                       map showLocalName gs))
            fnames)
 where
  showLocalName (m,g) = if m==mod then g else m++'.':g

  -- dot attributes for visualization of external function nodes:
  extAttrs = [("style","filled"),("color",".7 .3 1.0")]

viewDependencyGraph :: [(String,[(String,String)],[String])] -> IO ()
viewDependencyGraph deps = viewDotGraph $ dgraph "dependencies" nodes edges
 where
  nodes = map (\ (n,a,_) -> Node n a) deps ++
          map (\ n -> Node n [])
              (concatMap (\ (_,_,ts) -> ts) deps \\ map (\ (n,_,_) -> n) deps)
  edges = map (\ (s,t) -> Edge s t [])
              (nub (concatMap (\ (p,_,ds) -> map (\d -> (p,d)) ds) deps))

--------------------------------------------------------------------------------
-- Auxiliary operation to integrate a CASS analysis for an individual
-- operation.
withCASS :: String -> FunctionAnalysis AnalysisResult
withCASS ananame =
  LocalAnalysis (\f -> ActionResult (analyzeFunctionWithCASS f))
 where
   analyzeFunctionWithCASS (Func f _ _ _ _) =
     analyzeFunctionForBrowser ananame f AText

--------------------------------------------------------------------------------
-- This function is useful to integrate an existing program analysis
-- with result type (IO a) into the browser by providing a transformation
-- of the analysis results.
withAction :: FunctionAnalysis (IO _) -> FunctionAnalysis AnalysisResult
withAction (LocalAnalysis ana) =
   LocalAnalysis (\f -> ActionResult (ana f >> return ""))
withAction (LocalDataAnalysis ana) =
   LocalDataAnalysis (\types f -> ActionResult (ana types f >> return ""))
withAction (GlobalAnalysis ana) =
   GlobalAnalysis
     (\funs -> map (\(name,res) -> (name,ActionResult (res >> return "")))
                   (ana funs))
withAction (GlobalDataAnalysis ana) =
   GlobalDataAnalysis
     (\types funs -> map (\ (name,res) -> (name,ActionResult (res>>return "")))
                         (ana types funs))

-- A simple example for a global function analysis of type IO:
printFuncName :: [FuncDecl] -> [(QName,IO ())]
printFuncName =
  map (\fdecl -> (funcName fdecl, putStrLn (snd (funcName fdecl))))