checker.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
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 (LazyPat pat) = hsLPatType pat
hsPatType (LitPat lit) = hsLitType lit
hsPatType (AsPat var pat) = idType (unLoc var)
+hsPatType (ViewPat expr pat ty) = ty
hsPatType (ListPat _ ty) = mkListTy ty
hsPatType (PArrPat _ ty) = mkPArrTy ty
hsPatType (TuplePat pats box ty) = ty
hsPatType (ConPatOut{ pat_ty = ty })= ty
hsPatType (SigPatOut pat ty) = ty
-hsPatType (NPat lit _ _ ty) = ty
+hsPatType (NPat lit _ _) = overLitType lit
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
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 cons in_tys out_tys)
- = zonkLExpr env expr `thenM` \ new_expr ->
- mapM (zonkTcTypeToType env) in_tys `thenM` \ new_in_tys ->
- mapM (zonkTcTypeToType env) out_tys `thenM` \ new_out_tys ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpd new_expr new_rbinds cons new_in_tys new_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
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
-zonkOverLit env (HsIntegral i e)
- = 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') }
+zonkOverLit env ol =
+ let
+ zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
+ e' <- zonkExpr env (overLitExpr ol)
+ return (e', ty')
+ ru f (x, y) = return (f x y)
+ in
+ case ol of
+ (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff
+ (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
+ (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
-------------------------------------------------------------------------
-zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
-
-zonkRbinds env (HsRecordBinds rbinds)
- = mappM zonk_rbind rbinds >>= return . HsRecordBinds
+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)
; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
; return (env', AsPat (L loc v') pat') }
+zonk_pat env (ViewPat expr pat ty)
+ = do { expr' <- zonkLExpr env expr
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', ViewPat expr' pat' ty) }
+
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
; (env', pat') <- zonkPat env pat
; return (env', SigPatOut pat' ty') }
-zonk_pat env (NPat lit mb_neg eq_expr ty)
+zonk_pat env (NPat lit mb_neg eq_expr)
= do { lit' <- zonkOverLit env lit
; mb_neg' <- case mb_neg of
Nothing -> return Nothing
Just neg -> do { neg' <- zonkExpr env neg
; return (Just neg') }
; eq_expr' <- zonkExpr env eq_expr
- ; ty' <- zonkTcTypeToType env ty
- ; return (env, NPat lit' mb_neg' eq_expr' ty') }
+ ; return (env, NPat lit' mb_neg' eq_expr') }
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
= do { n' <- zonkIdBndr env n
; 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, [])
projects / ghc-hetmet.git / blobdiff