X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=be7c14ae70db0fadb19f7b16df46225905918ec4;hb=ecdaf6bc29d23bd704df8c65442ee08032a585fc;hp=6bcd3a3a87f3766f9cded3a8fa7db67214131dec;hpb=f84b83e59ee9b893dacc4e4c3bd49e00eae957b1;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 6bcd3a3..be7c14a 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -23,9 +23,8 @@ module Inst ( newDictBndr, newDictBndrs, newDictBndrsO, instCall, instStupidTheta, - cloneDict, - shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, - newMethod, newMethodFromName, newMethodWithGivenTy, + cloneDict, mkOverLit, + newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcSyntaxName, isHsVar, @@ -60,7 +59,7 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcPolyExpr ) import {-# SOURCE #-} TcUnify( boxyUnify, unifyType ) -import FastString(FastString) +import FastString import HsSyn import TcHsSyn import TcRnMonad @@ -471,47 +470,16 @@ newMethod inst_loc id tys = do \end{code} \begin{code} -shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId) -shortCutIntLit i ty - | isIntTy ty && inIntRange i -- Short cut for Int - = Just (HsLit (HsInt i)) - | isIntegerTy ty -- Short cut for Integer - = Just (HsLit (HsInteger i ty)) - | otherwise = Nothing - -shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId) -shortCutFracLit f ty - | isFloatTy ty - = Just (mk_lit floatDataCon (HsFloatPrim f)) - | isDoubleTy ty - = Just (mk_lit doubleDataCon (HsDoublePrim f)) - | otherwise = Nothing - where - mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) - -shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId) -shortCutStringLit s ty - | isStringTy ty -- Short cut for String - = Just (HsLit (HsString s)) - | otherwise = Nothing - -mkIntegerLit :: Integer -> TcM (LHsExpr TcId) -mkIntegerLit i = do - integer_ty <- tcMetaTy integerTyConName - span <- getSrcSpanM - return (L span $ HsLit (HsInteger i integer_ty)) - -mkRatLit :: Rational -> TcM (LHsExpr TcId) -mkRatLit r = do - rat_ty <- tcMetaTy rationalTyConName - span <- getSrcSpanM - return (L span $ HsLit (HsRat r rat_ty)) - -mkStrLit :: FastString -> TcM (LHsExpr TcId) -mkStrLit s = do - --string_ty <- tcMetaTy stringTyConName - span <- getSrcSpanM - return (L span $ HsLit (HsString s)) +mkOverLit :: OverLitVal -> TcM HsLit +mkOverLit (HsIntegral i) + = do { integer_ty <- tcMetaTy integerTyConName + ; return (HsInteger i integer_ty) } + +mkOverLit (HsFractional r) + = do { rat_ty <- tcMetaTy rationalTyConName + ; return (HsRat r rat_ty) } + +mkOverLit (HsIsString s) = return (HsString s) isHsVar :: HsExpr Name -> Name -> Bool isHsVar (HsVar f) g = f==g @@ -603,15 +571,13 @@ pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co}) (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2)) (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2)) pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon - <+> (braces (ppr (instType inst) <> implicWantedEqs) $$ - ifPprDebug implic_stuff) + <+> braces (ppr (instType inst) <> implicWantedEqs) where name = instName inst - (implic_stuff, implicWantedEqs) - | isImplicInst inst = (ppr (tci_reft inst), - text " &" <+> - ppr (filter isEqInst (tci_wanted inst))) - | otherwise = (empty, empty) + implicWantedEqs + | isImplicInst inst = text " &" <+> + ppr (filter isEqInst (tci_wanted inst)) + | otherwise = empty pprInstInFull inst@(EqInst {}) = pprInst inst pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)] @@ -729,11 +695,11 @@ traceDFuns ispecs funDepErr ispec ispecs = addDictLoc ispec $ - addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) + addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:")) 2 (pprInstances (ispec:ispecs))) dupInstErr ispec dup_ispec = addDictLoc ispec $ - addErr (hang (ptext SLIT("Duplicate instance declarations:")) + addErr (hang (ptext (sLit "Duplicate instance declarations:")) 2 (pprInstances [ispec, dup_ispec])) addDictLoc ispec thing_inside @@ -781,41 +747,27 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo -- [Same shortcut as in newOverloadedLit, but we -- may have done some unification by now] -lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc}) - | Just expr <- shortCutIntLit i ty - = return (GenInst [] (noLoc expr)) - | otherwise - = ASSERT( from_integer_name `isHsVar` fromIntegerName ) do -- A LitInst invariant - from_integer <- tcLookupId fromIntegerName - method_inst <- tcInstClassOp loc from_integer [ty] - integer_lit <- mkIntegerLit i - return (GenInst [method_inst] - (mkHsApp (L (instLocSpan loc) - (HsVar (instToId method_inst))) integer_lit)) - -lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc}) - | Just expr <- shortCutFracLit f ty - = return (GenInst [] (noLoc expr)) +lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val + , ol_rebindable = rebindable } + , tci_ty = ty, tci_loc = iloc}) +#ifdef DEBUG + | rebindable = panic "lookupSimpleInst" -- A LitInst invariant +#endif + | Just witness <- shortCutLit lit_val ty + = do { let lit' = lit { ol_witness = witness, ol_type = ty } + ; return (GenInst [] (L loc (HsOverLit lit'))) } | otherwise - = ASSERT( from_rat_name `isHsVar` fromRationalName ) do -- A LitInst invariant - from_rational <- tcLookupId fromRationalName - method_inst <- tcInstClassOp loc from_rational [ty] - rat_lit <- mkRatLit f - return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) - (HsVar (instToId method_inst))) rat_lit)) - -lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc}) - | Just expr <- shortCutStringLit s ty - = return (GenInst [] (noLoc expr)) - | otherwise - = ASSERT( from_string_name `isHsVar` fromStringName ) do -- A LitInst invariant - from_string <- tcLookupId fromStringName - method_inst <- tcInstClassOp loc from_string [ty] - string_lit <- mkStrLit s - return (GenInst [method_inst] - (mkHsApp (L (instLocSpan loc) - (HsVar (instToId method_inst))) string_lit)) + = do { hs_lit <- mkOverLit lit_val + ; from_thing <- tcLookupId (hsOverLitName lit_val) + -- Not rebindable, so hsOverLitName is the right thing + ; method_inst <- tcInstClassOp iloc from_thing [ty] + ; let witness = HsApp (L loc (HsVar (instToId method_inst))) + (L loc (HsLit hs_lit)) + lit' = lit { ol_witness = witness, ol_type = ty } + ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) } + where + loc = instLocSpan iloc --------------------- Dictionaries ------------------------ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) @@ -825,7 +777,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) Just (dfun_id, mb_inst_tys) -> do { use_stage <- getStage - ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred)) (topIdLvl dfun_id) use_stage -- It's possible that not all the tyvars are in @@ -966,10 +918,10 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do syntaxNameCtxt name orig ty tidy_env = do inst_loc <- getInstLoc orig let - msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> - ptext SLIT("(needed by a syntactic construct)"), - nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)), - nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)] + msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> + ptext (sLit "(needed by a syntactic construct)"), + nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)), + nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)] return (tidy_env, msg) \end{code}