ScopeModule.hs

{-+
This module provides the function #scopeModule# which takes abstract
syntax trees returned by the parser, where idientifers are annotated with
the position they occurred at in the source file, and produces abstract
syntax trees where the identifiers are annotated with the following
extra information:

  * Tagging to make every identifier globally unique, i.e., you can tell
    which entity (binding occurence) an identifier refers to, without knowing
    which scope it occurs in.
    Top-level entities are identified by their original names (M.n).
    Local entities are idenfified by their names in combination
     with a source position.

  * Tagging to tell what kind of entity the identifiers refer to (a value,
    a type class, a data constructor, ...)

The type #PNT# is the type used for identifiers holding this extra tagging
information.

(The function #numberNames# is responsible for
making names unique. It currently uses source positions, but it could
generate unique numbers instead, in which case the parser wouldn't have to
provide any position information.)
-}
module ScopeModule(scopeModule,XRefInfo,checkRefs,origName) where

import HsModule(hsModName)
import HsIdent(HsIdentI(..),getHSName,mapHsIdent)
import HsName(HsName,ModuleName)
import SrcLoc1(SrcLoc,srcLoc)
import HasBaseName

import WorkModule(inscpList) --WorkModuleI,ExpRel,inScope,
import Relations(relToList)
import TypedIds--(IdTy(..),blankTypeInfo,namespace,belongsTo)
import NameMaps
import NumberNames(numberNames,PN(..),Orig(G),orig,origModule,eqSrc,optLoc,unique)
import PNT
import ScopeNames
import UniqueNames(optOrigModule)
--import SourceNames(srcName,SN)

import QualNames(getQualified,mkUnqual,mkQual)
import Ents(Ent(..))

import PrettyPrint

import OutputM
import EnvM
import List(partition,nub)
import Maybe(fromJust)
import MUtils(mapSnd)
import OpTypes(ordBy)
import FiniteMap1

--import IOExts(trace) -- for debugging

{-
scopeModule :: ... => ...
                   -> HsModuleI i (ds (SN HsName))
                   -> (HsModuleI i (ds PNT),[XRefInfo])
-}
scopeModule (wm,exports) mod 
    = mergeOutputM -- merge now to avoid having to sort later
    . seqNames 
    . mapNames2 TopLevel (pickScope m envs HsVar, pickScope m envs HsCon)
    . addScope modenv
    . numberNames $ mod
  where
    m = getBaseName (hsModName mod)
    modenv = topenv wm
    envs = (modenv,mapSnd (impenv.relToList) exports)

    mergeOutputM = foldOutput [] (:[]) merge'

    merge' xs [] = xs
    merge' [] ys = ys
    merge' xxs@(x:xs) yys@(y:ys) = if ordBy srcLoc' x y
				   then x:merge' xs yys
				   else y:merge' xxs ys

    srcLoc' (_,i,_) = srcLoc i

checkRefs :: [XRefInfo] -> [(SrcLoc,Doc)]
checkRefs = concatMap checkRef
  where
    -- Exports and imports have already been checked by the module system code,
    -- so no need to check again. TODO: import specs are checked agains the
    -- environment...
    checkRef ((ExpEnt {},_),x,os) = []
    checkRef ((ImpEnt {},_),x,os) = []
    checkRef ((role,sp),x,os) =
      case os of
	[_] -> []
        [] -> [(srcLoc x,"not in scope:"<+>x)]
	_ -> [(srcLoc x,"ambiguous:"<+>x<+>ppiFTuple (map origname os))]
    origname (x,_) = origModule x<>"."<>getQualified x

--type Filter x y = FiniteMap x y->[y]

type SPName = (PName,ScopeFM)
type Scope = [(PIdent,IdTy PId)]
type ScopeFM = FiniteMap (HsIdentI HsName) Scope
type ImportScope = [(ModuleName,ScopeFM)]
type XRefInfo = ((Role (),NameSpace),PIdent,Scope)

pickScope :: ModuleName ->
             (ScopeFM,ImportScope) ->
             (PName->PIdent)->
	     Occurence SPName ->
	     SPName ->
	     OutputM XRefInfo PNT
pickScope m (modenv,ex) c (dctx,sp) (i,scope) =
     checkref . partition (isLocal.getHSName.fst) . nub . filterSame $ scope'
  where
    scope' = case dctx of
	       ImpEnt m _ -> fromJust (lookup m ex)
	       _ -> scope

    filterSame =
      case dctx of
	{- This should implement the revised Haskell 98 scoping rules for
	   instance declarations and subordinate names in imports/exports.-}
	Def (Instance (cl,_)) -> filterSameSub cl
	ExpEnt (Just (i,_))   -> filterSameSub i
	ImpEnt m (Just (i,_)) -> filterSameSub i
	FieldLabel            -> filter isField . filterSameNormal
	Sig TopLevel	      -> filterSameModule
	Use                   -> filter notLogic . filterSameNormal
	_                     -> filterSameNormal

    filterSameNormal env =
       -- i' `eqSrc` c i && sp == namespace ity'
       [it|it@(i',ity')<-lookenv env (c i),sp==pnamespace ity']

    notLogic (_,Assertion) = False
    notLogic (_,Property)  = False
    notLogic _             = True

    filterSameModule = filter sameModule . filterSameNormal
      where sameModule (i,_) = optOrigModule i == Just m

    -- P-Logic: conids can refer to properties&assertions in imports&exports
    pnamespace = if isExpOrImp then impexpnamespace else namespace
      where
        isExpOrImp =
          case dctx of
	    ExpEnt Nothing -> True
	    ImpEnt _ Nothing -> True
	    _ -> False
	impexpnamespace ity =
          case ity of
	    Assertion -> ClassOrTypeNames
	    Property -> ClassOrTypeNames
	    _ -> namespace ity

    filterSameSub i env = filtFM (sameSub env i) env
      where filtFM p = filter p . concat . eltsFM

    sameSub env iowner =
      case filter (isClassOrType.snd) $ lookenv env (HsCon iowner) of
	[(HsCon c,idty)] ->
	    case [orig s|s<-subs,s `eqSrc` n] of
	      [o] -> sameSub' o
	      [] -> --trace ("subordinate not found "++show (iowner,i,subs)) $
		    const False
	      _ -> --trace ("ambiguous subordinate name "++show (iowner,i,subs)) $
		   const False -- data/class with name duplications...
	  where
	    subs = subordinates idty
	    n = getQualified i -- i should be unqualified
	    sameSub' o (i,idty) = orig i==o && isSubordinate idty

	[] -> --trace ("not in scope "++show iowner) $
	      const False
	ents -> --trace ("ambiguous owner of subordinate names "++show (iowner,ents)) $
		const False

    isField (_,FieldOf {}) =  True
    isField _ = False

    isLocal (PN _ (G {})) = False
    isLocal _ = True -- hmm

    checkref (l:_,_) = ref [l] -- innermost binding, ambiguities not detected
    checkref (_,gs)  = ref (filterdefs gs)

    -- Defining occurences do not themselves conflict with imported names,
    -- except in instances, which aren't really defining occurences.
    filterdefs =
      case dctx of
	Def (Instance _) -> id
	Def _ -> filter ((==m).origModule.getHSName.fst)
	_ -> id

    ref is = output ((strip dctx,sp),c i,is) >>
	     case is of
	       [(oi,idty)] -> return (PNT (keepSrcName oi) idty (optLoc i))
	       _           -> return (PNT i (fakeidty sp) (optLoc i))
      where keepSrcName oi = PN (getBaseName i) (orig oi)

    -- To avoid recursive type:
    strip = fmap (const ())

    -- To avoid failing on references to ids not in scope
    fakeidty ValueNames = Value
    fakeidty ClassOrTypeNames = Type blankTypeInfo


addScope env m =
    --trace (show (hsModName m,wm)) $
    withEnv env (scopeNames extend m)
  where
    --global (ni,idty) = (N i (G i),idty)
    --  where N i _ = getHSName ni
    --local (ni,idty) = (getHSName ni,idty)
 
    extend new old = extenv old (filter notoldtyvar (mapSnd conv new))
      where
        --oldtyvars = [i|(HsVar i,Type {})<-old]
        notoldtyvar (i@(HsVar _),Type {}) = null [()|(_,Type{})<-lookenv old i]
        notoldtyvar _ = True

    conv = fmap getQualified

envMap = extenv emptyFM
extenv env bs = addListToFM_C (flip (++)) -- innermost binding first in the list
                              env
			      [(getBaseName i,[it])|it@(i,_)<-bs]
lookenv env i = lookupWithDefaultFM env [] (getBaseName i)

--topenv :: WorkModuleI HsName Id -> [(HsIdentI (PName),IdTy (PId))]
topenv wm = envMap [(origIdent qn m i,origt m t)|(qn,Ent m i t)<-inscpList wm]
      where 
        origt m = fmap (osub m) 
        osub m n = origName n m n
	    -- This generates references to names not necessarily in scope...

{-
impenv ::
  (Unique n, HasBaseName qn HsName, QualNames qn ModuleName n1,
   HasBaseName n ib) =>
  [(n1, Ent n)]
  -> FiniteMap (HsIdentI HsName) [(HsIdentI (PN HsName), IdTy (PN ib))]
--}
impenv exprel =
    envMap [(origIdent (unq m n) m i,origt m t)|(n,Ent m i t)<-exprel]
  where 
    unq m n = mkUnqual n `asTypeOf` mkQual m n
                      -- ^ this eliminates an ambiguite that was accepted by GHC
    origt m = fmap (osub m) 
    osub m n = origName n m n

origIdent qn m = mapHsIdent (origName qn m)
origName qn m n = PN (getBaseName qn) (unique m n)
--origName qn m n = PN (getBaseName qn) (G m (getBaseName n))

--instance (Printable a,Printable b) => PrintableOp (a,b) where
--  ppiOp (x,y) = "`("<>x<>","<>y<>")`"

subordinates (Class _ ms) = {-map HsVar-} ms
subordinates (Type TypeInfo {constructors=cs,fields=fs}) =
  {-map HsVar-} fs++map ({-HsCon .-} conName) cs
subordinates _ = []