Migrate the remaining parts of the exposed API to GhcMod a

src/GHCModi.hs

@@ -31,12 +31,12 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Exception (ghandle)
 import GHC (GhcMonad)
 import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Ghc
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
@@ -98,12 +98,11 @@ main = E.handle cmdHandler $
     go (opt,_) = E.handle someHandler $ do
         cradle0 <- findCradle
         let rootdir = cradleRootDir cradle0
-            cradle = cradle0 { cradleCurrentDir = rootdir }
+--            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
         setCurrentDirectory rootdir
         mvar <- liftIO newEmptyMVar
-        mlibdir <- getSystemLibDir
-        void $ forkIO $ setupDB cradle mlibdir opt mvar
-        run cradle mlibdir opt $ loop opt S.empty mvar
+        void $ forkIO $ runGhcMod opt $ setupDB mvar
+        runGhcMod opt $ loop S.empty mvar
       where
         -- this is just in case.
         -- If an error is caught here, it is a bug of GhcMod library.
@@ -117,31 +116,23 @@ replace (x:xs)    =  x  : replace xs
 
 ----------------------------------------------------------------
 
-run :: Cradle -> Maybe FilePath -> Options -> GhcMod a -> IO a
-run _ _ opt body = runGhcMod opt $ do
-    dflags <- G.getSessionDynFlags
-    G.defaultCleanupHandler dflags body
-
-----------------------------------------------------------------
-
-setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO ()
-setupDB cradle mlibdir opt mvar = E.handle handler $ do
-    db <- run cradle mlibdir opt getSymMdlDb
-    putMVar mvar db
+setupDB :: MVar SymMdlDb -> GhcMod ()
+setupDB mvar = ghandle handler $ do
+    liftIO . putMVar mvar =<< getSymMdlDb
   where
     handler (SomeException _) = return () -- fixme: put emptyDb?
 
 ----------------------------------------------------------------
 
-loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod ()
-loop opt set mvar = do
+loop :: Set FilePath -> MVar SymMdlDb -> GhcMod ()
+loop set mvar = do
     cmdArg <- liftIO getLine
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
     (ret,ok,set') <- case cmd of
-        "check"  -> checkStx opt set arg
+        "check"  -> checkStx set arg
         "find"   -> findSym set arg mvar
-        "lint"   -> toGhcMod $ lintStx  opt set arg
+        "lint"   -> lintStx set arg
         "info"   -> showInfo set arg
         "type"   -> showType set arg
         "split"  -> doSplit set arg
@@ -157,15 +148,14 @@ loop opt set mvar = do
       else do
         liftIO $ putStrLn $ "NG " ++ replace ret
     liftIO $ hFlush stdout
-    when ok $ loop opt set' mvar
+    when ok $ loop set' mvar
 
 ----------------------------------------------------------------
 
-checkStx :: Options
-         -> Set FilePath
+checkStx :: Set FilePath
          -> FilePath
          -> GhcMod (String, Bool, Set FilePath)
-checkStx _ set file = do
+checkStx set file = do
     set' <- toGhcMod $ newFileSet set file
     let files = S.toList set'
     eret <- check files
@@ -209,16 +199,17 @@ findSym set sym mvar = do
     let ret = lookupSym' opt sym db
     return (ret, True, set)
 
-lintStx :: GhcMonad m
-        => Options -> Set FilePath -> FilePath
-        -> m (String, Bool, Set FilePath)
-lintStx opt set optFile = liftIO $ do
-    ret <-lintSyntax opt' file
+lintStx :: Set FilePath
+        -> FilePath
+        -> GhcMod (String, Bool, Set FilePath)
+lintStx set optFile = do
+    ret <- local env' $ lint file
     return (ret, True, set)
   where
     (opts,file) = parseLintOptions optFile
     hopts = if opts == "" then [] else read opts
-    opt' = opt { hlintOpts = hopts }
+    env' e = e { gmOptions = opt' $ gmOptions e }
+    opt' o = o { hlintOpts = hopts }
 
 -- |
 -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"