mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit, mkVanillaTuplePat,
+ shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
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
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}
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}
%************************************************************************
%* *
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}
%************************************************************************
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 (WpLam id) = do { id' <- zonkIdBndr env id
+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') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
-------------------------------------------------------------------------
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)
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (env, ExprStmt new_expr new_then new_ty)
+zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
+ = do { (env', stmts') <- zonkStmts env stmts
+ ; let binders' = zonkIdOccs env' binders
+ ; usingExpr' <- zonkLExpr env' usingExpr
+ ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
+ ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
+
+zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
+ = do { (env', stmts') <- zonkStmts env stmts
+ ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
+ ; groupByClause' <-
+ case groupByClause of
+ GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
+ GroupBySomething eitherUsingExpr byExpr -> do
+ eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
+ byExpr' <- zonkLExpr env' byExpr
+ return $ GroupBySomething eitherUsingExpr' byExpr'
+
+ ; let env'' = extendZonkEnv env' (map snd binderMap')
+ ; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
+ where
+ mapEitherM f g x = do
+ case x of
+ Left a -> f a >>= (return . Left)
+ Right b -> g b >>= (return . Right)
+
+ zonkBinderMapEntry env (oldBinder, newBinder) = do
+ let oldBinder' = zonkIdOcc env oldBinder
+ newBinder' <- zonkIdBndr env newBinder
+ return (oldBinder', newBinder')
+
zonkStmt env (LetStmt binds)
= zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
returnM (env1, LetStmt new_binds)
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
+zonkMaybeLExpr env Nothing = return Nothing
+zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
+
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
- ; new_dicts <- zonkIdBndrs env dicts
+ ; new_dicts <- zonkDictBndrs env dicts
; let env1 = extendZonkEnv env new_dicts
; (env2, new_binds) <- zonkRecMonoBinds env1 binds
; (env', new_args) <- zonkConStuff env2 args
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
= mappM zonk_bndr vars `thenM` \ new_bndrs ->
newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
let
(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}
projects / ghc-hetmet.git / blobdiff