diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 48 |
1 files changed, 40 insertions, 8 deletions
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 |