-lookupSimpleInst :: ClassInstEnv
- -> Class
- -> Type -- Look up (c,t)
- -> TcM s [(Class,Type)] -- Here are the needed (c,t)s
-
-lookupSimpleInst class_inst_env clas ty
- = case (lookupMEnv matchTy class_inst_env ty) of
- Nothing -> failTc (noSimpleInst clas ty)
- Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
- where
- (_, theta, _) = splitSigmaTy (idType dfun)
-
-noSimpleInst clas ty sty
- = sep [ptext SLIT("No instance for class"), ppr sty clas,
- ptext SLIT("at type"), ppr sty ty]
+newOverloadedLit :: InstOrigin
+ -> HsOverLit
+ -> TcType
+ -> TcM TcExpr
+newOverloadedLit orig lit expected_ty
+ = zapToType expected_ty `thenM_`
+ -- The expected type might be a 'hole' type variable,
+ -- in which case we must zap it to an ordinary type variable
+ new_over_lit orig lit expected_ty
+
+new_over_lit orig lit@(HsIntegral i fi) expected_ty
+ | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
+ -- syntax. Reason: tcSyntaxName does unification
+ -- which is very inconvenient in tcSimplify
+ = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
+ returnM (HsApp expr (HsLit (HsInteger i)))
+
+ | Just expr <- shortCutIntLit i expected_ty
+ = returnM expr
+
+ | otherwise
+ = newLitInst orig lit expected_ty
+
+new_over_lit orig lit@(HsFractional r fr) expected_ty
+ | fr /= fromRationalName -- c.f. HsIntegral case
+ = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) ->
+ mkRatLit r `thenM` \ rat_lit ->
+ returnM (HsApp expr rat_lit)
+
+ | Just expr <- shortCutFracLit r expected_ty
+ = returnM expr
+
+ | otherwise
+ = newLitInst orig lit expected_ty
+
+newLitInst orig lit expected_ty
+ = getInstLoc orig `thenM` \ loc ->
+ newUnique `thenM` \ new_uniq ->
+ let
+ lit_inst = LitInst lit_id lit expected_ty loc
+ lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
+ in
+ extendLIE lit_inst `thenM_`
+ returnM (HsVar (instToId lit_inst))
+
+shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
+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))
+ | otherwise = Nothing
+
+shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
+shortCutFracLit f ty
+ | isFloatTy ty
+ = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+ | isDoubleTy ty
+ = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+ | otherwise = Nothing
+
+mkRatLit :: Rational -> TcM TcExpr
+mkRatLit r
+ = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
+ let
+ rational_ty = mkGenTyConApp rat_tc []
+ in
+ returnM (HsLit (HsRat r rational_ty))