Permalink
Browse files

fix for nonreporting of identifier ref ambiguity, arising in JCU afte…

…r UHC changes to name structure; infrastructure was there but onl partially used...
  • Loading branch information...
atzedijkstra committed Sep 6, 2012
1 parent 6f1216f commit c4e198f71c6dc269e53c864b4a1965a2e6b78066
@@ -48,7 +48,7 @@ import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
import GHC.List
import GHC.Enum( maxBound )
#else
-import Prelude hiding ( lex )
+import Prelude hiding ( lex, lexDigits, lexLitChar )
import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
import Data.Ratio( Ratio, (%) )
#endif
@@ -81,7 +81,7 @@ type CUtimbuf = ()
type CUtsname = ()
#ifndef __GLASGOW_HASKELL__
-type FD = CInt
+-- type FD = CInt
#endif
-- ---------------------------------------------------------------------------
@@ -68,7 +68,11 @@ version
%%[1 export(verInfo)
verInfo :: Version -> String
-verInfo v = verProg v ++ "-" ++ verFull v ++ ", Revision " ++ verSvnRevision v
+verInfo v =
+ verProg v ++ "-" ++ verFull v ++ ", revision " ++ verSvnRevision v
+%%[[50
+ ++ ", timestamp " ++ verTimestamp v
+%%]]
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
@@ -159,6 +159,17 @@ type IdDefOccGam = Gam IdOcc IdDefOcc
type IdDefOccAsc = AssocL IdOcc [IdDefOcc]
%%]
+%%[1 export(idDefOccGamUnion)
+-- | Union gam, but tailored to maintaining duplicate definition info
+idDefOccGamUnion :: IdDefOccGam -> IdDefOccGam -> IdDefOccGam
+%%[[1
+idDefOccGamUnion = gamUnion
+%%][50
+idDefOccGamUnion = gamUnionWith idDefOccLCmb
+%%]]
+{-# INLINE idDefOccGamUnion #-}
+%%]
+
%%[9
idDefOccGamPartitionByKind :: [IdOccKind] -> IdDefOccGam -> (IdDefOccAsc,IdDefOccAsc)
idDefOccGamPartitionByKind ks
@@ -201,6 +212,7 @@ idGam2QualGam = gamMap (\(iocc,docc) -> (iocc {ioccNm = hsnQualified $ ioccNm io
idQualGamReplacement :: IdQualGam -> IdOccKind -> HsName -> HsName
idQualGamReplacement g k n = maybe n id $ gamLookup (IdOcc n k) g
+{-# INLINE idQualGamReplacement #-}
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -255,20 +267,6 @@ instance (Ord k, PP k, PP v) => PP (SGam k v) where
pp g = ppGam g
%%]
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% ForceEval
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[(9999 hmtyinfer || hmtyast)
-instance ForceEval TyKiKey
-%%[[102
- where
- fevCount (TyKiKey_Name n) = cm1 "TyKiKey_Name" `cmUnion` fevCount n
- fevCount (TyKiKey_TyVar v) = cm1 "TyKiKey_TyVar" `cmUnion` fevCount v
-%%]]
-
-%%]
-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Init of soGam, only used by TyCore
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
@@ -284,6 +284,12 @@ gamFromAssocL = assocLToGam
{-# INLINE gamFromAssocL #-}
%%]
+%%[50 export(gamUnionWith)
+gamUnionWith :: Ord k => (v -> [v] -> [v]) -> Gam k v -> Gam k v -> Gam k v
+gamUnionWith cmb = sgamUnionWith (Just cmb)
+{-# INLINE gamUnionWith #-}
+%%]
+
%%[1
gamUnions :: Ord k => [Gam k v] -> Gam k v
gamUnions [] = emptyGam
@@ -104,40 +104,47 @@ instance Show (SGam k v) where
-- scope ident in scope?
inScp :: Scp -> Int -> Bool
inScp = flip elem
+{-# INLINE inScp #-}
-- sgam elt in scope?
sgameltInScp :: Scp -> SGamElt v -> Bool
sgameltInScp scp = inScp scp . sgeScpId
+{-# INLINE sgameltInScp #-}
%%]
%%[8
-- filter out the out of scopes
sgameltFilterInScp :: Scp -> [SGamElt v] -> [SGamElt v]
sgameltFilterInScp scp = filter (sgameltInScp scp)
+{-# INLINE sgameltFilterInScp #-}
-- map the in scopes
sgameltMapInScp :: Scp -> (v -> v) -> [SGamElt v] -> [SGamElt v]
sgameltMapInScp scp f = map (\e -> if sgameltInScp scp e then e {sgeVal = f (sgeVal e)} else e)
+{-# INLINE sgameltMapInScp #-}
-- extract the in scopes
sgameltGetFilterInScp :: Scp -> (v -> v') -> [SGamElt v] -> [v']
sgameltGetFilterInScp scp f es = [ f (sgeVal e) | e <- es, sgameltInScp scp e ]
+{-# INLINE sgameltGetFilterInScp #-}
%%]
%%[8
-- filter out the out of scopes, applying a mapping function on the fly
mapFilterInScp' :: Ord k => Scp -> ([SGamElt v] -> [SGamElt v]) -> SMap k v -> SMap k v
mapFilterInScp' scp f m
- -- = Map.mapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
= varmpMapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
+{-# INLINE mapFilterInScp' #-}
mapFilterInScp :: Ord k => Scp -> (SGamElt v -> SGamElt v) -> SMap k v -> SMap k v
mapFilterInScp scp f m
= mapFilterInScp' scp (map f) m
+{-# INLINE mapFilterInScp #-}
sgamFilterInScp :: Ord k => SGam k v -> SGam k v
sgamFilterInScp g@(SGam {sgScp = scp, sgMap = m})
= g {sgMap = mapFilterInScp scp id m}
+{-# INLINE sgamFilterInScp #-}
%%]
%%[8 export(sgamFilterMapEltAccumWithKey,sgamMapEltWithKey,sgamMapThr,sgamMap)
@@ -182,12 +189,20 @@ sgamSingleton :: k -> v -> SGam k v
sgamSingleton = sgamMetaLevSingleton metaLevVal
%%]
-%%[8 export(sgamUnion)
+%%[8 export(sgamUnionWith,sgamUnion)
-- combine gam, g1 is added to g2 with scope of g2
-sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
-sgamUnion g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
- = g2 {sgMap = varmpUnionWith (++) m1' m2}
+sgamUnionWith :: Ord k => Maybe (v -> [v] -> [v]) -> SGam k v -> SGam k v -> SGam k v
+sgamUnionWith cmb g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
+ = g2 {sgMap = varmpUnionWith cmb' m1' m2}
where m1' = mapFilterInScp scp1 (\e -> e {sgeScpId = hscp2}) m1
+ cmb' = maybe (++)
+ (\c -> \l1 l2 -> concat [ map (SGamElt scp) $ foldr c [] $ map sgeVal g | g@(SGamElt {sgeScpId = scp} : _) <- groupSortOn sgeScpId $ l1 ++ l2 ])
+ cmb
+
+-- combine gam, g1 is added to g2 with scope of g2
+sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
+sgamUnion = sgamUnionWith Nothing
+{-# INLINE sgamUnion #-}
%%]
%%[8 export(sgamPartitionEltWithKey,sgamPartitionWithKey)
@@ -102,10 +102,12 @@ mkDefOccGam'' l r mka os
mkDefOccGam' :: NmLev -> Range -> (IdOcc -> IdAspect) -> [IdOcc] -> IdDefOccGam
mkDefOccGam' l r mka os
= mkDefOccGam'' l r (\_ -> mka) (zip (repeat undefined) os)
+{-# INLINE mkDefOccGam' #-}
mkDefOccGam :: NmLev -> Range -> IdAspect -> [IdOcc] -> IdDefOccGam
mkDefOccGam l r a os
= mkDefOccGam' l r (const a) os
+{-# INLINE mkDefOccGam #-}
%%]
%%[3 hs
@@ -422,7 +424,7 @@ SEM AGItf
%%[1.initIdGam
SEM Body
| Body
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
%%]
TBD: 20100205 AD: The code below to remap identifiers should be revised. Too complex.
@@ -470,26 +472,26 @@ SEM Body
as n = Map.findWithDefault n n @importdeclarations.modAsMp
-- compute new gamma holding proper mapping for unqualified & qualified idents
mkg sel g
- = gamFromAssocL
+ = foldr idDefOccGamUnion emptyGam
[ {- tr "NameAnalysis.mkg" (o >#< ns)
- $ -} (o {ioccNm = n},d {doccNmAlts = Just ns})
+ $ -} gamSingleton (o {ioccNm = n}) (d {doccNmAlts = Set.fromList ns})
| (o,d) <- gamToAssocL g
, (n,es) <- sel o
, let ns = [ ioccNm eo | e <- es, let eo = mentIdOcc e, ioccKind eo == ioccKind o ]
]
gnew = mkg (lks False) @lhs.idGam
- in mkg (lks False) @declarations.idDefOccGam `gamUnion` gnew
+ in mkg (lks False) @declarations.idDefOccGam `idDefOccGamUnion` gnew
%%]
%%[1
SEM Expression
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Lambda
- expression . idGam = gamAddGam @patterns.idDefOccGam @lhs.idGam
+ expression . idGam = gamUnion @patterns.idDefOccGam @lhs.idGam
%%[[3
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%[[5
| Comprehension
@@ -506,13 +508,13 @@ SEM Expression
%%[4
SEM Pattern
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]
%%[4
SEM LeftHandSide
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]
%%[3
@@ -524,7 +526,7 @@ SEM Declaration
%%[[(90 codegen)
ForeignExport
%%]]
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%[[5
| Data Newtype
%%[[11
@@ -533,27 +535,27 @@ SEM Declaration
%%[[31
GADT
%%]]
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%[[6
| KindSignature
- kind . idGam = gamAddGam @idDefOccGamKind @lhs.idGam
+ kind . idGam = gamUnion @idDefOccGamKind @lhs.idGam
%%]]
%%[[9
| Class
-- simpletype . idGam = @lhs.idGam -- avoid cycles
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
. idDefOccGamInstForClass
= fst $ gamPartition (\_ d -> case doccAsp d of {IdAsp_Inst_Def _ n | n == @classrefname -> True ; _ -> False}) $ @lhs.idGam
| Instance
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%]
%%[1
SEM FunctionBinding
| FunctionBinding
- righthandside . idGam = gamAddGam @lefthandside.idDefOccGam @lhs.idGam
+ righthandside . idGam = gamUnion @lefthandside.idDefOccGam @lhs.idGam
%%]
%%[1
@@ -562,45 +564,45 @@ SEM RightHandSide
%%[[5
Guarded
%%]
- loc . idGam = gamAddGam @where.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @where.idDefOccGam @lhs.idGam
%%]
%%[5
SEM Alternative
| Alternative
- righthandside . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ righthandside . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
SEM Qualifier
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Generator
- lhs . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ lhs . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
%%]
%%[9
SEM Statement
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Generator
- lhs . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ lhs . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
%%]
%%[4
SEM Type
| Forall Exists
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%[6
SEM Kind
| Forall
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%[13
SEM ContextItem
| Forall
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -665,9 +667,9 @@ mkUseOccGam opts idGam names kind asp rng
occOfDef = idOccUse {ioccNm = nmOfDef}
idUseOccGam = gamSingleton occOfDef (IdUseOcc occOfDef asp rng (doccForUse mbDef))
errs = case mbDef of
- Just d | isJust (doccNmAlts d) && length alts > 1
- -> [rngLift rng Err_AmbiguousNameRef "name" "name" name alts]
- where alts = fromJust (doccNmAlts d)
+ Just d | Set.size (doccNmAlts d) > 1
+ -> [rngLift rng Err_AmbiguousNameRef "name" k name (Set.toList $ doccNmAlts d)]
+ where k = (show $ ioccKind $ doccOcc d) ++ " (" ++ (showPP $ pp $ doccAsp d) ++ ")"
_ -> []
%%]
@@ -958,7 +958,9 @@ pBody' opts addDecl
<|> pParens ((:) <$> pContextItemBase
<*> ( pImO
<|> (++) <$> pList1 (pCOMMA *> pContextItemBase) <*> pImO
- ) )
+ )
+ <|> pSucceed []
+ )
)
<* pDARROW
where pImO = (:[]) <$ pCOMMA <*> pContextItemImplWild `opt` []
Oops, something went wrong.

0 comments on commit c4e198f

Please sign in to comment.