- let ids_ = [id | Just (AnId id) <- mbThings]
-
- -- Clean up 'Unknown' types artificially injected into tyvars
- ids = map (stripUnknowns newvarsNames) ids_
-
- -- Obtain the terms
- mb_terms <- io$ mapM (obtainTerm cms force) ids
-
- -- Give names to suspensions and bind them in the local env
- mb_terms' <- if bindThings
- then io$ mapM (fmapMMaybe (bindSuspensions cms)) mb_terms
- else return mb_terms
- ppr_terms <- io$ mapM (fmapMMaybe (printTerm cms)) mb_terms'
- let docs = [ ppr id <+> char '=' <+> t | (Just t,id) <- zip ppr_terms ids]
- unqual <- io$ GHC.getPrintUnqual cms
- io . putStrLn . showSDocForUser unqual $ Outputable.vcat docs
-
- -- Type reconstruction may have obtained more defined types for some ids
- -- So we refresh their types.
- let new_ids0 = [ setIdType id ty | (id,Just t) <- zip ids mb_terms
- , let Just ty = termType t
- , ty `isMoreSpecificThan` idType id
- ]
- new_ids <- io$ mapM (\x->liftM (setIdType x) . instantiateTyVarsToUnknown cms . idType $ x)
- new_ids0
- let Session ref = cms
- hsc_env <- io$ readIORef ref
- let ictxt = hsc_IC hsc_env
- type_env = ic_type_env ictxt
- filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
- new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
- new_ic = ictxt {ic_type_env = new_type_env }
- io$ writeIORef ref (hsc_env {hsc_IC = new_ic })
-
- where
- isMoreSpecificThan :: Type -> Type -> Bool
- ty `isMoreSpecificThan ` ty1
+ mb_ids <- io$ mapM (cleanUp cms newvarsNames) (words str)
+ new_ids <- mapM (io . go cms) (catMaybes mb_ids)
+ io$ updateIds cms new_ids
+ where
+ -- Find the Id, clean up 'Unknowns'
+ cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
+ cleanUp cms newNames str = do
+ tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
+ return$ listToMaybe (map (stripUnknowns newNames)
+ [ i | Just (AnId i) <- tythings])
+
+ -- Do the obtainTerm--bindSuspensions-refineIdType dance
+ -- Warning! This function got a good deal of side-effects
+ go :: Session -> Id -> IO Id
+ go cms id = do
+ Just term <- obtainTerm cms force id
+ term' <- if not bindThings then return term
+ else bindSuspensions cms term
+ showterm <- pprTerm cms term'
+ unqual <- GHC.getPrintUnqual cms
+ (putStrLn . showSDocForUser unqual) (ppr id <+> char '=' <+> showterm)
+ -- Before leaving, we compare the type obtained to see if it's more specific
+ -- Note how we need the Unknown-clear type returned by obtainTerm
+ let Just reconstructedType = termType term
+ new_type <- instantiateTyVarsToUnknown cms
+ (mostSpecificType (idType id) reconstructedType)
+ return (setIdType id new_type)
+
+ updateIds :: Session -> [Id] -> IO ()
+ updateIds (Session ref) new_ids = do
+ hsc_env <- readIORef ref
+ let ictxt = hsc_IC hsc_env
+ type_env = ic_type_env ictxt
+ filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
+ new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
+ new_ic = ictxt {ic_type_env = new_type_env }
+ writeIORef ref (hsc_env {hsc_IC = new_ic })
+
+isMoreSpecificThan :: Type -> Type -> Bool
+ty `isMoreSpecificThan` ty1