|
sourcecode:
|
module BrowserAnalysis
( moduleAnalyses, allFunctionAnalyses, functionAnalyses
, viewDependencyGraph )
where
import Data.List ( nub, (\\) )
import FlatCurry.Types
import FlatCurry.Goodies ( funcName )
import FlatCurry.Show ( showFlatFunc, showFlatProg )
import AddTypes ( addTypeSignatures )
import Analysis.Types ( AOutFormat(..) )
import CASS.Server ( analyzeFunctionForBrowser )
import CASS.Registry ( functionAnalysisInfos )
import Data.GraphViz
import FlatCurry.ShowIntMod
import System.CurryPath ( runModuleActionQuiet )
import BrowserAnalysisTypes
import CurryBrowseAnalysis.Overlapping
import CurryBrowseAnalysis.PatternComplete
import CurryBrowseAnalysis.SolutionComplete
import CurryBrowseAnalysis.Nondeterminism
import CurryBrowseAnalysis.Dependency
import CurryBrowseAnalysis.Indeterminism
import CurryBrowseAnalysis.CalledByAnalysis
import CurryBrowseAnalysis.Linearity
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 <- runModuleActionQuiet addTypeSignatures 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))))
|