From 56dbd8b6a131a0caea890b2de2c1cf9915d0130f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:54:49 -0400 Subject: [PATCH] Copy the CallGraph stuff into a new module. --- semantic.cabal | 1 + src/Analysis/Abstract/ImportGraph.hs | 111 +++++++++++++++++++++++++++ 2 files changed, 112 insertions(+) create mode 100644 src/Analysis/Abstract/ImportGraph.hs diff --git a/semantic.cabal b/semantic.cabal index 132722e06..0463bcc8d 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -18,6 +18,7 @@ library Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead + , Analysis.Abstract.ImportGraph , Analysis.Abstract.Evaluating , Analysis.Abstract.Tracing , Analysis.CallGraph diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs new file mode 100644 index 000000000..eb39c919d --- /dev/null +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +module Analysis.Abstract.ImportGraph +( ImportGraph(..) +, renderImportGraph +, buildImportGraph +, ImportGraphAlgebra(..) +) where + +import qualified Algebra.Graph as G +import Algebra.Graph.Class +import Algebra.Graph.Export.Dot +import Data.Abstract.FreeVariables +import Data.Set (member) +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Declaration as Declaration +import Data.Term +import Prologue hiding (empty) + +-- | The graph of function definitions to symbols used in a given program. +newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Name } + deriving (Eq, Graph, Show) + +-- | Build the 'ImportGraph' for a 'Term' recursively. +buildImportGraph :: (ImportGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> ImportGraph +buildImportGraph = foldSubterms importGraphAlgebra + + +-- | Render a 'ImportGraph' to a 'ByteString' in DOT notation. +renderImportGraph :: ImportGraph -> ByteString +renderImportGraph = export (defaultStyle friendlyName) . unImportGraph + + +-- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. +-- +-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. +class ImportGraphAlgebra syntax where + -- | A 'SubtermAlgebra' computing the 'ImportGraph' for a piece of @syntax@. + importGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +instance (ImportGraphAlgebraStrategy syntax ~ strategy, ImportGraphAlgebraWithStrategy strategy syntax) => ImportGraphAlgebra syntax where + importGraphAlgebra = importGraphAlgebraWithStrategy (Proxy :: Proxy strategy) + + +-- | Types whose contribution to a 'ImportGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'ImportGraphAlgebraStrategy'. +class CustomImportGraphAlgebra syntax where + customImportGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +-- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body. +instance CustomImportGraphAlgebra Declaration.Function where + customImportGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) + +-- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body. +instance CustomImportGraphAlgebra Declaration.Method where + customImportGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) + +-- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'. +instance CustomImportGraphAlgebra Syntax.Identifier where + customImportGraphAlgebra (Syntax.Identifier name) bound + | name `member` bound = empty + | otherwise = vertex name + +instance Apply ImportGraphAlgebra syntaxes => CustomImportGraphAlgebra (Union syntaxes) where + customImportGraphAlgebra = Prologue.apply (Proxy :: Proxy ImportGraphAlgebra) importGraphAlgebra + +instance ImportGraphAlgebra syntax => CustomImportGraphAlgebra (TermF syntax a) where + customImportGraphAlgebra = importGraphAlgebra . termFOut + + +-- | The mechanism selecting 'Default'/'Custom' implementations for 'importGraphAlgebra' depending on the @syntax@ type. +class ImportGraphAlgebraWithStrategy (strategy :: Strategy) syntax where + importGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +-- | The 'Default' definition of 'importGraphAlgebra' combines all of the 'ImportGraph's within the @syntax@ 'Monoid'ally. +instance Foldable syntax => ImportGraphAlgebraWithStrategy 'Default syntax where + importGraphAlgebraWithStrategy _ = foldMap subtermValue + +-- | The 'Custom' strategy calls out to the 'customImportGraphAlgebra' method. +instance CustomImportGraphAlgebra syntax => ImportGraphAlgebraWithStrategy 'Custom syntax where + importGraphAlgebraWithStrategy _ = customImportGraphAlgebra + + +-- | Which instance of 'CustomImportGraphAlgebra' to use for a given @syntax@ type. +data Strategy = Default | Custom + +-- | A mapping of @syntax@ types onto 'Strategy's. +type family ImportGraphAlgebraStrategy syntax where + ImportGraphAlgebraStrategy Declaration.Function = 'Custom + ImportGraphAlgebraStrategy Declaration.Method = 'Custom + ImportGraphAlgebraStrategy Syntax.Identifier = 'Custom + ImportGraphAlgebraStrategy (Union fs) = 'Custom + ImportGraphAlgebraStrategy (TermF f a) = 'Custom + ImportGraphAlgebraStrategy a = 'Default + +instance Semigroup ImportGraph where + (<>) = overlay + +instance Monoid ImportGraph where + mempty = empty + mappend = (<>) + +instance Ord ImportGraph where + compare (ImportGraph G.Empty) (ImportGraph G.Empty) = EQ + compare (ImportGraph G.Empty) _ = LT + compare _ (ImportGraph G.Empty) = GT + compare (ImportGraph (G.Vertex a)) (ImportGraph (G.Vertex b)) = compare a b + compare (ImportGraph (G.Vertex _)) _ = LT + compare _ (ImportGraph (G.Vertex _)) = GT + compare (ImportGraph (G.Overlay a1 a2)) (ImportGraph (G.Overlay b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2 + compare (ImportGraph (G.Overlay _ _)) _ = LT + compare _ (ImportGraph (G.Overlay _ _)) = GT + compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2