import HscTypes ( HscEnv )
import Linker
-import DataCon
-import Type
-import TcRnMonad ( TcM, initTc, ioToTcRn,
- tryTcErrs)
+import DataCon
+import Type
+import Var
+import TcRnMonad ( TcM, initTc, ioToTcRn,
+ tryTcErrs, traceTc)
import TcType
import TcMType
import TcUnify
import TcGadt
import TcEnv
import DriverPhases
-import TyCon
-import Name
+import TyCon
+import Name
import VarEnv
import Util
import VarSet
-import TysPrim
+import TysPrim
import PrelNames
import TysWiredIn
getClosureData a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+ -- the info pointer we get back from unpackClosure# is to the
+ -- beginning of the standard info table, but the Storable instance
+ -- for info tables takes into account the extra entry pointer
+ -- when !tablesNextToCode, so we must adjust here:
+ itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
+#else
itbl <- peek (Ptr iptr)
+#endif
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
(Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
- return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
+ return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> fsep tt_docs)
pprTermM y p Term{dc=Right dc, subTerms=tt}
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
| null tt = return$ ppr dc
| otherwise = do
tt_docs <- mapM (y app_prec) tt
- return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
+ return$ cparen (p >= app_prec) (ppr dc <+> fsep tt_docs)
pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
print_elems <- mapM (y cons_prec) elems
return$ if isConsLast
then cparen (p >= cons_prec)
- . hsep
+ . fsep
. punctuate (space<>colon)
$ print_elems
- else brackets (hcat$ punctuate comma print_elems)
+ else brackets (fsep$ punctuate comma print_elems)
where Just a /= Just b = not (a `coreEqType` b)
_ /= _ = True
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceTc
+
trIO :: IO a -> TR a
trIO = liftTcM . ioToTcRn
-- and showing the '_' is more useful.
t | isThunk t && force -> seq a $ go (pred bound) tv ty a
-- We always follow indirections
- Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
+ Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
-- The interesting case
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
| isPointed ty = ASSERT2(not(null pointed)
, ptext SLIT("reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
- head pointed : reOrderTerms (tail pointed) unpointed tys
+ let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
| otherwise = ASSERT2(not(null unpointed)
, ptext SLIT("reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
- head unpointed : reOrderTerms pointed (tail unpointed) tys
+ let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
expandNewtypes t@Term{ ty=ty, subTerms=tt }
| Just (tc, args) <- splitNewTyConApp_maybe ty
substTy rev_subst `fmap` zonkTcType tv
where
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
- search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
- show max_depth ++ " steps"
+ search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+ int max_depth <> text " steps")
search stop expand l d =
case viewl l of
EmptyL -> return ()
-- improved rtti_t computed by RTTI
-- The main difference between RTTI types and their normal counterparts
-- is that the former are _not_ polymorphic, thus polymorphism must
- -- be stripped. Syntactically, forall's must be stripped
-computeRTTIsubst :: Type -> Type -> Maybe TvSubst
+ -- be stripped. Syntactically, forall's must be stripped.
+ -- We also remove predicates.
+computeRTTIsubst :: Type -> Type -> TvSubst
computeRTTIsubst ty rtti_ty =
+ case mb_subst of
+ Just subst -> subst
+ Nothing -> pprPanic "Failed to compute a RTTI substitution"
+ (ppr (ty, rtti_ty))
-- In addition, we strip newtypes too, since the reconstructed type might
-- not have recovered them all
- tcUnifyTys (const BindMe)
- [repType' $ dropForAlls$ ty]
- [repType' $ rtti_ty]
--- TODO stripping newtypes shouldn't be necessary, test
-
+ -- TODO stripping newtypes shouldn't be necessary, test
+ where mb_subst = tcUnifyTys (const BindMe)
+ [rttiView ty]
+ [rttiView rtti_ty]
-- Dealing with newtypes
{-
Note that it is very tricky to make this 'rewriting'
work with the unification implemented by TcM, where
substitutions are 'inlined'. The order in which
- constraints are unified is vital for this (or I am
- using TcM wrongly).
+ constraints are unified is vital for this.
+ This is a simple form of residuation, the technique of
+ delaying unification steps until enough information
+ is available.
-}
-congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
+congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes lhs rhs
-- TyVar lhs inductive case
| Just tv <- getTyVar_maybe lhs
| Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
, Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
, tycon_l /= tycon_r
- = return (lhs, upgrade tycon_l rhs)
+ = do rhs' <- upgrade tycon_l rhs
+ return (lhs, rhs')
| otherwise = return (lhs,rhs)
- where upgrade :: TyCon -> Type -> Type
+ where upgrade :: TyCon -> Type -> TR Type
upgrade new_tycon ty
- | not (isNewTyCon new_tycon) = ty
- | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
- , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
- = substTy subst ty'
- upgrade _ _ = panic "congruenceNewtypes.upgrade"
- -- assumes that reptype doesn't touch tyconApp args ^^^
+ | not (isNewTyCon new_tycon) = return ty
+ | otherwise = do
+ vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+ let ty' = mkTyConApp new_tycon vars
+ liftTcM (unifyType ty (repType ty'))
+ -- assumes that reptype doesn't ^^^^ touch tyconApp args
+ return ty'
--------------------------------------------------------------------------------