import FastString
import Panic
-#ifndef GHCI_TABLES_NEXT_TO_CODE
import Constants ( wORD_SIZE )
-#endif
import GHC.Arr ( Array(..) )
import GHC.Exts
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 iptr'
+ | ghciTablesNextToCode =
+ Ptr iptr
+ | otherwise =
+ -- 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
+ -- !ghciTablesNextToCode, so we must adjust here:
+ Ptr iptr `plusPtr` negate wORD_SIZE
+ itbl <- peek iptr'
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
- | Just (tc,_) <- splitNewTyConApp_maybe ty
+ | Just (tc,_) <- tcSplitTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
- , Just new_dc <- maybeTyConSingleCon tc = do
+ , Just new_dc <- tyConSingleDataCon_maybe tc = do
real_term <- y max_prec t
return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
isTupleTy ty = fromMaybe False $ do
(tc,_) <- splitTyConApp_maybe ty
- return (tc `elem` (fst.unzip.elems) boxedTupleArr)
+ return (isBoxedTupleTyCon tc)
isTyCon a_tc ty = fromMaybe False $ do
(tc,_) <- splitTyConApp_maybe ty
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
subTermsP <- sequence $ drop extra_args
- -- ^^^ all extra arguments are pointed
+ -- \^^^ all extra arguments are pointed
[ appArr (go (pred bound) tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
expandNewtypes t@Term{ ty=ty, subTerms=tt }
- | Just (tc, args) <- splitNewTyConApp_maybe ty
+ | Just (tc, args) <- tcSplitTyConApp_maybe ty
, isNewTyCon tc
, wrapped_type <- newTyConInstRhs tc args
- , Just dc <- maybeTyConSingleCon tc
+ , Just dc <- tyConSingleDataCon_maybe tc
, t' <- expandNewtypes t{ ty = wrapped_type
, subTerms = map expandNewtypes tt }
= NewtypeWrap ty (Right dc) t'
(l1',r1') <- congruenceNewtypes l1 r1
return (mkFunTy l1' l2', mkFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
- | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
- , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
+ | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
+ , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
, tycon_l /= tycon_r
= do rhs' <- upgrade tycon_l rhs
return (lhs, rhs')
-- Is this defined elsewhere?
-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
sigmaType :: Type -> Type
-sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
+sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType (dropForAlls ty)) [] ty