[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 :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
-getSrcSpanType modSum lineNo colNo =
+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 :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
-collectSpansTypes tcs lc =
+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 =
+    constrainedType' pids s x
-        (maybe [] (uncurry $ constrainedType pids s) <$> getType' x, s)
+        | withConstraints
+        = (maybe [] (uncurry $ constrainedType pids s) <$> getType' x, s)
+        | otherwise = (maybeToList <$> getType' x, s)
     constrainedType pids s spn genTyp =
       let
         ctys  = mapMaybe build pids

src/GHCMod.hs

@@ -150,7 +150,7 @@ ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
 ghcCommands (CmdCheck files) = checkSyntax files
 ghcCommands (CmdExpand files) = expandTemplate files
 ghcCommands (CmdInfo file symb) = info file $ Expression symb
-ghcCommands (CmdType file (line, col)) = types file line col
+ghcCommands (CmdType wCon file (line, col)) = types wCon file line col
 ghcCommands (CmdSplit file (line, col)) = splits file line col
 ghcCommands (CmdSig file (line, col)) = sig file line col
 ghcCommands (CmdAuto file (line, col)) = auto file line col

src/GHCMod/Options/Commands.hs

@@ -51,7 +51,7 @@ data GhcModCommands =
   | CmdCheck [FilePath]
   | CmdExpand [FilePath]
   | CmdInfo FilePath Symbol
-  | CmdType FilePath Point
+  | CmdType Bool FilePath Point
   | CmdSplit FilePath Point
   | CmdSig FilePath Point
   | CmdAuto FilePath Point
@@ -215,12 +215,12 @@ interactiveCommandsSpec =
 strArg :: String -> Parser String
 strArg = argument str . metavar
 
-filesArgsSpec :: ([String] -> b) -> Parser b
+filesArgsSpec :: Parser ([String] -> b) -> Parser b
-filesArgsSpec x = x <$> some (strArg "FILES..")
+filesArgsSpec x = x <*> some (strArg "FILES..")
 
-locArgSpec :: (String -> (Int, Int) -> b) -> Parser b
+locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b
 locArgSpec x = x
-  <$> strArg "FILE"
+  <*> strArg "FILE"
   <*> ( (,)
         <$> argument int (metavar "LINE")
         <*> argument int (metavar "COL")
@@ -261,17 +261,21 @@ browseArgSpec = CmdBrowse
             <=> help "Qualify symbols"
       )
   <*> some (strArg "MODULE")
-debugComponentArgSpec = filesArgsSpec CmdDebugComponent
+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)
-checkArgSpec = filesArgsSpec CmdCheck
+checkArgSpec = filesArgsSpec (pure CmdCheck)
-expandArgSpec = filesArgsSpec CmdExpand
+expandArgSpec = filesArgsSpec (pure CmdExpand)
 infoArgSpec = CmdInfo
     <$> strArg "FILE"
     <*> strArg "SYMBOL"
-typeArgSpec = locArgSpec CmdType
+typeArgSpec = locArgSpec $ CmdType <$>
-autoArgSpec = locArgSpec CmdAuto
+        switch
-splitArgSpec = locArgSpec CmdSplit
+          $$  long "constraints"
-sigArgSpec = locArgSpec CmdSig
+          <=> short 'c'
-refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"
+          <=> help "Include constraints into type signature"
+autoArgSpec = locArgSpec (pure CmdAuto)
+splitArgSpec = locArgSpec (pure CmdSplit)
+sigArgSpec = locArgSpec (pure CmdSig)
+refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL"
 mapArgSpec = CmdMapFile <$> strArg "FILE"
 unmapArgSpec = CmdUnmapFile <$> strArg "FILE"
 legacyInteractiveArgSpec = const CmdLegacyInteractive <$>