import Name
import VarEnv
import Util
+import ListSetOps
import VarSet
import TysPrim
import PrelNames
-- do its magic.
addConstraint :: TcType -> TcType -> TR ()
addConstraint actual expected = do
- traceTR $ fsep [text "add constraint:", ppr actual, equals, ppr expected]
+ traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
text "with", ppr expected])
(congruenceNewtypes actual expected >>=
_ -> return ty)
zterm
zonkTerm zterm'
- traceTR (text "Term reconstruction completed. Term obtained: " <> ppr term)
+ traceTR (text "Term reconstruction completed." $$
+ text "Term obtained: " <> ppr term $$
+ text "Type obtained: " <> ppr (termType term))
return term
where
go :: Int -> Type -> Type -> HValue -> TcM Term
go max_depth _ _ _ | seq max_depth False = undefined
go 0 my_ty _old_ty a = do
+ traceTR (text "Gave up reconstructing a term after" <>
+ int max_depth <> text " steps")
clos <- trIO $ getClosureData a
return (Suspension (tipe clos) my_ty a Nothing)
- go max_depth my_ty old_ty a = do
+ go max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
-- The interesting case
Constr -> do
- traceTR (text "entering a constructor")
+ traceTR (text "entering a constructor " <>
+ if monomorphic
+ then parens (text "already monomorphic: " <> ppr my_ty)
+ else Outputable.empty)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
let subTtypes = matchSubTypes dc old_ty
- (subTtypesP, subTtypesNP) = partition (isLifted |.| isRefType) subTtypes
subTermTvs <- mapMif (not . isMonomorphic)
(\t -> newVar (typeKind t))
subTtypes
- -- It is vital for newtype reconstruction that the unification step
- -- is done right here, _before_ the subterms are RTTI reconstructed
+ let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
+ || isRefType ty)
+ (zip subTtypes subTermTvs)
+ (subTtypesP, subTermTvsP ) = unzip subTermsP
+ (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
+
+ -- When we already have all the information, avoid solving
+ -- unnecessary constraints. Propagation of type information
+ -- to subterms is already being done via matching.
when (not monomorphic) $ do
-
- -- When we already have all the information, avoid solving
- -- unnecessary constraints. Propagation of type information
- -- to subterms is already being done via matching.
let myType = mkFunTys subTermTvs my_ty
- (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
+ (signatureType,_) <- instScheme (mydataConType dc)
+ -- It is vital for newtype reconstruction that the unification step
+ -- is done right here, _before_ the subterms are RTTI reconstructed
addConstraint myType signatureType
subTermsP <- sequence
[ appArr (go (pred max_depth) tv t) (ptrs clos) i
- | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
+ | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
- subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+ subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
subTerms = reOrderTerms subTermsP subTermsNP subTtypes
return (Term my_ty (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
(ppr pointed $$ ppr unpointed))
let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
| otherwise = ASSERT2(not(null unpointed)
- , ptext (sLit "Reorderterms") $$
+ , ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
-- It is vital for newtype reconstruction that the unification step
-- is done right here, _before_ the subterms are RTTI reconstructed
let myType = mkFunTys subTtypes my_ty
- (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
+ (signatureType,_) <- instScheme(mydataConType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i
| (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
-- In particular, we want them to unify with things.
improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
- traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
+ traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
| null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
| otherwise = dataConRepArgTys dc
+mydataConType :: DataCon -> Type
+-- ^ Custom version of DataCon.dataConUserType where we
+-- - remove the equality constraints
+-- - use the representation types for arguments, including dictionaries
+-- - keep the original result type
+mydataConType dc
+ = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
+ mkFunTys arg_tys $
+ res_ty
+ where univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+ eq_spec = dataConEqSpec dc
+ arg_tys = [case a of
+ PredTy p -> predTypeRep p
+ _ -> a
+ | a <- dataConRepArgTys dc]
+ res_ty = dataConOrigResTy dc
+
isRefType :: Type -> Bool
isRefType ty
| Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
2. To prevent the class of unsoundness shown by row 6,
the rtti type should be structurally more
defined than the old type we are comparing it to.
- check2 :: OldType -> NewTy pe -> Bool
+ check2 :: NewType -> OldType -> Bool
check2 a _ = True
check2 [a] a = True
check2 [a] (t Int) = False
}
--------------------------------------------------------------------------------
--- representation types for thetas
-rttiView :: Type -> Type
-rttiView ty | Just ty' <- coreView ty = rttiView ty'
-rttiView ty
- | (tvs, theta, tau) <- tcSplitSigmaTy ty
- = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
-
-- Restore Class predicates out of a representation type
dictsView :: Type -> Type
-- dictsView ty = ty
(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
-(f |.| g) x = f x || g x
\ No newline at end of file
+(f |.| g) x = f x || g x