X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=defa5bffc7deb48a145dfea2d0ec1d2c3cb4e6e3;hb=dbe50b77059c7d55f909ba4c10ac03b8374f5b5e;hp=205197a1a5c8d303d5725e159b3c2fed792cbf30;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 205197a..defa5bf 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -20,7 +20,8 @@ module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, mkVanillaTuplePat, + nlHsIntLit, mkVanillaTuplePat, + shortCutLit, hsOverLitName, mkArbitraryType, -- Put this elsewhere? @@ -40,16 +41,19 @@ import HsSyn -- oodles of it import Id import TcRnMonad +import PrelNames import Type import TcType import TcMType import TysPrim import TysWiredIn import TyCon +import DataCon import Name import Var import VarSet import VarEnv +import Literal import BasicTypes import Maybes import Unique @@ -57,6 +61,22 @@ import SrcLoc import Util import Bag import Outputable +import FastString +\end{code} + +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM \end{code} @@ -102,12 +122,47 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy +hsLitType (HsWordPrim w) = wordPrimTy hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy \end{code} +Overloaded literals. Here mainly becuase it uses isIntTy etc + +\begin{code} +shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit (HsIntegral i) ty + | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) + | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) + | isIntegerTy ty = Just (HsLit (HsInteger i ty)) + | otherwise = shortCutLit (HsFractional (fromInteger i)) ty + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + +shortCutLit (HsFractional f) ty + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) + | otherwise = Nothing + +shortCutLit (HsIsString s) ty + | isStringTy ty = Just (HsLit (HsString s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit -> HsExpr Id +mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName +\end{code} %************************************************************************ %* * @@ -313,11 +368,10 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty ds inl)) + zonk_prag (L loc (SpecPrag expr ty inl)) = do { expr' <- zonkExpr env expr ; ty' <- zonkTcTypeToType env ty - ; let ds' = zonkIdOccs env ds - ; return (L loc (SpecPrag expr' ty' ds' inl)) } + ; return (L loc (SpecPrag expr' ty' inl)) } \end{code} %************************************************************************ @@ -548,8 +602,8 @@ zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co - ; return (env, WpCo co') } +zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co + ; return (env, WpCast co') } zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id ; let env1 = extendZonkEnv1 env id' ; return (env1, WpLam id') } @@ -570,17 +624,10 @@ zonkDo env do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -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 +zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) + = do { ty' <- zonkTcTypeToType env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_type = ty' }) } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) @@ -1008,10 +1055,10 @@ mkArbitraryType warn tv (args,res) = splitKindFunTys kind tup_tc = tupleTyCon Boxed (length args) - msg = vcat [ hang (ptext SLIT("Inventing strangely-kinded Any TyCon")) - 2 (ptext SLIT("of kind") <+> quotes (ppr kind)) - , nest 2 (ptext SLIT("from an instantiation of type variable") <+> quotes (ppr tv)) - , ptext SLIT("This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) - , nest 2 (ptext SLIT("but is harmless without -O (and usually harmless anyway).")) - , ptext SLIT("See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] + msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon")) + 2 (ptext (sLit "of kind") <+> quotes (ppr kind)) + , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv)) + , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) + , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway).")) + , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] \end{code}