mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat,
+ mkArbitraryType, -- Put this elsewhere?
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
import TcRnMonad
import Type
import TcType
-import qualified Type
import TcMType
import TysPrim
import TysWiredIn
import TyCon
-import {- Kind parts of -} Type
import Name
import Var
import VarSet
hsPatType (NPat lit _ _ ty) = ty
hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
hsPatType (CoPat _ _ ty) = ty
-hsPatType (DictPat ds ms) = case (ds ++ ms) of
- [] -> unitTy
- [d] -> idType d
- ds -> mkTupleTy Boxed (length ds) (map idType ds)
-
hsLitType :: HsLit -> TcType
hsLitType (HsChar c) = charTy
= zonkIdBndr env global `thenM` \ new_global ->
mapM zonk_prag prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(InlinePrag {}) = return prag
- zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (SpecPrag expr' ty' ds' inl) }
+ zonk_prag prag@(L _ (InlinePrag {})) = return prag
+ zonk_prag (L loc (SpecPrag expr ty ds inl))
+ = do { expr' <- zonkExpr env expr
+ ; ty' <- zonkTcTypeToType env ty
+ ; let ds' = zonkIdOccs env ds
+ ; return (L loc (SpecPrag expr' ty' ds' inl)) }
\end{code}
%************************************************************************
returnM (ExplicitTuple new_exprs boxed)
zonkExpr env (RecordCon data_con con_expr rbinds)
- = zonkExpr env con_expr `thenM` \ new_con_expr ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordCon data_con new_con_expr new_rbinds)
+ = do { new_con_expr <- zonkExpr env con_expr
+ ; new_rbinds <- zonkRecFields env rbinds
+ ; return (RecordCon data_con new_con_expr new_rbinds) }
-zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
- zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
+zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
+ = do { new_expr <- zonkLExpr env expr
+ ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
+ ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
+ ; new_rbinds <- zonkRecFields env rbinds
+ ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl new_expr)
+zonkExpr env (HsTickPragma info expr)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (HsTickPragma info new_expr)
+
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
= do { e' <- zonkExpr env e; return (HsIntegral i e') }
zonkOverLit env (HsFractional r e)
= do { e' <- zonkExpr env e; return (HsFractional r e') }
+zonkOverLit env (HsIsString s e)
+ = do { e' <- zonkExpr env e; return (HsIsString s e') }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
-------------------------------------------------------------------------
-zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
-
-zonkRbinds env rbinds
- = mappM zonk_rbind rbinds
+zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
+zonkRecFields env (HsRecFields flds dd)
+ = do { flds' <- mappM zonk_rbind flds
+ ; return (HsRecFields flds' dd) }
where
- zonk_rbind (field, expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (fmap (zonkIdOcc env) field, new_expr)
+ zonk_rbind fld
+ = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldArg = new_expr }) }
+ -- Field selectors have declared types; hence no zonking
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
; e2' <- zonkExpr env e2
; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
-zonk_pat env (DictPat ds ms)
- = do { ds' <- zonkIdBndrs env ds
- ; ms' <- zonkIdBndrs env ms
- ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
-
zonk_pat env (CoPat co_fn pat ty)
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; (env', p2') <- zonkPat env1 p2
; return (env', InfixCon p1' p2') }
-zonkConStuff env (RecCon rpats)
- = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ]
- ; (env', pats') <- zonkPats env pats
- ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
- ; returnM (env', recCon) }
+zonkConStuff env (RecCon (HsRecFields rpats dd))
+ = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
+ ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
+ ; returnM (env', RecCon (HsRecFields rpats' dd)) }
+ -- Field selectors have declared types; hence no zonking
---------------------------
zonkPats env [] = return (env, [])
-- Make up an arbitrary type whose kind is the same as the tyvar.
-- We'll use this to instantiate the (unbound) tyvar.
mkArbitraryType tv
- | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
+ | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
| otherwise = mkTyConApp tycon []
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
- tycon | eqKind kind (tyConKind listTyCon) -- *->*
- = listTyCon -- No tuples this size
+ tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
+ = anyPrimTyCon1 -- No tuples this size
| all isLiftedTypeKind args && isLiftedTypeKind res
= tupleTyCon Boxed (length args) -- *-> ... ->*->*
+ -- Horrible hack to make less use of mkAnyPrimTyCon
| otherwise
- = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
- mkPrimTyCon tc_name kind 0 VoidRep
+ = mkAnyPrimTyCon (getUnique tv) kind
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
-
- tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
\end{code}