0N/A{-|

1879N/AModule : $Header$

0N/ACopyright : (c) Sonja Groening, Christian Maeder, Uni Bremen 2002-2004

0N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

0N/A

0N/AMaintainer : maeder@tzi.de

0N/AStability : provisional

0N/APortability : portable

0N/A

0N/A-}

0N/A

0N/Amodule Haskell.Haskell2DG (anaHaskellFile) where

0N/A

0N/Aimport Driver.Options

0N/A

0N/Aimport Static.DevGraph (DGNodeLab (..),

0N/A DGLinkLab (..),

0N/A DGLinkType (..),

1472N/A DGOrigin (..),

1472N/A DGraph,

1472N/A LibEnv,

0N/A GlobalEntry(..),

0N/A NodeSig(..),

0N/A getNode)

91N/Aimport Syntax.AS_Library (LIB_NAME (..),

0N/A LIB_ID (..))

0N/Aimport Logic.Grothendieck (G_sign (..),

0N/A G_l_sentence_list (..),

0N/A G_morphism (..),

0N/A gEmbed)

1879N/Aimport Logic.Logic

0N/Aimport Common.Lib.Graph (Node,

1879N/A empty,

0N/A insNode,

1879N/A insEdge,

1879N/A newNodes,

1879N/A match)

1879N/A

1879N/Aimport Common.Id (Token (..),

1879N/A SIMPLE_ID,

1879N/A nullPos)

1879N/A

1879N/Aimport qualified Common.Lib.Map as Map

1879N/Aimport Common.GlobalAnnotations (emptyGlobalAnnos)

1879N/A

1879N/A-- toplevel function: Creates DevGraph and

1879N/A-- LibEnv from a .hs file

1879N/A-- (including all imported modules)

1879N/AanaHaskellFile :: HetcatsOpts

0N/A -> String

0N/A -> IO (Maybe (LIB_NAME, -- filename

1879N/A HsModule, -- as tree

1879N/A DGraph, -- development graph

0N/A LibEnv)) -- DGraphs for

0N/A -- imported modules

0N/A -- incl. main module

1879N/AanaHaskellFile _ srcFile = anaHaskellFileAux srcFile

1879N/A

1879N/AanaHaskellFileAux :: String -> -- DGraph ->

1879N/A IO (Maybe (LIB_NAME, HsModule,

1879N/A DGraph, LibEnv))

0N/AanaHaskellFileAux srcFile =

0N/A do

1879N/A moduleSyntax <- fmap cvrtHsModule $ parseFile srcFile

0N/A (absSyn, modInfo, le) <- typeInference moduleSyntax

0N/A let libName = Lib_id(Indirect_link srcFile [])

0N/A -- convert HaskellEnv to DGraph, build up corresponding LibEnv

0N/A let (dg',le') = hasEnv2DG libName absSyn modInfo le

0N/A return (Just(libName, moduleSyntax, dg', le'))

1879N/A

0N/AtypeInference :: HsModule

0N/A -> IO (AHsModule, ModuleInfo, LibEnv)

0N/AtypeInference moduleSyntax =

0N/A do

0N/A let annotatedSyntax = getAnnotedSyntax moduleSyntax

0N/A

1879N/A (modInfos, le) <- anaImportDecls annotatedSyntax

0N/A

0N/A -- concat all modInfos

0N/A let importedModInfo = concatModuleInfos modInfos

1879N/A

1879N/A -- this is the ModuleInfo that we were passing into tiModule

0N/A -- earlier (just the Prelude stuff)

1879N/A

0N/A let initialModInfo = joinModuleInfo preludeModInfo importedModInfo

1879N/A

1934N/A -- call the type inference code for this module

0N/A (moduleEnv,

0N/A dataConEnv,

0N/A newClassHierarchy,

659N/A newKindInfoTable,

1934N/A moduleRenamed,

1879N/A moduleSynonyms) = tiModule annotatedSyntax initialModInfo

1879N/A

1879N/A let modInfo = ModuleInfo { varAssumps = moduleEnv,

1879N/A moduleName = getAModuleName annotatedSyntax,

1879N/A dconsAssumps = dataConEnv,

1879N/A classHierarchy = newClassHierarchy,

1879N/A kinds = newKindInfoTable,

1879N/A tyconsMembers = getTyconsMembers moduleRenamed,

1879N/A infixDecls = getInfixDecls moduleRenamed,

1879N/A synonyms = moduleSynonyms }

1879N/A

1879N/A return (moduleRenamed, modInfo, le)

0N/A

0N/AanaImportDecls :: AHsModule -> IO ([ModuleInfo], LibEnv)

0N/AanaImportDecls (AHsModule _ _ idecls _) = anaImports idecls [] Map.empty

1879N/A

1879N/AanaImports :: [AHsImportDecl] -> [ModuleInfo] -> LibEnv

1879N/A -> IO ([ModuleInfo], LibEnv)

1879N/AanaImports [] modInfos le = do return (modInfos, le)

1879N/AanaImports (imp:imps) modInfos le =

1879N/A do

1879N/A (newModInfo, le') <- anaOneImport imp le

1879N/A anaImports imps (newModInfo:modInfos) le'

0N/A

0N/AanaOneImport :: AHsImportDecl -> LibEnv

1879N/A -> IO (ModuleInfo, LibEnv)

1879N/AanaOneImport (AHsImportDecl _ aMod _ _ maybeListOfIdents) le = do

1879N/A let ln = toLibName aMod

1879N/A modSyn <- parseFile (fileName aMod)

1879N/A (annoSyn, modInfo, leImports) <- typeInference modSyn

1879N/A let le' = le `Map.union` leImports

1879N/A filteredModInfo = filtModInfo aMod modInfo maybeListOfIdents

1879N/A (dg,node) = addNode empty annoSyn filteredModInfo

1879N/A case annoSyn of

1879N/A AHsModule _ _ idecls _ -> case idecls of

1879N/A [] -> return (filteredModInfo,addDG2LibEnv le' ln node dg)

1879N/A _ -> return (filteredModInfo, addDG2LibEnv le' ln node

1879N/A $ addLinks idecls dg node le')

1879N/A

1879N/A where filtModInfo _ modInfo Nothing = modInfo

1879N/A -- we're not imposing restrictions

1879N/A filtModInfo aModule modInfo (Just (_, importSpecs)) =

1879N/A filterModuleInfo aModule modInfo $

1879N/A expandDotsInTyCons aModule (tyconsMembers modInfo) $

1879N/A map importSpecToExportSpec importSpecs

1879N/A

1879N/AtoLibName :: AModule -> LIB_NAME

1879N/AtoLibName aMod = Lib_id(Indirect_link (fileName aMod) [])

0N/A

0N/AaddLinks :: [AHsImportDecl] -> DGraph -> Node -> LibEnv

0N/A -> DGraph

1879N/AaddLinks [] dg _ _ = dg

0N/AaddLinks (idecl:idecls) dg mainNode le =

1879N/A let ln = toLibName (getModName idecl)

1879N/A node = lookupNode ln le

1879N/A (dgWithRef, ref) = addDGRef ln dg node

1879N/A link = createDGLinkLabel idecl

1879N/A -- insert new edge with LinkLabel

1879N/A linkedDG = insEdge (ref,mainNode,link) dgWithRef

1879N/A in addLinks idecls linkedDG mainNode le

1879N/A where getModName (AHsImportDecl _ name _ _ _) = name

1879N/A

1879N/A

1879N/AhasEnv2DG :: LIB_NAME -> AHsModule -> ModuleInfo

1879N/A -> LibEnv -> (DGraph, LibEnv)

1879N/AhasEnv2DG ln aMod modInfo le =

1879N/A let (dg, node) = addNode empty aMod modInfo

1879N/A dg' = addLinks (getImps aMod) dg node le

1879N/A in (dg', (addDG2LibEnv le ln node dg'))

1879N/A where getImps (AHsModule _ _ imps _) = imps

1879N/A

1879N/A-- input: (so far generated) DGraph,

1879N/A-- a module's abstract syntax and its ModuleInfo

1879N/A-- task: adds a new node (representing the module)

1879N/A-- to the DGraph

1879N/AaddNode :: DGraph -> AHsModule -> ModuleInfo

1879N/A -> (DGraph, Node)

1879N/AaddNode dg (AHsModule name exps imps decls) modInfo =

1879N/A -- create a node, representing the module

1879N/A let node_contents

1879N/A | imps == [] = -- module with no imports

1879N/A DGNode {

1879N/A dgn_name = aHsMod2SimpleId name,

1879N/A dgn_sign = G_sign Haskell modInfo,

1879N/A dgn_sens = G_l_sentence_list Haskell

1879N/A (extractSentences (AHsModule name

1879N/A exps imps decls)),

1879N/A dgn_origin = DGBasic }

1879N/A | otherwise = -- module with imports

1879N/A DGNode {

1879N/A dgn_name = aHsMod2SimpleId name,

1879N/A dgn_sign = G_sign Haskell modInfo,

1879N/A dgn_sens = G_l_sentence_list Haskell

1879N/A (extractSentences (AHsModule name

1879N/A exps imps decls)),

1879N/A dgn_origin = DGExtension }

1879N/A [node] = newNodes 0 dg

1879N/A -- add node to DGraph

1879N/A in (insNode (node, node_contents) dg, node)

1879N/A

1879N/AaddDGRef :: LIB_NAME -> DGraph -> Node -> (DGraph, Node)

1879N/AaddDGRef ln dg node =

1879N/A let node_contents =

1879N/A DGRef {

0N/A dgn_renamed = ln2SimpleId ln,

0N/A dgn_libname = ln,

0N/A dgn_node = node }

0N/A [newNode] = newNodes 0 dg

1879N/A in (insNode (newNode, node_contents) dg, newNode)

0N/A

1879N/Aln2SimpleId :: LIB_NAME -> Maybe (SIMPLE_ID)

0N/Aln2SimpleId (Lib_id (Indirect_link modName _)) =

0N/A Just (Token { tokStr = modName,

0N/A tokPos = nullPos })

0N/Aln2SimpleId (Lib_id (Direct_link modName _)) =

0N/A Just (Token { tokStr = modName,

1879N/A tokPos = nullPos })

0N/Aln2SimpleId (Lib_version link _) = ln2SimpleId (Lib_id link)

0N/A

1879N/A

1879N/A-- --------------- utilities --------------- --

1879N/A

1879N/AcreateDGLinkLabel :: AHsImportDecl -> DGLinkLab

1879N/AcreateDGLinkLabel idecl =

1879N/A case idecl of

1879N/A AHsImportDecl _ _ _ _ Nothing -> -- no hiding

1879N/A DGLink {

1879N/A dgl_morphism = gEmbed (G_morphism Haskell ()),

1879N/A dgl_type = GlobalDef,

1879N/A dgl_origin = DGExtension }

1879N/A AHsImportDecl _ _ _ _ (Just(False,_)) -> -- no hiding

0N/A DGLink {

0N/A dgl_morphism = gEmbed (G_morphism Haskell ()),

0N/A dgl_type = GlobalDef,

0N/A dgl_origin = DGExtension }

0N/A AHsImportDecl _ _ _ _ (Just(True,_)) -> -- hiding

0N/A DGLink {

1879N/A dgl_morphism = gEmbed (G_morphism Haskell ()),

1879N/A dgl_type = HidingDef,

1879N/A dgl_origin = DGExtension }

1879N/A

1879N/AaddDG2LibEnv :: LibEnv -> LIB_NAME -> Node -> DGraph -> LibEnv

1879N/AaddDG2LibEnv le libName n dg =

let

Just(nodeLab) = getNodeContent n dg

imp = EmptyNode (Logic Haskell)

params = []

parsig = dgn_sign nodeLab -- empty_signature Haskell

body = NodeSig (n, (dgn_sign nodeLab))

globalEnv = Map.insert (getDgn_name nodeLab)

(SpecEntry (imp,params,parsig,body))

Map.empty

in

Map.insert libName (emptyGlobalAnnos, globalEnv, dg) le

lookupNode :: LIB_NAME -> LibEnv -> Node

lookupNode ln le =

let Just (_, globalEnv, _) = Map.lookup ln le

(_, (SpecEntry (_, _, _, body))) = Map.elemAt 0 globalEnv

in

case (getNode body) of

Just n -> n

Nothing -> (-1)

aHsMod2SimpleId :: AModule -> Maybe SIMPLE_ID

aHsMod2SimpleId (AModule name) = Just (Token { tokStr = name,

tokPos = nullPos })

fileName :: AModule -> String

fileName (AModule name) = name ++ ".hs"

getNodeContent :: Node -> DGraph -> Maybe (DGNodeLab)

getNodeContent n dg =

case (match n dg) of

(Just (_,_,nodeLab,_), _) -> Just (nodeLab)

_ -> Nothing

getDgn_name :: DGNodeLab -> SIMPLE_ID

getDgn_name nl = let Just(n) = dgn_name nl

in n