1 files changed, 29 insertions, 5 deletions
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 1abe0fc9dc..f69600bf04 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -29,6 +29,7 @@ import GHC.Types.Id
 import GHC.Core.ConLike
 import GHC.Types.Name
 import GHC.Builtin.Types
+import GHC.Builtin.Names (rationalTyConName)
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -47,12 +48,14 @@ import GHC.Core.Type
 import GHC.Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Utils.Monad (concatMapM)
-
+import GHC.Types.SourceText (FractionalLit(..))
 import Control.Monad (zipWithM)
 import Data.List (elemIndex)
 import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.List.NonEmpty as NE
 
+-- import GHC.Driver.Ppr
+
 -- | Smart constructor that eliminates trivial lets
 mkPmLetVar :: Id -> Id -> [PmGrd]
 mkPmLetVar x y | x == y = []
@@ -199,13 +202,34 @@ desugarPat x pat = case pat of
     -- short cutting in dsOverLit works properly) is overloaded iff either is.
     dflags <- getDynFlags
     let platform = targetPlatform dflags
-    core_expr <- case olit of
+    pm_lit <- case olit of
       OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }
         | not rebindable
         , Just expr <- shortCutLit platform val ty
-        -> dsExpr expr
-      _ -> dsOverLit olit
-    let lit  = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)
+        -> coreExprAsPmLit <$> dsExpr expr
+        | not rebindable
+        , (HsFractional f) <- val
+        , negates <- if fl_neg f then 1 else 0
+        -> do
+            rat_tc <- dsLookupTyCon rationalTyConName
+            let rat_ty = mkTyConTy rat_tc
+            return $ Just $ PmLit rat_ty (PmLitOverRat negates f)
+        | otherwise
+        -> do
+           dsLit <- dsOverLit olit
+           let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit
+          --  pprTraceM "desugarPat"
+          --     (
+          --       text "val" <+> ppr val $$
+          --       text "witness" <+> ppr (ol_witness olit) $$
+          --       text "dsLit" <+> ppr dsLit $$
+          --       text "asPmLit" <+> ppr pmLit
+          --     )
+           return pmLit
+
+    let lit = case pm_lit of
+          Just l -> l
+          Nothing -> pprPanic "failed to detect OverLit" (ppr olit)
     let lit' = case mb_neg of
           Just _  -> expectJust "failed to negate lit" (negatePmLit lit)
           Nothing -> lit