Ghc->GhcMod: finish Browse, Check

Language/Haskell/GhcMod/Browse.hs

@@ -10,7 +10,7 @@ import Data.List (sort)
 import Data.Maybe (catMaybes)
 import Exception (ghandle)
 import FastString (mkFastString)
-import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
+import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
 import Language.Haskell.GhcMod.GHCApi
@@ -30,9 +30,7 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
 --   If 'operators' is 'True', operators are also returned.
 browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\")
        -> GhcMod String
-browse pkgmdl = do
+browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
-    opt <- options
-    convert opt . sort <$> (getModule >>= listExports)
   where
     (mpkg,mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl
@@ -70,14 +68,15 @@ processExports minfo = do
     removeOps
       | operators opt = id
       | otherwise = filter (isAlpha . head . getOccString)
-  mapM (toGhcMod . showExport opt minfo) $ removeOps $ G.modInfoExports minfo
+  mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
-showExport :: Options -> ModuleInfo -> Name -> Ghc String
+showExport :: Options -> ModuleInfo -> Name -> GhcMod String
 showExport opt minfo e = do
   mtype' <- mtype
   return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
   where
     mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
+    mtype :: GhcMod (Maybe String)
     mtype
       | detailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
@@ -92,7 +91,7 @@ showExport opt minfo e = do
       | isAlpha n = nm
       | otherwise = "(" ++ nm ++ ")"
     formatOp "" = error "formatOp"
-    inOtherModule :: Name -> Ghc (Maybe TyThing)
+    inOtherModule :: Name -> GhcMod (Maybe TyThing)
     inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
     justIf :: a -> Bool -> Maybe a
     justIf x True = Just x
@@ -139,7 +138,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
 ----------------------------------------------------------------
 
 -- | Browsing all functions in all system/user modules.
-browseAll :: DynFlags -> Ghc [(String,String)]
+browseAll :: DynFlags -> GhcMod [(String,String)]
 browseAll dflag = do
     ms <- G.packageDbModules True
     is <- mapM G.getModuleInfo ms

Language/Haskell/GhcMod/Check.hs

@@ -6,12 +6,10 @@ module Language.Haskell.GhcMod.Check (
   ) where
 
 import Control.Applicative ((<$>))
-import GHC (Ghc)
 import Language.Haskell.GhcMod.GHCApi
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
 
 ----------------------------------------------------------------
 
@@ -34,21 +32,17 @@ checkSyntax files = withErrorHandler sessionName $ do
 check :: [FilePath]  -- ^ The target files.
       -> GhcMod (Either String String)
 check fileNames = do
-  opt <- options
+  withLogger setAllWaringFlags $ do
-  toGhcMod $ withLogger opt setAllWaringFlags $ do
     setTargetFiles fileNames
 
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expandTemplate :: Options
+expandTemplate :: [FilePath]  -- ^ The target files.
-               -> Cradle
+               -> GhcMod String
-               -> [FilePath]  -- ^ The target files.
+expandTemplate [] = return ""
-               -> IO String
+expandTemplate files = withErrorHandler sessionName $ do
-expandTemplate _   _      []    = return ""
+    either id id <$> expand files
-expandTemplate opt cradle files = withGHC sessionName $ do
-    initializeFlagsWithCradle opt cradle
-    either id id <$> expand opt files
   where
     sessionName = case files of
       [file] -> file
@@ -57,8 +51,7 @@ expandTemplate opt cradle files = withGHC sessionName $ do
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expand :: Options
+expand :: [FilePath]  -- ^ The target files.
-      -> [FilePath]  -- ^ The target files.
+      -> GhcMod (Either String String)
-      -> Ghc (Either String String)
+expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $
-expand opt fileNames = withLogger opt (Gap.setDumpSplices . setNoWaringFlags) $
     setTargetFiles fileNames

Language/Haskell/GhcMod/Find.hs

@@ -9,6 +9,7 @@ import GHC (Ghc)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Browse (browseAll)
 import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 
@@ -32,13 +33,11 @@ type Symbol = String
 newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
 
 -- | Finding modules to which the symbol belong.
-findSymbol :: Options -> Cradle -> Symbol -> IO String
+findSymbol :: Symbol -> GhcMod String
-findSymbol opt cradle sym = withGHC' $ do
+findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb
-    initializeFlagsWithCradle opt cradle
-    lookupSym opt sym <$> getSymMdlDb
 
 -- | Creating 'SymMdlDb'.
-getSymMdlDb :: Ghc SymMdlDb
+getSymMdlDb :: GhcMod SymMdlDb
 getSymMdlDb = do
     sm <- G.getSessionDynFlags >>= browseAll
 #if MIN_VERSION_containers(0,5,0)
@@ -53,5 +52,5 @@ getSymMdlDb = do
     tieup x = (head (map fst x), map snd x)
 
 -- | Looking up 'SymMdlDb' with 'Symbol' to find modules.
-lookupSym :: Options -> Symbol -> SymMdlDb -> String
+lookupSym :: Symbol -> SymMdlDb -> [ModuleString]
-lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db)
+lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db)

Language/Haskell/GhcMod/GHCApi.hs

@@ -164,22 +164,25 @@ getDynamicFlags = do
     mlibdir <- getSystemLibDir
     G.runGhc mlibdir G.getSessionDynFlags
 
-withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a
+withDynFlags :: GhcMonad m
-withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)
+             => (DynFlags -> DynFlags)
+             -> m a
+             -> m a
+withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
   where
     setup = do
-        dflag <- G.getSessionDynFlags
+        dflags <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags (setFlag dflag)
+        void $ G.setSessionDynFlags (setFlags dflags)
-        return dflag
+        return dflags
     teardown = void . G.setSessionDynFlags
 
-withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a
+withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
 withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
   where
     setup = do
-        dflag <- G.getSessionDynFlags >>= addCmdOpts flags
+        dflags <- G.getSessionDynFlags >>= addCmdOpts flags
-        void $ G.setSessionDynFlags dflag
+        void $ G.setSessionDynFlags dflags
-        return dflag
+        return dflags
     teardown = void . G.setSessionDynFlags
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Logger.hs

@@ -6,20 +6,21 @@ module Language.Haskell.GhcMod.Logger (
   ) where
 
 import Bag (Bag, bagToList)
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>),(*>))
 import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 import Data.List (isPrefixOf)
 import Data.Maybe (fromMaybe)
 import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
 import Exception (ghandle)
-import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))
+import GHC (DynFlags, SrcSpan, Severity(SevError))
 import qualified GHC as G
 import HscTypes (SourceError, srcErrorMessages)
 import Language.Haskell.GhcMod.Doc (showPage, getStyle)
 import Language.Haskell.GhcMod.GHCApi (withDynFlags, withCmdFlags)
 import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Convert (convert)
+import Language.Haskell.GhcMod.Convert (convert')
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types (Options(..))
 import Outputable (PprStyle, SDoc)
 import System.FilePath (normalise)
@@ -33,11 +34,11 @@ newtype LogRef = LogRef (IORef Builder)
 newLogRef :: IO LogRef
 newLogRef = LogRef <$> newIORef id
 
-readAndClearLogRef :: Options -> LogRef -> IO String
+readAndClearLogRef :: LogRef -> GhcMod String
-readAndClearLogRef opt (LogRef ref) = do
+readAndClearLogRef (LogRef ref) = do
-    b <- readIORef ref
+    b <- liftIO $ readIORef ref
-    writeIORef ref id
+    liftIO $ writeIORef ref id
-    return $! convert opt (b [])
+    convert' (b [])
 
 appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
 appendLogRef df (LogRef ref) _ sev src style msg = do
@@ -47,28 +48,29 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
 ----------------------------------------------------------------
 
 -- | Set the session flag (e.g. "-Wall" or "-w:") then
---   executes a body. Log messages are returned as 'String'.
+--   executes a body. Logged messages are returned as 'String'.
 --   Right is success and Left is failure.
-withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)
+withLogger :: (DynFlags -> DynFlags)
-withLogger opt setDF body = ghandle (sourceError opt) $ do
+           -> GhcMod ()
+           -> GhcMod (Either String String)
+withLogger setDF body = ghandle sourceError $ do
     logref <- liftIO $ newLogRef
+    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
     withDynFlags (setLogger logref . setDF) $ do
-        withCmdFlags wflags $ do
+        withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref)
-            body
-            liftIO $ Right <$> readAndClearLogRef opt logref
   where
     setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
-    wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt
+
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: Options -> SourceError -> Ghc (Either String String)
+sourceError :: SourceError -> GhcMod (Either String String)
-sourceError opt err = do
+sourceError err = do
-    dflag <- G.getSessionDynFlags
+    dflags <- G.getSessionDynFlags
-    style <- getStyle
+    style <- toGhcMod getStyle
-    let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err
+    ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err)
-    return (Left ret)
+    return $ Left ret
 
 errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
 errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList

ghc-mod.cabal

@@ -53,6 +53,7 @@ Library
   GHC-Options:          -Wall
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Ghc
+                        Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Monad
                         Language.Haskell.GhcMod.Internal
   Other-Modules:        Language.Haskell.GhcMod.Boot
@@ -61,7 +62,6 @@ Library
                         Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.Cabal16
                         Language.Haskell.GhcMod.Cabal18
-                        Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Cradle
                         Language.Haskell.GhcMod.Debug

src/GHCMod.hs

@@ -115,11 +115,11 @@ main = flip E.catches handlers $ do
       "flag"    -> listFlags opt
       "browse"  -> runGhcMod opt $ concat <$> mapM browse remainingArgs
       "check"   -> runGhcMod opt $ checkSyntax remainingArgs
-      "expand"  -> expandTemplate opt cradle remainingArgs
+      "expand"  -> runGhcMod opt $ expandTemplate remainingArgs
       "debug"   -> debugInfo opt cradle
       "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
       "type"    -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
-      "find"    -> nArgs 1 $ findSymbol opt cradle cmdArg1
+      "find"    -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
       "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1
       "root"    -> rootInfo opt cradle
       "doc"     -> nArgs 1 $ packageDoc opt cradle cmdArg1

src/GHCModi.hs

@@ -35,6 +35,7 @@ import GHC (Ghc)
 import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Ghc
+import Language.Haskell.GhcMod.Convert (convert')
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
@@ -126,7 +127,7 @@ run _ _ opt body = runGhcMod opt $ do
 
 setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO ()
 setupDB cradle mlibdir opt mvar = E.handle handler $ do
-    db <- run cradle mlibdir opt (toGhcMod getSymMdlDb)
+    db <- run cradle mlibdir opt getSymMdlDb
     putMVar mvar db
   where
     handler (SomeException _) = return () -- fixme: put emptyDb?
@@ -140,7 +141,7 @@ loop opt set mvar = do
         arg = dropWhile (== ' ') arg'
     (ret,ok,set') <- case cmd of
         "check"  -> checkStx opt set arg
-        "find"   -> toGhcMod $ findSym  opt set arg mvar
+        "find"   -> findSym set arg mvar
         "lint"   -> toGhcMod $ lintStx  opt set arg
         "info"   -> toGhcMod $ showInfo opt set arg
         "type"   -> toGhcMod $ showType opt set arg
@@ -199,11 +200,11 @@ isSameMainFile file (Just x)
 
 ----------------------------------------------------------------
 
-findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb
+findSym :: Set FilePath -> String -> MVar SymMdlDb
-        -> Ghc (String, Bool, Set FilePath)
+        -> GhcMod (String, Bool, Set FilePath)
-findSym opt set sym mvar = do
+findSym set sym mvar = do
     db <- liftIO $ readMVar mvar
-    let ret = lookupSym opt sym db
+    ret <- convert' $ lookupSym sym db
     return (ret, True, set)
 
 lintStx :: Options -> Set FilePath -> FilePath

test/CheckSpec.hs

@@ -35,6 +35,5 @@ spec = do
         context "without errors" $ do
             it "doesn't output empty line" $ do
                 withDirectory_ "test/data/ghc-mod-check/Data" $ do
-                    cradle <- findCradleWithoutSandbox
+                    res <- runID $ checkSyntax ["Foo.hs"]
-                    res <- checkSyntax defaultOptions cradle ["Foo.hs"]
                     res `shouldBe` ""