-instToId :: Inst s -> TcIdOcc s
-instToId (Dict u clas ty orig loc)
- = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
- where
- str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
-
-instToId (Method u id tys rho_ty orig loc)
- = TcId (mkInstId u tau_ty (mkLocalName u str loc))
- where
- (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
- str = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName id)))
-
-instToId (LitInst u list ty orig loc)
- = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
+newOverloadedLit :: InstOrigin
+ -> HsOverLit
+ -> TcType
+ -> TcM (LHsExpr TcId)
+newOverloadedLit 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
+ -- ToDo: noLoc sadness
+ = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
+ mkIntegerLit i `thenM` \ integer_lit ->
+ returnM (mkHsApp (noLoc expr) integer_lit)
+ -- The mkHsApp will get the loc from the literal
+ | Just expr <- shortCutIntLit i expected_ty
+ = returnM expr
+
+ | otherwise
+ = newLitInst orig lit expected_ty
+
+newOverloadedLit orig lit@(HsFractional r fr) expected_ty
+ | fr /= fromRationalName -- c.f. HsIntegral case
+ = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
+ mkRatLit r `thenM` \ rat_lit ->
+ returnM (mkHsApp (noLoc expr) rat_lit)
+ -- The mkHsApp will get the loc from the literal
+
+ | Just expr <- shortCutFracLit r expected_ty
+ = returnM expr
+
+ | otherwise
+ = newLitInst orig lit expected_ty
+
+newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
+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 (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
+
+shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutIntLit i ty
+ | isIntTy ty && inIntRange i -- Short cut for Int
+ = Just (noLoc (HsLit (HsInt i)))
+ | isIntegerTy ty -- Short cut for Integer
+ = Just (noLoc (HsLit (HsInteger i ty)))
+ | otherwise = Nothing
+
+shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutFracLit f ty
+ | isFloatTy ty
+ = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+ | isDoubleTy ty
+ = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+ | otherwise = Nothing
+
+mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
+mkIntegerLit i
+ = tcMetaTy integerTyConName `thenM` \ integer_ty ->
+ getSrcSpanM `thenM` \ span ->
+ returnM (L span $ HsLit (HsInteger i integer_ty))
+
+mkRatLit :: Rational -> TcM (LHsExpr TcId)
+mkRatLit r
+ = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
+ getSrcSpanM `thenM` \ span ->
+ returnM (L span $ HsLit (HsRat r rat_ty))