Complete the renamer

3 files changed, 252 insertions, 162 deletions

diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 922b362d..45db4433 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -25,6 +25,9 @@ import Control.Monad hiding ( mapM )
 import Data.Traversable
 
 import GHC
+import BasicTypes
+import SrcLoc 
+import Bag
 
 -- -----------------------------------------------------------------------------
 -- Monad for renaming
@@ -72,193 +75,248 @@ runRnFM env rn = unRn rn lkp
 runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
 runRn lkp rn = unRn rn lkp
 
+-- -----------------------------------------------------------------------------
+-- Renaming 
+
 renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName]
 renameExportItems items = mapM renameExportItem items
 
 renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
 renameMaybeDoc mbDoc = mapM renameDoc mbDoc
 
+renameLDoc (L loc doc) = return . L loc =<< renameDoc doc
+
 renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
 renameDoc doc = case doc of
-
   DocEmpty -> return DocEmpty
-
   DocAppend a b -> do
     a' <- renameDoc a
     b' <- renameDoc b
     return (DocAppend a' b')
-
   DocString str -> return (DocString str)
-
   DocParagraph doc -> do
     doc' <- renameDoc doc
     return (DocParagraph doc')
-
   DocIdentifier ids -> do
     lkp <- getLookupRn
     case [ n | (True, n) <- map lkp ids ] of
       ids'@(_:_) -> return (DocIdentifier ids')
       [] -> return (DocIdentifier (map Link ids))
-
   DocModule str -> return (DocModule str)
-
   DocEmphasis doc -> do
     doc' <- renameDoc doc
     return (DocEmphasis doc')
-
   DocMonospaced doc -> do
     doc' <- renameDoc doc
     return (DocMonospaced doc')
-
   DocUnorderedList docs -> do
     docs' <- mapM renameDoc docs
     return (DocUnorderedList docs')
-
   DocOrderedList docs -> do
     docs' <- mapM renameDoc docs
     return (DocOrderedList docs')
-
--- -----------------------------------------------------------------------------
--- Renaming source code & documentation
-{-
-
-renameDecl :: HsDecl -> RnM HsDecl
-renameDecl decl
-  = case decl of
-	HsTypeDecl loc t args ty0 doc0 -> do
-	    ty <- renameType ty0
-	    doc <- renameMaybeDoc doc0
-	    return (HsTypeDecl loc t args ty doc)
-	HsDataDecl loc ctx0 t args cons0 drv0 doc0 -> do
-	    ctx <- renameContext ctx0
-	    cons <- mapM renameConDecl cons0
-	    drv <- mapM (lookupRn id) drv0
-	    doc <- renameMaybeDoc doc0
-	    return (HsDataDecl loc ctx t args cons drv doc)
-        HsNewTypeDecl loc ctx0 t args con0 drv0 doc0 -> do
-	    ctx <- renameContext ctx0
-	    con <- renameConDecl con0
-	    drv <- mapM (lookupRn id) drv0
-	    doc <- renameMaybeDoc doc0
-	    return (HsNewTypeDecl loc ctx t args con drv doc)
-        HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do
-	    ctxt <- renameContext ctxt0
-	    decls <- mapM renameDecl decls0
-	    doc <- renameMaybeDoc doc0
-	    return (HsClassDecl loc ctxt nm tvs fds decls doc)
-	HsTypeSig loc fs qt0 doc0 -> do
-	    qt <- renameType qt0
-	    doc <- renameMaybeDoc doc0
-	    return (HsTypeSig loc fs qt doc)
-	HsForeignImport loc cc safe ent n ty0 doc0 -> do
-	    ty <- renameType ty0
-	    doc <- renameMaybeDoc doc0
-	    return (HsForeignImport loc cc safe ent n ty doc)
-	HsInstDecl loc ctxt0 asst0 decls -> do
-	    ctxt <- renameContext ctxt0
-	    asst <- renamePred asst0
-	    return (HsInstDecl loc ctxt asst decls)
-	HsDocCommentNamed loc name doc0 -> do
-	    doc <- renameDoc doc0
-	    return (HsDocCommentNamed loc name doc)
-	_ -> 
-	    return decl
-
-renameConDecl :: HsConDecl -> RnM HsConDecl
-renameConDecl (HsConDecl loc nm tvs ctxt tys0 doc0) = do
-  tys <- mapM renameBangTy tys0
-  doc <- renameMaybeDoc doc0
-  return (HsConDecl loc nm tvs ctxt tys doc)
-renameConDecl (HsRecDecl loc nm tvs ctxt fields0 doc0) = do
-  fields <- mapM renameField fields0
-  doc <- renameMaybeDoc doc0
-  return (HsRecDecl loc nm tvs ctxt fields doc)
-
-renameField :: HsFieldDecl -> RnM HsFieldDecl
-renameField (HsFieldDecl ns ty0 doc0) = do 
-  ty <- renameBangTy ty0
-  doc <- renameMaybeDoc doc0
-  return (HsFieldDecl ns ty doc)
-
-renameBangTy :: HsBangType -> RnM HsBangType
-renameBangTy (HsBangedTy ty)   = HsBangedTy   `liftM` renameType ty
-renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
-
-renameContext :: HsContext -> RnM HsContext
-renameContext = mapM renamePred
-
-renameIPContext :: HsIPContext -> RnM HsIPContext
-renameIPContext cs = mapM renameCtxt cs
- where
-   renameCtxt (HsIP n t)   = liftM (HsIP n) (renameType t)
-   renameCtxt (HsAssump c) = liftM HsAssump (renamePred c)
-
-renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType])
-renamePred (c,tys0) = do
-  tys <- mapM renameType tys0
-  lookupRn (\c' -> (c',tys)) c
-
-renameType :: HsType -> RnM HsType
-renameType (HsForAllType tvs ctx0 ty0) = do
-  ctx <- renameIPContext ctx0
-  ty <- renameType ty0
-  return (HsForAllType tvs ctx ty)
-renameType (HsTyFun arg0 res0) = do
-  arg <- renameType arg0
-  res <- renameType res0
-  return (HsTyFun arg res)
-renameType (HsTyIP n ty0) = do
-  ty <- renameType ty0
-  return (HsTyIP n ty0)
-renameType (HsTyTuple b tys0) = do
-  tys <- mapM renameType tys0
-  return (HsTyTuple b tys)
-renameType (HsTyApp ty0 arg0) = do
-  ty <- renameType ty0
-  arg <- renameType arg0
-  return (HsTyApp ty arg)
-renameType (HsTyVar nm) =
-  return (HsTyVar nm)
-renameType (HsTyCon nm) =
-  lookupRn HsTyCon nm
-renameType (HsTyDoc ty0 doc0) = do
-  ty <- renameType ty0
-  doc <- renameDoc doc0
-  return (HsTyDoc ty doc)
-
-renameInstHead :: InstHead -> RnM InstHead
-renameInstHead (ctx,asst) = do
-  ctx <- renameContext ctx
-  asst <- renamePred asst
-  return (ctx,asst)
-
--- -----------------------------------------------------------------------------
-
-renameExportItems :: [ExportItem] -> RnM [ExportItem]
-renameExportItems items = mapM rn items
+  DocDefList docs -> do
+    docs' <- mapM (\(a,b) -> do
+      a' <- renameDoc a
+      b' <- renameDoc b
+      return (a',b')) docs
+    return (DocDefList docs')  
+  DocCodeBlock doc -> do
+    doc' <- renameDoc doc
+    return (DocCodeBlock doc')
+  DocURL str -> return (DocURL str) 
+  DocAName str -> return (DocAName str)
+
+rename = lookupRn id 
+renameL (L loc name) = return . L loc =<< rename name
+
+renameLPred (L loc p) = return . L loc =<< renamePred p
+
+renamePred :: HsPred Name -> RnM (HsPred DocName)
+renamePred (HsClassP name types) = do
+  name' <- rename name 
+  types' <- mapM renameLType types
+  return (HsClassP name' types')
+renamePred (HsIParam (Dupable name) t) = do
+  name' <- rename name
+  t' <- renameLType t
+  return (HsIParam (Dupable name') t')
+renamePred (HsIParam (Linear name) t) = do
+  name' <- rename name
+  t' <- renameLType t
+  return (HsIParam (Linear name') t')
+
+renameLType (L loc t) = return . L loc =<< renameType t
+
+renameType t = case t of 
+  HsForAllTy expl tyvars lcontext ltype -> do
+    tyvars' <- mapM renameLTyVarBndr tyvars
+    lcontext' <- renameLContext lcontext 
+    ltype' <- renameLType ltype
+    return (HsForAllTy expl tyvars' lcontext' ltype')
+
+  HsTyVar n -> return . HsTyVar =<< rename n
+  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+  
+  HsAppTy a b -> do
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsAppTy a' b')
+
+  HsFunTy a b -> do     
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsFunTy a' b')
+
+  HsListTy t -> return . HsListTy =<< renameLType t
+  HsPArrTy t -> return . HsPArrTy =<< renameLType t
+
+  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+  HsOpTy a (L loc op) b -> do
+    op' <- rename op
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsOpTy a' (L loc op') b')
+
+  HsParTy t -> return . HsParTy =<< renameLType t
+
+  HsNumTy n -> return (HsNumTy n)
+
+  HsPredTy p -> return . HsPredTy =<< renamePred p
+
+  HsKindSig t k -> do
+    t' <- renameLType t
+    return (HsKindSig t' k)
+
+  HsDocTy t doc -> do
+    t' <- renameLType t
+    doc' <- renameLDoc doc
+    return (HsDocTy t' doc')
+
+  _ -> error "renameType"
+ 
+renameLTyVarBndr (L loc tv) = do
+  name' <- rename (hsTyVarName tv)
+  return $ L loc (replaceTyVarName tv name')
+    
+renameLContext (L loc context) = do
+  context' <- mapM renameLPred context
+  return (L loc context')
+
+renameInstHead :: InstHead2 Name -> RnM (InstHead2 DocName)
+renameInstHead (preds, className, types) = do
+  preds' <- mapM renamePred preds
+  className' <- rename className
+  types' <- mapM renameType types
+  return (preds', className', types')
+
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+renameDecl d = case d of
+  TyClD d doc -> do
+    d' <- renameTyClD d
+    doc' <- renameMaybeDoc doc
+    return (TyClD d' doc')
+  SigD s doc -> do
+    s' <- renameSig s
+    doc' <- renameMaybeDoc doc
+    return (SigD s' doc')
+  ForD d doc -> do
+    d' <- renameForD d
+    doc' <- renameMaybeDoc doc
+    return (ForD d' doc')
+  _ -> error "renameDecl"
+
+renameTyClD d = case d of
+  ForeignType name a b -> do
+    name' <- renameL name
+    return (ForeignType name' a b)
+
+  TyData x lcontext lname ltyvars k cons _ -> do
+    lcontext' <- renameLContext lcontext
+    lname' <- renameL lname
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    cons' <- mapM renameLCon cons
+    -- we don't need the derivings
+    return (TyData x lcontext' lname' ltyvars' k cons' Nothing) 
+ 
+  TySynonym lname ltyvars ltype -> do
+    lname' <- renameL lname
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    ltype' <- renameLType ltype
+    return (TySynonym lname' ltyvars' ltype')
+
+  ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ -> do
+    lcontext' <- renameLContext lcontext
+    lname' <- renameL lname
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    lfundeps' <- mapM renameLFunDep lfundeps 
+    lsigs' <- mapM renameLSig lsigs
+    -- we don't need the default methods or the already collected doc entities
+    return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag [])
+ 
+  where
+    renameLCon (L loc con) = return . L loc =<< renameCon con
+    renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do
+      lname' <- renameL lname 
+      ltyvars' <- mapM renameLTyVarBndr ltyvars
+      lcontext' <- renameLContext lcontext
+      details' <- renameDetails details
+      restype' <- renameResType restype
+      mbldoc' <- mapM renameLDoc mbldoc
+      return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') 
+
+    renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+    renameDetails (InfixCon a b) = do
+      a' <- renameLType a
+      b' <- renameLType b
+      return (InfixCon a' b')
+  
+    renameField (HsRecField id arg doc) = do
+      id' <- renameL id
+      arg' <- renameLType arg
+      doc' <- mapM renameLDoc doc 
+      return (HsRecField id' arg' doc')
+
+    renameResType (ResTyH98) = return ResTyH98
+    renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+    renameLFunDep (L loc (xs, ys)) = do
+      xs' <- mapM rename xs
+      ys' <- mapM rename ys
+      return (L loc (xs', ys'))
+   
+    renameLSig (L loc sig) = return . L loc =<< renameSig sig
+      
+renameSig sig = case sig of 
+  TypeSig lname ltype -> do 
+    lname' <- renameL lname
+    ltype' <- renameLType ltype
+    return (TypeSig lname' ltype')
+  SpecSig lname ltype x -> do
+    lname' <- renameL lname
+    ltype' <- renameLType ltype
+    return (SpecSig lname' ltype' x)
+  InlineSig lname x -> do
+    lname' <- renameL lname
+    return (InlineSig lname' x)   
+  SpecInstSig t -> return . SpecInstSig =<< renameLType t
+  FixSig fsig -> return . FixSig =<< renameFixitySig fsig
   where
-	rn (ExportModule mod0)
-	   = return (ExportModule mod0)
- 	rn (ExportGroup lev id0 doc0) 
-	   = do doc <- renameDoc doc0
-	        return (ExportGroup lev id0 doc)
-	rn (ExportDecl x decl0 insts) -- x is an original name, don't rename it
-	   = do decl <- renameDecl decl0
-		insts <- mapM renameInstHead insts
-		return (ExportDecl x decl insts)
-	rn (ExportNoDecl x y subs)
-	   = do y' <- lookupRn id y
-	        subs' <- mapM (lookupRn id) subs
-		return (ExportNoDecl x y' subs')
-	rn (ExportDoc doc0)
-	   = do doc <- renameDoc doc0
-		return (ExportDoc doc)
--}
-
-renameInstHead = undefined
-
-
-renameDecl = undefined
+    renameFixitySig (FixitySig lname x) = do
+      lname' <- renameL lname
+      return (FixitySig lname' x)
+
+renameForD (ForeignImport lname ltype x y) = do
+  lname' <- renameL lname
+  ltype' <- renameLType ltype
+  return (ForeignImport lname' ltype' x y)
+renameForD (ForeignExport lname ltype x y) = do
+  lname' <- renameL lname
+  ltype' <- renameLType ltype
+  return (ForeignExport lname' ltype' x y)
 
 renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName)
 renameExportItem item = case item of 
@@ -267,7 +325,7 @@ renameExportItem item = case item of
     doc' <- renameDoc doc
     return (ExportGroup2 lev id doc')
   ExportDecl2 x decl doc instances -> do
-    decl' <- renameDecl decl
+    decl' <- renameLDecl decl
     doc' <- mapM renameDoc doc
     instances' <- mapM renameInstHead instances
     return (ExportDecl2 x decl' doc' instances')
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index b4cb6921..cd9d4fff 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -114,7 +114,7 @@ data ExportItem2 name
         GHC.Name	      -- the original name
 	(GHC.LHsDecl name) -- a declaration
         (Maybe (GHC.HsDoc name))       -- maybe a doc comment
-	[InstHead2]	      -- instances relevant to this declaration
+	[InstHead2 name]	      -- instances relevant to this declaration
 
   | ExportNoDecl2	-- an exported entity for which we have no documentation
 			-- (perhaps becuase it resides in another package)
@@ -135,7 +135,7 @@ data ExportItem2 name
 
 type InstHead = (HsContext,HsAsst)
 
-type InstHead2 = ([GHC.TyVar], [GHC.PredType], GHC.Class, [GHC.Type])
+type InstHead2 name = ([GHC.HsPred name], name, [GHC.HsType name])
 
 type ModuleMap = Map Module Interface
 type ModuleMap2 = Map GHC.Module HaddockModule
diff --git a/src/Main.hs b/src/Main.hs
index 13c1b129..ac33796d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,7 +25,7 @@ import Control.Monad ( when )
 import Control.Monad.Writer ( Writer, runWriter, tell )
 import Data.Char ( isSpace )
 import Data.IORef ( writeIORef )
-import Data.List ( nub, (\\), foldl', sortBy )
+import Data.List ( nub, (\\), foldl', sortBy, foldl1 )
 import Data.Maybe ( isJust, isNothing, maybeToList, listToMaybe )
 --import Debug.Trace
 import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) )
@@ -335,7 +335,7 @@ run flags files = do
 
   let haddockModules' = attachInstances haddockModules
 
-  let renamedModules = runWriter $ mapM (renameModule env) haddockModules'
+  let (renamedModules, messages') = runWriter $ mapM (renameModule env) haddockModules'
 
   putStrLn "pass 1 messages:"
   print messages
@@ -347,6 +347,7 @@ run flags files = do
 
   putStrLn "pass 2 export items:"
   printSDoc (ppr renamedModules) defaultUserStyle 
+  mapM_ putStrLn messages'
  
   --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules)
   --printSDoc (ppr group) defaultUserStyle
@@ -830,15 +831,17 @@ renameModule renamingEnv mod =
       (finalModuleDoc, missingNames2)
         = runRnFM localEnv (renameMaybeDoc (hmod_doc mod))
 
-      missingNames = map (showSDoc . ppr) (nub (missingNames1 ++ missingNames2))
+      missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2)
+      strings = map (showSDoc . ppr) missingNames 
+     
   in do
 	-- report things that we couldn't link to.  Only do this
 	-- for non-hidden modules.
    when (OptHide `notElem` hmod_options mod &&
-	 not (null missingNames)) $
+	 not (null strings)) $
 	  tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ 
 		": could not find link destinations for:\n"++
-		"   " ++ concat (map (' ':) missingNames)
+		"   " ++ concat (map (' ':) strings)
 		]
 
    --  trace (show (Map.toAscList import_env)) $ do
@@ -1231,7 +1234,7 @@ data SimpleType = SimpleType GHC.Name [SimpleType] deriving (Eq,Ord)
 attachInstances :: [HaddockModule] -> [HaddockModule]
 attachInstances modules = map attach modules
   where
-    instMap = fmap (sortImage instHead) $ collectInstances modules
+    instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
     attach mod = mod { hmod_export_items = newItems }
       where
         newItems = map attachExport (hmod_export_items mod)
@@ -1244,7 +1247,7 @@ attachInstances modules = map attach modules
 
 collectInstances
    :: [HaddockModule]
-   -> Map GHC.Name [InstHead2]  -- maps class/type names to instances
+   -> Map GHC.Name [([GHC.TyVar], [GHC.PredType], Class, [Type])]  -- maps class/type names to instances
 
 collectInstances modules
   = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
@@ -1256,7 +1259,7 @@ collectInstances modules
     tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, 
                     Just tycon <- nub (is_tcs inst) ]
 
-instHead :: InstHead2  -> ([Int], GHC.Name, [SimpleType])
+instHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> ([Int], GHC.Name, [SimpleType])
 instHead (_, _, cls, args)
   = (map argCount args, className cls, map simplify args)
   where
@@ -1289,6 +1292,35 @@ funTyConName = mkWiredInName gHC_PRIM
                         (ATyCon funTyCon)       -- Relevant TyCon
                         BuiltInSyntax
 
+toHsInstHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> InstHead2 GHC.Name
+toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) 
+
+toHsPred :: PredType -> GHC.HsPred GHC.Name 
+toHsPred (ClassP cls ts) = GHC.HsClassP (className cls) (map toLHsType ts)
+toHsPred (IParam n t) = GHC.HsIParam n (toLHsType t)
+
+toLHsType = noLoc . toHsType
+ 
+toHsType :: Type -> GHC.HsType GHC.Name
+toHsType t = case t of 
+  TyVarTy v -> GHC.HsTyVar (tyVarName v) 
+  AppTy a b -> GHC.HsAppTy (toLHsType a) (toLHsType b)
+  TyConApp tc ts -> case ts of 
+    [] -> GHC.HsTyVar (tyConName tc)
+    _  -> GHC.HsAppTy (tycon tc) (args ts)
+  FunTy a b -> GHC.HsFunTy (toLHsType a) (toLHsType b) 
+  ForAllTy v t -> cvForAll [v] t 
+  PredTy p -> GHC.HsPredTy (toHsPred p) 
+  NoteTy _ t -> toHsType t
+  where
+
+    tycon tc = noLoc (GHC.HsTyVar (tyConName tc))
+    args ts = foldl1 (\a b -> noLoc $ GHC.HsAppTy a b) (map toLHsType ts)
+    
+    cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t
+    cvForAll vs t = GHC.mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)
+    tyvarbinders vs = map (noLoc . GHC.UserTyVar . tyVarName) vs
+
 -- -----------------------------------------------------------------------------
 -- A monad which collects error messages