import DataCon
import Type
-import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM
- , writeMutVar )
+import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM)
import TcType
import TcMType
import TcUnify
import TcGadt
+import TcEnv
import TyCon
import Var
import Name
, bound_to :: Maybe Name -- Useful for printing
}
+isTerm, isSuspension, isPrim :: Term -> Bool
isTerm Term{} = True
isTerm _ = False
isSuspension Suspension{} = True
isPrim Prim{} = True
isPrim _ = False
+termType :: Term -> Maybe Type
termType t@(Suspension {}) = mb_ty t
termType t = Just$ ty t
itbl <- peek (Ptr iptr)
let tipe = readCType (BCI.tipe itbl)
elems = BCI.ptrs itbl
- ptrsList = Array 0 (fromIntegral$ elems) ptrs
+ ptrsList = Array 0 ((fromIntegral elems) - 1) ptrs
nptrs_data = [W# (indexWordArray# nptrs i)
| I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+ ASSERT(fromIntegral elems >= 0) return ()
ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
| fromIntegral i == pAP_CODE = PAP
| otherwise = Other (fromIntegral i)
-isConstr, isIndirection :: ClosureType -> Bool
+isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
fSuspension = (((return.).).). Suspension
}
+mapTermType :: (Type -> Type) -> Term -> Term
mapTermType f = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (fmap f mb_ty) hval n }
+termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
cPprTerm :: forall m. Monad m =>
((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
cPprTerm custom = go 0 where
- go prec t@Term{subTerms=tt, dc=dc} = do
+ go prec t@Term{} = do
let default_ prec t = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
Just doc <- firstJustM mb_customDocs
trIO :: IO a -> TR a
trIO = liftTcM . ioToTcRn
+liftTcM :: TcM a -> TR a
liftTcM = id
newVar :: Kind -> TR TcTyVar
matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
- , null (dataConExTyVars dc) --TODO case of extra existential tyvars
+ , isVanillaDataCon dc --TODO non-vanilla case
= dataConInstArgTys dc ty_args
-- assumes that newtypes are looked ^^^ through
| otherwise = dataConRepArgTys dc
-- Fast, breadth-first Type reconstruction
-
+max_depth = 10 :: Int
cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
tv <- liftM mkTyVarTy (newVar argTypeKind)
case mb_ty of
- Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
- (uncurry go)
- [(tv, hval)]
+ Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
+ (uncurry go)
+ [(tv, hval)]
+ max_depth
zonkTcType tv -- TODO untested!
Just ty | isMonomorphic ty -> return ty
Just ty -> do
search (isMonomorphic `fmap` zonkTcType tv)
(uncurry go)
[(tv, hval)]
+ max_depth
substTy rev_subst `fmap` zonkTcType tv
where
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
- search stop expand [] = return ()
- search stop expand (x:xx) = do new <- expand x
- unlessM stop $ search stop expand (xx ++ new)
+ search stop expand [] depth = return ()
+ search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
+ show max_depth ++ " steps"
+ search stop expand (x:xx) d = do
+ new <- expand x
+ unlessM stop $ search stop expand (xx ++ new) $! (pred d)
-- returns unification tasks,since we are going to want a breadth-first search
go :: Type -> HValue -> TR [(Type, HValue)]
let myType = mkFunTys subTtypes tv
(signatureType,_) <- instScheme(dataConRepType dc)
addConstraint myType signatureType
- return $ map (\(I# i#,t) -> case ptrs clos of
- (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
- (# e #) -> (t,e))
- (drop extra_args $ zip [0..] subTtypes)
+ return $ [ appArr (\e->(t,e)) (ptrs clos) i
+ | (i,t) <- drop extra_args $ zip [0..] subTtypes]
otherwise -> return []