From 1b66f65b48df07e24d61a66822b35293cb8d8d42 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Sat, 28 Jun 2014 21:43:51 +0200 Subject: [PATCH] Move lots of stuff to GhcMod - Generalize many signatures to GhcMonad m --- Language/Haskell/GhcMod/CaseSplit.hs | 21 ++++++----- Language/Haskell/GhcMod/Doc.hs | 4 +- Language/Haskell/GhcMod/FillSig.hs | 24 ++++++------ Language/Haskell/GhcMod/GHCApi.hs | 4 +- Language/Haskell/GhcMod/GHCChoice.hs | 8 ++-- Language/Haskell/GhcMod/Gap.hs | 11 +++--- Language/Haskell/GhcMod/Info.hs | 31 +++++++++------- Language/Haskell/GhcMod/SrcUtils.hs | 3 +- src/GHCModi.hs | 55 +++++++++++++--------------- 9 files changed, 83 insertions(+), 78 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 247e251..3cd5aba 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -7,11 +7,12 @@ import Data.List (find, intercalate) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Convert @@ -39,19 +40,19 @@ splitVar :: Options -> Int -- ^ Line number. -> Int -- ^ Column number. -> IO String -splitVar opt cradle file lineNo colNo = withGHC' $ do +splitVar opt cradle file lineNo colNo = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - splits opt file lineNo colNo + splits file lineNo colNo -- | Splitting a variable in a equation. -splits :: Options - -> FilePath -- ^ A target file. +splits :: FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> Ghc String -splits opt file lineNo colNo = ghandle handler body + -> GhcMod String +splits file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do + opt <- options modSum <- Gap.fileModSummary file whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do @@ -59,12 +60,12 @@ splits opt file lineNo colNo = ghandle handler body text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, text) - handler (SomeException _) = emptyResult opt + handler (SomeException _) = emptyResult =<< options ---------------------------------------------------------------- -- a. Code for getting the information of the variable -getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (Maybe SplitInfo) +getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) getSrcSpanTypeForSplit modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = pms} <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p @@ -173,7 +174,7 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: FilePath -> SplitToTextInfo -> Ghc String +genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do text <- T.readFile file return $ getCaseSplitText (T.lines text) info diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index 4c3d8ce..bbc6b77 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,6 +1,6 @@ module Language.Haskell.GhcMod.Doc where -import GHC (Ghc, DynFlags) +import GHC (DynFlags, GhcMonad) import qualified GHC as G import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) @@ -12,7 +12,7 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style -getStyle :: Ghc PprStyle +getStyle :: GhcMonad m => m PprStyle getStyle = do unqual <- G.getPrintUnqual return $ mkUserStyle unqual AllTheWay diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index a021e10..4b31e15 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -8,13 +8,14 @@ module Language.Haskell.GhcMod.FillSig ( import Data.Char (isSymbol) import Data.List (find, intercalate) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import Language.Haskell.GhcMod.GHCApi import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Convert import MonadUtils (liftIO) import Outputable (PprStyle) import qualified Type as Ty @@ -41,19 +42,19 @@ fillSig :: Options -> Int -- ^ Line number. -> Int -- ^ Column number. -> IO String -fillSig opt cradle file lineNo colNo = withGHC' $ do +fillSig opt cradle file lineNo colNo = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - sig opt file lineNo colNo + sig file lineNo colNo -- | Create a initial body from a signature. -sig :: Options - -> FilePath -- ^ A target file. +sig :: FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> Ghc String -sig opt file lineNo colNo = ghandle handler body + -> GhcMod String +sig file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do + opt <- options modSum <- Gap.fileModSummary file whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of Signature loc names ty -> @@ -63,6 +64,7 @@ sig opt file lineNo colNo = ghandle handler body (Ty.classMethods cls)) handler (SomeException _) = do + opt <- options -- Code cannot be parsed by ghc module -- Fallback: try to get information via haskell-src-exts whenFound opt (getSignatureFromHE file lineNo colNo) $ @@ -73,7 +75,7 @@ sig opt file lineNo colNo = ghandle handler body -- a. Code for getting the information -- Get signature from ghc parsing and typechecking -getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo) +getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) getSignature modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum -- Inspect the parse tree to find the signature @@ -96,7 +98,7 @@ getSignature modSum lineNo colNo = do obtainClassInfo minfo clsName loc _ -> return Nothing _ -> return Nothing - where obtainClassInfo :: G.ModuleInfo -> G.Name -> SrcSpan -> Ghc (Maybe SigInfo) + where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) obtainClassInfo minfo clsName loc = do tyThing <- G.modInfoLookupName minfo clsName return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe @@ -104,7 +106,7 @@ getSignature modSum lineNo colNo = do return $ InstanceDecl loc cls -- Get signature from haskell-src-exts -getSignatureFromHE :: FilePath -> Int -> Int -> Ghc (Maybe HESigInfo) +getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) getSignatureFromHE file lineNo colNo = do presult <- liftIO $ HE.parseFile file return $ case presult of diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index e12df43..d48b2e7 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -19,11 +19,11 @@ import Language.Haskell.GhcMod.GhcPkg import Control.Applicative ((<$>)) import Control.Monad (forM, void) -import CoreMonad (liftIO) import Data.Maybe (isJust, fromJust) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) +import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) import qualified GHC as G +import GhcMonad import GHC.Paths (libdir) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/GHCChoice.hs b/Language/Haskell/GhcMod/GHCChoice.hs index 99904f0..3ac604e 100644 --- a/Language/Haskell/GhcMod/GHCChoice.hs +++ b/Language/Haskell/GhcMod/GHCChoice.hs @@ -5,21 +5,21 @@ module Language.Haskell.GhcMod.GHCChoice where import Control.Exception (IOException) import CoreMonad (liftIO) import qualified Exception as GE -import GHC (Ghc, GhcMonad) +import GHC (GhcMonad) ---------------------------------------------------------------- -- | Try the left 'Ghc' action. If 'IOException' occurs, try -- the right 'Ghc' action. -(||>) :: Ghc a -> Ghc a -> Ghc a +(||>) :: GhcMonad m => m a -> m a -> m a x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y) -- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'. -goNext :: Ghc a +goNext :: GhcMonad m => m a goNext = liftIO . GE.throwIO $ userError "goNext" -- | Run any one 'Ghc' monad. -runAnyOne :: [Ghc a] -> Ghc a +runAnyOne :: GhcMonad m => [m a] -> m a runAnyOne = foldr (||>) goNext ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index ae5333a..b7fb1e3 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} module Language.Haskell.GhcMod.Gap ( Language.Haskell.GhcMod.Gap.ClsInst @@ -46,6 +46,7 @@ import Desugar (deSugarExpr) import DynFlags import ErrUtils import FastString +import GhcMonad import HscTypes import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Types @@ -151,7 +152,7 @@ getSrcFile _ = Nothing ---------------------------------------------------------------- -toStringBuffer :: [String] -> Ghc StringBuffer +toStringBuffer :: GhcMonad m => [String] -> m StringBuffer #if __GLASGOW_HASKELL__ >= 702 toStringBuffer = return . stringToStringBuffer . unlines #else @@ -174,13 +175,13 @@ fOptions = [option | (option,_,_,_) <- fFlags] ---------------------------------------------------------------- ---------------------------------------------------------------- -fileModSummary :: FilePath -> Ghc ModSummary +fileModSummary :: GhcMonad m => FilePath -> m ModSummary fileModSummary file = do mss <- getModuleGraph let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss return ms -withContext :: Ghc a -> Ghc a +withContext :: GhcMonad m => m a -> m a withContext action = gbracket setup teardown body where setup = getContext @@ -296,7 +297,7 @@ filterOutChildren get_thing xs where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: String -> Ghc SDoc +infoThing :: GhcMonad m => String -> m SDoc infoThing str = do names <- parseName str #if __GLASGOW_HASKELL__ >= 708 diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 14c338c..4394f9f 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -10,12 +10,13 @@ import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) +import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import qualified GHC as G import Language.Haskell.GhcMod.Doc (showPage) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Convert @@ -28,16 +29,17 @@ infoExpr :: Options -> FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> IO String -infoExpr opt cradle file expr = withGHC' $ do +infoExpr opt cradle file expr = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - info opt file expr + info file expr -- | Obtaining information of a target expression. (GHCi's info:) -info :: Options - -> FilePath -- ^ A target file. +info :: FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. - -> Ghc String -info opt file expr = convert opt <$> ghandle handler body + -> GhcMod String +info file expr = do + opt <- options + convert opt <$> ghandle handler body where body = inModuleContext file $ \dflag style -> do sdoc <- Gap.infoThing expr @@ -53,17 +55,18 @@ typeExpr :: Options -> Int -- ^ Line number. -> Int -- ^ Column number. -> IO String -typeExpr opt cradle file lineNo colNo = withGHC' $ do +typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - types opt file lineNo colNo + types file lineNo colNo -- | Obtaining type of a target expression. (GHCi's type:) -types :: Options - -> FilePath -- ^ A target file. +types :: FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> Ghc String -types opt file lineNo colNo = convert opt <$> ghandle handler body + -> GhcMod String +types file lineNo colNo = do + opt <- options + convert opt <$> ghandle handler body where body = inModuleContext file $ \dflag style -> do modSum <- Gap.fileModSummary file @@ -71,7 +74,7 @@ types opt file lineNo colNo = convert opt <$> ghandle handler body return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes handler (SomeException _) = return [] -getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] +getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 0270dc9..f261c3d 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -10,6 +10,7 @@ import Data.Generics import Data.Maybe (fromMaybe) import Data.Ord as O import GHC (Ghc, LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import GhcMonad import qualified GHC as G import GHC.SYB.Utils (Stage(..), everythingStaged) import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) @@ -79,7 +80,7 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser ---------------------------------------------------------------- -inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a +inModuleContext ::GhcMonad m => FilePath -> (DynFlags -> PprStyle -> m a) -> m a inModuleContext file action = withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do setTargetFiles [file] diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 5c01108..0baf43c 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -31,7 +31,7 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Typeable (Typeable) import Data.Version (showVersion) -import GHC (Ghc) +import GHC (GhcMonad) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc @@ -142,10 +142,10 @@ loop opt set mvar = do "check" -> checkStx opt set arg "find" -> findSym set arg mvar "lint" -> toGhcMod $ lintStx opt set arg - "info" -> toGhcMod $ showInfo opt set arg - "type" -> toGhcMod $ showType opt set arg - "split" -> toGhcMod $ doSplit opt set arg - "sig" -> toGhcMod $ doSig opt set arg + "info" -> showInfo set arg + "type" -> showType set arg + "split" -> doSplit set arg + "sig" -> doSig set arg "boot" -> bootIt set "browse" -> browseIt set arg "quit" -> return ("quit", False, set) @@ -173,7 +173,7 @@ checkStx _ set file = do Right ret -> return (ret, True, set') Left ret -> return (ret, True, set) -- fxime: set -newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath) +newFileSet :: GhcMonad m => Set FilePath -> FilePath -> m (Set FilePath) newFileSet set file = do let set1 | S.member file set = set @@ -183,7 +183,7 @@ newFileSet set file = do Nothing -> set1 Just mainfile -> S.delete mainfile set1 -getModSummaryForMain :: Ghc (Maybe G.ModSummary) +getModSummaryForMain :: GhcMonad m => m (Maybe G.ModSummary) getModSummaryForMain = find isMain <$> G.getModuleGraph where isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" @@ -209,8 +209,9 @@ findSym set sym mvar = do let ret = lookupSym' opt sym db return (ret, True, set) -lintStx :: Options -> Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) +lintStx :: GhcMonad m + => Options -> Set FilePath -> FilePath + -> m (String, Bool, Set FilePath) lintStx opt set optFile = liftIO $ do ret <-lintSyntax opt' file return (ret, True, set) @@ -236,44 +237,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of ---------------------------------------------------------------- -showInfo :: Options - -> Set FilePath +showInfo :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -showInfo opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +showInfo set fileArg = do let [file, expr] = words fileArg set' <- newFileSet set file - ret <- info opt file expr + ret <- info file expr return (ret, True, set') -showType :: Options - -> Set FilePath +showType :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -showType opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +showType set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file - ret <- types opt file (read line) (read column) + ret <- types file (read line) (read column) return (ret, True, set') -doSplit :: Options - -> Set FilePath +doSplit :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -doSplit opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +doSplit set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file - ret <- splits opt file (read line) (read column) + ret <- splits file (read line) (read column) return (ret, True, set') -doSig :: Options - -> Set FilePath +doSig :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -doSig opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +doSig set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file - ret <- sig opt file (read line) (read column) + ret <- sig file (read line) (read column) return (ret, True, set') ----------------------------------------------------------------