Support more kinds of literals in hover (#339)

* Support more kinds of literals in hover

* Fix for HLint

* Fix for GHC 8.8

* Fix for 8.4

* Fix 8.4 + suggestions by @cocreature

* More fixes for 8.4

* Deal with type sigs in all GHC versions

* Additional case for 8.4

* Separate isLit and isChildLit

Co-authored-by: Moritz Kiefer <[email protected]>

Author: serras

src/Development/IDE/Spans/Calculate.hs

@@ -158,15 +158,44 @@ getTypeLHsExpr tms e = do
     Nothing -> return Nothing
   where
     getSpanSource :: HsExpr GhcTc -> SpanSource
-    getSpanSource (HsLit U lit) = Lit (showGhc lit)
-    getSpanSource (HsOverLit U lit) = Lit (showGhc lit)
+    getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
     getSpanSource (HsVar U (L _ i)) = Named (getName i)
     getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
     getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
     getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
     getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
     getSpanSource _ = NoSource
 
+    isLit :: HsExpr GhcTc -> Bool
+    isLit (HsLit U _) = True
+    isLit (HsOverLit U _) = True
+    isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
+#if MIN_GHC_API_VERSION(8,6,0)
+    isLit (ExplicitSum  U _ _ xpr) = isLitChild (unLoc xpr)
+    isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
+#else
+    isLit (ExplicitSum  _ _ xpr _) = isLitChild (unLoc xpr)
+    isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
+#endif
+    isLit _ = False
+
+    isTupLit (Present U xpr) = isLitChild (unLoc xpr)
+    isTupLit _               = False
+
+    -- We need special treatment for children so things like [(1)] are still treated
+    -- as a list literal while not treating (1) as a literal.
+    isLitChild (HsWrap U _ xpr) = isLitChild xpr
+    isLitChild (HsPar U xpr)    = isLitChild (unLoc xpr)
+#if MIN_GHC_API_VERSION(8,8,0)
+    isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
+#elif MIN_GHC_API_VERSION(8,6,0)
+    isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
+#else
+    isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
+    isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
+#endif
+    isLitChild e = isLit e
+
 -- | Get the name and type of a pattern.
 getTypeLPat :: (GhcMonad m)
             => [TypecheckedModule]

test/exe/Main.hs

@@ -1209,8 +1209,8 @@ findDefinitionAndHoverTests = let
   tvrL40 = Position 40 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]
   intL41 = Position 41 20  ;  litI   = [ExpectHoverText ["7518"]]
   chrL36 = Position 37 24  ;  litC   = [ExpectHoverText ["'f'"]]
-  txtL8  = Position  8 14  ;  litT   = [ExpectHoverText ["\"dfgv\""]]
-  lstL43 = Position 43 12  ;  litL   = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]
+  txtL8  = Position  8 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]
+  lstL43 = Position 43 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]
   outL45 = Position 45  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
   innL48 = Position 48  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
   in
@@ -1246,8 +1246,8 @@ findDefinitionAndHoverTests = let
   , test no     broken tvrL40 kindV  "kind of (* -> *) type variable  #273"
   , test no     yes    intL41 litI   "literal Int  in hover info      #274"
   , test no     yes    chrL36 litC   "literal Char in hover info      #274"
-  , test no     broken txtL8  litT   "literal Text in hover info      #274"
-  , test no     broken lstL43 litL   "literal List in hover info      #274"
+  , test no     yes    txtL8  litT   "literal Text in hover info      #274"
+  , test no     yes    lstL43 litL   "literal List in hover info      #274"
   , test no     yes    docL41 constr "type constraint in hover info   #283"
   , test broken broken outL45 outSig "top-level signature             #310"
   , test broken broken innL48 innSig "inner     signature             #310"