- substs <- catMaybes `liftM` mapM (io . go cms)
- [id | AnId id <- tythings]
- mapM (io . applySubstToEnv cms) substs
- return ()
- where
-
- -- Do the obtainTerm--bindSuspensions-refineIdType dance
- -- Warning! This function got a good deal of side-effects
- go :: Session -> Id -> IO (Maybe TvSubst)
- go cms id = do
- mb_term <- obtainTerm cms force id
- maybe (return Nothing) `flip` mb_term $ \term -> do
- term' <- if not bindThings then return term
- else bindSuspensions cms term
- showterm <- printTerm cms term'
- unqual <- GHC.getPrintUnqual cms
- let showSDocForUserOneLine unqual doc =
- showDocWith LeftMode (doc (mkErrStyle unqual))
- (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+ let ids = [id | AnId id <- tythings]
+
+ -- Obtain the terms and the recovered type information
+ (terms, substs0) <- unzip `liftM` mapM go ids
+
+ -- Apply the substitutions obtained after recovering the types
+ modifySession $ \hsc_env ->
+ let (substs, skol_vars) = unzip$ map skolemiseSubst substs0
+ hsc_ic' = foldr (flip substInteractiveContext)
+ (extendInteractiveContext (hsc_IC hsc_env) [] (unionVarSets skol_vars))
+ substs
+ in hsc_env{hsc_IC = hsc_ic'}
+ -- Finally, print the Terms
+ unqual <- GHC.getPrintUnqual
+ docterms <- mapM showTerm terms
+ liftIO $ (printForUser stdout unqual . vcat)
+ (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
+ ids
+ docterms)
+ where
+ -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
+ go :: GhcMonad m => Id -> m (Term, TvSubst)
+ go id = do
+ term_ <- GHC.obtainTermFromId maxBound force id
+ term <- tidyTermTyVars term_
+ term' <- if bindThings &&
+ False == isUnliftedTypeKind (termType term)
+ then bindSuspensions term
+ else return term