[Type-constraints] Add an option to toggle this

Language/Haskell/GhcMod/Info.hs

@@ -52,17 +52,18 @@ info file expr =
 
 -- | Obtaining type of a target expression. (GHCi's type:)
 types :: IOish m
-      => FilePath     -- ^ A target file.
+      => Bool         -- ^ Include constraints into type signature
+      -> FilePath     -- ^ A target file.
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
       -> GhcModT m String
-types file lineNo colNo =
+types withConstraints file lineNo colNo =
   ghandle handler $
     runGmlT' [Left file] deferErrors $
       withInteractiveContext $ do
         crdl         <- cradle
         modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
-        srcSpanTypes <- getSrcSpanType modSum lineNo colNo
+        srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo
         dflag        <- G.getSessionDynFlags
         st           <- getStyle
         convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
@@ -71,8 +72,8 @@ types file lineNo colNo =
      gmLog GmException "types" $ showDoc ex
      return []
 
-getSrcSpanType :: (GhcMonad m) => G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
-getSrcSpanType modSum lineNo colNo =
+getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
+getSrcSpanType withConstraints modSum lineNo colNo =
   G.parseModule modSum
   >>= G.typecheckModule
-  >>= flip collectSpansTypes (lineNo, colNo)
+  >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)

Language/Haskell/GhcMod/SrcUtils.hs

@@ -43,8 +43,8 @@ instance HasType (LPat Id) where
 type CstGenQS = M.Map Var Type
 type CstGenQT = forall m. GhcMonad m => CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
 
-collectSpansTypes :: (GhcMonad m) => G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
-collectSpansTypes tcs lc =
+collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
+collectSpansTypes withConstraints tcs lc =
   everythingStagedWithContext TypeChecker M.empty (liftM2 (++))
     (return [])
     ((return [],) `mkQ` hsBind `extQ` hsExpr `extQ` hsPat)
@@ -53,7 +53,8 @@ collectSpansTypes tcs lc =
     insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)
     hsBind :: G.LHsBind Id -> CstGenQT
     hsBind (L _ G.AbsBinds{abs_exports = es'}) s
-      = (return [], foldr insExp s es')
+      | withConstraints = (return [], foldr insExp s es')
+      | otherwise       = (return [], s)
     hsBind x@(L _ b) s = constrainedType' (G.collectHsBindBinders b) s x
     hsExpr :: G.LHsExpr Id -> CstGenQT
     hsExpr x s = (maybeToList <$> getType' x, s)
@@ -63,8 +64,10 @@ collectSpansTypes tcs lc =
       | G.isGoodSrcSpan spn && spn `G.spans` lc
       = getType tcs x
       | otherwise = return Nothing
-    constrainedType' pids s x =
-        (maybe [] (uncurry $ constrainedType pids s) <$> getType' x, s)
+    constrainedType' pids s x
+        | withConstraints
+        = (maybe [] (uncurry $ constrainedType pids s) <$> getType' x, s)
+        | otherwise = (maybeToList <$> getType' x, s)
     constrainedType pids s spn genTyp =
       let
         ctys  = mapMaybe build pids