-import TcRnMonad ( TcM, initTc, initTcPrintErrors, ioToTcRn,
+import TcRnMonad ( TcM, initTc, ioToTcRn,
-cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
+cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
+cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
- Nothing -> go tv tv hval >>= zonkTerm
- Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
+ Nothing -> go bound tv tv hval >>= zonkTerm
+ Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
let monomorphic = not(isTyVarTy tv)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
let monomorphic = not(isTyVarTy tv)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
-- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
-- force blackholes, because it would almost certainly result in deadlock,
-- and showing the '_' is more useful.
-- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
-- force blackholes, because it would almost certainly result in deadlock,
-- and showing the '_' is more useful.
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
(newVar (liftedTypeKind))
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
(newVar (liftedTypeKind))
| (i, tv) <- zip [0..] vars]
return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
| (i, tv) <- zip [0..] vars]
return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
addConstraint myType signatureType
subTermsP <- sequence $ drop extra_args
-- ^^^ all extra arguments are pointed
addConstraint myType signatureType
subTermsP <- sequence $ drop extra_args
-- ^^^ all extra arguments are pointed
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
(drop extra_args subTtypes)
return (Term tv (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
-- assumption: ^^^ looks through newtypes
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
-- assumption: ^^^ looks through newtypes
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i