From 0c5da02d521f66ce0d54a44bcaf460aca09b3edf Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 20 Jan 2016 01:29:33 +0300 Subject: [PATCH] [Type-constraints] Add an option to toggle this --- Language/Haskell/GhcMod/Info.hs | 13 +++++++------ Language/Haskell/GhcMod/SrcUtils.hs | 13 ++++++++----- src/GHCMod.hs | 2 +- src/GHCMod/Options/Commands.hs | 30 ++++++++++++++++------------- 4 files changed, 33 insertions(+), 25 deletions(-) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 6b08caf..dc18f7c 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/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) diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 8bb988e..803d599 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index fdade72..8e517a8 100644 --- a/src/GHCMod.hs +++ b/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 diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 2e1f60a..275d4ae 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/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 x = x <$> some (strArg "FILES..") +filesArgsSpec :: Parser ([String] -> b) -> Parser b +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 -checkArgSpec = filesArgsSpec CmdCheck -expandArgSpec = filesArgsSpec CmdExpand +debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) +checkArgSpec = filesArgsSpec (pure CmdCheck) +expandArgSpec = filesArgsSpec (pure CmdExpand) infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" -typeArgSpec = locArgSpec CmdType -autoArgSpec = locArgSpec CmdAuto -splitArgSpec = locArgSpec CmdSplit -sigArgSpec = locArgSpec CmdSig -refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL" +typeArgSpec = locArgSpec $ CmdType <$> + switch + $$ long "constraints" + <=> short 'c' + <=> 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 <$>