From f2f3b120afd259933a603483d9a0eed7bd56f907 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Sun, 19 May 2013 01:16:37 +0400 Subject: [PATCH] Moving commands to Ghc monad --- Language/Haskell/GhcMod.hs | 6 ++++++ Language/Haskell/GhcMod/Browse.hs | 8 ++++---- Language/Haskell/GhcMod/Check.hs | 8 ++++---- Language/Haskell/GhcMod/Debug.hs | 9 +++++---- Language/Haskell/GhcMod/Info.hs | 18 +++++++++--------- Language/Haskell/GhcMod/List.hs | 8 ++++---- src/GHCMod.hs | 19 ++++++++++--------- 7 files changed, 42 insertions(+), 34 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 5f935a2..0344ec7 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -1,17 +1,22 @@ module Language.Haskell.GhcMod ( browseModule , checkSyntax + , check , module Language.Haskell.GhcMod.Cradle , debugInfo , debug , infoExpr + , info , typeExpr + , typeOf , listLanguages , lintSyntax , listModules , module Language.Haskell.GhcMod.Types , listFlags , getGHCVersion + , withGHCDummyFile + , withGHC ) where import Language.Haskell.GhcMod.Browse @@ -19,6 +24,7 @@ import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Debug import Language.Haskell.GhcMod.Flag +import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 32bda6e..69f921c 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -1,4 +1,4 @@ -module Language.Haskell.GhcMod.Browse (browseModule) where +module Language.Haskell.GhcMod.Browse (browseModule, browse) where import Control.Applicative import Data.Char @@ -17,7 +17,7 @@ import Var ---------------------------------------------------------------- -browseModule :: Options -> String -> IO String +browseModule :: Options -> String -> Ghc String browseModule opt mdlName = convert opt . format <$> browse opt mdlName where format @@ -32,8 +32,8 @@ browseModule opt mdlName = convert opt . format <$> browse opt mdlName (name, tail_) = break isSpace x formatOps' [] = error "formatOps'" -browse :: Options -> String -> IO [String] -browse opt mdlName = withGHCDummyFile $ do +browse :: Options -> String -> Ghc [String] +browse opt mdlName = do initializeFlags opt getModule >>= getModuleInfo >>= listExports where diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index e2e7895..ff07f3f 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -1,4 +1,4 @@ -module Language.Haskell.GhcMod.Check (checkSyntax) where +module Language.Haskell.GhcMod.Check (checkSyntax, check) where import Control.Applicative import Control.Monad @@ -12,13 +12,13 @@ import Prelude ---------------------------------------------------------------- -checkSyntax :: Options -> Cradle -> String -> IO String +checkSyntax :: Options -> Cradle -> String -> Ghc String checkSyntax opt cradle file = unlines <$> check opt cradle file ---------------------------------------------------------------- -check :: Options -> Cradle -> String -> IO [String] -check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg +check :: Options -> Cradle -> String -> Ghc [String] +check opt cradle fileName = checkIt `gcatch` handleErrMsg where checkIt = do readLog <- initializeFlagsWithCradle opt cradle options True diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2f6cf78..ba4cb5d 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -6,6 +6,7 @@ import Control.Monad import Data.List (intercalate) import Data.Maybe import GHC +import GhcMonad (liftIO) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types @@ -13,17 +14,17 @@ import Prelude ---------------------------------------------------------------- -debugInfo :: Options -> Cradle -> String -> String -> IO String +debugInfo :: Options -> Cradle -> String -> String -> Ghc String debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName -debug :: Options -> Cradle -> String -> String -> IO [String] +debug :: Options -> Cradle -> String -> String -> Ghc [String] debug opt cradle ver fileName = do (gopts, incDir, pkgs) <- if cabal then - fromCabalFile (ghcOpts opt) cradle ||> return (ghcOpts opt, [], []) + liftIO $ fromCabalFile (ghcOpts opt) cradle ||> return (ghcOpts opt, [], []) else return (ghcOpts opt, [], []) - [fast] <- withGHC fileName $ do + [fast] <- do void $ initializeFlagsWithCradle opt cradle gopts True setTargetFile fileName pure . canCheckFast <$> depanal [] False diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index e5088d5..3ea98c8 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -1,13 +1,13 @@ {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-} -module Language.Haskell.GhcMod.Info (infoExpr, typeExpr) where +module Language.Haskell.GhcMod.Info (infoExpr, info, typeExpr, typeOf) where import Control.Applicative import Control.Monad (void, when) import CoreUtils import Data.Function -import Data.Generics +import Data.Generics hiding (typeOf) import Data.List import Data.Maybe import Data.Ord as O @@ -36,10 +36,10 @@ data Cmd = Info | Type deriving Eq ---------------------------------------------------------------- -infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String +infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> Ghc String infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr -info :: Options -> Cradle -> FilePath -> ModuleString -> Expression -> IO String +info :: Options -> Cradle -> FilePath -> ModuleString -> Expression -> Ghc String info opt cradle fileName modstr expr = inModuleContext Info opt cradle fileName modstr exprToInfo "Cannot show info" where @@ -67,10 +67,10 @@ instance HasType (LHsBind Id) where instance HasType (LPat Id) where getType _ (L spn pat) = return $ Just (spn, hsPatType pat) -typeExpr :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> IO String -typeExpr opt cradle modstr lineNo colNo file = Language.Haskell.GhcMod.Info.typeOf opt cradle file modstr lineNo colNo +typeExpr :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> Ghc String +typeExpr opt cradle modstr lineNo colNo file = typeOf opt cradle file modstr lineNo colNo -typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String +typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> Ghc String typeOf opt cradle fileName modstr lineNo colNo = inModuleContext Type opt cradle fileName modstr exprToType errmsg where @@ -141,9 +141,9 @@ pprInfo pefas (thing, fixity, insts) ---------------------------------------------------------------- -inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String +inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String inModuleContext cmd opt cradle fileName modstr action errmsg = - withGHCDummyFile (valid ||> invalid ||> return errmsg) + valid ||> invalid ||> return errmsg where valid = do void $ initializeFlagsWithCradle opt cradle ["-w:"] False diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index 429c710..07a7f69 100644 --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -1,4 +1,4 @@ -module Language.Haskell.GhcMod.List (listModules) where +module Language.Haskell.GhcMod.List (listModules, list) where import Control.Applicative import Data.List @@ -10,11 +10,11 @@ import UniqFM ---------------------------------------------------------------- -listModules :: Options -> IO String +listModules :: Options -> Ghc String listModules opt = convert opt . nub . sort <$> list opt -list :: Options -> IO [String] -list opt = withGHCDummyFile $ do +list :: Options -> Ghc [String] +list opt = do initializeFlags opt getExposedModules <$> getSessionDynFlags where diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a6aa679..2da0c45 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -91,21 +91,21 @@ main = flip catches handlers $ do cmdArg3 = cmdArg !. 3 cmdArg4 = cmdArg !. 4 res <- case cmdArg0 of - "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) - "list" -> listModules opt - "check" -> withFile (checkSyntax opt cradle) cmdArg1 - "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1 - "debug" -> withFile (debugInfo opt cradle strVer) cmdArg1 - "type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1 - "info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1 + "browse" -> withGHCDummyFile $ concat <$> mapM (browseModule opt) (tail cmdArg) + "list" -> withGHCDummyFile $ listModules opt + "check" -> withGHCFile (checkSyntax opt cradle) cmdArg1 + "expand" -> withGHCFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1 + "debug" -> withGHCFile (debugInfo opt cradle strVer) cmdArg1 + "type" -> withGHCFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1 + "info" -> withGHCFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1 "lint" -> withFile (lintSyntax opt) cmdArg1 "lang" -> listLanguages opt "flag" -> listFlags opt "boot" -> do - mods <- listModules opt + mods <- withGHCDummyFile $ listModules opt langs <- listLanguages opt flags <- listFlags opt - pre <- concat <$> mapM (browseModule opt) preBrowsedModules + pre <- withGHCDummyFile $ concat <$> mapM (browseModule opt) preBrowsedModules return $ mods ++ langs ++ flags ++ pre cmd -> throw (NoSuchCommand cmd) putStr res @@ -130,6 +130,7 @@ main = flip catches handlers $ do if exist then cmd file else throw (FileNotExist file) + withGHCFile cmd = withFile (\f -> withGHC f (cmd f)) xs !. idx | length xs <= idx = throw SafeList | otherwise = xs !! idx