1a38107941725211e7c3f051f7a8f5e12199f03acmaeder{- |

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederModule : $Header$

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederDescription : Navigation through the Development Graph

54ea981a0503c396c2923a1c06421c6235baf27fChristian MaederCopyright : (c) Ewaryst Schulz, DFKI Bremen 2011

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederLicense : GPLv2 or higher, see LICENSE.txt

98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu Prodescu

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederMaintainer : ewaryst.schulz@dfki.de

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederStability : experimental

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederPortability : non-portable (via imports)

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederNavigation through the Development Graph based on Node and Link predicates

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederusing Depth First Search.

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder-}

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maedermodule Static.DGNavigation where

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maederimport Static.DevGraph

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder

f456529a89bfb620d39e5fd5b0a53b24643db96dDominik Lueckeimport qualified Data.Set as Set

f456529a89bfb620d39e5fd5b0a53b24643db96dDominik Lueckeimport Data.List

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maederimport Data.Maybe

1a38107941725211e7c3f051f7a8f5e12199f03acmaeder

1a38107941725211e7c3f051f7a8f5e12199f03acmaederimport Data.Graph.Inductive.Graph as Graph

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederimport Logic.Grothendieck

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederimport Common.Doc

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederimport Common.DocUtils

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederimport Syntax.AS_Library

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder-- * Navigator Class

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maederclass DevGraphNavigator a where

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder -- | get all the incoming ledges of the given node

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder incoming :: a -> Node -> [LEdge DGLinkLab]

1a38107941725211e7c3f051f7a8f5e12199f03acmaeder -- | get the label of the given node

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder getLabel :: a -> Node -> DGNodeLab

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder -- | get the local (not referenced) environment of the given node

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder getLocalNode :: a -> Node -> (DGraph, LNode DGNodeLab)

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder getInLibEnv :: a -> (LibEnv -> DGraph -> b) -> b

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski getCurrent :: a -> [LNode DGNodeLab]

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski relocate :: a -> DGraph -> [LNode DGNodeLab] -> a

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski-- | Get all the incoming ledges of the given node and eventually

6f08518fe3561930fef290b8e01384a6f1c90598Till Mossakowski-- cross the border to an other 'DGraph'. The new 'DevGraphNavigator'

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian Maeder-- is returned with 'DGraph' set to the new graph and current node to

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder-- the given node.

ecd98975b8a8ab5a7bc075562bdab51cf47d2a90Christian MaederfollowIncoming :: DevGraphNavigator a => a -> Node

f456529a89bfb620d39e5fd5b0a53b24643db96dDominik Luecke -> (a, LNode DGNodeLab, [LEdge DGLinkLab])

1e39a4ee4e97d16c48003d49e4af3d181f25ad71Christian MaederfollowIncoming dgn n = (dgn', lbln, incoming dgn' n')

1e39a4ee4e97d16c48003d49e4af3d181f25ad71Christian Maeder where (dgn', lbln@(n', _)) = followNode dgn n

1e39a4ee4e97d16c48003d49e4af3d181f25ad71Christian Maeder

f456529a89bfb620d39e5fd5b0a53b24643db96dDominik Luecke-- | get the local (not referenced) label of the given node

7ab2df3001654dd1b7a2cfc3da1ccef11c39a503Christian MaedergetLocalLabel :: DevGraphNavigator a => a -> Node -> DGNodeLab

0a65899b09e78455a94af9128455f6613441ab71cmaedergetLocalLabel dgnav = snd . snd . getLocalNode dgnav

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder

54ea981a0503c396c2923a1c06421c6235baf27fChristian MaederfollowNode :: DevGraphNavigator a => a -> Node -> (a, LNode DGNodeLab)

54ea981a0503c396c2923a1c06421c6235baf27fChristian MaederfollowNode dgnav n = (relocate dgnav dg [lbln], lbln)

54ea981a0503c396c2923a1c06421c6235baf27fChristian Maeder where (dg, lbln) = getLocalNode dgnav n

d0642e0d269791a923f2bf86ea249f971f14addbChristian Maeder

-- | get all the incoming ledges of the current node

directInn :: DevGraphNavigator a => a -> [LEdge DGLinkLab]

directInn dgnav = concatMap (incoming dgnav . fst) $ getCurrent dgnav

-- * Navigator Instance

-- | The navigator instance consists of a 'LibEnv' a current 'DGraph' and

-- a current 'Node' which is the starting point for navigation through the DG.

data DGNav = DGNav { dgnLibEnv :: LibEnv

, dgnDG :: DGraph

, dgnCurrent :: [LNode DGNodeLab] } deriving Show

instance Pretty DGNav where

pretty dgn = d1 <> text ":" <+> pretty (map fst $ dgnCurrent dgn)

where d1 = case optLibDefn $ dgnDG dgn of

Just (Lib_defn ln _ _ _) -> pretty ln

Nothing -> text "DG"

makeDGNav :: LibEnv -> DGraph -> [LNode DGNodeLab] -> DGNav

makeDGNav le dg cnl = DGNav le dg cnl' where

cnl' | null cnl = filter f $ labNodesDG dg

| otherwise = cnl

where f (n, _) = null $ filter isDefLink $ outDG dg n

isDefLink :: LEdge DGLinkLab -> Bool

isDefLink = isDefEdge . dgl_type . linkLabel

instance DevGraphNavigator DGNav where

-- we consider only the definition links in a DGraph

incoming dgn = filter isDefLink . innDG (dgnDG dgn)

getLabel = labDG . dgnDG

getLocalNode (DGNav{dgnLibEnv = le, dgnDG = dg}) n = lookupLocalNode le dg n

getInLibEnv (DGNav{dgnLibEnv = le, dgnDG = dg}) f = f le dg

getCurrent (DGNav{dgnCurrent = lblnl}) = lblnl

relocate dgn dg lblnl = dgn { dgnDG = dg, dgnCurrent = lblnl }

-- * Basic search functionality

-- | DFS based search

firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b

firstMaybe _ [] = Nothing

firstMaybe f (x:l) =

case f x of

Nothing -> firstMaybe f l

y -> y

-- | Searches all ancestor nodes of the current node and also the current node

-- for a node matching the given predicate

searchNode :: DevGraphNavigator a =>

(LNode DGNodeLab -> Bool) -> a -> Maybe (a, LNode DGNodeLab)

searchNode p dgnav =

firstMaybe (searchNodeFrom p dgnav . fst) $ getCurrent dgnav

searchNodeFrom :: DevGraphNavigator a => (LNode DGNodeLab -> Bool) -> a

-> Node -> Maybe (a, LNode DGNodeLab)

searchNodeFrom p dgnav n =

let (dgnav', lbln, ledgs) = followIncoming dgnav n

in if p lbln then Just (dgnav', lbln)

else firstMaybe (searchNodeFrom p dgnav') $ map linkSource ledgs

searchLink :: DevGraphNavigator a =>

(LEdge DGLinkLab -> Bool) -> a -> Maybe (a, LEdge DGLinkLab)

searchLink p dgnav =

firstMaybe (searchLinkFrom p dgnav . fst) $ getCurrent dgnav

searchLinkFrom :: DevGraphNavigator a => (LEdge DGLinkLab -> Bool) -> a

-> Node -> Maybe (a, LEdge DGLinkLab)

searchLinkFrom p dgnav n =

let (dgnav', _, ledgs) = followIncoming dgnav n

in case find p ledgs of

Nothing -> firstMaybe (searchLinkFrom p dgnav') $ map linkSource ledgs

x -> fmap ((,) dgnav') x

-- * Predicates to be used with 'searchNode'

-- | This predicate is true for nodes with a nodename equal to the given string

dgnPredName :: String -> LNode DGNodeLab -> Maybe (LNode DGNodeLab)

dgnPredName n nd@(_, lbl) = if getDGNodeName lbl == n then Just nd else Nothing

-- | This predicate is true for nodes which are instantiations of a

-- specification with the given name

dgnPredParameterized :: String -> LNode DGNodeLab -> Maybe (LNode DGNodeLab)

dgnPredParameterized n nd@(_, DGNodeLab

{ nodeInfo = DGNode { node_origin = DGInst sid }

})

| show sid == n = Just nd

| otherwise = Nothing

dgnPredParameterized _ _ = Nothing

-- * Predicates to be used with 'searchLink'

-- | This predicate is true for links which are argument instantiations of a

-- parameterized specification with the given name

dglPredActualParam :: String -> LEdge DGLinkLab -> Maybe (LEdge DGLinkLab)

dglPredActualParam n edg@(_, _, DGLink { dgl_origin = DGLinkInstArg sid })

| show sid == n = Just edg

| otherwise = Nothing

dglPredActualParam _ _ = Nothing

-- | This predicate is true for links which are instantiation morphisms

dglPredInstance :: LEdge DGLinkLab -> Maybe (LEdge DGLinkLab)

dglPredInstance edg@(_, _, DGLink { dgl_origin = DGLinkMorph _ }) = Just edg

dglPredInstance _ = Nothing

-- * Combined Node Queries

-- | Search for the given name in an actual parameter link

getActualParameterSpec :: DevGraphNavigator a => String -> a

-> Maybe (a, LNode DGNodeLab)

getActualParameterSpec n dgnav =

-- search first actual param

case searchLink (isJust . dglPredActualParam n) dgnav of

Nothing -> Nothing

Just (dgn', (sn, _, _)) ->

-- get the spec for the param

fmap f $ firstMaybe dglPredInstance $ incoming dgnav sn

where f edg = let sn' = linkSource edg

in (dgn', (sn', getLabel dgnav sn'))

-- | Search for the given name in an instantiation node

getParameterizedSpec :: DevGraphNavigator a => String -> a

-> Maybe (a, LNode DGNodeLab)

getParameterizedSpec n dgnav =

-- search first actual param

case searchNode (isJust . dgnPredParameterized n) dgnav of

Nothing -> Nothing

Just (dgn', (sn, _)) ->

-- get the spec for the param

fmap f $ firstMaybe dglPredInstance $ incoming dgnav sn

where f edg = let sn' = linkSource edg

in (dgn', (sn', getLabel dgnav sn'))

-- | Search for the given name in any node

getNamedSpec :: DevGraphNavigator a => String -> a -> Maybe (a, LNode DGNodeLab)

getNamedSpec n dgnav = searchNode (isJust . dgnPredName n) dgnav

-- | Combining a search function with an operation on nodes

fromSearchResult :: (DevGraphNavigator a) =>

(a -> Maybe (a, LNode DGNodeLab))

-> (a -> Node -> b) -> a -> Maybe b

fromSearchResult sf f dgnav = case sf dgnav of

Just (dgn', (n, _)) -> Just $ f dgn' n

_ -> Nothing

-- * Other utils

getLocalSyms :: DevGraphNavigator a => a -> Node -> Set.Set G_symbol

getLocalSyms dgnav n =

case dgn_origin $ getLocalLabel dgnav n of

DGBasicSpec _ _ s -> s

_ -> Set.empty

linkSource :: LEdge a -> Node

linkLabel :: LEdge a -> a

linkSource (x,_,_) = x

linkLabel (_,_,x) = x