ghc-mod 5.4.0.0 → 5.5.0.0

raw patch · 62 files changed

+2452/−1525 lines, 62 filesdep +binarydep +optparse-applicativedep +safedep −asyncdep −cerealdep ~cabal-helperdep ~doctestdep ~hspecsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, optparse-applicative, safe

Dependencies removed: async, cereal

Dependency ranges changed: cabal-helper, doctest, hspec

API changes (from Hackage documentation)

Files

• ChangeLog +18/−0
• Data/Binary/Generic.hs +134/−0
• Language/Haskell/GhcMod.hs +2/−0
• Language/Haskell/GhcMod/Boot.hs +1/−1
• Language/Haskell/GhcMod/Browse.hs +22/−19
• Language/Haskell/GhcMod/CabalHelper.hs +79/−60
• Language/Haskell/GhcMod/Caching.hs +72/−34
• Language/Haskell/GhcMod/Caching/Types.hs +20/−5
• Language/Haskell/GhcMod/Cradle.hs +21/−8
• Language/Haskell/GhcMod/CustomPackageDb.hs +16/−3
• Language/Haskell/GhcMod/Debug.hs +3/−2
• Language/Haskell/GhcMod/DebugLogger.hs +48/−0
• Language/Haskell/GhcMod/DynFlags.hs +4/−4
• Language/Haskell/GhcMod/Error.hs +0/−5
• Language/Haskell/GhcMod/FileMapping.hs +35/−4
• Language/Haskell/GhcMod/Find.hs +86/−67
• Language/Haskell/GhcMod/Gap.hs +12/−1
• Language/Haskell/GhcMod/Internal.hs +0/−7
• Language/Haskell/GhcMod/Lint.hs +5/−5
• Language/Haskell/GhcMod/Logging.hs +15/−3
• Language/Haskell/GhcMod/Modules.hs +5/−4
• Language/Haskell/GhcMod/Monad.hs +30/−18
• Language/Haskell/GhcMod/Monad/Compat.hs_h +28/−0
• Language/Haskell/GhcMod/Monad/Env.hs +68/−0
• Language/Haskell/GhcMod/Monad/Log.hs +71/−0
• Language/Haskell/GhcMod/Monad/Newtypes.hs +176/−0
• Language/Haskell/GhcMod/Monad/Orphans.hs +83/−0
• Language/Haskell/GhcMod/Monad/Out.hs +52/−0
• Language/Haskell/GhcMod/Monad/State.hs +67/−0
• Language/Haskell/GhcMod/Monad/Types.hs +34/−360
• Language/Haskell/GhcMod/Output.hs +22/−8
• Language/Haskell/GhcMod/PathsAndFiles.hs +10/−1
• Language/Haskell/GhcMod/Stack.hs +11/−6
• Language/Haskell/GhcMod/Target.hs +59/−62
• Language/Haskell/GhcMod/Test.hs +45/−0
• Language/Haskell/GhcMod/Types.hs +53/−65
• Language/Haskell/GhcMod/Utils.hs +2/−2
• Language/Haskell/GhcMod/World.hs +1/−1
• Setup.hs +5/−1
• System/Directory/ModTime.hs +63/−0
• Utils.hs +3/−14
• elisp/ghc-comp.el +1/−1
• elisp/ghc-info.el +1/−7
• elisp/ghc-process.el +27/−19
• elisp/ghc.el +1/−1
• ghc-mod.cabal +73/−51
• src/GHCMod.hs +84/−598
• src/GHCMod/Options.hs +201/−0
• src/GHCMod/Options/Commands.hs +292/−0
• src/GHCMod/Options/DocUtils.hs +48/−0
• src/GHCMod/Options/Help.hs +79/−0
• src/GHCMod/Options/ShellParse.hs +44/−0
• src/GHCMod/Version.hs +32/−0
• src/GHCModi.hs +1/−1
• src/Misc.hs +0/−48
• test/BrowseSpec.hs +6/−6
• test/FileMappingSpec.hs +12/−4
• test/LintSpec.hs +2/−2
• test/ListSpec.hs +1/−1
• test/MonadSpec.hs +29/−0
• test/ShellParseSpec.hs +34/−0
• test/TestUtils.hs +3/−16

@@ -1,3 +1,21 @@+2016-01-19 v5.5.0.0+	* Fix #660, cabal-helper errors when no global GHC is installed (Stack)+	* Fix #665, Reinstate internally managed CWD (no more `ghc-mod root`+	  requirement for frontends)+	* Merge #707, Support for spaces in file names when using+	  legacy-interactive+	* Merge #694, #706, #703, Rewrite command line parser using+	  optparse-applicative. Thanks @lierdakil!+	* Merge #693, Fix slowdown and bugs caused by excessive use of+	  `map-file`+	* Fix #678, "No instance nor default method for class operation put"+	* Fix #683, #684, a variety of caching related issues+	* Fix #666, The issue of the beast >:3+	* Merge #649, elisp: Add ghc-report-errors to inhibit *GHC Error*+	  logging+	* Fix #621, Preserve Cabal flag selection across automatic+	  reconfiguration+ 2015-09-16 v5.4.0.0 	* Add support for the Stack build tool 	* Fix #554, `module not interpreted` errors when using the `type`

@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,+    ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Generic+-- Copyright   : Bryan O'Sullivan+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>+-- Stability   : unstable+-- Portability : Only works with GHC 7.2 and newer+--+-- Instances for supporting GHC generics.+--+-----------------------------------------------------------------------------+module Data.Binary.Generic where++import Control.Applicative+import Data.Binary+import Data.Bits+import GHC.Generics+import Prelude++class GGBinary f where+    ggput :: f t -> Put+    ggget :: Get (f t)++-- Type without constructors+instance GGBinary V1 where+    ggput _ = return ()+    ggget   = return undefined++-- Constructor without arguments+instance GGBinary U1 where+    ggput U1 = return ()+    ggget    = return U1++-- Product: constructor with parameters+instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where+    ggput (x :*: y) = ggput x >> ggput y+    ggget = (:*:) <$> ggget <*> ggget++-- Metadata (constructor name, etc)+instance GGBinary a => GGBinary (M1 i c a) where+    ggput = ggput . unM1+    ggget = M1 <$> ggget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GGBinary (K1 i a) where+    ggput = put . unK1+    ggget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GGBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , GGBinary a, GGBinary b+         , SumSize    a, SumSize    b) => GGBinary (a :+: b) where+    ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)+         | otherwise = sizeError "encode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)+    {-# INLINE ggput #-}++    ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)+    {-# INLINE ggget #-}++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b, GGBinary a, GGBinary b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE getSum #-}++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE putSum #-}++instance GGBinary a => GSum (C1 c a) where+    getSum _ _ = ggget+    {-# INLINE getSum #-}++    putSum !code _ x = put code *> ggput x+    {-# INLINE putSum #-}++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word64++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++                       unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+    sumSize = Tagged 1

@@ -44,6 +44,7 @@   , pkgDoc   , rootInfo   , types+  , test   , splits   , sig   , refine@@ -88,3 +89,4 @@ import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.FileMapping+import Language.Haskell.GhcMod.Test

@@ -12,7 +12,7 @@ boot :: IOish m => GhcModT m String boot = concat <$> sequence ms   where-    ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]+    ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]  preBrowsedModules :: [String] preBrowsedModules = [

@@ -1,7 +1,9 @@ module Language.Haskell.GhcMod.Browse (-    browse+    browse,+    BrowseOpts(..)   ) where +import Safe import Control.Applicative import Control.Exception (SomeException(..)) import Data.Char@@ -13,8 +15,9 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) import Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.Logging import Name (getOccString) import Outputable import TyCon (isAlgTyCon)@@ -25,29 +28,29 @@ ----------------------------------------------------------------  -- | Getting functions, classes, etc from a module.---   If 'detailed' is 'True', their types are also obtained.---   If 'operators' is 'True', operators are also returned. browse :: forall m. IOish m-       => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")-       -> GhcModT m String-browse pkgmdl = do+           => BrowseOpts -- ^ Configuration parameters+           -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")+           -> GhcModT m String+browse opts pkgmdl = do     convert' . sort =<< go   where     -- TODO: Add API to Gm.Target to check if module is home module without     -- bringing up a GHC session as well then this can be made a lot cleaner-    go = ghandle (\(SomeException _) -> return []) $ do+    go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do       goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) +    logException ex =+        gmLog GmException "browse" $ showDoc ex+     goPkgModule = do-      opt <- options       runGmPkgGhc $-        processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid+        processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid      goHomeModule = runGmlT [Right mdlname] $ do-      opt <- options-      processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing+      processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing -    tryModuleInfo m = fromJust <$> G.getModuleInfo m+    tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m      (mpkg, mdl) = splitPkgMdl pkgmdl     mdlname = G.mkModuleName mdl@@ -76,31 +79,31 @@ isNotOp _ = error "isNotOp"  processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)-               => Options -> ModuleInfo -> m [String]+               => BrowseOpts -> ModuleInfo -> m [String] processExports opt minfo = do   let     removeOps-      | optOperators opt = id+      | optBrowseOperators opt = id       | otherwise = filter (isNotOp . getOccString)   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo  showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)-           => Options -> ModuleInfo -> Name -> m String+           => BrowseOpts -> ModuleInfo -> Name -> m 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` optQualified opt+    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt     mtype :: m (Maybe String)     mtype-      | optDetailed opt = do+      | optBrowseDetailed opt = do         tyInfo <- G.modInfoLookupName minfo e         -- If nothing found, load dependent module and lookup global         tyResult <- maybe (inOtherModule e) (return . Just) tyInfo         dflag <- G.getSessionDynFlags         return $ do           typeName <- tyResult >>= showThing dflag-          (" :: " ++ typeName) `justIf` optDetailed opt+          (" :: " ++ typeName) `justIf` optBrowseDetailed opt       | otherwise = return Nothing     formatOp nm       | null nm    = error "formatOp"

@@ -21,6 +21,7 @@   , getGhcMergedPkgOptions   , getCabalPackageDbStack   , prepareCabalHelper+  , withAutogen   ) #endif   where@@ -30,7 +31,8 @@ import Control.Category ((.)) import Data.Maybe import Data.Monoid-import Data.Serialize (Serialize)+import Data.Version+import Data.Binary (Binary) import Data.Traversable import Distribution.Helper hiding (Programs(..)) import qualified Distribution.Helper as CH@@ -58,7 +60,7 @@   cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),   cacheFile = mergedPkgOptsCacheFile distdir,   cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do-    opts <- withCabal $ runCHQuery ghcMergedPkgOptions+    opts <- runCHQuery ghcMergedPkgOptions     return ([setupConfigPath distdir], opts)  } @@ -68,7 +70,7 @@   cacheFile = pkgDbStackCacheFile distdir,   cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do     crdl <- cradle-    dbs <- withCabal $ map chPkgToGhcPkg <$>+    dbs <- map chPkgToGhcPkg <$>              runCHQuery packageDbStack     return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)  }@@ -85,7 +87,7 @@ -- 'resolveGmComponents'. getComponents :: (Applicative m, IOish m, Gm m)               => m [GmComponent 'GMCRaw ChEntrypoint]-getComponents = chCached$ \distdir -> Cached {+getComponents = chCached $ \distdir -> Cached {     cacheLens = Just (lGmcComponents . lGmCaches),     cacheFile = cabalHelperCacheFile distdir,     cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do@@ -111,79 +113,101 @@                  , (a', c) <- lc                  , a == a'                  ]-runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b-runCHQuery a = do++getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv+getQueryEnv = do   crdl <- cradle+  progs <- patchStackPrograms crdl =<< (optPrograms <$> options)+  readProc <- gmReadProcess   let projdir = cradleRootDir crdl       distdir = projdir </> cradleDistDir crdl--  opts <- options-  progs <- patchStackPrograms crdl (optPrograms opts)--  readProc <- gmReadProcess+  return (defaultQueryEnv projdir distdir) {+                  qeReadProcess = readProc+                , qePrograms = helperProgs progs+                } -  let qe = (defaultQueryEnv projdir distdir) {-               qeReadProcess = readProc-             , qePrograms = helperProgs progs-             }+runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b+runCHQuery a = do+  qe <- getQueryEnv   runQuery qe a   prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () prepareCabalHelper = do   crdl <- cradle-  let projdir = cradleRootDir crdl-      distdir = projdir </> cradleDistDir crdl-  readProc <- gmReadProcess   when (isCabalHelperProject $ cradleProject crdl) $-       withCabal $ liftIO $ prepare readProc projdir distdir+       withCabal $ prepare' =<< getQueryEnv -withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a-withCabal action = do+withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a+withAutogen action = do+    gmLog GmDebug "" $ strDoc $ "making sure autogen files exist"     crdl <- cradle-    opts <- options-    readProc <- gmReadProcess-     let projdir = cradleRootDir crdl         distdir = projdir </> cradleDistDir crdl +    (pkgName', _) <- runCHQuery packageId+     mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl-    mCabalConfig        <- liftIO $ timeMaybe (setupConfigFile crdl)-    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)+    mCabalMacroHeader   <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)+    mCabalPathsModule   <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName') -    mCusPkgDbStack <- getCustomPkgDbStack+    when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do+      gmLog GmDebug "" $ strDoc $ "autogen files out of sync"+      writeAutogen -    pkgDbStackOutOfSync <--         case mCusPkgDbStack of-           Just cusPkgDbStack -> do-             let qe = (defaultQueryEnv projdir distdir) {-                          qeReadProcess = readProc-                        , qePrograms = helperProgs $ optPrograms opts-                        }-             pkgDb <- runQuery qe $ map chPkgToGhcPkg <$> packageDbStack-             return $ pkgDb /= cusPkgDbStack+    action -           Nothing -> return False+ where+   writeAutogen = do+     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"+     writeAutogenFiles' =<< getQueryEnv -    proj <- cradleProject <$> cradle +withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a+withCabal action = do+    crdl <- cradle+    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalConfig        <- liftIO $ timeMaybe (setupConfigFile crdl)+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)++    let haveSetupConfig = isJust mCabalConfig++    cusPkgDb <- getCustomPkgDbStack+    (flgs, pkgDbStackOutOfSync) <- do+      if haveSetupConfig+        then runCHQuery $ do+          flgs <- nonDefaultConfigFlags+          pkgDb <- map chPkgToGhcPkg <$> packageDbStack+          return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb)+        else return ([], False)+     when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $-      gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."+      gmLog GmDebug "" $ strDoc $ "setup configuration is out of date"      when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $-      gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date, reconfiguring Cabal project."+      gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date"      when pkgDbStackOutOfSync $-      gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."+      gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack"      when ( isSetupConfigOutOfDate mCabalFile mCabalConfig         || pkgDbStackOutOfSync-        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $+        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do+          proj <- cradleProject <$> cradle+          opts <- options           case proj of-            CabalProject ->-                cabalReconfigure readProc (optPrograms opts) crdl projdir distdir-            StackProject {} ->+            CabalProject -> do+                gmLog GmDebug "" $ strDoc "reconfiguring Cabal project"+                cabalReconfigure (optPrograms opts) crdl flgs+            StackProject {} -> do+                gmLog GmDebug "" $ strDoc "reconfiguring Stack project"+                -- TODO: we could support flags for stack too, but it seems+                -- you're supposed to put those in stack.yaml so detecting which+                -- flags to pass down would be more difficult +                -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml+                -- (applies to local packages and extra-deps)"+                 stackReconfigure crdl (optPrograms opts)             _ ->                 error $ "withCabal: unsupported project type: " ++ show proj@@ -191,13 +215,8 @@     action   where-   writeAutogen projdir distdir = do+   cabalReconfigure progs crdl flgs = do      readProc <- gmReadProcess-     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"-     liftIO $ writeAutogenFiles readProc projdir distdir---   cabalReconfigure readProc progs crdl projdir distdir = do      withDirectory_ (cradleRootDir crdl) $ do         cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack         let progOpts =@@ -208,20 +227,20 @@                      then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]                      else []                 ++ map pkgDbArg cusPkgStack-        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""-        writeAutogen projdir distdir+                ++ flagOpt -   stackReconfigure crdl progs = do-     let projdir = cradleRootDir crdl-         distdir = projdir </> cradleDistDir crdl+            toFlag (f, True) = f+            toFlag (f, False) = '-':f+            flagOpt = ["--flags", unwords $ map toFlag flgs] +        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""+   stackReconfigure crdl progs = do      withDirectory_ (cradleRootDir crdl) $ do        supported <- haveStackSupport        if supported           then do             spawn [T.stackProgram progs, "build", "--only-dependencies", "."]             spawn [T.stackProgram progs, "build", "--only-configure", "."]-            writeAutogen projdir distdir           else             gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)" @@ -268,7 +287,7 @@     ghcPkgProgram = T.ghcPkgProgram progs   } -chCached :: (Applicative m, IOish m, Gm m, Serialize a)+chCached :: (Applicative m, IOish m, Gm m, Binary a)   => (FilePath -> Cached m GhcModState ChCacheData a) -> m a chCached c = do   projdir <- cradleRootDir <$> cradle@@ -276,7 +295,7 @@   d <- cacheInputData projdir   withCabal $ cached projdir (c distdir) d  where-   -- we don't need to include the disdir in the cache input because when it+   -- we don't need to include the distdir in the cache input because when it    -- changes the cache files will be gone anyways ;)    cacheInputData projdir = do                opts <- options@@ -284,7 +303,7 @@                progs' <- patchStackPrograms crdl (optPrograms opts)                return $ ( helperProgs progs'                         , projdir-                        , (gmVer, chVer)+                        , (showVersion gmVer, chVer)                         )     gmVer = GhcMod.version

@@ -1,4 +1,19 @@-{-# LANGUAGE OverloadedStrings #-}+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE CPP, OverloadedStrings #-} module Language.Haskell.GhcMod.Caching (     module Language.Haskell.GhcMod.Caching   , module Language.Haskell.GhcMod.Caching.Types@@ -7,64 +22,75 @@ import Control.Arrow (first) import Control.Monad import Control.Monad.Trans.Maybe+#if !MIN_VERSION_binary(0,7,0)+import Control.Exception+#endif import Data.Maybe-import Data.Serialize (Serialize, encode, decode)+import Data.Binary hiding (get) import Data.Version import Data.Label+import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import System.FilePath+import System.Directory.ModTime import Utils (TimedFile(..), timeMaybe, mightExist) import Paths_ghc_mod (version)+import Prelude  import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Caching.Types import Language.Haskell.GhcMod.Logging  -- | Cache a MonadIO action with proper invalidation.-cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize d, Show d)+cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d)        => FilePath -- ^ Directory to prepend to 'cacheFile'        -> Cached m GhcModState d a -- ^ Cache descriptor        -> d        -> m a cached dir cd d = do     mcc <- readCache-    tcfile <- liftIO $ timeMaybe (cacheFile cd)     case mcc of-      Nothing ->-          writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable"-      Just (ifs, d', a) | d /= d' -> do-          tcf <- timeCacheInput dir (cacheFile cd) ifs-          writeCache tcf (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'-      Just (ifs, _, a) -> do-          tcf <- timeCacheInput dir (cacheFile cd) ifs-          case invalidatingInputFiles tcf of-            Just [] -> return a-            Just _  -> writeCache tcf (Just a) "input files changed"-            Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?"+      Nothing -> do+          t <- liftIO $ getCurrentModTime+          writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable"+      Just (t, ifs, d', a) | d /= d' -> do+          tcfs <- timeCacheInput dir ifs+          writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'+      Just (t, ifs, _, a) -> do+          tcfs <- timeCacheInput dir ifs+          case invalidatingInputFiles $ TimedCacheFiles t tcfs of+            [] -> return a+            _  -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed"   where    cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" -   writeCache tcf ma cause = do-     (ifs', a) <- (cachedAction cd) tcf d ma+   lbsToStrict = BS.concat . LBS.toChunks+   lbsFromStrict bs = LBS.fromChunks [bs]++   writeCache tcfs ma cause = do+     (ifs', a) <- (cachedAction cd) tcfs d ma+     t <- liftIO $ getCurrentModTime      gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)                                                     <+> parens (text cause)      case cacheLens cd of        Nothing -> return ()        Just label -> do          gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)-         setLabel label $ Just (ifs', d, a)+         setLabel label $ Just (t, ifs', d, a) -     liftIO $ BS.writeFile (dir </> cacheFile cd) $-         BS.append cacheHeader $ encode (ifs', d, a)+     let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a)++     liftIO $ BS.writeFile (dir </> cacheFile cd) c+      return a     setLabel l x = do      s <- gmsGet      gmsPut $ set l x s -   readCache :: m (Maybe ([FilePath], d, a))+   readCache :: m (Maybe (ModTime, [FilePath], d, a))    readCache = runMaybeT $ do        case cacheLens cd of          Just label -> do@@ -74,30 +100,42 @@          Nothing ->              readCacheFromFile +   readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a)    readCacheFromFile = do          f <- MaybeT $ liftIO $ mightExist $ cacheFile cd          readCacheFromFile' f +   readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a)    readCacheFromFile' f = MaybeT $ do      gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)      cc <- liftIO $ BS.readFile f      case first BS8.words $ BS8.span (/='\n') cc of        (["Written", "by", "ghc-mod", ver], rest)            | BS8.unpack ver == showVersion version ->-            return $ either (const Nothing) Just $ decode $ BS.drop 1 rest+            either (const Nothing) Just+                `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)        _ -> return Nothing -timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles-timeCacheInput dir cfile ifs = liftIO $ do-    -- TODO: is checking the times this way around race free?+   decodeE b = do+#if MIN_VERSION_binary(0,7,0)+     return $ case decodeOrFail b of+       Left (_rest, _offset, errmsg) -> Left errmsg+       Right (_reset, _offset, a) -> Right a+#else+     ea <- liftIO $ try $ evaluate $ decode b+     return $ case ea of+       Left (ErrorCall errmsg) -> Left errmsg+       Right a -> Right a++#endif++timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile]+timeCacheInput dir ifs = liftIO $ do     ins <- (timeMaybe . (dir </>)) `mapM` ifs-    mtcfile <- timeMaybe cfile-    return $ TimedCacheFiles mtcfile (catMaybes ins)+    return $ catMaybes ins -invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath]-invalidatingInputFiles tcf =-    case tcCacheFile tcf of-      Nothing -> Nothing-      Just tcfile -> Just $ map tfPath $-                     -- get input files older than tcfile-                     filter (tcfile<) $ tcFiles tcf+invalidatingInputFiles :: TimedCacheFiles -> [FilePath]+invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =+    map tfPath $+        -- get input files older than tcfile+        filter ((TimedFile "" tcreated)<) tcfs

@@ -1,11 +1,26 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. module Language.Haskell.GhcMod.Caching.Types where  import Utils import Data.Label-import Data.Version+import System.Directory.ModTime import Distribution.Helper -type CacheContents d a = Maybe ([FilePath], d, a)+type CacheContents d a = Maybe (ModTime, [FilePath], d, a) type CacheLens s d a = s :-> CacheContents d a  data Cached m s d a = Cached {@@ -43,10 +58,10 @@  }  data TimedCacheFiles = TimedCacheFiles {-  tcCacheFile :: Maybe TimedFile,+  tcCreated :: ModTime,   -- ^ 'cacheFile' timestamp   tcFiles     :: [TimedFile]   -- ^ Timestamped files returned by the cached action- } deriving (Eq, Ord, Show)+ } deriving (Eq, Ord) -type ChCacheData = (Programs, FilePath, (Version, [Char]))+type ChCacheData = (Programs, FilePath, (String, String))

@@ -4,6 +4,7 @@   (     findCradle   , findCradle'+  , findCradleNoLog   , findSpecCradle   , cleanupCradle   )@@ -15,14 +16,17 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Stack+import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Error +import Safe import Control.Applicative-import Control.Monad import Control.Monad.Trans.Maybe import Data.Maybe import System.Directory import System.FilePath import Prelude+import Control.Monad.Trans.Journal (runJournalT)  ---------------------------------------------------------------- @@ -30,19 +34,22 @@ --   Find a cabal file by tracing ancestor directories. --   Find a sandbox according to a cabal sandbox config --   in a cabal directory.-findCradle :: (IOish m, GmOut m) => m Cradle+findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle findCradle = findCradle' =<< liftIO getCurrentDirectory -findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle+findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle+findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))++findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle findCradle' dir = run $     msum [ stackCradle dir          , cabalCradle dir          , sandboxCradle dir          , plainCradle dir          ]- where run a = fillTempDir =<< (fromJust <$> runMaybeT a)+ where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a) -findSpecCradle :: (IOish m, GmOut m) => FilePath -> m Cradle+findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle findSpecCradle dir = do     let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]     cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs@@ -77,8 +84,12 @@       , cradleDistDir    = "dist"       } -stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle+stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle stackCradle wdir = do+#if !MIN_VERSION_ghc(7,8,0)+    -- GHC < 7.8 is not supported by stack+    mzero+#endif     cabalFile <- MaybeT $ liftIO $ findCabalFile wdir      let cabalDir = takeDirectory cabalFile@@ -87,7 +98,9 @@      -- If dist/setup-config already exists the user probably wants to use cabal     -- rather than stack, or maybe that's just me ;)-    whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero+    whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do+      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."+      mzero      senv <- MaybeT $ getStackEnv cabalDir @@ -100,7 +113,7 @@       , cradleDistDir    = seDistDir senv       } -stackCradleSpec :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle+stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle stackCradleSpec wdir = do   crdl <- stackCradle wdir   case crdl of

@@ -1,6 +1,20 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. module Language.Haskell.GhcMod.CustomPackageDb where - import Control.Applicative import Control.Monad import Control.Category ((.))@@ -11,7 +25,6 @@ import Language.Haskell.GhcMod.PathsAndFiles import Prelude hiding ((.)) - parseCustomPackageDb :: String -> [GhcPkgDb] parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src  where@@ -19,7 +32,7 @@    parsePkgDb "user" = UserDb    parsePkgDb s = PackageDb s -getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])+getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb]) getCustomPkgDbStack = do     mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle     return $ parseCustomPackageDb <$> mCusPkgDbFile

@@ -3,6 +3,7 @@ import Control.Arrow (first) import Control.Applicative import Control.Monad+import Control.Monad.Trans.Journal import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char@@ -138,5 +139,5 @@ ----------------------------------------------------------------  -- | Obtaining root information.-rootInfo :: (IOish m, GmOut m) => m String-rootInfo = (++"\n") . cradleRootDir <$> findCradle+rootInfo :: forall m. (IOish m, GmOut m) => m String+rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))

@@ -1,6 +1,54 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.DebugLogger where +-- (c) The University of Glasgow 2005+--+-- The Glasgow Haskell Compiler License+--+-- Copyright 2002, The University Court of the University of Glasgow.+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- - Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- - Redistributions in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.+--+-- - Neither name of the University nor the names of its contributors may be+-- used to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+-- DAMAGE.  import GHC import FastString

@@ -25,8 +25,8 @@ -- * Friendly to foreign export -- * Not friendly to -XTemplateHaskell and -XPatternSynonyms -- * Uses little memory-setModeSimple :: DynFlags -> DynFlags-setModeSimple df = df {+setHscNothing :: DynFlags -> DynFlags+setHscNothing df = df {     ghcMode   = CompManager   , ghcLink   = NoLink   , hscTarget = HscNothing@@ -37,8 +37,8 @@ -- * Not friendly to foreign export -- * Friendly to -XTemplateHaskell and -XPatternSynonyms -- * Uses lots of memory-setModeIntelligent :: DynFlags -> DynFlags-setModeIntelligent df = df {+setHscInterpreted :: DynFlags -> DynFlags+setHscInterpreted df = df {     ghcMode   = CompManager   , ghcLink   = LinkInMemory   , hscTarget = HscInterpreted

@@ -104,11 +104,6 @@     GMETooManyCabalFiles cfs ->         text $ "Multiple cabal files found. Possible cabal files: \""                ++ intercalate "\", \"" cfs ++"\"."-    GMEWrongWorkingDirectory projdir cdir ->-        (text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.")-          <+> text "Currently in:" <+> showDoc cdir-          <> text "but should be in" <+> showDoc projdir-          <> text "."  ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) =

@@ -20,10 +20,30 @@ import GHC import Control.Monad -loadMappedFile :: IOish m => FilePath -> FilePath -> GhcModT m ()+{- | maps 'FilePath', given as first argument to take source from+'FilePath' given as second argument. Works exactly the same as+first form of `--map-file` CLI option.++\'from\' can be either full path, or path relative to project root.+\'to\' has to be either relative to project root, or full path (preferred)+-}+loadMappedFile :: IOish m+               => FilePath -- ^ \'from\', file that will be mapped+               -> FilePath -- ^ \'to\', file to take source from+               -> GhcModT m () loadMappedFile from to = loadMappedFile' from to False -loadMappedFileSource :: IOish m => FilePath -> String -> GhcModT m ()+{- |+maps 'FilePath', given as first argument to have source as given+by second argument.++\'from\' may or may not exist, and should be either full path,+or relative to project root.+-}+loadMappedFileSource :: IOish m+                     => FilePath -- ^ \'from\', file that will be mapped+                     -> String -- ^ \'src\', source+                     -> GhcModT m () loadMappedFileSource from src = do   tmpdir <- cradleTempDir `fmap` cradle   to <- liftIO $ do@@ -37,7 +57,9 @@ loadMappedFile' from to isTemp = do   cfn <- getCanonicalFileNameSafe from   unloadMappedFile' cfn-  addMMappedFile cfn (FileMapping to isTemp)+  crdl <- cradle+  let to' = makeRelative (cradleRootDir crdl) to+  addMMappedFile cfn (FileMapping to' isTemp)  mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>             HscEnv -> Target -> m Target@@ -57,7 +79,16 @@   return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing -unloadMappedFile :: IOish m => FilePath -> GhcModT m ()+{-|+unloads previously mapped file \'file\', so that it's no longer mapped,+and removes any temporary files created when file was+mapped.++\'file\' should be either full path, or relative to project root.+-}+unloadMappedFile :: IOish m+                 => FilePath -- ^ \'file\', file to unmap+                 -> GhcModT m () unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile'  unloadMappedFile' :: IOish m => FilePath -> GhcModT m ()

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}+{-# LANGUAGE CPP, DeriveGeneric #-}  module Language.Haskell.GhcMod.Find #ifndef SPEC@@ -10,32 +10,41 @@   , findSymbol   , lookupSym   , isOutdated+  -- * Load 'SymbolDb' asynchronously+  , AsyncSymbolDb+  , newAsyncSymbolDb+  , getAsyncSymbolDb   ) #endif   where -import Control.Applicative-import Control.Monad (when, void)-import Data.Function (on)-import Data.List (groupBy, sort)-import qualified GHC as G import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Gap (listVisibleModules)+import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.PathsAndFiles+import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.World (timedPackageCaches)-import Language.Haskell.GhcMod.Output-import Name (getOccString)-import Module (moduleName)-import System.Directory (doesFileExist, getModificationTime)-import System.FilePath ((</>))-import System.IO-import Prelude+import Language.Haskell.GhcMod.World +import qualified GHC as G+import Name+import Module+import Exception++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Control+import Control.Concurrent+import Control.DeepSeq+import Data.Function+import Data.List+import qualified Data.ByteString.Lazy as BS+import Data.Binary+import GHC.Generics (Generic) import Data.Map (Map) import qualified Data.Map as M+import System.Directory.ModTime+import Prelude  ---------------------------------------------------------------- @@ -43,22 +52,23 @@ type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. data SymbolDb = SymbolDb-  { table             :: Map Symbol [ModuleString]-  , symbolDbCachePath :: FilePath-  } deriving (Show)+  { sdTable             :: Map Symbol [ModuleString]+  , sdTimestamp         :: ModTime+  } deriving (Generic) +instance Binary SymbolDb+instance NFData SymbolDb+ isOutdated :: IOish m => SymbolDb -> GhcModT m Bool isOutdated db =-  (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches+  isOlderThan (sdTimestamp db) <$> timedPackageCaches  ----------------------------------------------------------------  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => Symbol -> GhcModT m String-findSymbol sym = do-  tmpdir <- cradleTempDir <$> cradle-  loadSymbolDb tmpdir >>= lookupSymbol sym+findSymbol sym = loadSymbolDb >>= lookupSymbol sym  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated.@@ -66,62 +76,36 @@ lookupSymbol sym db = convert' $ lookupSym sym db  lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym db = M.findWithDefault [] sym $ table db+lookupSym sym db = M.findWithDefault [] sym $ sdTable db  ---------------------------------------------------------------  -- | Loading a file and creates 'SymbolDb'.-loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb-loadSymbolDb dir = do+loadSymbolDb :: IOish m => GhcModT m SymbolDb+loadSymbolDb = do   ghcMod <- liftIO ghcModExecutable-  readProc <- gmReadProcess-  file   <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""-  !db    <- M.fromAscList . map conv . lines <$> liftIO (readFile file)-  return $ SymbolDb-    { table             = db-    , symbolDbCachePath = file-    }-  where-    conv :: String -> (Symbol, [ModuleString])-    conv = read-    chop :: String -> String-    chop "" = ""-    chop xs = init xs+  readProc <- gmReadProcess'+  out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""+  return $!! decode out  ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' --- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file---   if the file does not exist or is invalid.---   The file name is printed.--dumpSymbol :: IOish m => FilePath -> GhcModT m String-dumpSymbol dir = do-  create <- (liftIO . isOlderThan cache) =<< timedPackageCaches-  runGmPkgGhc $ do-    when create $-      liftIO . writeSymbolCache cache =<< getGlobalSymbolTable-    return $ unlines [cache]-  where-    cache = dir </> symbolCacheFile--writeSymbolCache :: FilePath-                 -> [(Symbol, [ModuleString])]-                 -> IO ()-writeSymbolCache cache sm =-  void . withFile cache WriteMode $ \hdl ->-    mapM (hPrint hdl) sm+-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout+dumpSymbol :: IOish m => GhcModT m ()+dumpSymbol = do+  ts <- liftIO getCurrentModTime+  st <- runGmPkgGhc getGlobalSymbolTable+  liftIO . BS.putStr $ encode SymbolDb {+      sdTable = M.fromAscList st+    , sdTimestamp = ts+    }  -- | Check whether given file is older than any file from the given set. -- Returns True if given file does not exist.-isOlderThan :: FilePath -> [TimedFile] -> IO Bool-isOlderThan cache files = do-  exist <- doesFileExist cache-  if not exist-  then return True-  else do-    tCache <- getModificationTime cache-    return $ any (tCache <=) $ map tfTime files -- including equal just in case+isOlderThan :: ModTime -> [TimedFile] -> Bool+isOlderThan tCache files =+  any (tCache <=) $ map tfTime files -- including equal just in case  -- | Browsing all functions in all system modules. getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]@@ -146,3 +130,38 @@ collectModules = map tieup . groupBy ((==) `on` fst) . sort   where     tieup x = (head (map fst x), map snd x)++----------------------------------------------------------------++data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb))++asyncLoadSymbolDb :: IOish m+                  => MVar (Either SomeException SymbolDb)+                  -> GhcModT m ()+asyncLoadSymbolDb mv = void $+    liftBaseWith $ \run -> forkIO $ void $ run $ do+      edb <- gtry loadSymbolDb+      liftIO $ putMVar mv edb++newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb+newAsyncSymbolDb = do+    mv <- liftIO newEmptyMVar+    asyncLoadSymbolDb mv+    return $ AsyncSymbolDb mv++getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb+getAsyncSymbolDb (AsyncSymbolDb mv) = do+  db <- liftIO $ handleEx <$> takeMVar mv+  outdated <- isOutdated db+  if outdated+    then do+      asyncLoadSymbolDb mv+      liftIO $ handleEx <$> readMVar mv+    else do+      liftIO $ putMVar mv $ Right db+      return db+ where+   handleEx edb =+     case edb of+       Left ex -> throw ex+       Right db -> db

@@ -101,6 +101,11 @@ import qualified Data.IntSet as I (IntSet, empty) #endif +#if __GLASGOW_HASKELL__ < 706+import Control.DeepSeq (NFData(rnf))+import Data.ByteString.Lazy.Internal (ByteString(..))+#endif+ import Bag import Lexer as L import Parser@@ -370,7 +375,7 @@                                         (char '\t' <> ptext (sLit "--") <+> loc)                          where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #else-    pprTyThingInContextLoc' pefas thing' = hang (pprTyThingInContext pefas thing') 2+    pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2                                     (char '\t' <> ptext (sLit "--") <+> loc)                                where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #endif@@ -563,4 +568,10 @@ mkErrStyle' = Outputable.mkErrStyle #else mkErrStyle' _ = Outputable.mkErrStyle+#endif++#if __GLASGOW_HASKELL__ < 706+instance NFData ByteString where+  rnf Empty       = ()+  rnf (Chunk _ b) = rnf b #endif

@@ -3,10 +3,6 @@ module Language.Haskell.GhcMod.Internal (   -- * Types     GHCOption-  , Package-  , PackageBaseName-  , PackageVersion-  , PackageId   , IncludeDir   , GmlT(..)   , MonadIO(..)@@ -21,7 +17,6 @@   -- * Environment, state and logging   , GhcModEnv(..)   , GhcModState-  , CompilerMode(..)   , GhcModLog   , GmLog(..)   , GmLogLevel(..)@@ -38,8 +33,6 @@   -- ** Accessing 'GhcModEnv' and 'GhcModState'   , options   , cradle-  , getCompilerMode-  , setCompilerMode   , targetGhcOptions   , withOptions   -- * 'GhcModError'

@@ -4,8 +4,8 @@ import Control.Exception (SomeException(..)) import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad import Language.Haskell.HLint (hlint)  import Language.Haskell.GhcMod.Utils (withMappedFile)@@ -15,12 +15,12 @@ -- | Checking syntax of a target file using hlint. --   Warnings and errors are returned. lint :: IOish m-     => FilePath  -- ^ A target file.+     => LintOpts  -- ^ Configuration parameters+     -> FilePath  -- ^ A target file.      -> GhcModT m String-lint file = do-  opt <- options+lint opt file =   withMappedFile file $ \tempfile ->-        liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)+        liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)     >>= mapM (replaceFileName tempfile)     >>= ghandle handler . pack  where

@@ -45,6 +45,11 @@ gmSetLogLevel level =     gmlJournal $ GhcModLog (Just level) (Last Nothing) [] +gmGetLogLevel :: forall m. GmLog m => m GmLogLevel+gmGetLogLevel = do+  GhcModLog { gmLogLevel = Just level } <-  gmlHistory+  return level+ gmSetDumpLevel :: GmLog m => Bool -> m () gmSetDumpLevel level =     gmlJournal $ GhcModLog Nothing (Last (Just level)) []@@ -71,12 +76,19 @@    let loc | loc' == "" = empty           | otherwise = text loc' <+>: empty-      msgDoc = gmLogLevelDoc level <+>: sep [loc, doc]-      msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc+      msgDoc = sep [loc, doc]+      msg = dropWhileEnd isSpace $ gmRenderDoc $ gmLogLevelDoc level <+>: msgDoc    when (level <= level') $ gmErrStrLn msg+  gmLogQuiet level loc' doc -  gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])+gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m ()+gmLogQuiet level loc doc =+  gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)])++gmAppendLogQuiet :: GmLog m => GhcModLog -> m ()+gmAppendLogQuiet GhcModLog { gmLogMessages } =+    forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc  gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m () gmVomit filename doc content = do

@@ -14,13 +14,14 @@ ----------------------------------------------------------------  -- | Listing installed modules.-modules :: (IOish m, Gm m) => m String-modules = do-  Options { optDetailed } <- options+modules :: (IOish m, Gm m)+        => Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to.+        -> m String+modules detailed = do   df <- runGmPkgGhc G.getSessionDynFlags   let mns = listVisibleModuleNames df       pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)-  convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn+  convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn                  | (mn, pkgs) <- pmnss, pkg <- pkgs ]  where    modulePkg df = lookupModulePackageInAllPackages df

@@ -50,31 +50,41 @@ import Exception  import System.Directory+import System.IO.Unsafe import Prelude -withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a withGhcModEnv = withGhcModEnv' withCradle  where    withCradle dir =-       gbracket (findCradle' dir) (liftIO . cleanupCradle)+       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst) -withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a+cwdLock :: MVar ThreadId+cwdLock = unsafePerformIO $ newEmptyMVar+{-# NOINLINE cwdLock #-}++withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a withGhcModEnv' withCradle dir opts f =-    withCradle dir $ \crdl ->+    withCradle dir $ \(crdl,lg) ->       withCradleRootDir crdl $-        f $ GhcModEnv opts crdl+        f (GhcModEnv opts crdl, lg)  where+   swapCurrentDirectory ndir = do+     odir <- canonicalizePath =<< getCurrentDirectory+     setCurrentDirectory ndir+     return odir+    withCradleRootDir (cradleRootDir -> projdir) a = do-       cdir <- liftIO $ getCurrentDirectory-       eq <- liftIO $ pathsEqual projdir cdir-       if not eq-          then throw $ GMEWrongWorkingDirectory projdir cdir-          else a+       success <- liftIO $ tryPutMVar cwdLock =<< myThreadId+       if not success+         then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!"+         else gbracket setup teardown (const a)+    where+      setup = liftIO $ swapCurrentDirectory projdir -   pathsEqual a b = do-     ca <- canonicalizePath a-     cb <- canonicalizePath b-     return $ ca == cb+      teardown odir = liftIO $ do+        setCurrentDirectory odir+        void $ takeMVar cwdLock  runGmOutT :: IOish m => Options -> GmOutT m a -> m a runGmOutT opts ma = do@@ -91,15 +101,17 @@ runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma  -- | Run a @GhcModT m@ computation.-runGhcModT :: (IOish m, GmOut m)+runGhcModT :: IOish m            => Options            -> GhcModT m a            -> m (Either GhcModError a, GhcModLog) runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do     runGmOutT opt $-      withGhcModEnv dir' opt $ \env ->-        first (fst <$>) <$> runGhcModT' env defaultGhcModState-          (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)+      withGhcModEnv dir' opt $ \(env,lg) ->+        first (fst <$>) <$> runGhcModT' env defaultGhcModState (do+          gmSetLogLevel (ooptLogLevel $ optOutput opt)+          gmAppendLogQuiet lg+          action)  -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the

@@ -0,0 +1,28 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.+-- RWST does not automatically become an instance of MonadIO.+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.+-- So, RWST automatically becomes an instance of+#if __GLASGOW_HASKELL__ < 708+-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different+-- classes before ghc 7.8+#define DIFFERENT_MONADIO 1++-- RWST doen't have a MonadIO instance before ghc 7.8+#define MONADIO_INSTANCES 1+#endif

@@ -0,0 +1,68 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Language.Haskell.GhcMod.Monad.Env where++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Error (ErrorT(..))+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmEnv m where+    gmeAsk :: m GhcModEnv+    gmeAsk = gmeReader id++    gmeReader :: (GhcModEnv -> a) -> m a+    gmeReader f = f `liftM` gmeAsk++    gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a+    {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}++instance Monad m => GmEnv (GmT m) where+    gmeAsk = GmT ask+    gmeReader = GmT . reader+    gmeLocal f a = GmT $ local f (unGmT a)++instance GmEnv m => GmEnv (GmOutT m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (StateT s m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (JournalT GhcModLog m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (ErrorT GhcModError m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m)

@@ -0,0 +1,71 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Language.Haskell.GhcMod.Monad.Log where++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Error (Error, ErrorT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Journal.Class (MonadJournal(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmLog m where+    gmlJournal :: GhcModLog -> m ()+    gmlHistory :: m GhcModLog+    gmlClear   :: m ()++instance Monad m => GmLog (JournalT GhcModLog m) where+    gmlJournal = journal+    gmlHistory = history+    gmlClear   = clear++instance Monad m => GmLog (GmT m) where+    gmlJournal = GmT . lift . lift . journal+    gmlHistory = GmT $ lift $ lift history+    gmlClear   = GmT $ lift $ lift clear++instance (Monad m, GmLog m) => GmLog (ReaderT r m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift  gmlClear++instance (Monad m, GmLog m) => GmLog (StateT s m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++instance (Monad m, GmLog m) => GmLog (MaybeT m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++deriving instance GmLog m => GmLog (GmOutT m)+deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m)

@@ -0,0 +1,176 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE RankNTypes, FlexibleInstances #-}++module Language.Haskell.GhcMod.Monad.Newtypes where++#include "Compat.hs_h"++import Language.Haskell.GhcMod.Types++import GHC++import Control.Applicative+import Control.Monad++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.Error (ErrorT(..), MonadError(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Reader.Class+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Journal.Class (MonadJournal(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control+import Control.Monad.Base (MonadBase(..), liftBase)++import Data.IORef+import Prelude++type GhcModT m = GmT (GmOutT m)++newtype GmOutT m a = GmOutT {+      unGmOutT :: ReaderT GhcModOut m a+    } deriving ( Functor+             , Applicative+             , Alternative+             , Monad+             , MonadPlus+             , MonadTrans+             )++newtype GmT m a = GmT {+      unGmT :: StateT GhcModState+                 (ErrorT GhcModError+                   (JournalT GhcModLog+                     (ReaderT GhcModEnv m) ) ) a+    } deriving ( Functor+               , Applicative+               , Alternative+               , Monad+               , MonadPlus+               , MonadError GhcModError+               )++newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }+    deriving ( Functor+             , Applicative+             , Alternative+             , Monad+             , MonadPlus+             , MonadError GhcModError+             )++newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }+    deriving ( Functor+             , Applicative+             , Monad+             )++-- GmOutT ----------------------------------------+instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where+    liftBase = GmOutT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where+    type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmOutT where+    type StT GmOutT a = StT (ReaderT GhcModEnv) a+    liftWith = defaultLiftWith GmOutT unGmOutT+    restoreT = defaultRestoreT GmOutT+++-- GmlT ------------------------------------------+instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where+    liftBase = GmlT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where+    type StM (GmlT m) a = StM (GmT m) a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmlT where+    type StT GmlT a = StT GmT a+    liftWith f = GmlT $+      liftWith $ \runGm ->+        liftWith $ \runEnv ->+          f $ \ma -> runEnv $ runGm $ unGmlT ma+    restoreT = GmlT . restoreT . restoreT++instance MonadTrans GmlT where+    lift = GmlT . lift . lift++-- GmT ------------------------------------------++instance forall r m. MonadReader r m => MonadReader r (GmT m) where+    local f ma = gmLiftWithInner (\run -> local f (run ma))+    ask = gmLiftInner ask++instance MonadState s m => MonadState s (GmT m) where+    get = GmT $ lift $ lift $ lift get+    put = GmT . lift . lift . lift . put+    state = GmT . lift . lift . lift . state++instance Monad m => MonadJournal GhcModLog (GmT m) where+  journal  w = GmT $ lift $ lift $ (journal w)+  history    = GmT $ lift $ lift $ history+  clear      = GmT $ lift $ lift $ clear++instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where+    liftBase = GmT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where+    type StM (GmT m) a =+          StM (StateT GhcModState+                (ErrorT GhcModError+                  (JournalT GhcModLog+                    (ReaderT GhcModEnv m) ) ) ) a+    liftBaseWith f = GmT (liftBaseWith $ \runInBase ->+        f $ runInBase . unGmT)+    restoreM = GmT . restoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmT where+    type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)+    liftWith f = GmT $+      liftWith $ \runS ->+        liftWith $ \runE ->+          liftWith $ \runJ ->+            liftWith $ \runR ->+              f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma+    restoreT = GmT . restoreT . restoreT . restoreT . restoreT+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++instance MonadTrans GmT where+    lift = GmT . lift . lift . lift . lift++gmLiftInner :: Monad m => m a -> GmT m a+gmLiftInner = GmT . lift . lift . lift . lift++gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))+                => (Run t -> m (StT t a)) -> t m a+gmLiftWithInner f = liftWith f >>= restoreT . return

@@ -0,0 +1,83 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.Haskell.GhcMod.Monad.Orphans where++#include "Compat.hs_h"++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Newtypes++#if DIFFERENT_MONADIO+import qualified MonadUtils as GHC (MonadIO(..))+#endif+import qualified Control.Monad.IO.Class as MTL++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Error (Error(..), ErrorT(..))++--------------------------------------------------+-- Miscellaneous instances++#if DIFFERENT_MONADIO+instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m)+deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m)+deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m)+deriving instance GHC.MonadIO LightGhc+#endif++deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m)+deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m)+deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m)+deriving instance MTL.MonadIO LightGhc++instance MonadIO IO where+    liftIO = id+instance MonadIO m => MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmOutT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmlT m) where+    liftIO = MTL.liftIO+instance MonadIO LightGhc where+    liftIO = MTL.liftIO

@@ -0,0 +1,52 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++module Language.Haskell.GhcMod.Monad.Out where++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmOut m where+    gmoAsk :: m GhcModOut++instance Monad m => GmOut (GmOutT m) where+    gmoAsk = GmOutT ask++instance Monad m => GmOut (GmlT m) where+    gmoAsk = GmlT $ lift $ GmOutT ask++instance GmOut m => GmOut (GmT m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (StateT s m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (JournalT w m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (MaybeT m) where+    gmoAsk = lift gmoAsk

@@ -0,0 +1,67 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Language.Haskell.GhcMod.Monad.State where++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmState m where+    gmsGet :: m GhcModState+    gmsGet = gmsState (\s -> (s, s))++    gmsPut :: GhcModState -> m ()+    gmsPut s = gmsState (\_ -> ((), s))++    gmsState :: (GhcModState -> (a, GhcModState)) -> m a+    gmsState f = do+      s <- gmsGet+      let ~(a, s') = f s+      gmsPut s'+      return a+    {-# MINIMAL gmsState | gmsGet, gmsPut #-}++instance GmState m => GmState (StateT s m) where+    gmsGet = lift gmsGet+    gmsPut = lift . gmsPut+    gmsState = lift . gmsState++instance Monad m => GmState (StateT GhcModState m) where+    gmsGet = get+    gmsPut = put+    gmsState = state++instance Monad m => GmState (GmT m) where+    gmsGet = GmT get+    gmsPut = GmT . put+    gmsState = GmT . state++instance GmState m => GmState (MaybeT m) where+    gmsGet = MaybeT $ Just `liftM` gmsGet+    gmsPut = MaybeT . (Just `liftM`) . gmsPut+    gmsState = MaybeT . (Just `liftM`) . gmsState++deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m)

@@ -36,7 +36,6 @@   , defaultGhcModState   , GmGhcSession(..)   , GmComponent(..)-  , CompilerMode(..)   -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'   , GmLogLevel(..)   , GhcModLog(..)@@ -50,8 +49,6 @@   , options   , outputOpts   , withOptions-  , getCompilerMode-  , setCompilerMode   , getMMappedFiles   , setMMappedFiles   , addMMappedFile@@ -65,21 +62,19 @@   , gmlSetSession   ) where --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.--- RWST does not automatically become an instance of MonadIO.--- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.--- So, RWST automatically becomes an instance of-#if __GLASGOW_HASKELL__ < 708--- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different--- classes before ghc 7.8-#define DIFFERENT_MONADIO 1---- RWST doen't have a MonadIO instance before ghc 7.8-#define MONADIO_INSTANCES 1-#endif+#include "Compat.hs_h"  import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Env+import Language.Haskell.GhcMod.Monad.State+import Language.Haskell.GhcMod.Monad.Log+import Language.Haskell.GhcMod.Monad.Out+import Language.Haskell.GhcMod.Monad.Newtypes+import Language.Haskell.GhcMod.Monad.Orphans ()++import Safe+ import GHC import DynFlags import Exception@@ -89,355 +84,23 @@ import Control.Monad  import Control.Monad.Reader (ReaderT(..))-import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT)-import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Maybe (MaybeT) -import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control  import Control.Monad.Reader.Class-import Control.Monad.Writer.Class-import Control.Monad.State.Class (MonadState(..))-import Control.Monad.Journal.Class (MonadJournal(..))-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Error (Error(..))-import qualified Control.Monad.IO.Class as MTL -#if DIFFERENT_MONADIO-import Data.Monoid (Monoid)-#endif- import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.IORef import Prelude -import qualified MonadUtils as GHC (MonadIO(..))--type GhcModT m = GmT (GmOutT m)--newtype GmOutT m a = GmOutT {-      unGmOutT :: ReaderT GhcModOut m a-    } deriving ( Functor-             , Applicative-             , Alternative-             , Monad-             , MonadPlus-             , MonadTrans-             , MTL.MonadIO-#if DIFFERENT_MONADIO-             , GHC.MonadIO-#endif-             , GmLog-             )--newtype GmT m a = GmT {-      unGmT :: StateT GhcModState-                 (ErrorT GhcModError-                   (JournalT GhcModLog-                     (ReaderT GhcModEnv m) ) ) a-    } deriving ( Functor-               , Applicative-               , Alternative-               , Monad-               , MonadPlus-               , MTL.MonadIO-#if DIFFERENT_MONADIO-               , GHC.MonadIO-#endif-               , MonadError GhcModError-               )--newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }-    deriving ( Functor-             , Applicative-             , Alternative-             , Monad-             , MonadPlus-             , MTL.MonadIO-#if DIFFERENT_MONADIO-             , GHC.MonadIO-#endif-             , MonadError GhcModError-             , GmEnv-             , GmState-             , GmLog-             )--newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }-    deriving ( Functor-             , Applicative-             , Monad-             , MTL.MonadIO-#if DIFFERENT_MONADIO-             , GHC.MonadIO-#endif-             )------------------------------------------------------- Miscellaneous instances--#if DIFFERENT_MONADIO-instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where-    liftIO = MTL.liftIO-instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where-    liftIO = MTL.liftIO-instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where-    liftIO = MTL.liftIO-instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where-    liftIO = MTL.liftIO-instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where-    liftIO = MTL.liftIO-#endif--instance MonadIO IO where-    liftIO = id-instance MonadIO m => MonadIO (ReaderT x m) where-    liftIO = MTL.liftIO-instance MonadIO m => MonadIO (StateT x m) where-    liftIO = MTL.liftIO-instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where-    liftIO = MTL.liftIO-instance MonadIO m => MonadIO (JournalT x m) where-    liftIO = MTL.liftIO-instance MonadIO m => MonadIO (MaybeT m) where-    liftIO = MTL.liftIO-instance MonadIOC m => MonadIO (GmOutT m) where-    liftIO = MTL.liftIO-instance MonadIOC m => MonadIO (GmT m) where-    liftIO = MTL.liftIO-instance MonadIOC m => MonadIO (GmlT m) where-    liftIO = MTL.liftIO-instance MonadIO LightGhc where-    liftIO = MTL.liftIO--instance MonadTrans GmT where-    lift = GmT . lift . lift . lift . lift-instance MonadTrans GmlT where-    lift = GmlT . lift . lift------------------------------------------------------- Gm Classes- type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) --- GmEnv ------------------------------------------class Monad m => GmEnv m where-    gmeAsk :: m GhcModEnv-    gmeAsk = gmeReader id--    gmeReader :: (GhcModEnv -> a) -> m a-    gmeReader f = f `liftM` gmeAsk--    gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a-    {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}--instance Monad m => GmEnv (GmT m) where-    gmeAsk = GmT ask-    gmeReader = GmT . reader-    gmeLocal f a = GmT $ local f (unGmT a)--instance GmEnv m => GmEnv (GmOutT m) where-    gmeAsk = lift gmeAsk-    gmeReader = lift . gmeReader-    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))--instance GmEnv m => GmEnv (StateT s m) where-    gmeAsk = lift gmeAsk-    gmeReader = lift . gmeReader-    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))--instance GmEnv m => GmEnv (JournalT GhcModLog m) where-    gmeAsk = lift gmeAsk-    gmeReader = lift . gmeReader-    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))--instance GmEnv m => GmEnv (ErrorT GhcModError m) where-    gmeAsk = lift gmeAsk-    gmeReader = lift . gmeReader-    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))---- GmState ----------------------------------------class Monad m => GmState m where-    gmsGet :: m GhcModState-    gmsGet = gmsState (\s -> (s, s))--    gmsPut :: GhcModState -> m ()-    gmsPut s = gmsState (\_ -> ((), s))--    gmsState :: (GhcModState -> (a, GhcModState)) -> m a-    gmsState f = do-      s <- gmsGet-      let ~(a, s') = f s-      gmsPut s'-      return a-    {-# MINIMAL gmsState | gmsGet, gmsPut #-}--instance GmState m => GmState (StateT s m) where-    gmsGet = lift gmsGet-    gmsPut = lift . gmsPut-    gmsState = lift . gmsState--instance Monad m => GmState (StateT GhcModState m) where-    gmsGet = get-    gmsPut = put-    gmsState = state--instance Monad m => GmState (GmT m) where-    gmsGet = GmT get-    gmsPut = GmT . put-    gmsState = GmT . state--instance GmState m => GmState (MaybeT m) where-    gmsGet = MaybeT $ Just `liftM` gmsGet-    gmsPut = MaybeT . (Just `liftM`) . gmsPut-    gmsState = MaybeT . (Just `liftM`) . gmsState---- GmLog ------------------------------------------class Monad m => GmLog m where-    gmlJournal :: GhcModLog -> m ()-    gmlHistory :: m GhcModLog-    gmlClear   :: m ()--instance Monad m => GmLog (JournalT GhcModLog m) where-    gmlJournal = journal-    gmlHistory = history-    gmlClear   = clear--instance Monad m => GmLog (GmT m) where-    gmlJournal = GmT . lift . lift . journal-    gmlHistory = GmT $ lift $ lift history-    gmlClear   = GmT $ lift $ lift clear--instance (Monad m, GmLog m) => GmLog (ReaderT r m) where-    gmlJournal = lift . gmlJournal-    gmlHistory = lift gmlHistory-    gmlClear = lift  gmlClear--instance (Monad m, GmLog m) => GmLog (StateT s m) where-    gmlJournal = lift . gmlJournal-    gmlHistory = lift gmlHistory-    gmlClear = lift gmlClear---- GmOut ------------------------------------------class Monad m => GmOut m where-    gmoAsk :: m GhcModOut--instance Monad m => GmOut (GmOutT m) where-    gmoAsk = GmOutT ask--instance Monad m => GmOut (GmlT m) where-    gmoAsk = GmlT $ lift $ GmOutT ask--instance GmOut m => GmOut (GmT m) where-    gmoAsk = lift gmoAsk--instance GmOut m => GmOut (StateT s m) where-    gmoAsk = lift gmoAsk--instance Monad m => MonadJournal GhcModLog (GmT m) where-  journal !w = GmT $ lift $ lift $ (journal w)-  history    = GmT $ lift $ lift $ history-  clear      = GmT $ lift $ lift $ clear--instance forall r m. MonadReader r m => MonadReader r (GmT m) where-    local f ma = gmLiftWithInner (\run -> local f (run ma))-    ask = gmLiftInner ask--instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where-    tell = gmLiftInner . tell-    listen ma =-      liftWith (\run -> listen (run ma)) >>= \(sta, w) ->-          flip (,) w `liftM` restoreT (return sta)--    pass maww = maww >>= gmLiftInner . pass . return--instance MonadState s m => MonadState s (GmT m) where-    get = GmT $ lift $ lift $ lift get-    put = GmT . lift . lift . lift . put-    state = GmT . lift . lift . lift . state-- ----------------------------------------------------- monad-control instances---- GmOutT -----------------------------------------instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where-    liftBase = GmOutT . liftBase--instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where-    type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a-    liftBaseWith = defaultLiftBaseWith-    restoreM = defaultRestoreM-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}--instance MonadTransControl GmOutT where-    type StT GmOutT a = StT (ReaderT GhcModEnv) a-    liftWith = defaultLiftWith GmOutT unGmOutT-    restoreT = defaultRestoreT GmOutT----- GmlT -------------------------------------------instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where-    liftBase = GmlT . liftBase--instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where-    type StM (GmlT m) a = StM (GmT m) a-    liftBaseWith = defaultLiftBaseWith-    restoreM = defaultRestoreM-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}--instance MonadTransControl GmlT where-    type StT GmlT a = StT GmT a-    liftWith f = GmlT $-      liftWith $ \runGm ->-        liftWith $ \runEnv ->-          f $ \ma -> runEnv $ runGm $ unGmlT ma-    restoreT = GmlT . restoreT . restoreT----- GmT --------------------------------------------instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where-    liftBase = GmT . liftBase--instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where-    type StM (GmT m) a =-          StM (StateT GhcModState-                (ErrorT GhcModError-                  (JournalT GhcModLog-                    (ReaderT GhcModEnv m) ) ) ) a-    liftBaseWith f = GmT (liftBaseWith $ \runInBase ->-        f $ runInBase . unGmT)-    restoreM = GmT . restoreM-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}--instance MonadTransControl GmT where-    type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)-    liftWith f = GmT $-      liftWith $ \runS ->-        liftWith $ \runE ->-          liftWith $ \runJ ->-            liftWith $ \runR ->-              f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma-    restoreT = GmT . restoreT . restoreT . restoreT . restoreT-    {-# INLINE liftWith #-}-    {-# INLINE restoreT #-}--gmLiftInner :: Monad m => m a -> GmT m a-gmLiftInner = GmT . lift . lift . lift . lift--gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))-                => (Run t -> m (StT t a)) -> t m a-gmLiftWithInner f = liftWith f >>= restoreT . return---------------------------------------------------- -- GHC API instances -----------------------------  -- GHC cannot prove the following instances to be decidable automatically using@@ -452,19 +115,21 @@     getSession = gmlGetSession     setSession = gmlSetSession +-- | Get the underlying GHC session gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession = do-        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet-        GHC.liftIO $ readIORef ref+        ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet+        liftIO $ readIORef ref +-- | Set the underlying GHC session gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () gmlSetSession a = do-        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet-        GHC.liftIO $ flip writeIORef a ref+        ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet+        liftIO $ flip writeIORef a ref  instance GhcMonad LightGhc where-    getSession = (GHC.liftIO . readIORef) =<< LightGhc ask-    setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask+    getSession = (liftIO . readIORef) =<< LightGhc ask+    setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask  #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where@@ -519,6 +184,21 @@     gmask = liftBaseOp gmask . liftRestore      where liftRestore f r = f $ liftBaseOp_ r +instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++ ----------------------------------------------------------------  options :: GmEnv m => m Options@@ -529,12 +209,6 @@  cradle :: GmEnv m => m Cradle cradle = gmCradle `liftM` gmeAsk--getCompilerMode :: GmState m => m CompilerMode-getCompilerMode = gmCompilerMode `liftM` gmsGet--setCompilerMode :: GmState m => CompilerMode -> m ()-setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet  getMMappedFiles :: GmState m => m FileMappingMap getMMappedFiles = gmMMappedFiles `liftM` gmsGet

@@ -17,6 +17,7 @@ -- Derived from process:System.Process -- Copyright (c) The University of Glasgow 2004-2008 +{-# LANGUAGE FlexibleInstances #-} module Language.Haskell.GhcMod.Output (     gmPutStr   , gmErrStr@@ -27,12 +28,15 @@   , gmErrStrIO    , gmReadProcess+  , gmReadProcess'    , stdoutGateway   , flushStdoutGateway   ) where  import Data.List+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS import qualified Data.Label as L import qualified Data.Label.Base as LB import System.IO@@ -51,7 +55,17 @@  import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..)) import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))+import Language.Haskell.GhcMod.Gap () +class ProcessOutput a where+  hGetContents' :: Handle -> IO a++instance ProcessOutput String where+  hGetContents' = hGetContents++instance ProcessOutput ByteString where+  hGetContents' = BS.hGetContents+ outputFns :: (GmOut m, MonadIO m')           => m (String -> m' (), String -> m' ()) outputFns =@@ -108,6 +122,9 @@     Nothing ->         return $ readProcess +gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString)+gmReadProcess' = readProcessStderrChan+ flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () flushStdoutGateway c = do   mv <- newEmptyMVar@@ -175,17 +192,14 @@       return (a', L.set l s' f)  readProcessStderrChan ::-    GmOut m => m (FilePath -> [String] -> String -> IO String)+    (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) readProcessStderrChan = do   (_, e :: String -> IO ()) <- outputFns   return $ readProcessStderrChan' e -readProcessStderrChan' ::-    (String -> IO ()) -> FilePath -> [String] -> String -> IO String-readProcessStderrChan' pute = go pute- where-   go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String-   go putErr exe args input = do+readProcessStderrChan' :: (ProcessOutput a, NFData a) =>+    (String -> IO ()) -> FilePath -> [String] -> String -> IO a+readProcessStderrChan' putErr exe args input = do      let cp = (proc exe args) {                 std_out = CreatePipe               , std_err = CreatePipe@@ -195,7 +209,7 @@       _ <- forkIO $ reader e -     output  <- hGetContents o+     output  <- hGetContents' o      withForkWait (evaluate $ rnf output) $ \waitOut -> do         -- now write any input

@@ -200,7 +200,16 @@  -- localBuildInfoFile defaultDistPref  macrosHeaderPath :: FilePath-macrosHeaderPath = "build/autogen/cabal_macros.h"+macrosHeaderPath = autogenModulesDir </> "cabal_macros.h"++autogenModulePath :: String -> String+autogenModulePath pkg_name =+    autogenModulesDir </> ("Paths_" ++ map fixchar pkg_name) <.> ".hs"+  where fixchar '-' = '_'+        fixchar c   = c++autogenModulesDir :: FilePath+autogenModulesDir = "build" </> "autogen"  ghcSandboxPkgDbDir :: String -> String ghcSandboxPkgDbDir buildPlatf = do

@@ -16,7 +16,7 @@  module Language.Haskell.GhcMod.Stack where -+import Safe import Control.Applicative import Control.Exception as E import Control.Monad@@ -33,6 +33,8 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Output+import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Error import qualified Language.Haskell.GhcMod.Utils as U import Prelude @@ -46,10 +48,10 @@     } patchStackPrograms _crdl progs = return progs -getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)+getStackEnv :: (IOish m, GmOut m, GmLog m) => FilePath -> m (Maybe StackEnv) getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do     env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]-    let look k = fromJust $ lookup k env+    let look k = fromJustNote "getStackEnv" $ lookup k env     return StackEnv {         seDistDir       = look "dist-dir"       , seBinPath       = splitSearchPath $ look "bin-path"@@ -80,11 +82,14 @@           exeExtension = if isWindows then "exe" else "" -readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String+readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String readStack args = do   stack <- MaybeT $ liftIO $ findExecutable "stack"   readProc <- lift gmReadProcess-  lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do+  flip gcatch handler $ do     liftIO $ evaluate =<< readProc stack args ""  where-   exToErr = throw . GMEStackBootstrap . GMEString . show+   handler (e :: IOError) = do+     gmLog GmWarning "readStack" $ gmeDoc $ exToErr e+     mzero+   exToErr = GMEStackBootstrap . GMEString . show

@@ -40,6 +40,7 @@ import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.GhcMod.Output +import Safe import Data.Maybe import Data.Monoid as Monoid import Data.Either@@ -104,10 +105,13 @@      Nothing -> return () -+-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a runGmlT fns action = runGmlT' fns return action +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules, with updated GHC flags runGmlT' :: IOish m               => [Either FilePath ModuleName]               -> (DynFlags -> Ghc DynFlags)@@ -115,6 +119,9 @@               -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules, with updated GHC flags and a final+-- transformation runGmlTWith :: IOish m                  => [Either FilePath ModuleName]                  -> (DynFlags -> Ghc DynFlags)@@ -143,7 +150,7 @@                   | otherwise = setEmptyLogger      initSession opts' $-        setModeSimple >>> setLogger >>> mdf+        setHscNothing >>> setLogger >>> mdf      mappedStrs <- getMMappedFilePaths     let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns@@ -182,13 +189,13 @@             let cns = filter (/= ChSetupHsName) $ Map.keys mcs              gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."-            return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs+            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs           else do             when noCandidates $               throwError $ GMECabalCompAssignment mdlcs              let cn = pickComponent candidates-            return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs+            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs  resolvedComponentsCache :: IOish m => FilePath ->     Cached (GhcModT m) GhcModState@@ -199,25 +206,20 @@     cacheFile = resolvedComponentsCacheFile distdir,     cachedAction = \tcfs comps ma -> do         Cradle {..} <- cradle-        let iifsM = invalidatingInputFiles tcfs+        let iifs = invalidatingInputFiles tcfs++            setupChanged =+                (cradleRootDir </> setupConfigPath distdir) `elem` iifs+             mums :: Maybe [Either FilePath ModuleName]             mums =-              case iifsM of-                Nothing -> Nothing-                Just iifs ->-                  let-                      filterOutSetupCfg =-                          filter (/= cradleRootDir </> setupConfigPath distdir)-                      changedFiles = filterOutSetupCfg iifs-                  in if null changedFiles-                       then Nothing-                       else Just $ map Left changedFiles-            setupChanged = maybe False-                                 (elem $ cradleRootDir </> setupConfigPath distdir)-                                 iifsM-        case (setupChanged, ma) of-          (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }-          _ -> return ()+              let+                  filterOutSetupCfg =+                      filter (/= cradleRootDir </> setupConfigPath distdir)+                  changedFiles = filterOutSetupCfg iifs+              in if null changedFiles || setupChanged+                   then Nothing+                   else Just $ map Left changedFiles          let mdesc (Left f) = "file:" ++ f             mdesc (Right mn) = "module:" ++ moduleNameString mn@@ -229,7 +231,8 @@         gmLog GmDebug "resolvedComponentsCache" $               text "files changed" <+>: changedDoc -        mcs <- resolveGmComponents mums comps+        mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps+         return (setupConfigPath distdir : flatten mcs , mcs)  } @@ -334,7 +337,7 @@       rms <- resolveModule env srcDirs `mapM` eps       return c { gmcEntrypoints = Set.fromList $ catMaybes rms } --- TODO: remember that he file from `main-is:` is always module `Main` and let+-- TODO: remember that the file from `main-is:` is always module `Main` and let -- ghc do the warning about it. Right now we run that module through -- resolveModule like any other resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]@@ -387,27 +390,30 @@    --     | makeRelative dir fn /= fn  type CompilationUnit = Either FilePath ModuleName+type Components =+    [GmComponent 'GMCRaw (Set ModulePath)]+type ResolvedComponentsMap =+    Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))  resolveGmComponents :: (IOish m, Gm m)-    => Maybe [CompilationUnit]+    => Maybe ([CompilationUnit], ResolvedComponentsMap)         -- ^ Updated modules-    -> [GmComponent 'GMCRaw (Set ModulePath)]-    -> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))-resolveGmComponents mumns cs = do-    s <- gmsGet-    m' <- foldrM' (gmComponents s) cs $ \c m -> do+    -> Components -> m ResolvedComponentsMap+resolveGmComponents mcache cs = do+    let rcm = fromMaybe Map.empty $ snd <$> mcache++    m' <- foldrM' rcm cs $ \c m -> do         case Map.lookup (gmcName c) m of           Nothing -> insertUpdated m c           Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'                        then return m                        else insertUpdated m c-    gmsPut s { gmComponents = m' }     return m'   where    foldrM' b fa f = foldrM f b fa    insertUpdated m c = do-     rc <- resolveGmComponent mumns c+     rc <- resolveGmComponent (fst <$> mcache) c      return $ Map.insert (gmcName rc) rc m     same :: Eq b@@ -431,21 +437,25 @@      setTargets targets -    mode <- getCompilerMode-    if mode == Intelligent-      then loadTargets' Intelligent-      else do-        mdls <- depanal [] False-        let fallback = needsFallback mdls-        if fallback then do-            resetTargets targets-            setIntelligent-            gmLog GmInfo "loadTargets" $-                text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."-            loadTargets' Intelligent-          else-            loadTargets' Simple+    mg <- depanal [] False +    let interp = needsHscInterpreted mg+    target <- hscTarget <$> getSessionDynFlags+    when (interp && target /= HscInterpreted) $ do+      resetTargets targets+      _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags+      gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."++    target' <- hscTarget <$> getSessionDynFlags++    case target' of+      HscNothing -> do+        void $ load LoadAllTargets+        mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg+      HscInterpreted -> do+        void $ load LoadAllTargets+      _ -> error ("loadTargets: unsupported hscTarget")+     gmLog GmDebug "loadTargets" $ text "Loading done"    where@@ -456,30 +466,16 @@       return $ Target tid taoc src     relativize tgt = return tgt -    loadTargets' Simple = do-        void $ load LoadAllTargets-        mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph--    loadTargets' Intelligent = do-        df <- getSessionDynFlags-        void $ setSessionDynFlags (setModeIntelligent df)-        void $ load LoadAllTargets-     resetTargets targets' = do         setTargets []         void $ load LoadAllTargets         setTargets targets' -    setIntelligent = do-        newdf <- setModeIntelligent <$> getSessionDynFlags-        void $ setSessionDynFlags newdf-        setCompilerMode Intelligent-     showTargetId (Target (TargetModule s) _ _) = moduleNameString s     showTargetId (Target (TargetFile s _) _ _) = s -needsFallback :: ModuleGraph -> Bool-needsFallback = any $ \ms ->+needsHscInterpreted :: ModuleGraph -> Bool+needsHscInterpreted = any $ \ms ->                 let df = ms_hspp_opts ms in                    Opt_TemplateHaskell `xopt` df                 || Opt_QuasiQuotes     `xopt` df@@ -492,4 +488,5 @@ cabalResolvedComponents = do     crdl@(Cradle{..}) <- cradle     comps <- mapM (resolveEntrypoint crdl) =<< getComponents-    cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps+    withAutogen $+      cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps

@@ -0,0 +1,45 @@+module Language.Haskell.GhcMod.Test where++import Control.Applicative+import Data.List+import System.FilePath+import System.Directory+import Prelude++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.DynFlags++import GHC+import GHC.Exception+import OccName++test :: IOish m+      => FilePath -> GhcModT m String+test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do+    mg <- getModuleGraph+    root <- cradleRootDir <$> cradle+    f' <- makeRelative root <$> liftIO (canonicalizePath f)+    let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg+        mdl = ms_mod ms+        mn = moduleName mdl++    Just mi <- getModuleInfo mdl+    let exs = map (occNameString . getOccName) $ modInfoExports mi+        cqs = filter ("prop_" `isPrefixOf`) exs++    setContext [ IIDecl $ simpleImportDecl mn+               , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck"+               ]++    _res <- mapM runTest cqs++    return ""++runTest :: GhcMonad m => String -> m (Maybe SomeException)+runTest fn = do+  res <- runStmt ("quickCheck " ++ fn) RunToCompletion+  return $ case res of+    RunOk [] -> Nothing+    RunException se -> Just se+    _ -> error "runTest"

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,-  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}+  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,+  GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types (     module Language.Haskell.GhcMod.Types@@ -15,9 +16,9 @@ import Control.Applicative import Control.Concurrent import Control.Monad-import Data.Serialize-import Data.Version-import Data.List (intercalate)+import Control.DeepSeq+import Data.Binary+import Data.Binary.Generic import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set)@@ -35,7 +36,6 @@ #endif import GHC (ModuleName, moduleNameString, mkModuleName) import HscTypes (HscEnv)-import PackageConfig (PackageConfig) import GHC.Generics import Text.PrettyPrint (Doc) import Prelude@@ -104,13 +104,6 @@   , optPrograms       :: Programs     -- | GHC command line options set on the @ghc-mod@ command line   , optGhcUserOptions :: [GHCOption]-  -- | If 'True', 'browse' also returns operators.-  , optOperators      :: Bool-  -- | If 'True', 'browse' also returns types.-  , optDetailed       :: Bool-  -- | If 'True', 'browse' will return fully qualified name-  , optQualified      :: Bool-  , optHlintOpts      :: [String]   , optFileMappings   :: [(FilePath, Maybe FilePath)]   } deriving (Show) @@ -130,10 +123,6 @@     , stackProgram   = "stack"     }   , optGhcUserOptions = []-  , optOperators      = False-  , optDetailed       = False-  , optQualified      = False-  , optHlintOpts      = []   , optFileMappings   = []   } @@ -212,17 +201,13 @@  data GhcModState = GhcModState {       gmGhcSession   :: !(Maybe GmGhcSession)-    , gmComponents   :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))-    , gmCompilerMode :: !CompilerMode     , gmCaches       :: !GhcModCaches     , gmMMappedFiles :: !FileMappingMap     } -data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)- defaultGhcModState :: GhcModState defaultGhcModState =-    GhcModState n Map.empty Simple (GhcModCaches n n n n) Map.empty+    GhcModState n (GhcModCaches n n n n) Map.empty  where n = Nothing  ----------------------------------------------------------------@@ -233,7 +218,9 @@               | PackageDb String                 deriving (Eq, Show, Generic) -instance Serialize GhcPkgDb+instance Binary GhcPkgDb where+    put = ggput . from+    get = to `fmap` ggget  -- | A single GHC command line option. type GHCOption = String@@ -241,40 +228,13 @@ -- | An include directory for modules. type IncludeDir = FilePath --- | A package name.-type PackageBaseName = String---- | A package version.-type PackageVersion = String---- | A package id.-type PackageId = String---- | A package's name, verson and id.-type Package = (PackageBaseName, PackageVersion, PackageId)--pkgName :: Package -> PackageBaseName-pkgName (n, _, _) = n--pkgVer :: Package -> PackageVersion-pkgVer (_, v, _) = v--pkgId :: Package -> PackageId-pkgId (_, _, i) = i--showPkg :: Package -> String-showPkg (n, v, _) = intercalate "-" [n, v]--showPkgId :: Package -> String-showPkgId (n, v, i) = intercalate "-" [n, v, i]- -- | Haskell expression. newtype Expression = Expression { getExpression :: String }   deriving (Show, Eq, Ord)  -- | Module name. newtype ModuleString = ModuleString { getModuleString :: String }-  deriving (Show, Read, Eq, Ord)+  deriving (Show, Eq, Ord, Binary, NFData)  data GmLogLevel =     GmSilent@@ -287,14 +247,11 @@   | GmVomit     deriving (Eq, Ord, Enum, Bounded, Show, Read) --- | Collection of packages-type PkgDb = (Map Package PackageConfig)- data GmModuleGraph = GmModuleGraph {     gmgGraph :: Map ModulePath (Set ModulePath)   } deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Serialize GmModuleGraph where+instance Binary GmModuleGraph where   put GmModuleGraph {..} = put (mpim, graph)     where       mpim :: Map ModulePath Integer@@ -334,13 +291,17 @@   , gmcSourceDirs      :: [FilePath]   } deriving (Eq, Ord, Show, Read, Generic, Functor) -instance Serialize eps => Serialize (GmComponent t eps)+instance Binary eps => Binary (GmComponent t eps) where+    put = ggput . from+    get = to `fmap` ggget  data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }   deriving (Eq, Ord, Show, Read, Generic, Typeable)-instance Serialize ModulePath+instance Binary ModulePath where+    put = ggput . from+    get = to `fmap` ggget -instance Serialize ModuleName where+instance Binary ModuleName where   get = mkModuleName <$> get   put mn = put (moduleNameString mn) @@ -388,8 +349,6 @@   | GMETooManyCabalFiles [FilePath]   -- ^ Too many cabal files found. -  | GMEWrongWorkingDirectory FilePath FilePath-     deriving (Eq,Show,Typeable)  instance Error GhcModError where@@ -398,13 +357,42 @@  instance Exception GhcModError -deriving instance Generic Version-instance Serialize Version+instance Binary CabalHelper.Programs where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChModuleName where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChComponentName where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChEntrypoint where+    put = ggput . from+    get = to `fmap` ggget -instance Serialize CabalHelper.Programs-instance Serialize ChModuleName-instance Serialize ChComponentName-instance Serialize ChEntrypoint+-- | Options for "lintWith" function+data LintOpts = LintOpts {+        optLintHlintOpts :: [String]+        -- ^ options that will be passed to hlint executable+      } deriving (Show)++-- | Default "LintOpts" instance+defaultLintOpts :: LintOpts+defaultLintOpts = LintOpts []++-- | Options for "browseWith" function+data BrowseOpts = BrowseOpts {+        optBrowseOperators      :: Bool+        -- ^ If 'True', "browseWith" also returns operators.+      , optBrowseDetailed       :: Bool+        -- ^ If 'True', "browseWith" also returns types.+      , optBrowseQualified      :: Bool+        -- ^ If 'True', "browseWith" will return fully qualified name+    } deriving (Show)++-- | Default "BrowseOpts" instance+defaultBrowseOpts :: BrowseOpts+defaultBrowseOpts = BrowseOpts False False False  mkLabel ''GhcModCaches mkLabel ''GhcModState

@@ -70,8 +70,8 @@       | otherwise               = c  newTempDir :: FilePath -> IO FilePath-newTempDir dir =-  flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory+newTempDir _dir =+  flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory  whenM :: Monad m => m Bool -> m () -> m () whenM mb ma = mb >>= flip when ma

@@ -20,7 +20,7 @@   , worldCabalConfig   :: Maybe TimedFile   , worldCabalSandboxConfig :: Maybe TimedFile   , worldSymbolCache   :: Maybe TimedFile-  } deriving (Eq, Show)+  } deriving (Eq)  timedPackageCaches :: IOish m => GhcModT m [TimedFile] timedPackageCaches = do

@@ -99,7 +99,7 @@         libexecdir'      = fromPathTemplate (libexecdir idirtpl)          pd_extended      = onlyExePackageDesc [exe] pd-        install_target   = fromJust $ installTarget exe+        install_target   = fromJustNote "xInstallTarget" $ installTarget exe         install_target'  = ID.substPathTemplate env install_target         -- $libexec isn't a real thing :/ so we have to simulate it         install_target'' = substLibExec' libexecdir' install_target'@@ -140,6 +140,10 @@     case filter ((=="") . snd) $ readP_to_S parseVersion str of       [(ver, _)] -> ver       _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n"++fromJustNote :: String -> Maybe a -> a+fromJustNote _ (Just x) = x+fromJustNote note Nothing = error $ "fromJustNote ("++note++"): "  -- sanityCheckCabalVersions args cf desc lbi = do --   (cabalInstallVer, cabalVer) <- getCabalExecVer

@@ -0,0 +1,63 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+module System.Directory.ModTime where++import Control.Applicative+import Control.DeepSeq+import Data.Binary+#if MIN_VERSION_directory(1,2,0)+import Data.Time (UTCTime(..), Day(..), getCurrentTime)+#else+import System.Time (ClockTime(..), getClockTime)+#endif+import System.Directory+import Prelude++#if MIN_VERSION_directory(1,2,0)++newtype ModTime = ModTime UTCTime+    deriving (Eq, Ord, NFData)+getCurrentModTime = ModTime <$> getCurrentTime++instance Binary ModTime where+    put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) =+        put day >> put (toRational difftime)+    get =+        ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get))++#else++newtype ModTime = ModTime ClockTime+    deriving (Eq, Ord)+getCurrentModTime = ModTime <$> getClockTime++instance Binary ModTime where+    put (ModTime (TOD s ps)) =+        put s >> put ps+    get =+        ModTime <$> (TOD <$> get <*> get)++instance NFData ModTime where+    rnf (ModTime (TOD s ps)) =+        s `seq` ps `seq` (ModTime $! TOD s ps) `seq` ()++#endif++getCurrentModTime :: IO ModTime++getModTime :: FilePath -> IO ModTime+getModTime f = ModTime <$> getModificationTime f

@@ -4,29 +4,18 @@ import Control.Applicative import Data.Traversable import System.Directory+import System.Directory.ModTime -#if MIN_VERSION_directory(1,2,0)-import Data.Time (UTCTime)-#else-import System.Time (ClockTime)-#endif import Prelude --#if MIN_VERSION_directory(1,2,0)-type ModTime = UTCTime-#else-type ModTime = ClockTime-#endif- data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }-                 deriving (Eq, Show)+                 deriving (Eq)  instance Ord TimedFile where     compare (TimedFile _ a) (TimedFile _ b) = compare a b  timeFile :: FilePath -> IO TimedFile-timeFile f = TimedFile <$> pure f <*> getModificationTime f+timeFile f = TimedFile <$> pure f <*> getModTime f  mightExist :: FilePath -> IO (Maybe FilePath) mightExist f = do

@@ -101,7 +101,7 @@ (defun ghc-boot (n)   (prog2       (message "Initializing...")-      (ghc-sync-process "boot\n" n nil 'skip-map-file)+      (ghc-sync-process "boot\n" n)     (message "Initializing...done")))  (defun ghc-load-modules (mods)

@@ -111,13 +111,7 @@ 	 (cn (int-to-string (1+ (current-column)))) 	 (file (buffer-file-name)) 	 (cmd (format "type %s %s %s\n" file ln cn)))-    (ghc-sync-process cmd nil 'ghc-type-fix-string)))--(defun ghc-type-fix-string ()-  (save-excursion-    (goto-char (point-min))-    (while (search-forward "[Char]" nil t)-      (replace-match "String"))))+    (ghc-sync-process cmd nil)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

@@ -1,3 +1,4 @@+;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-process.el@@ -21,12 +22,11 @@ (defvar-local ghc-process-process-name nil) (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil)-(defvar-local ghc-process-callback nil)-(defvar-local ghc-process-hook nil) (defvar-local ghc-process-root nil)  (defvar ghc-command "ghc-mod") +(defvar ghc-report-errors t "Report GHC errors to *GHC Error* buffer") (defvar ghc-error-buffer "*GHC Error*")  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -34,12 +34,12 @@ (defun ghc-get-project-root ()   (ghc-run-ghc-mod '("root"))) -(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)+(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook)   (unless ghc-process-process-name     (setq ghc-process-process-name (ghc-get-project-root)))   (when (and ghc-process-process-name (not ghc-process-running))     (setq ghc-process-running t)-    (if hook1 (funcall hook1))+    (if sync-before-hook (funcall sync-before-hook))     (let* ((cbuf (current-buffer)) 	   (name ghc-process-process-name) 	   (root (file-name-as-directory ghc-process-process-name))@@ -51,14 +51,13 @@       (ghc-with-current-buffer buf         (setq ghc-process-original-buffer cbuf) 	(setq ghc-process-original-file file)-	(setq ghc-process-hook hook2) 	(setq ghc-process-root root) 	(let ((pro (ghc-get-process cpro name buf root)) 	      (map-cmd (format "map-file %s\n" file)))-	  ;; map-file-	  (unless skip-map-file+;	       (unmap-cmd (format "unmap-file %s\n" file)))+	  (when (buffer-modified-p (current-buffer)) 	    (setq ghc-process-file-mapping t)-	    (setq ghc-process-callback nil)+	    (setq ghc-process-async-after-callback nil) 	    (erase-buffer) 	    (when ghc-debug 	      (ghc-with-debug-buffer@@ -69,7 +68,7 @@ 	      (save-restriction 		(widen) 		(process-send-region pro (point-min) (point-max))))-	    (process-send-string pro "\004\n")+	    (process-send-string pro "\n\004\n") 	    (condition-case nil 		(let ((inhibit-quit nil)) 		  (while ghc-process-file-mapping@@ -78,12 +77,21 @@ 	       (setq ghc-process-running nil) 	       (setq ghc-process-file-mapping nil)))) 	  ;; command-	  (setq ghc-process-callback callback)+	  (setq ghc-process-async-after-callback async-after-callback) 	  (erase-buffer) 	  (when ghc-debug 	    (ghc-with-debug-buffer 	     (insert (format "%% %s" cmd)))) 	  (process-send-string pro cmd)++	  ;;; this needs to be done asyncrounously after the command actually+	  ;;; finished, gah+	  ;; (when do-map-file+	  ;;   (when ghc-debug+	  ;;	 (ghc-with-debug-buffer+	  ;;	  (insert (format "%% %s" unmap-cmd))))+	  ;;   (process-send-string pro unmap-cmd))+ 	  pro)))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -144,7 +152,8 @@ 		    (with-current-buffer pbuf 		      (goto-char (point-max)) 		      (insert-buffer-substring tbuf 1 end))-		  (with-current-buffer (get-buffer-create ghc-error-buffer)+		  (when ghc-report-errors+                    (with-current-buffer (get-buffer-create ghc-error-buffer) 		    (setq buffer-read-only t) 		    (let* ((buffer-read-only nil) 			   (inhibit-read-only t)@@ -156,7 +165,7 @@ 			(goto-char (point-max)) 			(insert-buffer-substring tbuf 1 end) 			(set-buffer-modified-p nil))-		      (redisplay))))+		      (redisplay))))) 		(delete-region 1 end))))) 	(goto-char (point-max)) 	(forward-line -1)@@ -164,13 +173,12 @@ 	 ((looking-at "^OK$") 	  (delete-region (point) (point-max)) 	  (setq ghc-process-file-mapping nil)-	  (when ghc-process-callback-	    (if ghc-process-hook (funcall ghc-process-hook))+	  (when ghc-process-async-after-callback 	    (goto-char (point-min))-	    (funcall ghc-process-callback 'ok)+	    (funcall ghc-process-async-after-callback 'ok) 	    (setq ghc-process-running nil))) 	 ((looking-at "^NG ")-	  (funcall ghc-process-callback 'ng)+	  (funcall ghc-process-async-after-callback 'ng) 	  (setq ghc-process-running nil)))))))  (defun ghc-process-sentinel (_process _event)@@ -183,12 +191,12 @@ (defvar ghc-process-num-of-results nil) (defvar ghc-process-results nil) -(defun ghc-sync-process (cmd &optional n hook skip-map-file)+(defun ghc-sync-process (cmd &optional n)   (unless ghc-process-running     (setq ghc-process-rendezvous nil)     (setq ghc-process-results nil)     (setq ghc-process-num-of-results (or n 1))-    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file)))+    (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil)))       ;; ghc-process-running is now t.       ;; But if the process exits abnormally, it is set to nil.       (condition-case nil@@ -199,7 +207,7 @@ 	 (setq ghc-process-running nil))))     ghc-process-results)) -(defun ghc-process-callback (status)+(defun ghc-sync-process-callback (status)   (cond    ((eq status 'ok)     (let* ((n ghc-process-num-of-results)

@@ -28,7 +28,7 @@ 	       (< emacs-minor-version minor)))       (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.4.0.0")+(defconst ghc-version "5.5.0.0")  (defgroup ghc-mod '() "ghc-mod customization") 

@@ -1,8 +1,9 @@ Name:                   ghc-mod-Version:                5.4.0.0+Version:                5.5.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,                         Daniel Gröber <dxld@darkboxed.org>,-                        Alejandro Serrano <trupill@gmail.com>+                        Alejandro Serrano <trupill@gmail.com>,+                        Nikolay Yakimov <root@livid.pp.ru> Maintainer:             Daniel Gröber <dxld@darkboxed.org> License:                AGPL-3 License-File:           LICENSE@@ -33,6 +34,7 @@                         SetupCompat.hs                         NotCPP/*.hs                         NotCPP/COPYING+                        Language/Haskell/GhcMod/Monad/Compat.hs_h                         test/data/annotations/*.hs                         test/data/broken-cabal/*.cabal                         test/data/broken-cabal/cabal.sandbox.config.in@@ -131,6 +133,12 @@                         Language.Haskell.GhcMod.Logging                         Language.Haskell.GhcMod.Modules                         Language.Haskell.GhcMod.Monad+                        Language.Haskell.GhcMod.Monad.Env+                        Language.Haskell.GhcMod.Monad.Log+                        Language.Haskell.GhcMod.Monad.Newtypes+                        Language.Haskell.GhcMod.Monad.Orphans+                        Language.Haskell.GhcMod.Monad.Out+                        Language.Haskell.GhcMod.Monad.State                         Language.Haskell.GhcMod.Monad.Types                         Language.Haskell.GhcMod.Output                         Language.Haskell.GhcMod.PathsAndFiles@@ -140,41 +148,45 @@                         Language.Haskell.GhcMod.SrcUtils                         Language.Haskell.GhcMod.Stack                         Language.Haskell.GhcMod.Target+                        Language.Haskell.GhcMod.Test                         Language.Haskell.GhcMod.Types                         Language.Haskell.GhcMod.Utils                         Language.Haskell.GhcMod.World   Other-Modules:        Paths_ghc_mod                         Utils-  Build-Depends:        base >= 4.0 && < 5-                      , bytestring-                      , cereal >= 0.4-                      , containers-                      , cabal-helper == 0.6.* && >= 0.6.0.0-                      , deepseq-                      , directory-                      , filepath-                      , ghc-                      , ghc-paths-                      , ghc-syb-utils-                      , hlint >= 1.8.61-                      , monad-journal >= 0.4-                      , old-time-                      , pretty-                      , process-                      , syb-                      , temporary-                      , time-                      , transformers-                      , transformers-base-                      , mtl >= 2.0-                      , monad-control >= 1-                      , split-                      , haskell-src-exts-                      , text-                      , djinn-ghc >= 0.0.2.2-                      , fclabels == 2.0.*-                      , extra == 1.4.*-                      , pipes == 4.1.*+                        Data.Binary.Generic+                        System.Directory.ModTime+  Build-Depends:        base              < 5 && >= 4.0+                      , bytestring        < 0.11+                      , binary            < 0.8 && >= 0.5.1.0+                      , containers        < 0.6+                      , cabal-helper      < 0.7 && >= 0.6.3.0+                      , deepseq           < 1.5+                      , directory         < 1.3+                      , filepath          < 1.5+                      , ghc               < 7.11+                      , ghc-paths         < 0.2+                      , ghc-syb-utils     < 0.3+                      , hlint             < 1.10 && >= 1.8.61+                      , monad-journal     < 0.8 && >= 0.4+                      , old-time          < 1.2+                      , pretty            < 1.2+                      , process           < 1.3+                      , syb               < 0.7+                      , temporary         < 1.3+                      , time              < 1.6+                      , transformers      < 0.5+                      , transformers-base < 0.5+                      , mtl               < 2.3 && >= 2.0+                      , monad-control     < 1.1 && >= 1+                      , split             < 0.3+                      , haskell-src-exts  < 1.18+                      , text              < 1.3+                      , djinn-ghc         < 0.1 && >= 0.0.2.2+                      , fclabels          == 2.0.*+                      , extra             == 1.4.*+                      , pipes             == 4.1.*+                      , safe              < 0.4 && >= 0.3.9   if impl(ghc < 7.8)     Build-Depends:      convertible   if impl(ghc < 7.5)@@ -186,38 +198,47 @@   Default-Language:     Haskell2010   Main-Is:              GHCMod.hs   Other-Modules:        Paths_ghc_mod+                      , GHCMod.Options+                      , GHCMod.Options.Commands+                      , GHCMod.Version+                      , GHCMod.Options.DocUtils+                      , GHCMod.Options.ShellParse+                      , GHCMod.Options.Help   GHC-Options:          -Wall -fno-warn-deprecations -threaded   Default-Extensions:   ConstraintKinds, FlexibleContexts   HS-Source-Dirs:       src-  Build-Depends:        base >= 4.0 && < 5-                      , async-                      , directory-                      , filepath-                      , pretty-                      , process-                      , split-                      , mtl >= 2.0-                      , ghc+  Build-Depends:        base      < 5 && >= 4.0+                      , directory < 1.3+                      , filepath  < 1.5+                      , pretty    < 1.2+                      , process   < 1.3+                      , split     < 0.3+                      , mtl       < 2.3 && >= 2.0+                      , ghc       < 7.11+                      , monad-control ==1.0.*+                      , fclabels  ==2.0.*+                      , optparse-applicative >=0.11.0 && <0.13.0                       , ghc-mod-                      , fclabels == 2.0.*  Executable ghc-modi   Default-Language:     Haskell2010   Main-Is:              GHCModi.hs   Other-Modules:        Paths_ghc_mod-                        Misc                         Utils   GHC-Options:          -Wall -threaded -fno-warn-deprecations   if os(windows)       Cpp-Options:      -DWINDOWS   Default-Extensions:   ConstraintKinds, FlexibleContexts   HS-Source-Dirs:       src, .-  Build-Depends:        base >= 4.0 && < 5-                      , directory-                      , filepath-                      , process-                      , time-                      , old-time+  Build-Depends:        base      < 5 && >= 4.0+                      , binary    < 0.8 && >= 0.5.1.0+                      , deepseq   < 1.5+                      , directory < 1.3+                      , filepath  < 1.5+                      , process   < 1.3+                      , old-time  < 1.2+                      , time      < 1.6+                      , ghc-mod  Test-Suite doctest   Type:                 exitcode-stdio-1.0@@ -237,8 +258,8 @@                         ConstraintKinds, FlexibleContexts,                         DataKinds, KindSignatures, TypeOperators, ViewPatterns   Main-Is:              Main.hs-  Hs-Source-Dirs:       test, .-  Ghc-Options:          -Wall -fno-warn-deprecations+  Hs-Source-Dirs:       test, ., src+  Ghc-Options:          -Wall -fno-warn-deprecations -threaded   CPP-Options:          -DSPEC=1   Type:                 exitcode-stdio-1.0   Other-Modules:        Paths_ghc_mod@@ -257,6 +278,7 @@                         PathsAndFilesSpec                         HomeModuleGraphSpec                         FileMappingSpec+                        ShellParseSpec    Build-Depends:        hspec >= 2.0.0   if impl(ghc == 7.4.*)

@@ -2,450 +2,64 @@  module Main where -import Config (cProjectVersion)-import Control.Category import Control.Applicative-import Control.Arrow import Control.Monad import Data.Typeable (Typeable)-import Data.Version (showVersion)-import Data.Label import Data.List import Data.List.Split-import Data.Char (isSpace)-import Data.Maybe import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad-import Paths_ghc_mod-import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))-import qualified System.Console.GetOpt as O+import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) import System.FilePath ((</>)) import System.Directory (setCurrentDirectory, getAppUserDataDirectory,                         removeDirectoryRecursive)-import System.Environment (getArgs) import System.IO import System.Exit-import Text.PrettyPrint-import Prelude hiding ((.))--import Misc--progVersion :: String -> String-progVersion pf =-    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "-                               ++ cProjectVersion ++ "\n"--ghcModVersion :: String-ghcModVersion = progVersion ""--ghcModiVersion :: String-ghcModiVersion = progVersion "i"--optionUsage :: (String -> String) -> [OptDescr a] -> [String]-optionUsage indent opts = concatMap optUsage opts- where-   optUsage (Option so lo dsc udsc) =-       [ concat $ intersperse ", " $ addLabel `map` allFlags-       , indent $ udsc-       , ""-       ]-    where-      allFlags = shortFlags ++ longFlags-      shortFlags = (('-':) . return) `map` so :: [String]-      longFlags  = ("--"++) `map` lo--      addLabel f@('-':'-':_) = f ++ flagLabel "="-      addLabel f@('-':_)     = f ++ flagLabel " "-      addLabel _ = undefined--      flagLabel s =-          case dsc of-            NoArg  _ -> ""-            ReqArg _ label -> s ++ label-            OptArg _ label -> s ++ "["++label++"]"---- TODO: Generate the stuff below automatically-usage :: String-usage =- "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\- \*Global Options (OPTIONS)*\n\- \    Global options can be specified before and after the command and\n\- \    interspersed with command specific options\n\- \\n"-   ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++- "*Commands*\n\- \    - version\n\- \        Print the version of the program.\n\- \\n\- \    - help\n\- \       Print this help message.\n\- \\n\- \    - list [FLAGS...] | modules [FLAGS...]\n\- \        List all visible modules.\n\- \      Flags:\n\- \        -d\n\- \            Print package modules belong to.\n\- \\n\- \    - lang\n\- \        List all known GHC language extensions.\n\- \\n\- \    - flag\n\- \        List GHC -f<bla> flags.\n\- \\n\- \    - browse [FLAGS...] [PACKAGE:]MODULE...\n\- \        List symbols in a module.\n\- \      Flags:\n\- \        -o\n\- \            Also print operators.\n\- \        -d\n\- \            Print symbols with accompanying signatures.\n\- \        -q\n\- \            Qualify symbols.\n\- \\n\- \    - check FILE...\n\- \        Load the given files using GHC and report errors/warnings, but\n\- \        don't produce output files.\n\- \\n\- \    - expand FILE...\n\- \        Like `check' but also pass `-ddump-splices' to GHC.\n\- \\n\- \    - info   FILE [MODULE] EXPR\n\- \        Look up an identifier in the context of FILE (like ghci's `:info')\n\- \        MODULE is completely ignored and only allowed for backwards\n\- \        compatibility.\n\- \\n\- \    - type FILE [MODULE] LINE COL\n\- \        Get the type of the expression under (LINE,COL).\n\- \\n\- \    - split FILE [MODULE] LINE COL\n\- \        Split a function case by examining a type's constructors.\n\- \\n\- \        For example given the following code snippet:\n\- \\n\- \            f :: [a] -> a\n\- \            f x = _body\n\- \\n\- \        would be replaced by:\n\- \\n\- \            f :: [a] -> a\n\- \            f [] = _body\n\- \            f (x:xs) = _body\n\- \\n\- \        (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\- \\n\- \    - sig FILE MODULE LINE COL\n\- \        Generate initial code given a signature.\n\- \\n\- \        For example when (LINE,COL) is on the signature in the following\n\- \        code snippet:\n\- \\n\- \            func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\- \\n\- \        ghc-mod would add the following on the next line:\n\- \\n\- \            func x y z f = _func_body\n\- \\n\- \        (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\- \\n\- \    - refine FILE MODULE LINE COL EXPR\n\- \        Refine the typed hole at (LINE,COL) given EXPR.\n\- \\n\- \        For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\- \          -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\- \        code snippet:\n\- \\n\- \            filterNothing :: [Maybe a] -> [a]\n\- \            filterNothing xs = _body\n\- \\n\- \        ghc-mod changes the code to get a value of type `[a]', which\n\- \        results in:\n\- \\n\- \            filterNothing xs = filter _body_1 _body_2\n\- \\n\- \        (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\- \\n\- \    - auto FILE MODULE LINE COL\n\- \        Try to automatically fill the contents of a hole.\n\- \\n\- \    - find SYMBOL\n\- \        List all modules that define SYMBOL.\n\- \\n\- \    - lint FILE\n\- \        Check files using `hlint'.\n\- \      Flags:\n\- \        -h\n\- \            Option to be passed to hlint.\n\- \\n\- \    - root\n\- \        Try to find the project directory. For Cabal projects this is the\n\- \        directory containing the cabal file, for projects that use a cabal\n\- \        sandbox but have no cabal file this is the directory containing the\n\- \        cabal.sandbox.config file and otherwise this is the current\n\- \        directory.\n\- \\n\- \    - doc MODULE\n\- \        Try finding the html documentation directory for the given MODULE.\n\- \\n\- \    - debug\n\- \        Print debugging information. Please include the output in any bug\n\- \        reports you submit.\n\- \\n\- \    - debugComponent [MODULE_OR_FILE...]\n\- \        Debugging information related to cabal component resolution.\n\- \\n\- \    - boot\n\- \         Internal command used by the emacs frontend.\n\- \\n\- \    - legacy-interactive\n\- \         ghc-modi compatibility mode.\n"- where-   indent = ("    "++)--cmdUsage :: String -> String -> String-cmdUsage cmd realUsage =-  let-      -- Find command head-      a = dropWhile (not . isCmdHead) $ lines realUsage-      -- Take til the end of the current command block-      b = flip takeWhile a $ \l ->-            all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l))-      -- Drop extra newline from the end-      c = dropWhileEnd (all isSpace) b--      isIndented    = ("    " `isPrefixOf`)-      isNotCmdHead  = ( not .  ("    - " `isPrefixOf`))--      containsAnyCmdHead s = (("    - ") `isInfixOf` s)-      containsCurrCmdHead s = (("    - " ++ cmd) `isInfixOf` s)-      isCmdHead s =-          containsAnyCmdHead s &&-            or [ containsCurrCmdHead s-               , any (cmd `isPrefixOf`) (splitOn " | " s)-               ]--      unindent (' ':' ':' ':' ':l) = l-      unindent l = l-  in unlines $ unindent <$> c+import Text.PrettyPrint hiding ((<>))+import GHCMod.Options+import Prelude  ghcModStyle :: Style ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }  ---------------------------------------------------------------- -option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a-option s l udsc dsc = Option s l dsc udsc--reqArg :: String -> (String -> a) -> ArgDescr a-reqArg udsc dsc = ReqArg dsc udsc--optArg :: String -> (Maybe String -> a) -> ArgDescr a-optArg udsc dsc = OptArg dsc udsc--intToLogLevel :: Int -> GmLogLevel-intToLogLevel = toEnum--globalArgSpec :: [OptDescr (Options -> Either [String] Options)]-globalArgSpec =-      [ option "v" ["verbose"] "Increase or set log level. (0-7)" $-          optArg "LEVEL" $ \ml o -> Right $ case ml of-              Nothing ->-                  modify (lOoptLogLevel . lOptOutput) increaseLogLevel o-              Just l ->-                  set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o--      , option "s" [] "Be silent, set log level to 0" $-          NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o--      , option "l" ["tolisp"] "Format output as an S-Expression" $-          NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o--      , option "b" ["boundary", "line-seperator"] "Output line separator"$-          reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o--      , option "" ["line-prefix"] "Output line separator"$-          reqArg "OUT,ERR" $ \s o -> let-                [out, err] = splitOn "," s-              in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o--      , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $-          reqArg "OPT" $ \g o -> Right $-              o { optGhcUserOptions = g : optGhcUserOptions o }--{--File map docs:--CLI options:-* `--map-file "file1.hs=file2.hs"` can be used to tell-    ghc-mod that it should take source code for `file1.hs` from `file2.hs`.-    `file1.hs` can be either full path, or path relative to project root.-    `file2.hs` has to be either relative to project root,-    or full path (preferred).-* `--map-file "file.hs"` can be used to tell ghc-mod that it should take-    source code for `file.hs` from stdin. File end marker is `\EOT\n`,-    i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be-    either full path, or relative to project root.--Interactive commands:-* `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.-    Works the same as second form of `--map-file` CLI option.-* `unmap-file file.hs` -- unloads previously mapped file, so that it's-    no longer mapped. `file.hs` can be full path or relative to-    project root, either will work.--Exposed functions:-* `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,-    given as first argument to take source from `FilePath` given as second-    argument. Works exactly the same as first form of `--map-file`-    CLI option.-* `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps-    `FilePath`, given as first argument to have source as given-    by second argument. Works exactly the same as second form of `--map-file`-    CLI option, sans reading from stdin.-* `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as-    first argument, and removes any temporary files created when file was-    mapped. Works exactly the same as `unmap-file` interactive command--}-      , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $-          reqArg "OPT" $ \g o ->-             let m = case second (drop 1) $ span (/='=') g of-                       (s,"") -> (s, Nothing)-                       (f,t)  -> (f, Just t)-             in-             Right $ o { optFileMappings = m : optFileMappings o }--      , option "" ["with-ghc"] "GHC executable to use" $-          reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o--      , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $-          reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o--      , option "" ["with-cabal"] "cabal-install executable to use" $-          reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o--      , option "" ["with-stack"] "stack executable to use" $-          reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o--      , option "" ["version"] "print version information" $-          NoArg $ \_ -> Left ["version"]--      , option "" ["help"] "print this help message" $-          NoArg $ \_ -> Left ["help"]-  ]----parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])-parseGlobalArgs argv-    = case O.getOpt' RequireOrder globalArgSpec argv of-        (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of-                        Right o' -> Right (o', u ++ r)-                        Left c -> Right (defaultOptions, c)-        (_,_,u,e)  -> Left $ InvalidCommandLine $ Right $-            "Parsing command line options failed: "-               ++ concat (e ++ map errUnrec u)- where-   errUnrec :: String -> String-   errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"--parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]-                 -> [String]-                 -> Options-                 -> (Options, [String])-parseCommandArgs spec argv opts-    = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of-        (o,r,[])   -> case foldr (=<<) (Right opts) o of-                        Right o' -> (o', r)-                        Left c -> (defaultOptions, c)-        (_,_,errs) ->-            fatalError $ "Parsing command options failed: " ++ concat errs--------------------------------------------------------------------data CmdError = UnknownCommand String-              | NoSuchFileError String-              | LibraryError GhcModError--                deriving (Show, Typeable)--instance Exception CmdError--data InteractiveOptions = InteractiveOptions {-      ghcModExtensions :: Bool-    }- handler :: IOish m => GhcModT m a -> GhcModT m a-handler = flip gcatches $-          [ GHandler $ \(FatalError msg) -> exitError msg-          , GHandler $ \e@(ExitSuccess) -> throw e-          , GHandler $ \e@(ExitFailure _) -> throw e-          , GHandler $ \(InvalidCommandLine e) -> do-                case e of-                  Left cmd ->-                      exitError $ "Usage for `"++cmd++"' command:\n\n"-                                  ++ (cmdUsage cmd usage) ++ "\n"-                                  ++ "ghc-mod: Invalid command line form."-                  Right msg -> exitError $ "ghc-mod: " ++ msg+handler = flip gcatches+          [ GHandler $ \(e :: ExitCode) -> throw e           , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e           ]  main :: IO () main = do     hSetEncoding stdout utf8-    args <- getArgs-    case parseGlobalArgs args of-      Left e -> throw e-      Right res@(globalOptions,_) -> catches (progMain res) [-            Handler $ \(e :: GhcModError) ->-              runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)-          ]--progMain :: (Options,[String]) -> IO ()-progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $-    case globalCommands cmdArgs of-      Just s -> gmPutStr s-      Nothing -> wrapGhcCommands globalOptions cmdArgs+    parseArgs >>= \res@(globalOptions, _) ->+      catches (progMain res) [+              Handler $ \(e :: GhcModError) ->+                runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)+            ] -globalCommands :: [String] -> Maybe String-globalCommands (cmd:_)-    | cmd == "help"    = Just usage-    | cmd == "version" = Just ghcModVersion-globalCommands _       = Nothing+progMain :: (Options, GhcModCommands) -> IO ()+progMain (globalOptions, commands) = runGmOutT globalOptions $+  wrapGhcCommands globalOptions commands  -- ghc-modi legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do-    opt <- options     prepareCabalHelper-    tmpdir <- cradleTempDir <$> cradle-    gmo <- gmoAsk-    symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir+    asyncSymbolDb <- newAsyncSymbolDb     world <- getCurrentWorld-    legacyInteractiveLoop symdbreq world--bug :: IOish m => String -> GhcModT m ()-bug msg = do-  gmPutStrLn $ notGood $ "BUG: " ++ msg-  liftIO exitFailure--notGood :: String -> String-notGood msg = "NG " ++ escapeNewlines msg--escapeNewlines :: String -> String-escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"--replace :: String -> String -> String -> String-replace needle replacement = intercalate replacement . splitOn needle+    legacyInteractiveLoop asyncSymbolDb world -legacyInteractiveLoop :: IOish m-                      => SymDbReq -> World -> GhcModT m ()-legacyInteractiveLoop symdbreq world = do+legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()+legacyInteractiveLoop asyncSymbolDb world = do     liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle      -- blocking-    cmdArg <- liftIO $ getLine+    cmdArg <- liftIO getLine      -- after blocking, we need to see if the world has changed. @@ -455,72 +69,53 @@                 then getCurrentWorld -- TODO: gah, we're hitting the fs twice                 else return world -    when changed $ do-        dropSession--    let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg-        arg = concat args'-        cmd = dropWhileEnd isSpace cmd'-        args = dropWhileEnd isSpace `map` args'--    res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of-        "check"  -> checkSyntaxCmd [arg]-        "lint"   -> lintCmd [arg]-        "find"    -> do-            db <- getDb symdbreq >>= checkDb symdbreq-            lookupSymbol arg db--        "info"   -> infoCmd [head args, concat $ tail args']-        "type"   -> typesCmd args-        "split"  -> splitsCmd args--        "sig"    -> sigCmd args-        "auto"   -> autoCmd args-        "refine" -> refineCmd args--        "boot"   -> bootCmd []-        "browse" -> browseCmd args--        "map-file"   ->  liftIO getFileSourceFromStdin-                     >>= loadMappedFileSource arg-                     >>  return ""--        "unmap-file" ->  unloadMappedFile arg-                     >>  return ""+    when changed dropSession -        "quit"   -> liftIO $ exitSuccess-        ""       -> liftIO $ exitSuccess-        _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"+    res <- flip gcatches interactiveHandlers $ do+      pargs <- either (throw . InvalidCommandLine . Right) return+              $ parseArgsInteractive cmdArg+      case pargs of+        CmdFind symbol ->+            lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb+        -- other commands are handled here+        x              -> ghcCommands x      gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)-    legacyInteractiveLoop symdbreq world'+    legacyInteractiveLoop asyncSymbolDb world'  where-   interactiveHandlers =-          [ GHandler $ \e@(FatalError _) -> throw e-          , GHandler $ \e@(ExitSuccess) -> throw e-          , GHandler $ \e@(ExitFailure _) -> throw e+    interactiveHandlers =+          [ GHandler $ \(e :: ExitCode) -> throw e+          , GHandler $ \(InvalidCommandLine e) -> do+              let err = notGood $ either ("Invalid command line: "++) Prelude.id e+              liftIO $ do+                putStr err+                exitFailure           , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""           ]+    notGood msg = "NG " ++ escapeNewlines msg+    escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"+    replace needle replacement = intercalate replacement . splitOn needle  getFileSourceFromStdin :: IO String getFileSourceFromStdin = do-  let loop' acc = do-        line <- getLine-        if not (null line) && last line == '\EOT'-        then return $ acc ++ init line-        else loop' (acc++line++"\n")-  loop' ""+  linesIn <- readStdin'+  return (intercalate "\n" linesIn)+  where+    readStdin' = do+      x <- getLine+      if x/="\EOT"+        then fmap (x:) readStdin'+        else return []  -- Someone please already rewrite the cmdline parsing code *weep* :'(-wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m ()-wrapGhcCommands _opts []            = fatalError "No command given (try --help)"-wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo-wrapGhcCommands opts args = do+wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()+wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo+wrapGhcCommands opts cmd =     handleGmError $ runGhcModT opts $ handler $ do       forM_ (reverse $ optFileMappings opts) $         uncurry loadMMappedFiles -      ghcCommands args+      gmPutStr =<< ghcCommands cmd  where    handleGmError action = do      (e, _l) <- liftIO . evaluate =<< action@@ -536,37 +131,39 @@        loadMappedFileSource from src  -ghcCommands :: IOish m => [String] -> GhcModT m ()-ghcCommands []         = fatalError "No command given (try --help)"-ghcCommands (cmd:args) = gmPutStr =<< action args- where-   action = case cmd of-     _ | cmd == "list" || cmd == "modules" -> modulesCmd-     "lang"    -> languagesCmd-     "flag"    -> flagsCmd-     "browse"  -> browseCmd-     "check"   -> checkSyntaxCmd-     "expand"  -> expandTemplateCmd-     "debug"   -> debugInfoCmd-     "debug-component" -> componentInfoCmd-     "info"    -> infoCmd-     "type"    -> typesCmd-     "split"   -> splitsCmd-     "sig"     -> sigCmd-     "refine"  -> refineCmd-     "auto"    -> autoCmd-     "find"    -> findSymbolCmd-     "lint"    -> lintCmd---     "root"    -> rootInfoCmd-     "doc"     -> pkgDocCmd-     "dumpsym" -> dumpSymbolCmd-     "boot"    -> bootCmd-     "legacy-interactive" -> legacyInteractiveCmd---     "nuke-caches" -> nukeCachesCmd-     _         -> fatalError $ "unknown command: `" ++ cmd ++ "'"--newtype FatalError = FatalError String deriving (Show, Typeable)-instance Exception FatalError+ghcCommands :: IOish m => GhcModCommands -> GhcModT m String+-- ghcCommands cmd = action args+ghcCommands (CmdLang) = languages+ghcCommands (CmdFlag) = flags+ghcCommands (CmdDebug) = debugInfo+ghcCommands (CmdDebugComponent ts) = componentInfo ts+ghcCommands (CmdBoot) = boot+-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""+-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands+ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""+ghcCommands (CmdModules detail) = modules detail+ghcCommands (CmdDumpSym) = dumpSymbol >> return ""+ghcCommands (CmdFind symb) = findSymbol symb+ghcCommands (CmdDoc m) = pkgDoc m+ghcCommands (CmdLint opts file) = lint opts file+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 (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+ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr+-- interactive-only commands+ghcCommands (CmdMapFile f) =+      liftIO getFileSourceFromStdin+  >>= loadMappedFileSource f+  >>  return ""+ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return ""+ghcCommands (CmdQuit) = liftIO exitSuccess+ghcCommands (CmdTest file) = test file+ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd  newtype InvalidCommandLine = InvalidCommandLine (Either String String)     deriving (Show, Typeable)@@ -574,117 +171,6 @@  exitError :: (MonadIO m, GmOut m) => String -> m a exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure--fatalError :: String -> a-fatalError s = throw $ FatalError $ "ghc-mod: " ++ s--withParseCmd :: IOish m-             => [OptDescr (Options -> Either [String] Options)]-             -> ([String] -> GhcModT m a)-             -> [String]-             -> GhcModT m a-withParseCmd spec action args  = do-  (opts', rest) <- parseCommandArgs spec args <$> options-  withOptions (const opts') $ action rest--withParseCmd' :: (IOish m, ExceptionMonad m)-              => String-              -> [OptDescr (Options -> Either [String] Options)]-              -> ([String] -> GhcModT m a)-              -> [String]-              -> GhcModT m a-withParseCmd' cmd spec action args =-    catchArgs cmd $ withParseCmd spec action args--catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a-catchArgs cmd action =-    action `gcatch` \(PatternMatchFail _) ->-        throw $ InvalidCommandLine (Left cmd)--modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,-  debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,-  refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd,-  dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd-  :: IOish m => [String] -> GhcModT m String--modulesCmd    = withParseCmd' "modules" s $ \[] -> modules- where s = modulesArgSpec-languagesCmd  = withParseCmd' "lang"    [] $ \[] -> languages-flagsCmd      = withParseCmd' "flag"    [] $ \[] -> flags-debugInfoCmd  = withParseCmd' "debug"   [] $ \[] -> debugInfo-componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts--- internal-bootCmd       = withParseCmd' "boot" [] $ \[] -> boot-nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""--dumpSymbolCmd     = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir-findSymbolCmd     = withParseCmd' "find" [] $ \[sym]  -> findSymbol sym-pkgDocCmd         = withParseCmd' "doc"  [] $ \[mdl]  -> pkgDoc mdl-lintCmd           = withParseCmd' "lint" s  $ \[file] -> lint file- where s = hlintArgSpec-browseCmd         = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls- where s = browseArgSpec-checkSyntaxCmd    = withParseCmd [] $ checkAction checkSyntax-expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate--typesCmd      = withParseCmd [] $ locAction  "type"  types-splitsCmd     = withParseCmd [] $ locAction  "split" splits-sigCmd        = withParseCmd [] $ locAction  "sig"    sig-autoCmd       = withParseCmd [] $ locAction  "auto"   auto-refineCmd     = withParseCmd [] $ locAction' "refine" refine--infoCmd       = withParseCmd [] $ action-  where action [file,_,expr] = info file $ Expression expr-        action [file,expr]   = info file $ Expression expr-        action _ = throw $ InvalidCommandLine (Left "info")--legacyInteractiveCmd = withParseCmd [] go- where-   go [] =-       legacyInteractive >> return ""-   go ("help":[]) =-       return usage-   go ("version":[]) =-       return ghcModiVersion-   go _ = throw $ InvalidCommandLine (Left "legacy-interactive")--checkAction :: ([t] -> a) -> [t] -> a-checkAction _ []         = throw $ InvalidCommandLine (Right "No files given.")-checkAction action files = action files--locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a-locAction _ action [file,_,line,col] = action file (read line) (read col)-locAction _ action [file,  line,col] = action file (read line) (read col)-locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)--locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a-locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)-locAction' _ action [f,  line,col,expr] = action f (read line) (read col) (Expression expr)-locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)---modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]-modulesArgSpec =-    [ option "d" ["detailed"] "Print package modules belong to." $-             NoArg $ \o -> Right $ o { optDetailed = True }-    ]---hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]-hlintArgSpec =-    [ option "h" ["hlintOpt"] "Option to be passed to hlint" $-             reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }-    ]--browseArgSpec :: [OptDescr (Options -> Either [String] Options)]-browseArgSpec =-    [ option "o" ["operators"] "Also print operators." $-             NoArg $ \o -> Right $ o { optOperators = True }-    , option "d" ["detailed"] "Print symbols with accompanying signature." $-             NoArg $ \o -> Right $ o { optDetailed = True }-    , option "q" ["qualified"] "Qualify symbols" $-             NoArg $ \o -> Right $ o { optQualified = True }-    ]  nukeCaches :: IOish m => GhcModT m () nukeCaches = do

@@ -0,0 +1,201 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module GHCMod.Options (+  parseArgs,+  parseArgsInteractive,+  GhcModCommands(..)+) where++import Options.Applicative+import Options.Applicative.Types+import Language.Haskell.GhcMod.Types+import Control.Arrow+import Data.Char (toUpper, toLower)+import Data.List (intercalate)+import Language.Haskell.GhcMod.Read+import GHCMod.Options.Commands+import GHCMod.Version+import GHCMod.Options.DocUtils+import GHCMod.Options.Help+import GHCMod.Options.ShellParse++parseArgs :: IO (Options, GhcModCommands)+parseArgs =+  execParser opts+  where+    opts = info (argAndCmdSpec <**> helpVersion)+           $$  fullDesc+           <=> header "ghc-mod: Happy Haskell Programming"++parseArgsInteractive :: String -> Either String GhcModCommands+parseArgsInteractive args =+  handle $ execParserPure (prefs idm) opts $ parseCmdLine args+  where+    opts = info interactiveCommandsSpec $$ fullDesc+    handle (Success a) = Right a+    handle (Failure failure) =+          Left $ fst $ renderFailure failure ""+    handle _ = Left "Completion invoked"++helpVersion :: Parser (a -> a)+helpVersion =+      helper+  <*> abortOption (InfoMsg ghcModVersion)+      $$  long "version"+      <=> help "Print the version of the program."+  <*> argument r+      $$  value id+      <=> metavar ""+  where+    r :: ReadM (a -> a)+    r = do+      v <- readerAsk+      case v of+        "help" -> readerAbort ShowHelpText+        "version" -> readerAbort $ InfoMsg ghcModVersion+        _ -> return id++argAndCmdSpec :: Parser (Options, GhcModCommands)+argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec++splitOn :: Eq a => a -> [a] -> ([a], [a])+splitOn c = second (drop 1) . break (==c)++logLevelParser :: Parser GmLogLevel+logLevelParser =+    logLevelSwitch <*>+           logLevelOption+      <||> silentSwitch+  where+    logLevelOption =+      option parseLL+        $$  long "verbose"+        <=> metavar "LEVEL"+        <=> value GmWarning+        <=> showDefaultWith showLL+        <=> help' $$$ do+          "Set log level ("+            <> int' (fromEnum (minBound :: GmLogLevel))+            <> "-"+            <> int' (fromEnum (maxBound :: GmLogLevel))+            <> ")"+          "You can also use strings (case-insensitive):"+          para'+            $ intercalate ", "+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])+    logLevelSwitch =+      repeatAp succ' . length <$> many $$ flag' ()+        $$  short 'v'+        <=> help "Increase log level"+    silentSwitch = flag' GmSilent+        $$  long "silent"+        <=> short 's'+        <=> help "Be silent, set log level to 'silent'"+    showLL = drop 2 . map toLower . show+    repeatAp f n = foldr (.) id (replicate n f)+    succ' x | x == maxBound = x+            | otherwise     = succ x+    parseLL = do+      v <- readerAsk+      let+        il'= toEnum . min maxBound <$> readMaybe v+        ll' = readMaybe ("Gm" ++ capFirst v)+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'+    capFirst (h:t) = toUpper h : map toLower t+    capFirst [] = []++outputOptsSpec :: Parser OutputOpts+outputOptsSpec = OutputOpts+      <$> logLevelParser+      <*> flag PlainStyle LispStyle+          $$  long "tolisp"+          <=> short 'l'+          <=> help "Format output as an S-Expression"+      <*> LineSeparator <$$> strOption+          $$  long "boundary"+          <=> long "line-separator"+          <=> short 'b'+          <=> metavar "SEP"+          <=> value "\0"+          <=> showDefault+          <=> help "Output line separator"+      <*> optional $$ splitOn ',' <$$> strOption+          $$  long "line-prefix"+          <=> metavar "OUT,ERR"+          <=> help "Output prefixes"++programsArgSpec :: Parser Programs+programsArgSpec = Programs+      <$> strOption+          $$  long "with-ghc"+          <=> value "ghc"+          <=> showDefault+          <=> help "GHC executable to use"+      <*> strOption+          $$  long "with-ghc-pkg"+          <=> value "ghc-pkg"+          <=> showDefault+          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"+      <*> strOption+          $$  long "with-cabal"+          <=> value "cabal"+          <=> showDefault+          <=> help "cabal-install executable to use"+      <*> strOption+          $$  long "with-stack"+          <=> value "stack"+          <=> showDefault+          <=> help "stack executable to use"++globalArgSpec :: Parser Options+globalArgSpec = Options+      <$> outputOptsSpec+      <*> programsArgSpec+      <*> many $$ strOption+          $$  long "ghcOpt"+          <=> long "ghc-option"+          <=> short 'g'+          <=> metavar "OPT"+          <=> help "Option to be passed to GHC"+      <*> many fileMappingSpec+  where+    fileMappingSpec =+      getFileMapping . splitOn '=' <$> strOption+        $$  long "map-file"+        <=> metavar "MAPPING"+        <=> fileMappingHelp+    fileMappingHelp = help' $ do+        "Redirect one file to another"+        "--map-file \"file1.hs=file2.hs\""+        indent 4 $ do+          "can be used to tell ghc-mod"+            \\ "that it should take source code"+            \\ "for `file1.hs` from `file2.hs`."+          "`file1.hs` can be either full path,"+            \\ "or path relative to project root."+          "`file2.hs` has to be either relative to project root,"+            \\  "or full path (preferred)"+        "--map-file \"file.hs\""+        indent 4 $ do+          "can be used to tell ghc-mod that it should take"+            \\ "source code for `file.hs` from stdin. File end"+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."+            \\ "`file.hs` may or may not exist, and should be"+            \\ "either full path, or relative to project root."+    getFileMapping = second (\i -> if null i then Nothing else Just i)

@@ -0,0 +1,292 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module GHCMod.Options.Commands where++import Options.Applicative+import Options.Applicative.Types+import Options.Applicative.Builder.Internal+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Read+import GHCMod.Options.DocUtils+import GHCMod.Options.Help++type Symbol = String+type Expr = String+type Module = String+type Line = Int+type Col = Int+type Point = (Line, Col)++data GhcModCommands =+    CmdLang+  | CmdFlag+  | CmdDebug+  | CmdBoot+  | CmdNukeCaches+  | CmdRoot+  | CmdLegacyInteractive+  | CmdModules Bool+  | CmdDumpSym+  | CmdFind Symbol+  | CmdDoc Module+  | CmdLint LintOpts FilePath+  | CmdBrowse BrowseOpts [Module]+  | CmdDebugComponent [String]+  | CmdCheck [FilePath]+  | CmdExpand [FilePath]+  | CmdInfo FilePath Symbol+  | CmdType FilePath Point+  | CmdSplit FilePath Point+  | CmdSig FilePath Point+  | CmdAuto FilePath Point+  | CmdRefine FilePath Point Expr+  | CmdTest FilePath+  -- interactive-only commands+  | CmdMapFile FilePath+  | CmdUnmapFile FilePath+  | CmdQuit+  deriving (Show)++commandsSpec :: Parser GhcModCommands+commandsSpec =+  hsubparser commands++commands :: Mod CommandFields GhcModCommands+commands =+       command "lang"+          $$  info (pure CmdLang)+          $$  progDesc "List all known GHC language extensions"+    <> command "flag"+          $$  info (pure CmdFlag)+          $$  progDesc "List GHC -f<foo> flags"+    <> command "debug"+          $$  info (pure CmdDebug)+          $$  progDesc' $$$ do+              "Print debugging information. Please include"+                \\ "the output in any bug reports you submit"+    <> command "debug-component"+          $$  info debugComponentArgSpec+          $$  progDesc' $$$ do+              "Debugging information related to cabal component"+                \\ "resolution"+    <> command "boot"+          $$  info (pure CmdBoot)+          $$  progDesc "Internal command used by the emacs frontend"+    -- <> command "nuke-caches"+    --       $$  info (pure CmdNukeCaches) idm+    <> command "root"+          $$  info (pure CmdRoot)+          $$  progDesc'+              "Try to find the project directory."+          <=> desc $$$ do+              "For Cabal projects this is the"+                \\ "directory containing the cabal file, for projects"+                \\ "that use a cabal sandbox but have no cabal file"+                \\ "this is the directory containing the cabal.sandbox.config"+                \\ "file and otherwise this is the current directory"+    <> command "legacy-interactive"+          $$  info legacyInteractiveArgSpec+          $$  progDesc "ghc-modi compatibility mode"+    <> command "list"+          $$  info modulesArgSpec+          $$  progDesc "List all visible modules"+    <> command "modules"+          $$  info modulesArgSpec+          $$  progDesc "List all visible modules"+    <> command "dumpsym"+          $$  info (pure CmdDumpSym) idm+    <> command "find"+          $$  info findArgSpec+          $$  progDesc "List all modules that define SYMBOL"+    <> command "doc"+          $$  info docArgSpec+          $$  progDesc' $$$ do+              "Try finding the html documentation directory"+                \\ "for the given MODULE"+    <> command "lint"+          $$  info lintArgSpec+          $$  progDesc "Check files using `hlint'"+    <> command "browse"+          $$  info browseArgSpec+          $$  progDesc "List symbols in a module"+    <> command "check"+          $$  info checkArgSpec+          $$  progDesc' $$$ do+              "Load the given files using GHC and report errors/warnings,"+                \\ "but don't produce output files"+    <> command "expand"+          $$  info expandArgSpec+          $$  progDesc "Like `check' but also pass `-ddump-splices' to GHC"+    <> command "info"+          $$  info infoArgSpec+          $$  progDesc' $$$ do+              "Look up an identifier in the context"+                \\ "of FILE (like ghci's `:info')"+    <> command "type"+          $$  info typeArgSpec+          $$  progDesc "Get the type of the expression under (LINE,COL)"+    <> command "split"+          $$  info splitArgSpec+          $$  progDesc+                  "Split a function case by examining a type's constructors"+          <=> desc $$$ do+                "For example given the following code snippet:"+                code $ do+                  "f :: [a] -> a"+                  "f x = _body"+                "would be replaced by:"+                code $ do+                  "f :: [a] -> a"+                  "f [] = _body"+                  "f (x:xs) = _body"+                "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"+    <> command "sig"+          $$  info sigArgSpec+          $$  progDesc "Generate initial code given a signature"+          <=> desc $$$ do+              "For example when (LINE,COL) is on the"+                \\ "signature in the following code snippet:"+              code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)"+              "ghc-mod would add the following on the next line:"+              code "func x y z f = _func_body"+              "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"+    <> command "auto"+          $$  info autoArgSpec+          $$  progDesc "Try to automatically fill the contents of a hole"+    <> command "refine"+          $$  info refineArgSpec+          $$  progDesc "Refine the typed hole at (LINE,COL) given EXPR"+          <=> desc $$$ do+              "For example if EXPR is `filter', which has type"+                \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on"+                \\ " the hole `_body' in the following code snippet:"+              code $ do+                "filterNothing :: [Maybe a] -> [a]"+                "filterNothing xs = _body"+              "ghc-mod changes the code to get a value of type"+                \\ " `[a]', which results in:"+              code "filterNothing xs = filter _body_1 _body_2"+              "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"+    <> command "test"+          $$  info (CmdTest <$> strArg "FILE")+          $$  progDesc ""+++interactiveCommandsSpec :: Parser GhcModCommands+interactiveCommandsSpec =+    hsubparser'+        $  commands+        <> command "map-file"+              $$  info mapArgSpec+              $$  progDesc "tells ghc-modi to read `file.hs` source from stdin"+              <=> desc $$$ do+                "Works the same as second form of"+                  \\ "`--map-file` CLI option."+        <> command "unmap-file"+              $$  info unmapArgSpec+              $$  progDesc' $$$ do+                    "unloads previously mapped file,"+                      \\ "so that it's no longer mapped."+              <=> desc $$$ do+                    "`file.hs` can be full path or relative"+                      \\ "to project root, either will work."+        <> command "quit"+              $$ info (pure CmdQuit)+              $$ progDesc "Exit interactive mode"+        <> command ""+              $$ info (pure CmdQuit) idm++strArg :: String -> Parser String+strArg = argument str . metavar++filesArgsSpec :: ([String] -> b) -> Parser b+filesArgsSpec x = x <$> some (strArg "FILES..")++locArgSpec :: (String -> (Int, Int) -> b) -> Parser b+locArgSpec x = x+  <$> strArg "FILE"+  <*> ( (,)+        <$> argument int (metavar "LINE")+        <*> argument int (metavar "COL")+      )++modulesArgSpec, docArgSpec, findArgSpec,+  lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,+  infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,+  sigArgSpec, refineArgSpec, debugComponentArgSpec,+  mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands++modulesArgSpec = CmdModules+  <$> switch+        $$  long "detailed"+        <=> short 'd'+        <=> help "Print package modules belong to"+findArgSpec = CmdFind <$> strArg "SYMBOL"+docArgSpec = CmdDoc <$> strArg "MODULE"+lintArgSpec = CmdLint+  <$> LintOpts <$$> many $$ strOption+      $$  long "hlintOpt"+      <=> short 'h'+      <=> help "Option to be passed to hlint"+  <*> strArg "FILE"+browseArgSpec = CmdBrowse+  <$> (BrowseOpts+        <$> switch+            $$  long "operators"+            <=> short 'o'+            <=> help "Also print operators"+        <*> switch+            $$  long "detailed"+            <=> short 'd'+            <=> help "Print symbols with accompanying signature"+        <*> switch+            $$  long "qualified"+            <=> short 'q'+            <=> help "Qualify symbols"+      )+  <*> some (strArg "MODULE")+debugComponentArgSpec = filesArgsSpec CmdDebugComponent+checkArgSpec = filesArgsSpec CmdCheck+expandArgSpec = filesArgsSpec CmdExpand+infoArgSpec = CmdInfo+    <$> strArg "FILE"+    <*> strArg "SYMBOL"+typeArgSpec = locArgSpec CmdType+autoArgSpec = locArgSpec CmdAuto+splitArgSpec = locArgSpec CmdSplit+sigArgSpec = locArgSpec CmdSig+refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"+mapArgSpec = CmdMapFile <$> strArg "FILE"+unmapArgSpec = CmdUnmapFile <$> strArg "FILE"+legacyInteractiveArgSpec = const CmdLegacyInteractive <$>+  optional interactiveCommandsSpec++hsubparser' :: Mod CommandFields a -> Parser a+hsubparser' m = mkParser d g rdr+  where+    Mod _ d g = m `mappend` metavar ""+    (cmds, subs) = mkCommand m+    rdr = CmdReader cmds (fmap add_helper . subs)+    add_helper pinfo = pinfo+      { infoParser = infoParser pinfo <**> helper }++int :: ReadM Int+int = do+  v <- readerAsk+  maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v

@@ -0,0 +1,48 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GHCMod.Options.DocUtils (+  ($$),+  ($$$),+  (<=>),+  (<$$>),+  (<||>)+) where++import Options.Applicative+import Data.Monoid+import Prelude++infixl 6 <||>+infixr 7 <$$>+infixr 7 $$+infixr 8 <=>+infixr 9 $$$++($$) :: (a -> b) -> a -> b+($$) = ($)++($$$) :: (a -> b) -> a -> b+($$$) = ($)++(<||>) :: Alternative a => a b -> a b -> a b+(<||>) = (<|>)++(<=>) :: Monoid m => m -> m -> m+(<=>) = (<>)++(<$$>) :: Functor f => (a -> b) -> f a -> f b+(<$$>) = (<$>)

@@ -0,0 +1,79 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}++module GHCMod.Options.Help where++import Options.Applicative+import Options.Applicative.Help.Pretty (Doc)+import qualified Options.Applicative.Help.Pretty as PP+import Control.Monad.State+import GHC.Exts( IsString(..) )+import Data.Maybe+import Data.Monoid+import Prelude++newtype MyDocM s a = MyDoc {unwrapState :: State s a}+  deriving (Monad, Functor, Applicative, MonadState s)+type MyDoc = MyDocM (Maybe Doc) ()++instance IsString (MyDocM (Maybe Doc) a) where+    fromString = append . para++instance Monoid (MyDocM (Maybe Doc) ()) where+  mappend a b = append $ doc a <> doc b+  mempty = append PP.empty++para :: String -> Doc+para = PP.fillSep . map PP.text . words++append :: Doc -> MyDocM (Maybe Doc) a+append s = modify m >> return undefined+  where+    m :: Maybe Doc -> Maybe Doc+    m Nothing = Just s+    m (Just old) = Just $ old PP..$. s++infixr 7 \\+(\\) :: MyDoc -> MyDoc -> MyDoc+(\\) a b = append $ doc a PP.<+> doc b++doc :: MyDoc -> Doc+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState++help' :: MyDoc -> Mod f a+help' = helpDoc . Just . doc++desc :: MyDoc -> InfoMod a+desc = footerDoc . Just . doc . indent 2++code :: MyDoc -> MyDoc+code x = do+  _ <- " "+  indent 4 x+  " "++progDesc' :: MyDoc -> InfoMod a+progDesc' = progDescDoc . Just . doc++indent :: Int -> MyDoc -> MyDoc+indent n = append . PP.indent n . doc++int' :: Int -> MyDoc+int' = append . PP.int++para' :: String -> MyDoc+para' = append . para

@@ -0,0 +1,44 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+module GHCMod.Options.ShellParse (parseCmdLine) where++import Data.Char+import Data.List++go :: String -> String -> [String] -> Bool -> [String]+-- result+go [] curarg accargs _ = reverse $ reverse curarg : accargs+go (c:cl) curarg accargs quotes+  -- open quotes+  | c == '\STX', not quotes+  = go cl curarg accargs True+  -- close quotes+  | c == '\ETX', quotes+  = go cl curarg accargs False+  -- space separates arguments outside quotes+  | isSpace c, not quotes+  = if null curarg+      then go cl curarg accargs quotes+      else go cl [] (reverse curarg : accargs) quotes+  -- general character+  | otherwise = go cl (c:curarg) accargs quotes++parseCmdLine :: String -> [String]+parseCmdLine comline'+  | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline'+  = go (dropWhile isSpace comline) [] [] False+parseCmdLine [] = [""]+parseCmdLine comline = words comline

@@ -0,0 +1,32 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GHCMod.Version where++import Paths_ghc_mod+import Data.Version (showVersion)+import Config (cProjectVersion)++progVersion :: String -> String+progVersion pf =+    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "+                               ++ cProjectVersion++ghcModVersion :: String+ghcModVersion = progVersion ""++ghcModiVersion :: String+ghcModiVersion = progVersion "i"

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | WARNING -- This program is deprecated, use `ghc-mod legacy-interactive` instead.

@@ -1,48 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, CPP #-}--module Misc (-    SymDbReq-  , newSymDbReq-  , getDb-  , checkDb-  ) where--import Control.Concurrent.Async (Async, async, wait)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Prelude--import Language.Haskell.GhcMod-import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad--------------------------------------------------------------------type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)-data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)--newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq-newSymDbReq opt gmo tmpdir = do-    let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir-    req <- async act-    ref <- newIORef req-    return $ SymDbReq ref act--getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb-getDb (SymDbReq ref _) = do-    req <- liftIO $ readIORef ref-    -- 'wait' really waits for the asynchronous action at the fist time.-    -- Then it reads a cached value from the second time.-    hoistGhcModT =<< liftIO (wait req)--checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb-checkDb (SymDbReq ref act) db = do-    outdated <- isOutdated db-    if outdated then do-        -- async and wait here is unnecessary because this is essentially-        -- synchronous. But Async can be used a cache.-        req <- liftIO $ async act-        liftIO $ writeIORef ref req-        hoistGhcModT =<< liftIO (wait req)-      else-        return db

@@ -12,23 +12,23 @@ spec = do     describe "browse Data.Map" $ do         it "contains at least `differenceWithKey'" $ do-            syms <- runD $ lines <$> browse "Data.Map"+            syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Map"             syms `shouldContain` ["differenceWithKey"]      describe "browse -d Data.Either" $ do         it "contains functions (e.g. `either') including their type signature" $ do-            syms <- run defaultOptions { optDetailed = True }-                    $ lines <$> browse "Data.Either"+            syms <- runD+                    $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either"             syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]          it "contains type constructors (e.g. `Left') including their type signature" $ do-            syms <- run defaultOptions { optDetailed = True}-                    $ lines <$> browse "Data.Either"+            syms <- runD+                    $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either"             syms `shouldContain` ["Left :: a -> Either a b"]      describe "`browse' in a project directory" $ do         it "can list symbols defined in a a local module" $ do             withDirectory_ "test/data/ghc-mod-check/" $ do-                syms <- runD $ lines <$> browse "Data.Foo"+                syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Foo"                 syms `shouldContain` ["foo"]                 syms `shouldContain` ["fibonacci"]

@@ -122,13 +122,13 @@           withDirectory_ "test/data/file-mapping" $ do             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"-              lint "File.hs"+              lint defaultLintOpts "File.hs"             res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"         it "lints in-memory file if one is specified and outputs original filename" $ do           withDirectory_ "test/data/file-mapping" $ do             res <- runD $ do               loadMappedFileSource "File.hs" "func a b = (++) a b\n"-              lint "File.hs"+              lint defaultLintOpts "File.hs"             res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"         it "shows types of the expression for redirected files" $ do             let tdir = "test/data/file-mapping"@@ -163,6 +163,14 @@               mapM_ (uncurry loadMappedFile) fm               checkSyntax ["File.hs"]             res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "works with full path as well" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            cwd <- getCurrentDirectory+            let fm = [("File.hs", cwd </> "File_Redir.hs")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFile) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"         it "checks in-memory file" $ do           withDirectory_ "test/data/file-mapping/preprocessor" $ do             src <- readFile "File_Redir.hs"@@ -175,14 +183,14 @@           withDirectory_ "test/data/file-mapping/preprocessor" $ do             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"-              lint "File.hs"+              lint defaultLintOpts "File.hs"             res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"         it "lints in-memory file if one is specified and outputs original filename" $ do           withDirectory_ "test/data/file-mapping/preprocessor" $ do             src <- readFile "File_Redir_Lint.hs"             res <- runD $ do               loadMappedFileSource "File.hs" src-              lint "File.hs"+              lint defaultLintOpts "File.hs"             res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"       describe "literate haskell tests" $ do         it "checks redirected file if one is specified and outputs original filename" $ do

@@ -8,10 +8,10 @@ spec = do     describe "lint" $ do         it "can detect a redundant import" $ do-            res <- runD $ lint "test/data/hlint/hlint.hs"+            res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs"             res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"          context "when no suggestions are given" $ do             it "doesn't output an empty line" $ do-                res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs"+                res <- runD $ lint defaultLintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs"                 res `shouldBe` ""

@@ -10,5 +10,5 @@ spec = do     describe "modules" $ do         it "contains at least `Data.Map'" $ do-            mdls <- runD $ lines <$> modules+            mdls <- runD $ lines <$> modules False             mdls `shouldContain` ["Data.Map"]

@@ -3,6 +3,8 @@ import Test.Hspec import TestUtils import Control.Monad.Error.Class+import Control.Concurrent+import Control.Exception  spec :: Spec spec = do@@ -15,3 +17,30 @@                          return "hello"                      `catchError` (const $ fail "oh noes")              a `shouldBe` (Left $ GMEString "oh noes")++    describe "runGhcModT" $+        it "throws an exception when run in multiple threads" $ do++          mv_ex :: MVar (Either SomeException ())+              <- newEmptyMVar+          mv_startup_barrier :: MVar () <- newEmptyMVar++          _t1 <- forkOS $ do+                 putMVar mv_startup_barrier ()+                 -- wait (inside GhcModT) for t2 to receive the exception+                 _ <- runD $ liftIO $ readMVar mv_ex+                 return ()++          _t2 <- forkOS $ do+                 readMVar mv_startup_barrier -- wait for t1 to start up+                 res <- try $ runD $ return ()+                 res' <- evaluate res+                 putMVar mv_ex res'++          ex <- takeMVar mv_ex++          isLeft ex `shouldBe` True++isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True

@@ -0,0 +1,34 @@+module ShellParseSpec where+++import GHCMod.Options.ShellParse++import Test.Hspec++spec :: Spec+spec =+  describe "parseCmdLine" $ do+    it "splits arguments" $ do+      parseCmdLine "test command line" `shouldBe` ["test", "command", "line"]+      parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"]+    it "honors quoted segments if turned on" $+      parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX"+        `shouldBe` ["test", "command", "line", "with quoted segment"]+    it "doesn't honor quoted segments if turned off" $+      parseCmdLine "test command line \STXwith quoted segment\ETX"+        `shouldBe` words "test command line \STXwith quoted segment\ETX"+    it "squashes multiple spaces" $ do+      parseCmdLine "test       command"+        `shouldBe` ["test", "command"]+      parseCmdLine "ascii-escape           test       command"+        `shouldBe` ["test", "command"]+    it "ingores leading spaces" $ do+      parseCmdLine "     test       command"+        `shouldBe` ["test", "command"]+      parseCmdLine "   ascii-escape           test       command"+        `shouldBe` ["test", "command"]+    it "parses empty string as no argument" $ do+      parseCmdLine ""+        `shouldBe` [""]+      parseCmdLine "ascii-escape "+        `shouldBe` [""]

@@ -43,22 +43,9 @@     Right a ->  return a     Left e -> error $ show e -withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a+withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a withSpecCradle cradledir f = do-    gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl ->-      bracketWorkingDirectory (cradleRootDir crdl) $-        f crdl--bracketWorkingDirectory ::-    (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c-bracketWorkingDirectory dir a =-    gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a)--swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath-swapWorkingDirectory ndir = liftIO $ do-  odir <- getCurrentDirectory >>= canonicalizePath-  setCurrentDirectory $ ndir-  return odir+    gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f  runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do@@ -69,7 +56,7 @@     => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do   runGmOutT opt $-    withGhcModEnv' withSpecCradle dir' opt $ \env -> do+    withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do       first (fst <$>) <$> runGhcModT' env defaultGhcModState         (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)