-----------------------------------------------------------------------------
--- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
-----------------------------------------------------------------------------
-instantiateTyVarsToUnknown :: Session -> Type -> IO Type
-instantiateTyVarsToUnknown cms ty
--- We have a GADT, so just fix its tyvars
- | Just (tycon, args) <- splitTyConApp_maybe ty
- , tycon /= funTyCon
- , isGADT tycon
- = mapM fixTyVars args >>= return . mkTyConApp tycon
--- We have a regular TyCon, so map recursively to its args
- | Just (tycon, args) <- splitTyConApp_maybe ty
- , tycon /= funTyCon
- = do unknownTyVar <- unknownTV
- args' <- mapM (instantiateTyVarsToUnknown cms) args
- return$ mkTyConApp tycon args'
--- we have a tyvar of kind *
- | Just tyvar <- getTyVar_maybe ty
- , ([],_) <- splitKindFunTys (tyVarKind tyvar)
- = unknownTV
--- we have a higher kind tyvar, so insert an unknown of the appropriate kind
- | Just tyvar <- getTyVar_maybe ty
- , (args,_) <- splitKindFunTys (tyVarKind tyvar)
- = liftM mkTyConTy $ unknownTC !! length args
--- Base case
- | otherwise = return ty
-
- where unknownTV = do
- Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
- return$ mkTyConTy unknown_tc
- unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
- unknownTC1 = do
- Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
- return unknown_tc
- unknownTC2 = do
- Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
- return unknown_tc
- unknownTC3 = do
- Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
- return unknown_tc
--- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
- isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
- | otherwise = False
- fixTyVars ty
- | Just (tycon, args) <- splitTyConApp_maybe ty
- = mapM fixTyVars args >>= return . mkTyConApp tycon
--- Fix the tyvar so that the interactive environment doesn't choke on it TODO
- | Just tv <- getTyVar_maybe ty = return ty --TODO
- | otherwise = return ty
-
--- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
-stripUnknowns :: [Name] -> Id -> Id
-stripUnknowns names id = setIdType id . fst . go names . idType
- $ id
- where
- go tyvarsNames@(v:vv) ty
- | Just (ty1,ty2) <- splitFunTy_maybe ty = let
- (ty1',vv') = go tyvarsNames ty1
- (ty2',vv'')= go vv' ty2
- in (mkFunTy ty1' ty2', vv'')
- | Just (ty1,ty2) <- splitAppTy_maybe ty = let
- (ty1',vv') = go tyvarsNames ty1
- (ty2',vv'')= go vv' ty2
- in (mkAppTy ty1' ty2', vv'')
- | Just (tycon, args) <- splitTyConApp_maybe ty
- , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
- , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
- in (arg':aa,vv'))
- ([],vv') args
- = (mkAppTys tycon' args',vv'')
- | Just (tycon, args) <- splitTyConApp_maybe ty
- , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
- in (arg':aa,vv'))
- ([],tyvarsNames) args
- = (mkTyConApp tycon args',vv')
- | otherwise = (ty, tyvarsNames)
- where fixTycon tycon (v:vv) = do
- k <- lookup (tyConName tycon) kinds
- return (mkTyVarTy$ mkTyVar v k, vv)
- kinds = [ (unknownTyConName, liftedTypeKind)
- , (unknown1TyConName, kind1)
- , (unknown2TyConName, kind2)
- , (unknown3TyConName, kind3)]
- kind1 = mkArrowKind liftedTypeKind liftedTypeKind
- kind2 = mkArrowKind kind1 liftedTypeKind
- kind3 = mkArrowKind kind2 liftedTypeKind