packages feed

ghc-mod 5.5.0.0 → 5.8.0.0

raw patch · 183 files changed

Files

ChangeLog view
@@ -1,3 +1,37 @@+2017-05-26 v5.8.0.0+	* Fix logic bug in fix for excessive use of `map-file`+	* Bump HLint to 2.x+	* Reorganize Cabal file to make maintanance easier+	* Merge #872, Do not log warning when Stack project is preferred+	* Merge #873, Fix build on case-insensitive filesystems+	* Fix 'debug' command when ghc(-pkg) not on PATH+	* Rework README+	* Reorganize modules as preparation for splitting off ghc-mod-core+	* Remove dependency on 'pretty' and use GHC's pretty printer instead+	* Merge #854, Fix for "ghc-mod doc" when usind with stack+	* Merge #858, Fix Gap.fromTyThing returning GHC internal+	  representation instead of the user readable representation of+	  types+	* Fix #774, 'find*File' searching all the way up to /+	* Fix #778, Check directory permissions before reading in+	  findFileInParentsP+	* Merge #817, fix #779, bad "ghc-mod check" performance++2017-01-16 v5.7.0.0+	* Bump cabal-helper to 0.7.3.0 to support Cabal-1.24.1.0+	* Bump haskell-src-exts, optparse-applicative, pipes and extra+	  to be compatible with stackage.++2016-07-29 v5.6.0.0+	* Bump cabal-helper to 0.7, adds support for Cabal-1.24+	* Merge #737, `map-file` caching issues+	* Merge #767, Add `browse` option to show symbol "parents"+	* Merge #731, Type constraints+	* Fix #69 (via #731), Missing type constraints+	* Fix #438, Case splitting not working+	* Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed+	* Add support for GHC 8.0+ 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`@@ -29,9 +63,9 @@ 	  super slowness) 	* Expose all internal modules because API will get a major 	  redesign soon anyways-        * ghc-mod(i) executable must now be run in project directory for-          commands other than `root`-        * Add --line-prefix option for multiplexing stdout/err onto one stream+	* ghc-mod(i) executable must now be run in project directory for+	  commands other than `root`+	* Add --line-prefix option for multiplexing stdout/err onto one stream  2015-08-14 v5.3.0.0 	* Re-license majority of code under the AGPL-3@@ -39,72 +73,72 @@ 	* Remove `cabalDependPackages', `cabalAllTargets' 	* Merge #434, Fix finding sandbox config file and directory. 	* Merge #431, Re-add output line separator global option for expand-          command.+	  command. 	* Merge #470, Support for overriding the package-db stack 	* Merge #486, Fix ineffective cache invalidation for `find`  2014-12-31 v5.2.1.2 	* Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers 	  are operators-        * Fix incompatibility with monad-control >= 1.0.0-        * Fix temporary directories not being removed properly-        * Merge #405, #408, a race condition in the Emacs frontend-        * Merge #403, Support unicode quotes in module regexp+	* Fix incompatibility with monad-control >= 1.0.0+	* Fix temporary directories not being removed properly+	* Merge #405, #408, a race condition in the Emacs frontend+	* Merge #403, Support unicode quotes in module regexp  2014-11-03 v5.2.1.1-        * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.-        * Support `where` clauses, `let` bindings and `case` expressions-          in case splitting, #400+	* Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.+	* Support `where` clauses, `let` bindings and `case` expressions+	  in case splitting, #400  2014-11-02 v5.2.1.0-        * Fix `newTempDir` on Windows-        * GhcModT's liftIO instance now converts GhcMOdError exceptions-          into monadic failures+	* Fix `newTempDir` on Windows+	* GhcModT's liftIO instance now converts GhcMOdError exceptions+	  into monadic failures  2014-10-30 v5.2.0.0-        * Return type of `loadSymbolDb` is now in GhcModT-        * Function `dumpSymbol` now takes the path of the target directory-        * Fix #387, Pattern match failure in GhcPkg-        * Fix #386, `ghc-mod version` should not check `cabal configure`-        * Fix #391, Error on command `-g` when used before command despite-          --help output saying this is valid-        * Fix formatting of `ghc-version` constant in the elisp code.  in-          version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".+	* Return type of `loadSymbolDb` is now in GhcModT+	* Function `dumpSymbol` now takes the path of the target directory+	* Fix #387, Pattern match failure in GhcPkg+	* Fix #386, `ghc-mod version` should not check `cabal configure`+	* Fix #391, Error on command `-g` when used before command despite+	  --help output saying this is valid+	* Fix formatting of `ghc-version` constant in the elisp code.  in+	  version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".  2014-10-04 v5.1.1.0-        * Handle various consistency related issues: #222, #224, #326, #332-        * Add `isOutdated` to Language.Haskell.GhcMod+	* Handle various consistency related issues: #222, #224, #326, #332+	* Add `isOutdated` to Language.Haskell.GhcMod  2014-09-17 v5.1.0.2-        * Fix building with haskell-src-exts < 1.16.0+	* Fix building with haskell-src-exts < 1.16.0  2014-09-16 v5.1.0.1-        * Fix building with haskell-src-exts-1.16.0-        * Loosen monad-journal dependency+	* Fix building with haskell-src-exts-1.16.0+	* Loosen monad-journal dependency  2014-09-12 v5.1.0.0-        * GhcModError is now a recursive data type (`GMECabalConfigure`'s-          type changed)-        * GhcModT's MonadIO instance now converts IOError's to failures in-          the ErrorT part of GhcModT on `liftIO`.-        * Make `loadSymbolDb` polimorphic in the return types's monad.-        * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal-        * Fix `check` command for modules using `-XPatternSynonyms`-        * Merge #364, Support cabal configuration flags+	* GhcModError is now a recursive data type (`GMECabalConfigure`'s+	  type changed)+	* GhcModT's MonadIO instance now converts IOError's to failures in+	  the ErrorT part of GhcModT on `liftIO`.+	* Make `loadSymbolDb` polimorphic in the return types's monad.+	* Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal+	* Fix `check` command for modules using `-XPatternSynonyms`+	* Merge #364, Support cabal configuration flags  2014-08-29 v5.0.1.2-        * Merge #345, Try fixing duplicate errors-        * Merge #344, elisp: Use advice to check syntax on save-buffer-        * Merge #341, support `browse -d` in ghc-modi-        * Merge #352, elisp: Fix C-u accidentally getting turned into a-          prefix command+	* Merge #345, Try fixing duplicate errors+	* Merge #344, elisp: Use advice to check syntax on save-buffer+	* Merge #341, support `browse -d` in ghc-modi+	* Merge #352, elisp: Fix C-u accidentally getting turned into a+	  prefix command  2014-08-24 v5.0.1.1-        * Fix CaseSplitting faliure when using "fancy types" (see #336)-        * Print error information in "spec" test suite when using `extract`+	* Fix CaseSplitting faliure when using "fancy types" (see #336)+	* Print error information in "spec" test suite when using `extract`  2014-08-20 v5.0.1-        * Fix missing file in "Data-Files"+	* Fix missing file in "Data-Files"  2014-08-20 v5.0.0 	* ghc-mod consumes much less memory than ghc-mod-4.1.
− Data/Binary/Generic.hs 
@@ -1,134 +0,0 @@-{-# 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
+ GhcMod.hs view
@@ -0,0 +1,92 @@+-- | The ghc-mod library.++module GhcMod (+  -- * Cradle+    Cradle(..)+  , Project(..)+  , findCradle+  -- * Options+  , Options(..)+  , LineSeparator(..)+  , OutputStyle(..)+  , FileMapping(..)+  , defaultOptions+  -- * Logging+  , GmLogLevel+  , increaseLogLevel+  , decreaseLogLevel+  , gmSetLogLevel+  , gmLog+  -- * Types+  , ModuleString+  , Expression(..)+  , GhcPkgDb+  , Symbol+  , SymbolDb+  , GhcModError(..)+  -- * Monad Types+  , GhcModT+  , IOish+  -- * Monad utilities+  , runGhcModT+  , withOptions+  , dropSession+  -- * 'GhcMod' utilities+  , boot+  , browse+  , check+  , checkSyntax+  , debugInfo+  , componentInfo+  , expandTemplate+  , info+  , lint+  , pkgDoc+  , rootInfo+  , types+  , test+  , splits+  , sig+  , refine+  , auto+  , modules+  , languages+  , flags+  , findSymbol+  , lookupSymbol+  , dumpSymbol+  -- * SymbolDb+  , loadSymbolDb+  , isOutdated+  -- * Output+  , gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn+  -- * FileMapping+  , loadMappedFile+  , loadMappedFileSource+  , unloadMappedFile+  ) where++import GhcMod.Exe.Boot+import GhcMod.Exe.Browse+import GhcMod.Exe.CaseSplit+import GhcMod.Exe.Check+import GhcMod.Exe.Debug+import GhcMod.Exe.FillSig+import GhcMod.Exe.Find+import GhcMod.Exe.Flag+import GhcMod.Exe.Info+import GhcMod.Exe.Lang+import GhcMod.Exe.Lint+import GhcMod.Exe.Modules+import GhcMod.Exe.PkgDoc+import GhcMod.Exe.Test+import GhcMod.Cradle+import GhcMod.FileMapping+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Target+import GhcMod.Types
+ GhcMod/Exe/Boot.hs view
@@ -0,0 +1,29 @@+module GhcMod.Exe.Boot where++import Control.Applicative+import Prelude++import GhcMod.Exe.Browse+import GhcMod.Exe.Flag+import GhcMod.Exe.Lang+import GhcMod.Exe.Modules+import GhcMod.Monad+import GhcMod.Types (defaultBrowseOpts)++-- | Printing necessary information for front-end booting.+boot :: IOish m => GhcModT m String+boot = concat <$> sequence ms+  where+    ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]++preBrowsedModules :: [String]+preBrowsedModules = [+    "Prelude"+  , "Control.Applicative"+  , "Control.Exception"+  , "Control.Monad"+  , "Data.Char"+  , "Data.List"+  , "Data.Maybe"+  , "System.IO"+  ]
+ GhcMod/Exe/Browse.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}+module GhcMod.Exe.Browse (+    browse,+    BrowseOpts(..)+  ) where++import Safe+import Control.Applicative+import Control.Exception (SomeException(..))+import Data.Char+import Data.List+import Data.Maybe+import FastString+import GHC+import HscTypes+import qualified GHC as G+import GhcMod.Convert+import GhcMod.Doc (showPage, styleUnqualified)+import GhcMod.Gap as Gap+import GhcMod.Types+import GhcMod.Monad+import GhcMod.Logging+import Name (getOccString)+import Outputable+import TyCon (isAlgTyCon)+import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)+import Exception (ExceptionMonad, ghandle)+import Prelude+#if __GLASGOW_HASKELL__ >= 800+import PatSyn (pprPatSynType)+#endif++----------------------------------------------------------------++-- | Getting functions, classes, etc from a module.+browse :: forall m. IOish m+           => 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 (\ex@(SomeException _) -> logException ex >> return []) $ do+      goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)++    logException ex =+        gmLog GmException "browse" $ showToDoc ex++    goPkgModule = do+      runGmPkgGhc $+        processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid++    goHomeModule = runGmlT [Right mdlname] $ do+      processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing++    tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m++    (mpkg, mdl) = splitPkgMdl pkgmdl+    mdlname = G.mkModuleName mdl+    mpkgid = mkFastString <$> mpkg++-- |+--+-- >>> splitPkgMdl "base:Prelude"+-- (Just "base","Prelude")+-- >>> splitPkgMdl "Prelude"+-- (Nothing,"Prelude")+splitPkgMdl :: String -> (Maybe String,String)+splitPkgMdl pkgmdl =+  case break (==':') pkgmdl of+    (mdl, "")    -> (Nothing, mdl)+    (pkg, _:mdl) -> (Just pkg, mdl)++-- Haskell 2010:+-- small -> ascSmall | uniSmall | _+-- ascSmall -> a | b | ... | z+-- uniSmall -> any Unicode lowercase letter+-- varid -> (small {small | large | digit | ' })++isNotOp :: String -> Bool+isNotOp (h:_) = isAlpha h || (h == '_')+isNotOp _ = error "isNotOp"++processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)+               => BrowseOpts -> ModuleInfo -> m [String]+processExports opt minfo = do+  let+    removeOps+      | 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)+           => 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` optBrowseQualified opt+    mtype :: m (Maybe String)+    mtype+      | optBrowseDetailed opt || optBrowseParents 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+        let sig = do+                    typeName <- tyResult >>= showThing dflag+                    (" :: " ++ typeName) `justIf` optBrowseDetailed opt+        let parent = do+                    thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe+                    (" -- from:" ++ thing) `justIf` optBrowseParents opt+        return $ case concat $ catMaybes [sig, parent] of+                    [] -> Nothing+                    x  -> Just x+      | otherwise = return Nothing+    formatOp nm+      | null nm    = error "formatOp"+      | isNotOp nm = nm+      | otherwise  = "(" ++ nm ++ ")"+    inOtherModule :: Name -> m (Maybe TyThing)+    inOtherModule nm = do+      G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm+    justIf :: a -> Bool -> Maybe a+    justIf x True = Just x+    justIf _ False = Nothing++showThing :: DynFlags -> TyThing -> Maybe String+showThing dflag tything = showThing' dflag (fromTyThing tything)++showThing' :: DynFlags -> GapThing -> Maybe String+showThing' dflag (GtA a) = Just $ formatType dflag a+showThing' _     (GtT t) = unwords . toList <$> tyType t+  where+    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)+#if __GLASGOW_HASKELL__ >= 800+showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p+#endif+showThing' _     _       = Nothing++formatType :: DynFlags -> Type -> String+formatType dflag a = showOutputable dflag (removeForAlls a)++tyType :: TyCon -> Maybe String+tyType typ+    | isAlgTyCon typ+      && not (G.isNewTyCon typ)+      && not (G.isClassTyCon typ) = Just "data"+    | G.isNewTyCon typ            = Just "newtype"+    | G.isClassTyCon typ          = Just "class"+    | Gap.isSynTyCon typ          = Just "type"+    | otherwise                   = Nothing++removeForAlls :: Type -> Type+removeForAlls ty = removeForAlls' ty' tty'+  where+    ty'  = dropForAlls ty+    tty' = splitFunTy_maybe ty'++removeForAlls' :: Type -> Maybe (Type, Type) -> Type+removeForAlls' ty Nothing = ty+removeForAlls' ty (Just (pre, ftype))+    | isPredTy pre        = mkFunTy pre (dropForAlls ftype)+    | otherwise           = ty++showOutputable :: Outputable a => DynFlags -> a -> String+showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
+ GhcMod/Exe/CaseSplit.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE CPP #-}++module GhcMod.Exe.CaseSplit (+    splits+  ) where++import Data.List (find, intercalate)+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Data.Text.IO as T (readFile)+import System.FilePath+import Prelude++import qualified DataCon as Ty+import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))+import qualified GHC as G+import Outputable (PprStyle)+import qualified TyCon as Ty+import qualified Type as Ty+import Exception++import GhcMod.Convert+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Doc+import GhcMod.Logging+import GhcMod.Types+import GhcMod.Utils (withMappedFile)+import GhcMod.FileMapping (fileModSummaryWithMapping)+import Control.DeepSeq++----------------------------------------------------------------+-- CASE SPLITTING+----------------------------------------------------------------++data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]+               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)+data SplitToTextInfo = SplitToTextInfo { sVarName     :: String+                                       , sBindingSpan :: SrcSpan+                                       , sVarSpan     :: SrcSpan+                                       , sTycons      :: [String]+                                       }++-- | Splitting a variable in a equation.+splits :: IOish m+       => FilePath     -- ^ A target file.+       -> Int          -- ^ Line number.+       -> Int          -- ^ Column number.+       -> GhcModT m String+splits file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do+      oopts <- outputOpts+      crdl <- cradle+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)+      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do+          let (varName, bndLoc, (varLoc,varT))+                | (SplitInfo vn bl vlvt _matches) <- x+                = (vn, bl, vlvt)+                | (TySplitInfo vn bl vlvt) <- x+                = (vn, bl, vlvt)+              varName' = showName dflag style varName  -- Convert name to string+          t <- withMappedFile file $ \file' ->+                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $+                                             getTyCons dflag style varName varT)+          return $!! (fourInts bndLoc, t)+ where+   handler (SomeException ex) = do+     gmLog GmException "splits" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++----------------------------------------------------------------+-- a. Code for getting the information of the variable++getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForSplit modSum lineNo colNo = do+  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo+  if isJust fn+     then return fn+     else getSrcSpanTypeForTypeSplit modSum lineNo colNo++-- Information for a function case split+getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForFnSplit modSum lineNo colNo = do+    p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum+    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)+        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI+    case varPat of+      Nothing  -> return Nothing+      Just varPat' -> do+        varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var+        case varT of+          Just varT' ->+#if __GLASGOW_HASKELL__ >= 710+            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match+#else+            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match+#endif+            in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )+          _ -> return Nothing++isPatternVar :: LPat Id -> Bool+isPatternVar (L _ (G.VarPat _)) = True+isPatternVar _                  = False++getPatternVarName :: LPat Id -> G.Name+#if __GLASGOW_HASKELL__ >= 800+getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName+#else+getPatternVarName (L _ (G.VarPat vName)) = G.getName vName+#endif+getPatternVarName _                      = error "This should never happened"++-- TODO: Information for a type family case split+getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing++----------------------------------------------------------------+-- b. Code for getting the possible constructors++getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]+getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =+  let name' = showName dflag style name  -- Convert name to string+  in getTyCon dflag style name' tyCon+getTyCons dflag style name _ = [showName dflag style name]++-- Write cases for one type+getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]+-- 1. Non-matcheable type constructors+getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]+-- 2. Special cases+-- 2.1. Tuples+getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =+  let [uniqueDataCon] = Ty.tyConDataCons tyCon+      tupleArity = Ty.dataConSourceArity uniqueDataCon+      -- Deal with both boxed and unboxed tuples+      isUnboxed = Ty.isUnboxedTupleTyCon tyCon+      startSign = if isUnboxed then "(#" else "("+      endSign   = if isUnboxed then "#)" else ")"+  in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]+-- 3. General case+getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)++-- These type constructors should not be matched against+isNotMatcheableTyCon :: Ty.TyCon -> Bool+isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#+                       || Ty.isFunTyCon ty   -- Function types++-- Write case for one constructor+getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String+-- 1. Infix constructors+getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =+  let dName  = showName dflag style $ Ty.dataConName dcon+  in case Ty.dataConSourceArity dcon of+       0 -> dName+       1 -> vName ++ dName+       n -> if dName == ":" -- Special case for lists+            then vName ++ ":" ++ vName ++ "s"+            else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)+-- 2. Non-record, non-infix syntax+getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =+  let dName  = showName dflag style $ Ty.dataConName dcon+  in if last dName == '#'  -- Special case for I#, C# and so on+     then vName+     else case Ty.dataConSourceArity dcon of+            0 -> dName+            _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)+-- 3. Records+getDataCon dflag style vName dcon =+  let dName = showName dflag style $ Ty.dataConName dcon+#if __GLASGOW_HASKELL__ >= 800+      flds  = map Ty.flSelector $ Ty.dataConFieldLabels dcon+#else+      flds  = Ty.dataConFieldLabels dcon+#endif+  in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"++-- Create a new variable by adjoining a number+newVar :: String -> Int -> String+newVar v n = v ++ show n++-- Create a list of variables which start with the same prefix+newVars :: String -> Int -> Int -> String+newVars _ _ 0 = ""+newVars v s 1 = newVar v s+newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)++-- Create a list of variables which start with the same prefix+-- Special case for a single variable, in which case no number is adjoint+newVarsSpecialSingleton :: String -> Int -> Int -> String+newVarsSpecialSingleton v _     1 = v+newVarsSpecialSingleton v start n = newVars v start n++showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String+showFieldNames _     _     _ []      = "" -- This should never happen+showFieldNames dflag style v (x:xs) = let fName = showName dflag style x+                                          fAcc  = fName ++ " = " ++ v ++ "_" ++ fName+                                       in case xs of+                                            [] -> fAcc+                                            _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs++----------------------------------------------------------------+-- c. Code for performing the case splitting++genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>+    FilePath -> SplitToTextInfo -> m String+genCaseSplitTextFile file info = liftIO $ do+  t <- T.readFile file+  return $ getCaseSplitText (T.lines t) info++getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String+getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS+                                       , sVarSpan = sVS, sTycons = sT }  =+  let bindingText = getBindingText t sBS+      difference  = srcSpanDifference sBS sVS+      replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT+      -- The newly generated bindings need to be indented to align with the+      -- original binding.+      replaced'   = head replaced : map (indentBindingTo sBS) (tail replaced)+   in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')++getBindingText :: [T.Text] -> SrcSpan -> [T.Text]+getBindingText t srcSpan =+  let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan+      lines_ = drop (sl - 1) $ take el t+   in if sl == el+      then -- only one line+           [T.drop (sc - 1) $ T.take ec $ head lines_]+      else -- several lines+            let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)+             in T.drop (sc - 1) first : rest ++ [T.take ec last_]++srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)+srcSpanDifference b v =+  let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b+      Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v+   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line++replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]+replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =+  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon+      lengthDiff  = length tycon' - length varname+      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'+      spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff+   in zipWith (\n line -> if n < vsl+                          then line  -- before variable starts+                          else if n == vsl+                               then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line+                               else T.replicate spacesToAdd (T.pack " ") `T.append` line)+              [0 ..] t++indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]+indentBindingTo bndLoc binds =+  let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc+      indent      = (T.replicate (sl - 1) (T.pack " ") `T.append`)+   in indent (head binds) : tail binds
+ GhcMod/Exe/Check.hs view
@@ -0,0 +1,57 @@+module GhcMod.Exe.Check (+    checkSyntax+  , check+  , expandTemplate+  , expand+  ) where++import Control.Applicative+import Prelude+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap+import GhcMod.Logger+import GhcMod.Monad++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+checkSyntax :: IOish m+            => [FilePath]  -- ^ The target files.+            -> GhcModT m String+checkSyntax []    = return ""+checkSyntax files = either id id <$> check files++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+check :: IOish m+      => [FilePath]  -- ^ The target files.+      -> GhcModT m (Either String String)+check files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)+      (return ())++----------------------------------------------------------------++-- | Expanding Haskell Template.+expandTemplate :: IOish m+               => [FilePath]  -- ^ The target files.+               -> GhcModT m String+expandTemplate []    = return ""+expandTemplate files = either id id <$> expand files++----------------------------------------------------------------++-- | Expanding Haskell Template.+expand :: IOish m => [FilePath] -> GhcModT m (Either String String)+expand files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))+      (return ())
+ GhcMod/Exe/Debug.hs view
@@ -0,0 +1,182 @@+module GhcMod.Exe.Debug (debugInfo, rootInfo, componentInfo) where++import Control.Arrow (first)+import Control.Applicative+import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Char+import Data.Maybe+import Data.Version+import Data.List.Split+import System.Directory++import GhcMod.Exe.Internal+import GhcMod.Cradle+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Pretty+import GhcMod.Stack+import GhcMod.Target+import GhcMod.Types+import GhcMod.Utils++import Paths_ghc_mod (version)++import Config (cProjectVersion)+import Pretty++----------------------------------------------------------------++-- | Obtaining debug information.+debugInfo :: IOish m => GhcModT m String+debugInfo = do+    Options {..} <- options+    Cradle {..} <- cradle++    [ghcPath, ghcPkgPath] <- liftIO $+        case cradleProject of+          StackProject se ->+              catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]+          _ ->+              return ["ghc", "ghc-pkg"]++    cabal <-+        case cradleProject of+          CabalProject -> cabalDebug ghcPkgPath+          StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath+          _ -> return []++    pkgOpts <- packageGhcOptions++    readProc <- gmReadProcess++    ghcVersion <- liftIO $+        dropWhileEnd isSpace <$> readProc ghcPath ["--numeric-version"] ""++    return $ unlines $+      [ "Version:              ghc-mod-" ++ showVersion version+      , "Library GHC Version:  " ++ cProjectVersion+      , "System GHC Version:   " ++ ghcVersion+      , "Root directory:       " ++ cradleRootDir+      , "Current directory:    " ++ cradleCurrentDir+      , "GHC Package flags:\n"   ++ renderGm (nest 4 $+              fsep $ map text pkgOpts)+      , "GHC System libraries: " ++ ghcLibDir+      ] ++ cabal++stackPaths :: IOish m => GhcModT m [String]+stackPaths = do+    Cradle { cradleProject = StackProject senv } <- cradle+    ghc <- getStackGhcPath senv+    ghcPkg <- getStackGhcPkgPath senv+    return $+         [ "Stack ghc executable:    " ++ show ghc+         , "Stack ghc-pkg executable:" ++ show ghcPkg+         ]++cabalDebug :: IOish m => FilePath -> GhcModT m [String]+cabalDebug ghcPkgPath = do+    Cradle {..} <- cradle+    mcs <- cabalResolvedComponents+    let entrypoints = Map.map gmcEntrypoints mcs+        graphs      = Map.map gmcHomeModuleGraph mcs+        opts        = Map.map gmcGhcOpts mcs+        srcOpts     = Map.map gmcGhcSrcOpts mcs++    readProc <- gmReadProcess+    cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"++    cabalInstVersion <-+        if cabalExists+          then liftIO $+            dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""+          else return ""++    packages <- liftIO $ readProc ghcPkgPath ["list", "--simple-output"] ""+    let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages++    return $+         [ "cabal-install Version: "    ++ cabalInstVersion+         , "Cabal Library Versions:\n"  ++ renderGm (nest 4 $+              fsep $ map text cabalPackages)+         , "Cabal file:            "    ++ show cradleCabalFile+         , "Project:               " ++ show cradleProject+         , "Cabal entrypoints:\n"       ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc smpDoc entrypoints)+         , "Cabal components:\n"        ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc graphDoc graphs)+         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) opts)+         , "GHC search path options:\n" ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)+         ]++componentInfo :: IOish m => [String] -> GhcModT m String+componentInfo ts = do+    -- TODO: most of this is copypasta of targetGhcOptions. Factor out more+    -- useful function from there.+    crdl <- cradle+    sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts+    mcs <- cabalResolvedComponents+    let+        mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+        candidates = findCandidates $ map snd mdlcs+        cn = pickComponent candidates+    opts <- targetGhcOptions crdl sefnmn++    return $ unlines $+         [ "Matching Components:\n"     ++ renderGm (nest 4 $+              alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)+         , "Picked Component:\n"        ++ renderGm (nest 4 $+              gmComponentNameDoc cn)+         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $ fsep $ map text opts)+         ]+ where+   zipMap f l = l `zip` (f `map` l)++guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)+guessModuleFile m+  | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =+      return $ Right $ mkModuleName m+ where+   infixr 1 .||.+   infixr 2 .&&.+   (.||.) = liftA2 (||)+   (.&&.) = liftA2 (&&)++guessModuleFile str = Left `liftM` liftIO (canonFilePath str)++graphDoc :: GmModuleGraph -> Doc+graphDoc GmModuleGraph{..} =+    mapDoc mpDoc smpDoc' gmgGraph+ where+   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp+   mpDoc' = text . moduleNameString . mpModule++setDoc :: (a -> Doc) -> Set.Set a -> Doc+setDoc f s = vcat $ map f $ Set.toList s++smpDoc :: Set.Set ModulePath -> Doc+smpDoc smp = setDoc mpDoc smp++mpDoc :: ModulePath -> Doc+mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)++mnDoc :: ModuleName -> Doc+mnDoc mn = text (moduleNameString mn)++alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc+alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)++mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc+mapDoc kd ad m = vcat $+    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m+----------------------------------------------------------------++-- | Obtaining root information.+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String+rootInfo = do+    crdl <- findCradleNoLog =<< (optPrograms <$> options)+    liftIO $ cleanupCradle crdl+    return $ cradleRootDir crdl ++ "\n"
+ GhcMod/Exe/FillSig.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}++module GhcMod.Exe.FillSig (+    sig+  , refine+  , auto+  ) where++import Data.Char (isSymbol)+import Data.Function (on)+import Data.Functor+import Data.List (find, nub, sortBy)+import qualified Data.Map as M+import Data.Maybe (catMaybes)+import Prelude++import Exception (ghandle, SomeException(..))+import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,+            SrcSpan, Type, GenLocated(L))+import Pretty (($$), text, nest)+import qualified GHC as G+import qualified Name as G+import Outputable (PprStyle)+import qualified Type as Ty+import qualified HsBinds as Ty+import qualified Class as Ty+import qualified Var as Ty+import qualified HsPat as Ty+import qualified Language.Haskell.Exts as HE+import Djinn.GHC++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.DynFlags+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Logging (gmLog)+import GhcMod.Pretty (showToDoc)+import GhcMod.Doc+import GhcMod.Types+import GhcMod.FileMapping (fileModSummaryWithMapping)++#if __GLASGOW_HASKELL__ >= 710+import GHC (unLoc)+#endif++----------------------------------------------------------------+-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE+----------------------------------------------------------------++-- Possible signatures we can find: function or instance+data SigInfo+    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)+    | InstanceDecl SrcSpan G.Class+    | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]++-- Signature for fallback operation via haskell-src-exts+data HESigInfo+    = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)+    | HEFamSignature+          HE.SrcSpan+          TyFamType+          (HE.Name HE.SrcSpanInfo)+          [HE.Name HE.SrcSpanInfo]++data TyFamType = Closed | Open | Data+initialTyFamString :: TyFamType -> (String, String)+initialTyFamString Closed = ("instance", "")+initialTyFamString Open   = ("function", "type instance ")+initialTyFamString Data   = ("function", "data instance ")++-- | Create a initial body from a signature.+sig :: IOish m+    => FilePath     -- ^ A target file.+    -> Int          -- ^ Line number.+    -> Int          -- ^ Column number.+    -> GhcModT m String+sig file lineNo colNo =+    runGmlT' [Left file] deferErrors $ ghandle fallback $ do+      oopts <- outputOpts+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping file+      whenFound oopts (getSignature modSum lineNo colNo) $ \s ->+        case s of+          Signature loc names ty ->+              ("function", fourInts loc, map (initialBody dflag style ty) names)++          InstanceDecl loc cls ->+            let body x = initialBody dflag style (G.idType x) x+            in ("instance", fourInts loc, body `map` Ty.classMethods cls)++          TyFamDecl loc name flavour vars ->+            let (rTy, initial) = initialTyFamString flavour+                body = initialFamBody dflag style name vars+            in (rTy, fourInts loc, [initial ++ body])+  where+    fallback (SomeException _) = do+      oopts <- outputOpts+      -- Code cannot be parsed by ghc module+      -- Fallback: try to get information via haskell-src-exts+      whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of+        HESignature loc names ty ->+          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)+        HEFamSignature loc flavour name vars ->+          let (rTy, initial) = initialTyFamString flavour+           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])++----------------------------------------------------------------+-- a. Code for getting the information++-- Get signature from ghc parsing and typechecking+getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)+getSignature modSum lineNo colNo = do+    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum+    -- Inspect the parse tree to find the signature+    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->+#elif __GLASGOW_HASKELL__ >= 710+      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->+#else+      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->+#endif+        -- We found a type signature+        return $ Just $ Signature loc (map G.unLoc names) ty+      [L _ (G.InstD _)] -> do+        -- We found an instance declaration+        TypecheckedModule{tm_renamed_source = Just tcs+                         ,tm_checked_module_info = minfo} <- G.typecheckModule p+        let lst = listifyRenamedSpans tcs (lineNo, colNo)+        case Gap.getClass lst of+            Just (clsName,loc) -> obtainClassInfo minfo clsName loc+            _                  -> return Nothing+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do+#elif __GLASGOW_HASKELL__ >= 708+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do+#elif __GLASGOW_HASKELL__ >= 706+      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do+#else+      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do+#endif+#if __GLASGOW_HASKELL__ >= 708+        let flavour = case info of+                        G.ClosedTypeFamily _ -> Closed+                        G.OpenTypeFamily     -> Open+                        G.DataFamily         -> Data+#else+        let flavour = case info of  -- Closed type families where introduced in GHC 7.8+                        G.TypeFamily -> Open+                        G.DataFamily -> Data+#endif++#if __GLASGOW_HASKELL__ >= 800+            getTyFamVarName x = case x of+                L _ (G.UserTyVar (G.L _ n))     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 710+            getTyFamVarName x = case x of+                L _ (G.UserTyVar n)     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 706+            getTyFamVarName x = case x of+                L _ (G.UserTyVar n)     -> n+                L _ (G.KindedTyVar n _) -> n+#else+            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg+                L _ (G.UserTyVar n _)     -> n+                L _ (G.KindedTyVar n _ _) -> n+#endif+         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)+      _ -> return Nothing+  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)+        obtainClassInfo minfo clsName loc = do+          tyThing <- G.modInfoLookupName minfo clsName+          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe+                      cls <- G.tyConClass_maybe clsCon+                      return $ InstanceDecl loc cls++-- Get signature from haskell-src-exts+getSignatureFromHE :: (MonadIO m, GhcMonad m) =>+    FilePath -> Int -> Int -> m (Maybe HESigInfo)+getSignatureFromHE file lineNo colNo = do+  presult <- liftIO $ HE.parseFile file+  return $ case presult of+             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do+               decl <- find (typeSigInRangeHE lineNo colNo) mdecls+               case decl of+                 HE.TypeSig (HE.SrcSpanInfo s _) names ty ->+                     return $ HESignature s names ty++                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ ->+                   let (name, tys) = dHeadTyVars declHead in+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)++                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->+                   let (name, tys) = dHeadTyVars declHead in+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)+                 _ -> fail ""+             _ -> Nothing+  where cleanTyVarBind (HE.KindedVar _ n _) = n+        cleanTyVarBind (HE.UnkindedVar _ n) = n++#if MIN_VERSION_haskell_src_exts(1,16,0)+        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])+        dHeadTyVars (HE.DHead _ name) = (name, [])+        dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)+        dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])+        dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r+#else+        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])+        dHeadTyVars (HE.DHead _ n tys) = (n, tys)+#endif++----------------------------------------------------------------+-- b. Code for generating initial code++-- A list of function arguments, and whether they are functions or normal+-- arguments is built from either a function signature or an instance signature+data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String++initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String+initialBody dflag style ty name =+    initialBody' (getFnName dflag style name) (getFnArgs ty)++initialBody' :: String -> [FnArg] -> String+initialBody' fname args =+    initialHead fname args ++ " = " ++ n ++ "_body"+ where n = if isSymbolName fname then "" else '_':fname++initialFamBody :: FnArgsInfo ty name+               => DynFlags -> PprStyle -> name -> [name] -> String+initialFamBody dflag style name args =+    initialHead fnName fnArgs ++ " = ()"+ where fnName = getFnName dflag style name+       fnArgs = map (FnExplicitName . getFnName dflag style) args++initialHead :: String -> [FnArg] -> String+initialHead fname args =+  case initialBodyArgs args infiniteVars infiniteFns of+    []      -> fname+    arglist -> if isSymbolName fname+               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)+               else fname ++ " " ++ unwords arglist++initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]+initialBodyArgs [] _ _ = []+initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs+initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs+initialBodyArgs (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs+initialBodyArgs _                  _      _  =+    error "initialBodyArgs: This should never happen" -- Lists are infinite++initialHead1 :: String -> [FnArg] -> [String] -> String+initialHead1 fname args elts =+  case initialBodyArgs1 args elts of+    []      -> fname+    arglist+      | isSymbolName fname ->+        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)+      | otherwise ->+        fname ++ " " ++ unwords arglist++initialBodyArgs1 :: [FnArg] -> [String] -> [String]+initialBodyArgs1 args elts = take (length args) elts++-- Getting the initial body of function and instances differ+-- This is because for functions we only use the parsed file+-- (so the full file doesn't have to be type correct)+-- but for instances we need to get information about the class++class FnArgsInfo ty name | ty -> name, name -> ty where+  getFnName :: DynFlags -> PprStyle -> name -> String+  getFnArgs :: ty -> [FnArg]++instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where+  getFnName dflag style name = showOccName dflag style $ Gap.occName name+#if __GLASGOW_HASKELL__ >= 800+  getFnArgs (G.HsForAllTy _ (L _ iTy))+#elif __GLASGOW_HASKELL__ >= 710+  getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))+#else+  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))+#endif+    = getFnArgs iTy++  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy+  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =+      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy+    where fnarg ty = case ty of+#if __GLASGOW_HASKELL__ >= 800+              (G.HsForAllTy _ (L _ iTy)) ->+#elif __GLASGOW_HASKELL__ >= 710+              (G.HsForAllTy _ _ _ _ (L _ iTy)) ->+#else+              (G.HsForAllTy _ _ _ (L _ iTy)) ->+#endif+                fnarg iTy++              (G.HsParTy (L _ iTy))          -> fnarg iTy+              (G.HsFunTy _ _)                -> True+              _                              -> False+  getFnArgs _ = []++instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where+  getFnName _ _ (HE.Ident  _ s) = s+  getFnName _ _ (HE.Symbol _ s) = s+  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy+  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy+  getFnArgs (HE.TyFun _ lTy rTy)    =+      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy+    where fnarg ty = case ty of+              (HE.TyForall _ _ _ iTy) -> fnarg iTy+              (HE.TyParen _ iTy)      -> fnarg iTy+              (HE.TyFun _ _ _)        -> True+              _                       -> False+  getFnArgs _ = []++instance FnArgsInfo Type Id where+  getFnName dflag style method = showOccName dflag style $ G.getOccName method+  getFnArgs = getFnArgs' . Ty.dropForAlls+    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =+            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)+                  (\_ -> FnArgFunction:getFnArgs' rTy)+                  $ Ty.splitFunTy_maybe lTy++          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =+              getFnArgs' iTy++          getFnArgs' _ = []++-- Infinite supply of variable and function variable names+infiniteVars, infiniteFns :: [String]+infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]+infiniteFns  = infiniteSupply ["f","g","h"]+infiniteSupply :: [String] -> [String]+infiniteSupply initialSupply =+    initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)+                               ([1 .. ] :: [Integer])++-- Check whether a String is a symbol name+isSymbolName :: String -> Bool+isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c+isSymbolName []    = error "This should never happen"+++----------------------------------------------------------------+-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION+----------------------------------------------------------------++refine :: IOish m+       => FilePath     -- ^ A target file.+       -> Int          -- ^ Line number.+       -> Int          -- ^ Column number.+       -> Expression   -- ^ A Haskell expression.+       -> GhcModT m String+refine file lineNo colNo (Expression expr) =+  ghandle handler $+    runGmlT' [Left file] deferErrors $ do+      oopts <- outputOpts+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping file+      p <- G.parseModule modSum+      tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+      ety <- G.exprType expr+      whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $+        \(loc, name, rty, paren) ->+            let eArgs = getFnArgs ety+                rArgs = getFnArgs rty+                diffArgs' = length eArgs - length rArgs+                diffArgs  = if diffArgs' < 0 then 0 else diffArgs'+                iArgs = take diffArgs eArgs+                txt = initialHead1 expr iArgs (infinitePrefixSupply name)+             in (fourInts loc, doParen paren txt)+  where+   handler (SomeException ex) = do+     gmLog GmException "refining" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++-- Look for the variable in the specified position+findVar+  :: GhcMonad m+  => DynFlags+  -> PprStyle+  -> G.TypecheckedModule+  -> G.TypecheckedSource+  -> Int+  -> Int+  -> m (Maybe (SrcSpan, String, Type, Bool))+findVar dflag style tcm tcs lineNo colNo =+  case lst of+#if __GLASGOW_HASKELL__ >= 800+    e@(L _ (G.HsVar (L _ i))):others -> do+#else+    e@(L _ (G.HsVar i)):others -> do+#endif+      tyInfo <- Gap.getType tcm e+      case tyInfo of+        Just (s, typ)+          | name == "undefined" || head name == '_' ->+            return $ Just (s, name, typ, b)+          where+            name = getFnName dflag style i+            -- If inside an App, we need parenthesis+            b = case others of+                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->+                    isSearchedVar i a1 || isSearchedVar i a2+                  _  -> False+        _ -> return Nothing+    _ -> return Nothing+  where+    lst :: [G.LHsExpr Id]+    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)++infinitePrefixSupply :: String -> [String]+infinitePrefixSupply "undefined" = repeat "undefined"+infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])++doParen :: Bool -> String -> String+doParen False s = s+doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s++isSearchedVar :: Id -> G.HsExpr Id -> Bool+#if __GLASGOW_HASKELL__ >= 800+isSearchedVar i (G.HsVar (L _ i2)) = i == i2+#else+isSearchedVar i (G.HsVar i2) = i == i2+#endif+isSearchedVar _ _ = False+++----------------------------------------------------------------+-- REFINE AUTOMATICALLY+----------------------------------------------------------------++auto :: IOish m+     => FilePath     -- ^ A target file.+     -> Int          -- ^ Line number.+     -> Int          -- ^ Column number.+     -> GhcModT m String+auto file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do+        oopts <- outputOpts+        style <- getStyle+        dflag <- G.getSessionDynFlags+        modSum <- fileModSummaryWithMapping file+        p <- G.parseModule modSum+        tcm@TypecheckedModule {+                 tm_typechecked_source = tcs+               , tm_checked_module_info = minfo+               } <- G.typecheckModule p+        whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do+          topLevel <- getEverythingInTopLevel minfo+          let (f,pats) = getPatsForVariable tcs (lineNo,colNo)+              -- Remove self function to prevent recursion, and id to trim+              -- cases+              filterFn (n,_) = let funName = G.getOccString n+                                   recName = G.getOccString (G.getName f)+                               in funName `notElem` recName:notWantedFuns+              -- Find without using other functions in top-level+              localBnds = M.unions $+                  map (\(L _ pat) -> getBindingsForPat pat) pats+              lbn = filter filterFn (M.toList localBnds)+          djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000+          let -- Find with the entire top-level+              almostEnv = M.toList $ M.union localBnds topLevel+              env = filter filterFn almostEnv+          djinns <- djinn True (Just minfo) env rty (Max 10) 100000+          return ( fourInts loc+                 , map (doParen paren) $ nub (djinnsEmpty ++ djinns))+ where+   handler (SomeException ex) = do+     gmLog GmException "auto-refining" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++-- Functions we do not want in completions+notWantedFuns :: [String]+notWantedFuns = ["id", "asTypeOf", "const"]++-- Get all things defined in top-level+getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)+getEverythingInTopLevel m = do+  let modInfo  = tyThingsToInfo (G.modInfoTyThings m)+      topNames = G.modInfoTopLevelScope m+  case topNames of+    Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'+                         let topThings' = catMaybes topThings+                             topInfo    = tyThingsToInfo topThings'+                         return $ M.union modInfo topInfo+    Nothing -> return modInfo++tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type+tyThingsToInfo [] = M.empty+tyThingsToInfo (G.AnId i : xs) =+    M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)+-- Getting information about constructors is not needed+-- because they will be added by djinn-ghc when traversing types+-- #if __GLASGOW_HASKELL__ >= 708+-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]+-- #else+-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]+-- #endif+tyThingsToInfo (_:xs) = tyThingsToInfo xs++-- Find the Id of the function and the pattern where the hole is located+getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])+getPatsForVariable tcs (lineNo, colNo) =+  let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $+                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]+   in case bnd of+        G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of+          Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])+          _                     -> (error "This should never happen", [])+        G.FunBind { Ty.fun_id = L _ funId } ->+          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)+#if __GLASGOW_HASKELL__ >= 708+                    :: [G.LMatch Id (G.LHsExpr Id)]+#else+                    :: [G.LMatch Id]+#endif+#if __GLASGOW_HASKELL__ >= 710+              (L _ (G.Match _ pats _ _):_) = m+#else+              (L _ (G.Match pats _ _):_) = m+#endif+           in (funId, pats)+        _ -> (error "This should never happen", [])++getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)+#else+getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)+#endif+getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l+getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b+getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =+    M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)+#if __GLASGOW_HASKELL__ >= 708+getBindingsForPat (Ty.ListPat  l _ _) =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+#else+getBindingsForPat (Ty.ListPat  l _)   =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+#endif+getBindingsForPat (Ty.TuplePat l _ _) =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+getBindingsForPat (Ty.PArrPat  l _)   =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.ConPatIn (L _ i) d) =+    M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)+getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d+getBindingsForPat _ = M.empty++getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.PrefixCon args) =+#else+getBindingsForRecPat (Ty.PrefixCon args) =+#endif+    M.unions $ map (\(L _ i) -> getBindingsForPat i) args+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =+#else+getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =+#endif+    M.union (getBindingsForPat a1) (getBindingsForPat a2)+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#else+getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#endif+    getBindingsForRecFields (map unLoc' fields)+ where+#if __GLASGOW_HASKELL__ >= 710+   unLoc' = unLoc+#else+   unLoc' = id+#endif+   getBindingsForRecFields [] = M.empty+   getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =+       M.union (getBindingsForPat a) (getBindingsForRecFields fs)
+ GhcMod/Exe/Find.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}++module GhcMod.Exe.Find+  ( Symbol+  , SymbolDb+  , loadSymbolDb+  , lookupSymbol+  , dumpSymbol+  , findSymbol+  , lookupSym+  , isOutdated+  -- * Load 'SymbolDb' asynchronously+  , AsyncSymbolDb+  , newAsyncSymbolDb+  , getAsyncSymbolDb+  ) where++import qualified GHC as G+import FastString+import Module+import OccName+import HscTypes+import Exception++import GhcMod.Convert+import GhcMod.Gap+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Types+import GhcMod.Utils+import GhcMod.World+import GhcMod.LightGhc++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans.Control+import Control.Concurrent++import Data.List+import Data.Binary+import Data.Function+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef++import System.Directory.ModTime+import System.IO.Unsafe++import GHC.Generics (Generic)++import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import GhcMod.PathsAndFiles+import System.Directory+import Prelude++----------------------------------------------------------------++-- | Type of function and operation names.+type Symbol = BS.ByteString+type ModuleNameBS = BS.ByteString++-- | Database from 'Symbol' to \['ModuleString'\].+data SymbolDb = SymbolDb+  { sdTable             :: Map Symbol (Set ModuleNameBS)+  , sdTimestamp         :: ModTime+  } deriving (Generic)++#if __GLASGOW_HASKELL__ >= 708+instance Binary SymbolDb+#else+instance Binary SymbolDb where+  put (SymbolDb a b) = put a >> put b+  get = do+    a <- get+    b <- get+    return (SymbolDb a b)+#endif+instance NFData SymbolDb++isOutdated :: IOish m => SymbolDb -> GhcModT m Bool+isOutdated db =+  isOlderThan (sdTimestamp db) <$> timedPackageCaches++----------------------------------------------------------------++-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]+--   which will be concatenated. 'loadSymbolDb' is called internally.+findSymbol :: IOish m => String -> GhcModT m String+findSymbol sym = loadSymbolDb' >>= lookupSymbol sym++-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]+--   which will be concatenated.+lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String+lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db++lookupSym :: Symbol -> SymbolDb -> [ModuleString]+lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db++---------------------------------------------------------------++loadSymbolDb' :: IOish m => GhcModT m SymbolDb+loadSymbolDb' = do+  cache <- symbolCache <$> cradle+  let doLoad True = do+        db <- decode <$> liftIO (LBS.readFile cache)+        outdated <- isOutdated db+        if outdated+        then doLoad False+        else return db+      doLoad False = do+        db <- loadSymbolDb+        liftIO $ LBS.writeFile cache $ encode db+        return db+  doLoad =<< liftIO (doesFileExist cache)++-- | Loading a file and creates 'SymbolDb'.+loadSymbolDb :: IOish m => GhcModT m SymbolDb+loadSymbolDb = do+  ghcMod <- liftIO ghcModExecutable+  readProc <- gmReadProcess'+  out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""+  return $!! decode out++----------------------------------------------------------------+-- used 'ghc-mod dumpsym'++-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout+dumpSymbol :: IOish m => GhcModT m ()+dumpSymbol = do+  ts <- liftIO getCurrentModTime+  st <- runGmPkgGhc $ getGlobalSymbolTable+  liftIO . LBS.putStr $ encode SymbolDb {+      sdTable = 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 :: ModTime -> [TimedFile] -> Bool+isOlderThan tCache files =+  any (tCache <=) $ map tfTime files -- including equal just in case++-- | Browsing all functions in all system modules.+getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m)+                     => m (Map Symbol (Set ModuleNameBS))+getGlobalSymbolTable =+  foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags)++extend :: (G.GhcMonad m, MonadIO m)+       => Map Symbol (Set ModuleNameBS)+       -> Module+       -> m (Map Symbol (Set ModuleNameBS))+extend mm mdl = do+  hsc_env <- G.getSession+  eps <- liftIO $ readIORef $ hsc_EPS hsc_env+  modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do+    G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)+  return $ M.unionWith S.union mm $ extractBindings modinfo mdl++extractBindings :: Maybe G.ModuleInfo+                -> G.Module+                -> Map Symbol (Set ModuleNameBS)+extractBindings Nothing  _   = M.empty+extractBindings (Just inf) mdl = M.fromList $ do+  name <- G.modInfoExports inf+  let sym = fastStringToByteString $ occNameFS $ G.getOccName name+      mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl+  return (sym, mdls)++mkFastStringByteString' :: BS.ByteString -> FastString+#if !MIN_VERSION_ghc(7,8,0)+fastStringToByteString :: FastString -> BS.ByteString+fastStringToByteString = BS.pack . bytesFS++mkFastStringByteString' = mkFastStringByteList . BS.unpack+#elif __GLASGOW_HASKELL__ == 708+mkFastStringByteString' = unsafePerformIO . mkFastStringByteString+#else+mkFastStringByteString' = mkFastStringByteString+#endif++----------------------------------------------------------------++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
+ GhcMod/Exe/Flag.hs view
@@ -0,0 +1,9 @@+module GhcMod.Exe.Flag where++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.Monad++-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.+flags :: IOish m => GhcModT m String+flags = convert' Gap.ghcCmdOptions
+ GhcMod/Exe/Info.hs view
@@ -0,0 +1,79 @@+module GhcMod.Exe.Info (+    info+  , types+  ) where++import Data.Function (on)+import Data.List (sortBy)+import System.FilePath+import Exception (ghandle, SomeException(..))+import GHC (GhcMonad, SrcSpan)+import Prelude+import qualified GHC as G++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.Doc+import GhcMod.DynFlags+import GhcMod.Gap+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Types+import GhcMod.Utils (mkRevRedirMapFunc)+import GhcMod.FileMapping (fileModSummaryWithMapping)++----------------------------------------------------------------++-- | Obtaining information of a target expression. (GHCi's info:)+info :: IOish m+     => FilePath     -- ^ A target file.+     -> Expression   -- ^ A Haskell expression.+     -> GhcModT m String+info file expr =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withInteractiveContext $ do+        convert' =<< body+  where+    handler (SomeException ex) = do+      gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex)+      convert' "Cannot show info"++    body :: (GhcMonad m, GmState m, GmEnv m) => m String+    body = do+      m <- mkRevRedirMapFunc+      sdoc  <- Gap.infoThing m expr+      st    <- getStyle+      dflag <- G.getSessionDynFlags+      return $ showPage dflag st sdoc++----------------------------------------------------------------++-- | Obtaining type of a target expression. (GHCi's type:)+types :: IOish m+      => Bool         -- ^ Include constraints into type signature+      -> FilePath     -- ^ A target file.+      -> Int          -- ^ Line number.+      -> Int          -- ^ Column number.+      -> GhcModT m String+types withConstraints file lineNo colNo =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withInteractiveContext $ do+        crdl         <- cradle+        modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)+        srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo+        dflag        <- G.getSessionDynFlags+        st           <- getStyle+        convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes+ where+   handler (SomeException ex) = do+     gmLog GmException "types" $ showToDoc ex+     return []++getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]+getSrcSpanType withConstraints modSum lineNo colNo =+  G.parseModule modSum+  >>= G.typecheckModule+  >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)
+ GhcMod/Exe/Internal.hs view
@@ -0,0 +1,73 @@+-- | Low level access to the ghc-mod library.++module GhcMod.Exe.Internal (+  -- * Types+    GHCOption+  , IncludeDir+  , GmlT(..)+  , MonadIO(..)+  , GmEnv(..)+  -- * Various Paths+  , ghcLibDir+  , ghcModExecutable+  -- * Logging+  , withLogger+  , setNoWarningFlags+  , setAllWarningFlags+  -- * Environment, state and logging+  , GhcModEnv(..)+  , GhcModState+  , GhcModLog+  , GmLog(..)+  , GmLogLevel(..)+  , gmSetLogLevel+  -- * Monad utilities+  , runGhcModT'+  , hoistGhcModT+  , runGmlT+  , runGmlT'+  , gmlGetSession+  , gmlSetSession+  , loadTargets+  , cabalResolvedComponents+  -- ** Accessing 'GhcModEnv' and 'GhcModState'+  , options+  , cradle+  , targetGhcOptions+  , withOptions+  -- * 'GhcModError'+  , gmeDoc+  -- * World+  , World+  , getCurrentWorld+  , didWorldChange+  -- * Cabal Helper+  , ModulePath(..)+  , GmComponent(..)+  , GmComponentType(..)+  , GmModuleGraph(..)+  , prepareCabalHelper+  -- * Misc stuff+  , GHandler(..)+  , gcatches+  -- * FileMapping+  , module GhcMod.FileMapping+  ) where++import GHC.Paths (libdir)++import GhcMod.Target+import GhcMod.DynFlags+import GhcMod.Error+import GhcMod.Logger+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Types+import GhcMod.Utils+import GhcMod.World+import GhcMod.CabalHelper+import GhcMod.FileMapping++-- | Obtaining the directory for ghc system libraries.+ghcLibDir :: FilePath+ghcLibDir = libdir
+ GhcMod/Exe/Lang.hs view
@@ -0,0 +1,10 @@+module GhcMod.Exe.Lang where++import DynFlags (supportedLanguagesAndExtensions)+import GhcMod.Convert+import GhcMod.Monad++-- | Listing language extensions.++languages :: IOish m => GhcModT m String+languages = convert' supportedLanguagesAndExtensions
+ GhcMod/Exe/Lint.hs view
@@ -0,0 +1,30 @@+module GhcMod.Exe.Lint where++import Exception (ghandle)+import Control.Exception (SomeException(..))+import GhcMod.Logger (checkErrorPrefix)+import GhcMod.Convert+import GhcMod.Types+import GhcMod.Monad+import Language.Haskell.HLint3++import GhcMod.Utils (withMappedFile)+import Language.Haskell.Exts.SrcLoc (SrcSpan(..))++-- | Checking syntax of a target file using hlint.+--   Warnings and errors are returned.+lint :: IOish m+     => LintOpts  -- ^ Configuration parameters+     -> FilePath  -- ^ A target file.+     -> GhcModT m String+lint opt file = ghandle handler $+  withMappedFile file $ \tempfile -> do+    res <- liftIO $ hlint $ "--quiet" : tempfile : optLintHlintOpts opt+    pack . map (show . substFile file tempfile) $ res+  where+    pack = convert' . map init -- init drops the last \n.+    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"+    substFile orig temp idea+      | srcSpanFilename (ideaSpan idea) == temp+      = idea{ideaSpan=(ideaSpan idea){srcSpanFilename = orig}}+    substFile _ _ idea = idea
+ GhcMod/Exe/Modules.hs view
@@ -0,0 +1,27 @@+module GhcMod.Exe.Modules (modules) where++import Control.Arrow+import Data.List+import GhcMod.Convert+import GhcMod.Types+import GhcMod.Monad+import GhcMod.Gap ( listVisibleModuleNames+                                   , lookupModulePackageInAllPackages+                                   )++import qualified GHC as G++----------------------------------------------------------------++-- | Listing installed modules.+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 detailed then pkg ++ " " ++ mn else mn+                 | (mn, pkgs) <- pmnss, pkg <- pkgs ]+ where+   modulePkg df = lookupModulePackageInAllPackages df
+ GhcMod/Exe/PkgDoc.hs view
@@ -0,0 +1,29 @@+module GhcMod.Exe.PkgDoc (pkgDoc) where++import GhcMod.Types+import GhcMod.GhcPkg+import GhcMod.Monad+import GhcMod.Output++import Control.Applicative+import Prelude++-- | Obtaining the package name and the doc path of a module.+pkgDoc :: IOish m => String -> GhcModT m String+pkgDoc mdl = do+    ghcPkg <- getGhcPkgProgram+    readProc <- gmReadProcess+    pkgDbStack <- getPackageDbStack+    pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) ""+    if pkg == "" then+        return "\n"+      else do+        htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) ""+        let ret = pkg ++ " " ++ drop 14 htmlpath+        return ret+  where+    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]+                   ++ ghcPkgDbStackOpts dbs+    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]+                       ++ ghcPkgDbStackOpts dbs+    trim = takeWhile (`notElem` " \n")
+ GhcMod/Exe/Test.hs view
@@ -0,0 +1,45 @@+module GhcMod.Exe.Test where++import Control.Applicative+import Data.List+import System.FilePath+import System.Directory+import Prelude++import GhcMod.Types+import GhcMod.Monad+import 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"
− LICENSE 
@@ -1,6 +0,0 @@-ghc-mod was originally licensed under the BSD3 but the primary license has been-changed to the AGPL3, files originally contributed under the BSD3 license remain-under this license and can generally be identified by the lack of a GPL header.--See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for-copies of the two licenses.
− Language/Haskell/GhcMod.hs 
@@ -1,92 +0,0 @@--- | The ghc-mod library.--module Language.Haskell.GhcMod (-  -- * Cradle-    Cradle(..)-  , Project(..)-  , findCradle-  -- * Options-  , Options(..)-  , LineSeparator(..)-  , OutputStyle(..)-  , FileMapping(..)-  , defaultOptions-  -- * Logging-  , GmLogLevel-  , increaseLogLevel-  , decreaseLogLevel-  , gmSetLogLevel-  , gmLog-  -- * Types-  , ModuleString-  , Expression(..)-  , GhcPkgDb-  , Symbol-  , SymbolDb-  , GhcModError(..)-  -- * Monad Types-  , GhcModT-  , IOish-  -- * Monad utilities-  , runGhcModT-  , withOptions-  , dropSession-  -- * 'GhcMod' utilities-  , boot-  , browse-  , check-  , checkSyntax-  , debugInfo-  , componentInfo-  , expandTemplate-  , info-  , lint-  , pkgDoc-  , rootInfo-  , types-  , test-  , splits-  , sig-  , refine-  , auto-  , modules-  , languages-  , flags-  , findSymbol-  , lookupSymbol-  , dumpSymbol-  -- * SymbolDb-  , loadSymbolDb-  , isOutdated-  -- * Output-  , gmPutStr-  , gmErrStr-  , gmPutStrLn-  , gmErrStrLn-  -- * FileMapping-  , loadMappedFile-  , loadMappedFileSource-  , unloadMappedFile-  ) where--import Language.Haskell.GhcMod.Boot-import Language.Haskell.GhcMod.Browse-import Language.Haskell.GhcMod.CaseSplit-import Language.Haskell.GhcMod.Check-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Debug-import Language.Haskell.GhcMod.FillSig-import Language.Haskell.GhcMod.Find-import Language.Haskell.GhcMod.Flag-import Language.Haskell.GhcMod.Info-import Language.Haskell.GhcMod.Lang-import Language.Haskell.GhcMod.Lint-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Modules-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.PkgDoc-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Target-import Language.Haskell.GhcMod.Output-import Language.Haskell.GhcMod.FileMapping-import Language.Haskell.GhcMod.Test
− Language/Haskell/GhcMod/Boot.hs 
@@ -1,27 +0,0 @@-module Language.Haskell.GhcMod.Boot where--import Control.Applicative-import Prelude-import Language.Haskell.GhcMod.Browse-import Language.Haskell.GhcMod.Flag-import Language.Haskell.GhcMod.Lang-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Modules---- | Printing necessary information for front-end booting.-boot :: IOish m => GhcModT m String-boot = concat <$> sequence ms-  where-    ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]--preBrowsedModules :: [String]-preBrowsedModules = [-    "Prelude"-  , "Control.Applicative"-  , "Control.Exception"-  , "Control.Monad"-  , "Data.Char"-  , "Data.List"-  , "Data.Maybe"-  , "System.IO"-  ]
− Language/Haskell/GhcMod/Browse.hs 
@@ -1,155 +0,0 @@-module Language.Haskell.GhcMod.Browse (-    browse,-    BrowseOpts(..)-  ) where--import Safe-import Control.Applicative-import Control.Exception (SomeException(..))-import Data.Char-import Data.List-import Data.Maybe-import FastString-import GHC-import qualified GHC as G-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)-import Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Logging-import Name (getOccString)-import Outputable-import TyCon (isAlgTyCon)-import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)-import Exception (ExceptionMonad, ghandle)-import Prelude---------------------------------------------------------------------- | Getting functions, classes, etc from a module.-browse :: forall m. IOish m-           => 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 (\ex@(SomeException _) -> logException ex >> return []) $ do-      goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)--    logException ex =-        gmLog GmException "browse" $ showDoc ex--    goPkgModule = do-      runGmPkgGhc $-        processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid--    goHomeModule = runGmlT [Right mdlname] $ do-      processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing--    tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m--    (mpkg, mdl) = splitPkgMdl pkgmdl-    mdlname = G.mkModuleName mdl-    mpkgid = mkFastString <$> mpkg---- |------ >>> splitPkgMdl "base:Prelude"--- (Just "base","Prelude")--- >>> splitPkgMdl "Prelude"--- (Nothing,"Prelude")-splitPkgMdl :: String -> (Maybe String,String)-splitPkgMdl pkgmdl =-  case break (==':') pkgmdl of-    (mdl, "")    -> (Nothing, mdl)-    (pkg, _:mdl) -> (Just pkg, mdl)---- Haskell 2010:--- small -> ascSmall | uniSmall | _--- ascSmall -> a | b | ... | z--- uniSmall -> any Unicode lowercase letter--- varid -> (small {small | large | digit | ' })--isNotOp :: String -> Bool-isNotOp (h:_) = isAlpha h || (h == '_')-isNotOp _ = error "isNotOp"--processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)-               => BrowseOpts -> ModuleInfo -> m [String]-processExports opt minfo = do-  let-    removeOps-      | 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)-           => 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` optBrowseQualified opt-    mtype :: m (Maybe String)-    mtype-      | 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` optBrowseDetailed opt-      | otherwise = return Nothing-    formatOp nm-      | null nm    = error "formatOp"-      | isNotOp nm = nm-      | otherwise  = "(" ++ nm ++ ")"-    inOtherModule :: Name -> m (Maybe TyThing)-    inOtherModule nm = do-      G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm-    justIf :: a -> Bool -> Maybe a-    justIf x True = Just x-    justIf _ False = Nothing--showThing :: DynFlags -> TyThing -> Maybe String-showThing dflag tything = showThing' dflag (fromTyThing tything)--showThing' :: DynFlags -> GapThing -> Maybe String-showThing' dflag (GtA a) = Just $ formatType dflag a-showThing' _     (GtT t) = unwords . toList <$> tyType t-  where-    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)-showThing' _     _       = Nothing--formatType :: DynFlags -> Type -> String-formatType dflag a = showOutputable dflag (removeForAlls a)--tyType :: TyCon -> Maybe String-tyType typ-    | isAlgTyCon typ-      && not (G.isNewTyCon typ)-      && not (G.isClassTyCon typ) = Just "data"-    | G.isNewTyCon typ            = Just "newtype"-    | G.isClassTyCon typ          = Just "class"-    | Gap.isSynTyCon typ          = Just "type"-    | otherwise                   = Nothing--removeForAlls :: Type -> Type-removeForAlls ty = removeForAlls' ty' tty'-  where-    ty'  = dropForAlls ty-    tty' = splitFunTy_maybe ty'--removeForAlls' :: Type -> Maybe (Type, Type) -> Type-removeForAlls' ty Nothing = ty-removeForAlls' ty (Just (pre, ftype))-    | isPredTy pre        = mkFunTy pre (dropForAlls ftype)-    | otherwise           = ty--showOutputable :: Outputable a => DynFlags -> a -> String-showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
− Language/Haskell/GhcMod/CabalHelper.hs 
@@ -1,310 +0,0 @@--- 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.CabalHelper-#ifndef SPEC-  ( getComponents-  , getGhcMergedPkgOptions-  , getCabalPackageDbStack-  , prepareCabalHelper-  , withAutogen-  )-#endif-  where--import Control.Applicative-import Control.Monad-import Control.Category ((.))-import Data.Maybe-import Data.Monoid-import Data.Version-import Data.Binary (Binary)-import Data.Traversable-import Distribution.Helper hiding (Programs(..))-import qualified Distribution.Helper as CH-import qualified Language.Haskell.GhcMod.Types as T-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Output-import Language.Haskell.GhcMod.CustomPackageDb-import Language.Haskell.GhcMod.Stack-import System.FilePath-import System.Process-import System.Exit-import Prelude hiding ((.))--import Paths_ghc_mod as GhcMod---- | Only package related GHC options, sufficient for things that don't need to--- access home modules-getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)-  => m [GHCOption]-getGhcMergedPkgOptions = chCached $ \distdir -> Cached {-  cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),-  cacheFile = mergedPkgOptsCacheFile distdir,-  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do-    opts <- runCHQuery ghcMergedPkgOptions-    return ([setupConfigPath distdir], opts)- }--getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]-getCabalPackageDbStack = chCached $ \distdir -> Cached {-  cacheLens = Just (lGmcPackageDbStack . lGmCaches),-  cacheFile = pkgDbStackCacheFile distdir,-  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do-    crdl <- cradle-    dbs <- map chPkgToGhcPkg <$>-             runCHQuery packageDbStack-    return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)- }--chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb-chPkgToGhcPkg ChPkgGlobal = GlobalDb-chPkgToGhcPkg ChPkgUser = UserDb-chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f---- | Primary interface to cabal-helper and intended single entrypoint to--- constructing 'GmComponent's------ The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by--- 'resolveGmComponents'.-getComponents :: (Applicative m, IOish m, Gm m)-              => m [GmComponent 'GMCRaw ChEntrypoint]-getComponents = chCached $ \distdir -> Cached {-    cacheLens = Just (lGmcComponents . lGmCaches),-    cacheFile = cabalHelperCacheFile distdir,-    cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do-      runCHQuery $ do-        q <- join7-               <$> ghcOptions-               <*> ghcPkgOptions-               <*> ghcSrcOptions-               <*> ghcLangOptions-               <*> entrypoints-               <*> entrypoints-               <*> sourceDirs-        let cs = flip map q $ curry8 (GmComponent mempty)-        return ([setupConfigPath distdir], cs)-  }- where-   curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h--   join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f-   join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]-   join' lb lc = [ (a, (b, c))-                 | (a, b)  <- lb-                 , (a', c) <- lc-                 , a == a'-                 ]--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-  return (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-  when (isCabalHelperProject $ cradleProject crdl) $-       withCabal $ prepare' =<< getQueryEnv--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-    let projdir = cradleRootDir crdl-        distdir = projdir </> cradleDistDir crdl--    (pkgName', _) <- runCHQuery packageId--    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl-    mCabalMacroHeader   <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)-    mCabalPathsModule   <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName')--    when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do-      gmLog GmDebug "" $ strDoc $ "autogen files out of sync"-      writeAutogen--    action-- where-   writeAutogen = do-     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"-     writeAutogenFiles' =<< getQueryEnv---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"--    when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $-      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"--    when ( isSetupConfigOutOfDate mCabalFile mCabalConfig-        || pkgDbStackOutOfSync-        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do-          proj <- cradleProject <$> cradle-          opts <- options-          case proj of-            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--    action-- where-   cabalReconfigure progs crdl flgs = do-     readProc <- gmReadProcess-     withDirectory_ (cradleRootDir crdl) $ do-        cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack-        let progOpts =-                [ "--with-ghc=" ++ T.ghcProgram progs ]-                -- Only pass ghc-pkg if it was actually set otherwise we-                -- might break cabal's guessing logic-                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)-                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]-                     else []-                ++ map pkgDbArg cusPkgStack-                ++ flagOpt--            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", "."]-          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)"--   spawn [] = return ()-   spawn (exe:args) = do-     readProc <- gmReadProcess-     liftIO $ void $ readProc exe args ""--   haveStackSupport = do-     (rv, _, _) <--         liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""-     case rv of-       ExitSuccess -> return True-       ExitFailure _ -> return False----pkgDbArg :: GhcPkgDb -> String-pkgDbArg GlobalDb      = "--package-db=global"-pkgDbArg UserDb        = "--package-db=user"-pkgDbArg (PackageDb p) = "--package-db=" ++ p---- * Neither file exists -> should return False:---   @Nothing < Nothing = False@---   (since we don't need to @cabal configure@ when no cabal file exists.)------ * Cabal file doesn't exist (impossible since cabal-helper is only used with--- cabal projects) -> should return False---   @Just cc < Nothing = False@------ * dist/setup-config doesn't exist yet -> should return True:---   @Nothing < Just cf = True@------ * Both files exist---   @Just cc < Just cf = cc < cf = cc `olderThan` cf@-isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool-isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do-  worldCabalConfig < worldCabalFile--helperProgs :: Programs -> CH.Programs-helperProgs progs = CH.Programs {-    cabalProgram  = T.cabalProgram progs,-    ghcProgram    = T.ghcProgram progs,-    ghcPkgProgram = T.ghcPkgProgram progs-  }--chCached :: (Applicative m, IOish m, Gm m, Binary a)-  => (FilePath -> Cached m GhcModState ChCacheData a) -> m a-chCached c = do-  projdir <- cradleRootDir <$> cradle-  distdir <- (projdir </>) . cradleDistDir <$> cradle-  d <- cacheInputData projdir-  withCabal $ cached projdir (c distdir) d- where-   -- 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-               crdl <- cradle-               progs' <- patchStackPrograms crdl (optPrograms opts)-               return $ ( helperProgs progs'-                        , projdir-                        , (showVersion gmVer, chVer)-                        )--   gmVer = GhcMod.version-   chVer = VERSION_cabal_helper
− Language/Haskell/GhcMod/Caching.hs 
@@ -1,141 +0,0 @@--- 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-  ) where--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.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, 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-    case mcc of-      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"--   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 (t, 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 (ModTime, [FilePath], d, a))-   readCache = runMaybeT $ do-       case cacheLens cd of-         Just label -> do-             c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile-             setLabel label $ Just c-             return c-         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 ->-            either (const Nothing) Just-                `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)-       _ -> return Nothing--   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-    return $ catMaybes ins--invalidatingInputFiles :: TimedCacheFiles -> [FilePath]-invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =-    map tfPath $-        -- get input files older than tcfile-        filter ((TimedFile "" tcreated)<) tcfs
− Language/Haskell/GhcMod/Caching/Types.hs 
@@ -1,67 +0,0 @@--- 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 System.Directory.ModTime-import Distribution.Helper--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 {-  cacheFile       :: FilePath,-  cacheLens       :: Maybe (CacheLens s d a),-  cachedAction    :: TimedCacheFiles-                  -> d-                  -> Maybe a-                  -> m ([FilePath], a)--  -- ^ @cachedAction tcf data ma@-  ---  -- * @tcf@: Input file timestamps. Not technically necessary, just an-  -- optimizazion when knowing which input files changed can make updating the-  -- cache faster-  ---  -- * @data@: Arbitrary static input data to cache action. Can be used to-  -- invalidate the cache using something other than file timestamps-  -- i.e. environment tool version numbers-  ---  -- * @ma@: Cached data if it existed-  ---  -- Returns:-  ---  -- * @fst@: Input files used in generating the cache-  ---  -- * @snd@: Cache data, will be stored alongside the static input data in the-  --   'cacheFile'-  ---  -- The cached action, will only run if one of the following is true:-  ---  -- * 'cacheFile' doesn\'t exist yet-  -- * 'cacheFile' exists and 'inputData' changed-  -- * any files returned by the cached action changed- }--data TimedCacheFiles = TimedCacheFiles {-  tcCreated :: ModTime,-  -- ^ 'cacheFile' timestamp-  tcFiles     :: [TimedFile]-  -- ^ Timestamped files returned by the cached action- } deriving (Eq, Ord)--type ChCacheData = (Programs, FilePath, (String, String))
− Language/Haskell/GhcMod/CaseSplit.hs 
@@ -1,251 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.CaseSplit (-    splits-  ) where--import Data.List (find, intercalate)-import Data.Maybe (isJust)-import qualified Data.Text as T-import qualified Data.Text.IO as T (readFile)-import System.FilePath-import Prelude--import qualified DataCon as Ty-import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))-import qualified GHC as G-import Outputable (PprStyle)-import qualified TyCon as Ty-import qualified Type as Ty-import Exception--import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.DynFlags-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Language.Haskell.GhcMod.Doc-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)--------------------------------------------------------------------- CASE SPLITTING-------------------------------------------------------------------data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]-               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)-data SplitToTextInfo = SplitToTextInfo { sVarName     :: String-                                       , sBindingSpan :: SrcSpan-                                       , sVarSpan     :: SrcSpan-                                       , sTycons      :: [String]-                                       }---- | Splitting a variable in a equation.-splits :: IOish m-       => FilePath     -- ^ A target file.-       -> Int          -- ^ Line number.-       -> Int          -- ^ Column number.-       -> GhcModT m String-splits file lineNo colNo =-  ghandle handler $ runGmlT' [Left file] deferErrors $ do-      oopts <- outputOpts-      crdl <- cradle-      style <- getStyle-      dflag <- G.getSessionDynFlags-      modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)-      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of-        (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do-          let varName' = showName dflag style varName  -- Convert name to string-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                             getTyCons dflag style varName varT)-          return (fourInts bndLoc, t)-        (TySplitInfo varName bndLoc (varLoc,varT)) -> do-          let varName' = showName dflag style varName  -- Convert name to string-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                             getTyCons dflag style varName varT)-          return (fourInts bndLoc, t)- where-   handler (SomeException ex) = do-     gmLog GmException "splits" $-           text "" $$ nest 4 (showDoc ex)-     emptyResult =<< outputOpts--------------------------------------------------------------------- a. Code for getting the information of the variable--getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForSplit modSum lineNo colNo = do-  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo-  if isJust fn-     then return fn-     else getSrcSpanTypeForTypeSplit modSum lineNo colNo---- Information for a function case split-getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForFnSplit modSum lineNo colNo = do-    p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum-    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)-        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI-    case varPat of-      Nothing  -> return Nothing-      Just varPat' -> do-        varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var-        case varT of-          Just varT' ->-#if __GLASGOW_HASKELL__ >= 710-            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match-#else-            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match-#endif-            in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )-          _ -> return Nothing--isPatternVar :: LPat Id -> Bool-isPatternVar (L _ (G.VarPat _)) = True-isPatternVar _                  = False--getPatternVarName :: LPat Id -> G.Name-getPatternVarName (L _ (G.VarPat vName)) = G.getName vName-getPatternVarName _                      = error "This should never happened"---- TODO: Information for a type family case split-getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing--------------------------------------------------------------------- b. Code for getting the possible constructors--getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]-getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =-  let name' = showName dflag style name  -- Convert name to string-  in getTyCon dflag style name' tyCon-getTyCons dflag style name _ = [showName dflag style name]---- Write cases for one type-getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]--- 1. Non-matcheable type constructors-getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]--- 2. Special cases--- 2.1. Tuples-getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =-  let [uniqueDataCon] = Ty.tyConDataCons tyCon-      tupleArity = Ty.dataConSourceArity uniqueDataCon-      -- Deal with both boxed and unboxed tuples-      isUnboxed = Ty.isUnboxedTupleTyCon tyCon-      startSign = if isUnboxed then "(#" else "("-      endSign   = if isUnboxed then "#)" else ")"-  in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]--- 3. General case-getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)---- These type constructors should not be matched against-isNotMatcheableTyCon :: Ty.TyCon -> Bool-isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#-                       || Ty.isFunTyCon ty   -- Function types---- Write case for one constructor-getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String--- 1. Infix constructors-getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =-  let dName  = showName dflag style $ Ty.dataConName dcon-  in case Ty.dataConSourceArity dcon of-       0 -> dName-       1 -> vName ++ dName-       n -> if dName == ":" -- Special case for lists-            then vName ++ ":" ++ vName ++ "s"-            else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)--- 2. Non-record, non-infix syntax-getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =-  let dName  = showName dflag style $ Ty.dataConName dcon-  in if last dName == '#'  -- Special case for I#, C# and so on-     then vName-     else case Ty.dataConSourceArity dcon of-            0 -> dName-            _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)--- 3. Records-getDataCon dflag style vName dcon =-  let dName = showName dflag style $ Ty.dataConName dcon-      flds  = Ty.dataConFieldLabels dcon-  in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"---- Create a new variable by adjoining a number-newVar :: String -> Int -> String-newVar v n = v ++ show n---- Create a list of variables which start with the same prefix-newVars :: String -> Int -> Int -> String-newVars _ _ 0 = ""-newVars v s 1 = newVar v s-newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)---- Create a list of variables which start with the same prefix--- Special case for a single variable, in which case no number is adjoint-newVarsSpecialSingleton :: String -> Int -> Int -> String-newVarsSpecialSingleton v _     1 = v-newVarsSpecialSingleton v start n = newVars v start n--showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String-showFieldNames _     _     _ []      = "" -- This should never happen-showFieldNames dflag style v (x:xs) = let fName = showName dflag style x-                                          fAcc  = fName ++ " = " ++ v ++ "_" ++ fName-                                       in case xs of-                                            [] -> fAcc-                                            _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs--------------------------------------------------------------------- c. Code for performing the case splitting--genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>-    FilePath -> SplitToTextInfo -> m String-genCaseSplitTextFile file info = liftIO $ do-  t <- T.readFile file-  return $ getCaseSplitText (T.lines t) info--getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String-getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS-                                       , sVarSpan = sVS, sTycons = sT })  =-  let bindingText = getBindingText t sBS-      difference  = srcSpanDifference sBS sVS-      replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT-      -- The newly generated bindings need to be indented to align with the-      -- original binding.-      replaced'   = head replaced : map (indentBindingTo sBS) (tail replaced)-   in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')--getBindingText :: [T.Text] -> SrcSpan -> [T.Text]-getBindingText t srcSpan =-  let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan-      lines_ = drop (sl - 1) $ take el t-   in if sl == el-      then -- only one line-           [T.drop (sc - 1) $ T.take ec $ head lines_]-      else -- several lines-            let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)-             in T.drop (sc - 1) first : rest ++ [T.take ec last_]--srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)-srcSpanDifference b v =-  let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b-      Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v-   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line--replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]-replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =-  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon-      lengthDiff  = length tycon' - length varname-      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'-      spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff-   in zipWith (\n line -> if n < vsl-                          then line  -- before variable starts-                          else if n == vsl-                               then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line-                               else T.replicate spacesToAdd (T.pack " ") `T.append` line)-              [0 ..] t--indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]-indentBindingTo bndLoc binds =-  let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc-      indent      = (T.replicate (sl - 1) (T.pack " ") `T.append`)-   in indent (head binds) : tail binds
− Language/Haskell/GhcMod/Check.hs 
@@ -1,57 +0,0 @@-module Language.Haskell.GhcMod.Check (-    checkSyntax-  , check-  , expandTemplate-  , expand-  ) where--import Control.Applicative-import Prelude-import Language.Haskell.GhcMod.DynFlags-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad---------------------------------------------------------------------- | Checking syntax of a target file using GHC.---   Warnings and errors are returned.-checkSyntax :: IOish m-            => [FilePath]  -- ^ The target files.-            -> GhcModT m String-checkSyntax []    = return ""-checkSyntax files = either id id <$> check files---------------------------------------------------------------------- | Checking syntax of a target file using GHC.---   Warnings and errors are returned.-check :: IOish m-      => [FilePath]  -- ^ The target files.-      -> GhcModT m (Either String String)-check files =-    runGmlTWith-      (map Left files)-      return-      ((fmap fst <$>) . withLogger setNoMaxRelevantBindings)-      (return ())---------------------------------------------------------------------- | Expanding Haskell Template.-expandTemplate :: IOish m-               => [FilePath]  -- ^ The target files.-               -> GhcModT m String-expandTemplate []    = return ""-expandTemplate files = either id id <$> expand files---------------------------------------------------------------------- | Expanding Haskell Template.-expand :: IOish m => [FilePath] -> GhcModT m (Either String String)-expand files =-    runGmlTWith-      (map Left files)-      return-      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))-      (return ())
− Language/Haskell/GhcMod/Convert.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}--module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where--import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Types--import Control.Applicative-import Prelude--type Builder = String -> String---- |------ >>> replace '"' "\\\"" "foo\"bar" ""--- "foo\\\"bar"-replace :: Char -> String -> String -> Builder-replace _ _  [] = id-replace c cs (x:xs)-  | x == c    = (cs ++) . replace c cs xs-  | otherwise = (x :) . replace c cs xs--inter :: Char -> [Builder] -> Builder-inter _ [] = id-inter c bs = foldr1 (\x y -> x . (c:) . y) bs--convert' :: (ToString a, IOish m, GmEnv m) => a -> m String-convert' x = flip convert x . optOutput <$> options--convert :: ToString a => OutputOpts -> a -> String-convert opt@OutputOpts { ooptStyle = LispStyle  } x = toLisp opt x "\n"-convert opt@OutputOpts { ooptStyle = PlainStyle } x-  | str == "\n" = ""-  | otherwise   = str-  where-    str = toPlain opt x "\n"--class ToString a where-  toLisp  :: OutputOpts -> a -> Builder-  toPlain :: OutputOpts -> a -> Builder--lineSep :: OutputOpts -> String-lineSep oopts = interpret lsep-  where-    interpret s = read $ "\"" ++ s ++ "\""-    LineSeparator lsep = ooptLineSeparator oopts---- |------ >>> toLisp (optOutput defaultOptions) "fo\"o" ""--- "\"fo\\\"o\""--- >>> toPlain (optOutput defaultOptions) "foo" ""--- "foo"-instance ToString String where-  toLisp  oopts = quote oopts-  toPlain oopts = replace '\n' (lineSep oopts)---- |------ >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] ""--- "(\"foo\" \"bar\" \"ba\\\"z\")"--- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] ""--- "foo\nbar\nbaz"-instance ToString [String] where-  toLisp  oopts = toSexp1 oopts-  toPlain oopts = inter '\n' . map (toPlain oopts)--instance ToString [ModuleString] where-  toLisp  oopts = toLisp oopts . map getModuleString-  toPlain oopts = toPlain oopts . map getModuleString---- |------ >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]--- >>> toLisp (optOutput defaultOptions) inp ""--- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"--- >>> toPlain (optOutput defaultOptions) inp ""--- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""-instance ToString [((Int,Int,Int,Int),String)] where-  toLisp  oopts = toSexp2 . map toS-    where-      toS x = ('(' :) . tupToString oopts x . (')' :)-  toPlain oopts = inter '\n' . map (tupToString oopts)--instance ToString ((Int,Int,Int,Int),String) where-  toLisp  oopts x = ('(' :) . tupToString oopts x . (')' :)-  toPlain oopts x = tupToString oopts x--instance ToString ((Int,Int,Int,Int),[String]) where-  toLisp  oopts (x,s) = ('(' :) .  fourIntsToString x .-                        (' ' :) . toLisp oopts s . (')' :)-  toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s--instance ToString (String, (Int,Int,Int,Int),[String]) where-  toLisp  oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]-  toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]--toSexp1 :: OutputOpts -> [String] -> Builder-toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)--toSexp2 :: [Builder] -> Builder-toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)--fourIntsToString :: (Int,Int,Int,Int) -> Builder-fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)-                           . (show b ++) . (' ' :)-                           . (show c ++) . (' ' :)-                           . (show d ++)--tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder-tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)-                                . (show b ++) . (' ' :)-                                . (show c ++) . (' ' :)-                                . (show d ++) . (' ' :)-                                . quote oopts s -- fixme: quote is not necessary--quote :: OutputOpts -> String -> Builder-quote oopts str = ("\"" ++) .  (quote' str ++) . ("\"" ++)-  where-    lsep = lineSep oopts-    quote' [] = []-    quote' (x:xs)-      | x == '\n' = lsep   ++ quote' xs-      | x == '\\' = "\\\\" ++ quote' xs-      | x == '"'  = "\\\"" ++ quote' xs-      | otherwise = x       : quote' xs---------------------------------------------------------------------- Empty result to be returned when no info can be gathered-emptyResult :: Monad m => OutputOpts -> m String-emptyResult oopts = return $ convert oopts ([] :: [String])---- Return an emptyResult when Nothing-whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String-whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from---- Return an emptyResult when Nothing, inside a monad-whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String-whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from
− Language/Haskell/GhcMod/Cradle.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE CPP #-}-module Language.Haskell.GhcMod.Cradle-#ifndef SPEC-  (-    findCradle-  , findCradle'-  , findCradleNoLog-  , findSpecCradle-  , cleanupCradle-  )-#endif-  where--import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Monad.Types-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.Trans.Maybe-import Data.Maybe-import System.Directory-import System.FilePath-import Prelude-import Control.Monad.Trans.Journal (runJournalT)---------------------------------------------------------------------- | Finding 'Cradle'.---   Find a cabal file by tracing ancestor directories.---   Find a sandbox according to a cabal sandbox config---   in a cabal directory.-findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle-findCradle = findCradle' =<< liftIO getCurrentDirectory--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 =<< (fromJustNote "findCradle'" <$> runMaybeT a)--findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle-findSpecCradle dir = do-    let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]-    cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs-    gcs <- filterM isNotGmCradle cs-    fillTempDir =<< case gcs of-                      [] -> fromJust <$> runMaybeT (plainCradle dir)-                      c:_ -> return c- where-   isNotGmCradle crdl =-     liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")--cleanupCradle :: Cradle -> IO ()-cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl--fillTempDir :: IOish m => Cradle -> m Cradle-fillTempDir crdl = do-  tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)-  return crdl { cradleTempDir = tmpDir }--cabalCradle :: IOish m => FilePath -> MaybeT m Cradle-cabalCradle wdir = do-    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir--    let cabalDir = takeDirectory cabalFile--    return Cradle {-        cradleProject    = CabalProject-      , cradleCurrentDir = wdir-      , cradleRootDir    = cabalDir-      , cradleTempDir    = error "tmpDir"-      , cradleCabalFile  = Just cabalFile-      , cradleDistDir    = "dist"-      }--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--    _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir--    -- 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 $ cabalDir </> setupConfigPath "dist") $ do-      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."-      mzero--    senv <- MaybeT $ getStackEnv cabalDir--    return Cradle {-        cradleProject    = StackProject senv-      , cradleCurrentDir = wdir-      , cradleRootDir    = cabalDir-      , cradleTempDir    = error "tmpDir"-      , cradleCabalFile  = Just cabalFile-      , cradleDistDir    = seDistDir senv-      }--stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle-stackCradleSpec wdir = do-  crdl <- stackCradle wdir-  case crdl of-    Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do-      b <- isGmDistDir seDistDir-      when b mzero-      return crdl-    _ -> error "stackCradleSpec"- where-   isGmDistDir dir =-       liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")--sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle-sandboxCradle wdir = do-    sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir-    return Cradle {-        cradleProject    = SandboxProject-      , cradleCurrentDir = wdir-      , cradleRootDir    = sbDir-      , cradleTempDir    = error "tmpDir"-      , cradleCabalFile  = Nothing-      , cradleDistDir    = "dist"-      }--plainCradle :: IOish m => FilePath -> MaybeT m Cradle-plainCradle wdir = do-    return $ Cradle {-        cradleProject    = PlainProject-      , cradleCurrentDir = wdir-      , cradleRootDir    = wdir-      , cradleTempDir    = error "tmpDir"-      , cradleCabalFile  = Nothing-      , cradleDistDir    = "dist"-      }
− Language/Haskell/GhcMod/CustomPackageDb.hs 
@@ -1,38 +0,0 @@--- 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 ((.))-import Data.Maybe-import Data.Traversable-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.PathsAndFiles-import Prelude hiding ((.))--parseCustomPackageDb :: String -> [GhcPkgDb]-parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src- where-   parsePkgDb "global" = GlobalDb-   parsePkgDb "user" = UserDb-   parsePkgDb s = PackageDb s--getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb])-getCustomPkgDbStack = do-    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle-    return $ parseCustomPackageDb <$> mCusPkgDbFile
− Language/Haskell/GhcMod/Debug.hs 
@@ -1,143 +0,0 @@-module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where--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-import Data.List.Split-import Text.PrettyPrint-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Internal-import Language.Haskell.GhcMod.Target-import Language.Haskell.GhcMod.Pretty-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Stack---------------------------------------------------------------------- | Obtaining debug information.-debugInfo :: IOish m => GhcModT m String-debugInfo = do-    Options {..} <- options-    Cradle {..} <- cradle--    cabal <--        case cradleProject of-          CabalProject -> cabalDebug-          StackProject {} -> (++) <$> stackPaths <*> cabalDebug-          _ -> return []--    pkgOpts <- packageGhcOptions--    return $ unlines $-      [ "Root directory:       " ++ cradleRootDir-      , "Current directory:    " ++ cradleCurrentDir-      , "GHC Package flags:\n"   ++ render (nest 4 $-              fsep $ map text pkgOpts)-      , "GHC System libraries: " ++ ghcLibDir-      , "GHC user options:\n"    ++ render (nest 4 $-              fsep $ map text optGhcUserOptions)-      ] ++ cabal--stackPaths :: IOish m => GhcModT m [String]-stackPaths = do-    Cradle { cradleProject = StackProject senv } <- cradle-    ghc <- getStackGhcPath senv-    ghcPkg <- getStackGhcPkgPath senv-    return $-         [ "Stack ghc executable:    " ++ show ghc-         , "Stack ghc-pkg executable:" ++ show ghcPkg-         ]--cabalDebug :: IOish m => GhcModT m [String]-cabalDebug = do-    Cradle {..} <- cradle-    mcs <- cabalResolvedComponents-    let entrypoints = Map.map gmcEntrypoints mcs-        graphs      = Map.map gmcHomeModuleGraph mcs-        opts        = Map.map gmcGhcOpts mcs-        srcOpts     = Map.map gmcGhcSrcOpts mcs--    return $-         [ "Cabal file:           " ++ show cradleCabalFile-         , "Project:   " ++ show cradleProject-         , "Cabal entrypoints:\n"       ++ render (nest 4 $-              mapDoc gmComponentNameDoc smpDoc entrypoints)-         , "Cabal components:\n"        ++ render (nest 4 $-              mapDoc gmComponentNameDoc graphDoc graphs)-         , "GHC Cabal options:\n"       ++ render (nest 4 $-              mapDoc gmComponentNameDoc (fsep . map text) opts)-         , "GHC search path options:\n" ++ render (nest 4 $-              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)-         ]--componentInfo :: IOish m => [String] -> GhcModT m String-componentInfo ts = do-    -- TODO: most of this is copypasta of targetGhcOptions. Factor out more-    -- useful function from there.-    crdl <- cradle-    sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts-    mcs <- cabalResolvedComponents-    let-        mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn-        candidates = findCandidates $ map snd mdlcs-        cn = pickComponent candidates-    opts <- targetGhcOptions crdl sefnmn--    return $ unlines $-         [ "Matching Components:\n"     ++ render (nest 4 $-              alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)-         , "Picked Component:\n"        ++ render (nest 4 $-              gmComponentNameDoc cn)-         , "GHC Cabal options:\n"       ++ render (nest 4 $ fsep $ map text opts)-         ]- where-   zipMap f l = l `zip` (f `map` l)--guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)-guessModuleFile m-  | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =-      return $ Right $ mkModuleName m- where-   infixr 1 .||.-   infixr 2 .&&.-   (.||.) = liftA2 (||)-   (.&&.) = liftA2 (&&)--guessModuleFile str = Left `liftM` liftIO (canonFilePath str)--graphDoc :: GmModuleGraph -> Doc-graphDoc GmModuleGraph{..} =-    mapDoc mpDoc smpDoc' gmgGraph- where-   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp-   mpDoc' = text . moduleNameString . mpModule--setDoc :: (a -> Doc) -> Set.Set a -> Doc-setDoc f s = vcat $ map f $ Set.toList s--smpDoc :: Set.Set ModulePath -> Doc-smpDoc smp = setDoc mpDoc smp--mpDoc :: ModulePath -> Doc-mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)--mnDoc :: ModuleName -> Doc-mnDoc mn = text (moduleNameString mn)--alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc-alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)--mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc-mapDoc kd ad m = vcat $-    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m--------------------------------------------------------------------- | Obtaining root information.-rootInfo :: forall m. (IOish m, GmOut m) => m String-rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
− Language/Haskell/GhcMod/DebugLogger.hs 
@@ -1,138 +0,0 @@--- 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-import Pretty-import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)-import qualified Outputable-import ErrUtils--import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Gap-import Prelude--debugLogAction :: (String -> IO ()) -> GmLogAction-debugLogAction putErr dflags severity srcSpan style msg-    = case severity of-      SevOutput      -> printSDoc putErr msg style--#if __GLASGOW_HASKELL__ >= 706-      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style-#endif--#if __GLASGOW_HASKELL__ >= 708-      SevInteractive -> let-          putStrSDoc = debugLogActionHPutStrDoc dflags putErr-       in-          putStrSDoc msg style-#endif-      SevInfo        -> printErrs putErr msg style-      SevFatal       -> printErrs putErr msg style-      _              -> do putErr "\n"-#if __GLASGOW_HASKELL__ >= 706-                           printErrs putErr (mkLocMessage severity srcSpan msg) style-#else-                           printErrs putErr (mkLocMessage srcSpan msg) style-#endif-                           -- careful (#2302): printErrs prints in UTF-8,-                           -- whereas converting to string first and using-                           -- hPutStr would just emit the low 8 bits of-                           -- each unicode char.-    where-#if __GLASGOW_HASKELL__ >= 706-      printSDoc put = debugLogActionHPrintDoc  dflags put-      printErrs put = debugLogActionHPrintDoc  dflags put-#endif---#if __GLASGOW_HASKELL__ >= 706--debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()-debugLogActionHPrintDoc dflags put d sty- = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty-      -- Adds a newline--debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()-debugLogActionHPutStrDoc dflags put d sty-  = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc-  where   -- Don't add a newline at the end, so that successive-          -- calls to this log-action can output all on the same line-    doc = runSDoc d (initSDocContext dflags sty)--#else--printSDoc = printErrs--printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()-printErrs put doc sty = do-  gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))--#endif--gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()--- printDoc adds a newline to the end-gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")--gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()-gmPrintDoc_ mode pprCols putS doc-  = fullRender mode pprCols 1.5 put done doc-  where-    put (Chr c)  next = putS [c] >> next-    put (Str s)  next = putS s >> next-    put (PStr s) next = putS (unpackFS s) >> next-#if __GLASGOW_HASKELL__ >= 708-    put (ZStr s) next = putS (zString s) >> next-#endif-    put (LStr s _l) next = putS (unpackLitString s) >> next--    done = return () -- hPutChar hdl '\n'
− Language/Haskell/GhcMod/Doc.hs 
@@ -1,25 +0,0 @@-module Language.Haskell.GhcMod.Doc where--import GHC-import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)-import Outputable-import Pretty (Mode(..))--showPage :: DynFlags -> PprStyle -> SDoc -> String-showPage dflag style = showDocWith dflag PageMode . withStyle dflag style--showOneLine :: DynFlags -> PprStyle -> SDoc -> String-showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style---- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String--- showForUser dflags unqual sdoc =---     showDocWith dflags PageMode $---       runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay--getStyle :: GhcMonad m => m PprStyle-getStyle = do-    unqual <- getPrintUnqual-    return $ mkUserStyle unqual AllTheWay--styleUnqualified :: PprStyle-styleUnqualified = mkUserStyle neverQualify AllTheWay
− Language/Haskell/GhcMod/DynFlags.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.DynFlags where--import Control.Applicative-import Control.Monad-import GHC-import qualified GHC as G-import GHC.Paths (libdir)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.DebugLogger-import System.IO.Unsafe (unsafePerformIO)-import Prelude--setEmptyLogger :: DynFlags -> DynFlags-setEmptyLogger df =-    Gap.setLogAction df $ \_ _ _ _ _ -> return ()--setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags-setDebugLogger put df = do-  Gap.setLogAction df (debugLogAction put)---- * Fast--- * Friendly to foreign export--- * Not friendly to -XTemplateHaskell and -XPatternSynonyms--- * Uses little memory-setHscNothing :: DynFlags -> DynFlags-setHscNothing df = df {-    ghcMode   = CompManager-  , ghcLink   = NoLink-  , hscTarget = HscNothing-  , optLevel  = 0-  }---- * Slow--- * Not friendly to foreign export--- * Friendly to -XTemplateHaskell and -XPatternSynonyms--- * Uses lots of memory-setHscInterpreted :: DynFlags -> DynFlags-setHscInterpreted df = df {-    ghcMode   = CompManager-  , ghcLink   = LinkInMemory-  , hscTarget = HscInterpreted-  , optLevel  = 0-  }---- | Parse command line ghc options and add them to the 'DynFlags' passed-addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags-addCmdOpts cmdOpts df =-    fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)-  where-    fst3 (a,_,_) = a--------------------------------------------------------------------withDynFlags :: GhcMonad m-             => (DynFlags -> DynFlags)-             -> m a-             -> m a-withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)-  where-    setup = do-        dflags <- G.getSessionDynFlags-        void $ G.setSessionDynFlags (setFlags dflags)-        return dflags-    teardown = void . G.setSessionDynFlags--withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a-withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)-  where-    setup = do-        dflags <- G.getSessionDynFlags-        void $ G.setSessionDynFlags =<< addCmdOpts flags dflags-        return dflags-    teardown = void . G.setSessionDynFlags---------------------------------------------------------------------- | Set 'DynFlags' equivalent to "-w:".-setNoWarningFlags :: DynFlags -> DynFlags-setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags}---- | Set 'DynFlags' equivalent to "-Wall".-setAllWarningFlags :: DynFlags -> DynFlags-setAllWarningFlags df = df { warningFlags = allWarningFlags }--allWarningFlags :: Gap.WarnFlags-allWarningFlags = unsafePerformIO $-    G.runGhc (Just libdir) $ do-        df <- G.getSessionDynFlags-        df' <- addCmdOpts ["-Wall"] df-        return $ G.warningFlags df'---------------------------------------------------------------------- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".-setNoMaxRelevantBindings :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }-#else-setNoMaxRelevantBindings = id-#endif--deferErrors :: DynFlags -> Ghc DynFlags-deferErrors df = return $-  Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $-  Gap.setDeferTypeErrors $ setNoWarningFlags df
− Language/Haskell/GhcMod/Error.hs 
@@ -1,160 +0,0 @@--- 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 ExistentialQuantification #-}-module Language.Haskell.GhcMod.Error (-    GhcModError(..)-  , GmError-  , gmeDoc-  , ghcExceptionDoc-  , liftMaybe-  , overrideError-  , modifyError-  , modifyError'-  , modifyGmError-  , tryFix-  , GHandler(..)-  , gcatches-  , module Control.Monad.Error-  , module Control.Exception-  ) where--import Control.Arrow hiding ((<+>))-import Control.Exception-import Control.Monad.Error hiding (MonadIO, liftIO)-import qualified Data.Set as Set-import Data.List-import Data.Version-import System.Process (showCommandForUser)-import Text.PrettyPrint-import Text.Printf--import Exception-import Panic-import Config (cProjectVersion, cHostPlatformString)-import Paths_ghc_mod (version)--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Pretty--type GmError m = MonadError GhcModError m--gmeDoc :: GhcModError -> Doc-gmeDoc e = case e of-    GMENoMsg ->-        text "Unknown error"-    GMEString msg ->-        text msg-    GMECabalConfigure msg ->-        text "Configuring cabal project failed" <+>: gmeDoc msg-    GMEStackConfigure msg ->-        text "Configuring stack project failed" <+>: gmeDoc msg-    GMEStackBootstrap msg ->-        text "Bootstrapping stack project environment failed" <+>: gmeDoc msg-    GMECabalCompAssignment ctx ->-        text "Could not find a consistent component assignment for modules:" $$-          (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$-        text "" $$-        (if all (Set.null . snd) ctx-           then noComponentSuggestions-           else empty) $$-        text "- To find out which components ghc-mod knows about try:" $$-            nest 4 (backticks $ text "ghc-mod debug")--      where-        noComponentSuggestions =-          text "- Are some of these modules part of a test and or benchmark?\-               \ Try enabling them:" $$-              nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")--        backticks d = char '`' <> d <> char '`'-        ctxDoc = moduleDoc *** compsDoc-                 >>> first (<> colon) >>> uncurry (flip hang 4)--        moduleDoc (Left fn)   =-            text "File " <> quotes (text fn)-        moduleDoc (Right mdl) =-            text "Module " <> quotes (text $ moduleNameString mdl)--        compsDoc sc | Set.null sc = text "has no known components"-        compsDoc sc = fsep $ punctuate comma $-                        map gmComponentNameDoc $ Set.toList sc-    GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in-        case emsg of-          Right err ->-             text (printf "Launching system command `%s` failed: " c)-                  <> gmeDoc err-          Left rv -> text $-             printf "Launching system command `%s` failed (exited with %d)" c rv-    GMENoCabalFile ->-        text "No cabal file found."-    GMETooManyCabalFiles cfs ->-        text $ "Multiple cabal files found. Possible cabal files: \""-               ++ intercalate "\", \"" cfs ++"\"."--ghcExceptionDoc :: GhcException -> Doc-ghcExceptionDoc e@(CmdLineError _) =-    text $ "<command line>: " ++ showGhcException e ""-ghcExceptionDoc (UsageError str) = strDoc str-ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\-\GHC panic! (the 'impossible' happened)\n\-\  ghc-mod version %s\n\-\  GHC library version %s for %s:\n\-\       %s\n\-\\n\-\Please report this as a bug: %s\n"-    gmVer ghcVer platform msg url- where-   gmVer = showVersion version-   ghcVer = cProjectVersion-   platform = cHostPlatformString-   url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String--ghcExceptionDoc e = text $ showGhcException e ""--liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a-liftMaybe e action = maybe (throwError e) return =<< action--overrideError :: MonadError e m => e -> m a -> m a-overrideError e action = modifyError (const e) action--modifyError :: MonadError e m => (e -> e) -> m a -> m a-modifyError f action = action `catchError` \e -> throwError $ f e--infixr 0 `modifyError'`-modifyError' :: MonadError e m => m a -> (e -> e) -> m a-modifyError' = flip modifyError--modifyGmError :: (MonadIO m, ExceptionMonad m)-              => (GhcModError -> GhcModError) -> m a -> m a-modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)--tryFix :: MonadError e m => m a -> (e -> m ()) -> m a-tryFix action f = do-  action `catchError` \e -> f e >> action--data GHandler m a = forall e . Exception e => GHandler (e -> m a)--gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a-gcatches io handlers = io `gcatch` gcatchesHandler handlers--gcatchesHandler :: (MonadIO m, ExceptionMonad m)-    => [GHandler m a] -> SomeException -> m a-gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers-    where tryHandler (GHandler handler) res-              = case fromException e of-                Just e' -> handler e'-                Nothing -> res
− Language/Haskell/GhcMod/FileMapping.hs 
@@ -1,103 +0,0 @@-module Language.Haskell.GhcMod.FileMapping-    ( loadMappedFile-    , loadMappedFileSource-    , unloadMappedFile-    , mapFile-    , fileModSummaryWithMapping-    ) where--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Gap-import Language.Haskell.GhcMod.HomeModuleGraph-import Language.Haskell.GhcMod.Utils--import System.IO-import System.FilePath-import System.Directory--import Control.Monad.Trans.Maybe-import GHC-import Control.Monad--{- | 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--{- |-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-    (fn, h) <- openTempFile tmpdir (takeFileName from)-    hPutStr h src-    hClose h-    return fn-  loadMappedFile' from to True--loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()-loadMappedFile' from to isTemp = do-  cfn <- getCanonicalFileNameSafe from-  unloadMappedFile' cfn-  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-mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do-  mapping <- lookupMMappedFile filePath-  mkMappedTarget (Just filePath) tid taoc mapping-mapFile env (Target tid@(TargetModule moduleName) taoc _) = do-  (fp, mapping) <- do-    filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)-    mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile-    return (filePath, mmf)-  mkMappedTarget fp tid taoc mapping--mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) =>-                  Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target-mkMappedTarget _ _ taoc (Just to) =-  return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing-mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing--{-|-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 ()-unloadMappedFile' cfn = void $ runMaybeT $ do-  fm <- MaybeT $ lookupMMappedFile cfn-  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)-  delMMappedFile cfn--fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>-                            FilePath -> m ModSummary-fileModSummaryWithMapping fn =-  withMappedFile fn $ \fn' -> fileModSummary fn'
− Language/Haskell/GhcMod/FillSig.hs 
@@ -1,554 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}--module Language.Haskell.GhcMod.FillSig (-    sig-  , refine-  , auto-  ) where--import Data.Char (isSymbol)-import Data.Function (on)-import Data.Functor-import Data.List (find, nub, sortBy)-import qualified Data.Map as M-import Data.Maybe (catMaybes)-import Text.PrettyPrint (($$), text, nest)-import Prelude--import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,-            SrcSpan, Type, GenLocated(L))-import qualified GHC as G-import qualified Name as G-import Outputable (PprStyle)-import qualified Type as Ty-import qualified HsBinds as Ty-import qualified Class as Ty-import qualified Var as Ty-import qualified HsPat as Ty-import qualified Language.Haskell.Exts.Annotated as HE-import Djinn.GHC--import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Language.Haskell.GhcMod.Logging (gmLog)-import Language.Haskell.GhcMod.Pretty (showDoc)-import Language.Haskell.GhcMod.Doc-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)--#if __GLASGOW_HASKELL__ >= 710-import GHC (unLoc)-#endif--------------------------------------------------------------------- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE--------------------------------------------------------------------- Possible signatures we can find: function or instance-data SigInfo-    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)-    | InstanceDecl SrcSpan G.Class-    | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]---- Signature for fallback operation via haskell-src-exts-data HESigInfo-    = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)-    | HEFamSignature-          HE.SrcSpan-          TyFamType-          (HE.Name HE.SrcSpanInfo)-          [HE.Name HE.SrcSpanInfo]--data TyFamType = Closed | Open | Data-initialTyFamString :: TyFamType -> (String, String)-initialTyFamString Closed = ("instance", "")-initialTyFamString Open   = ("function", "type instance ")-initialTyFamString Data   = ("function", "data instance ")---- | Create a initial body from a signature.-sig :: IOish m-    => FilePath     -- ^ A target file.-    -> Int          -- ^ Line number.-    -> Int          -- ^ Column number.-    -> GhcModT m String-sig file lineNo colNo =-    runGmlT' [Left file] deferErrors $ ghandle fallback $ do-      oopts <- outputOpts-      style <- getStyle-      dflag <- G.getSessionDynFlags-      modSum <- fileModSummaryWithMapping file-      whenFound oopts (getSignature modSum lineNo colNo) $ \s ->-        case s of-          Signature loc names ty ->-              ("function", fourInts loc, map (initialBody dflag style ty) names)--          InstanceDecl loc cls ->-            let body x = initialBody dflag style (G.idType x) x-            in ("instance", fourInts loc, body `map` Ty.classMethods cls)--          TyFamDecl loc name flavour vars ->-            let (rTy, initial) = initialTyFamString flavour-                body = initialFamBody dflag style name vars-            in (rTy, fourInts loc, [initial ++ body])-  where-    fallback (SomeException _) = do-      oopts <- outputOpts-      -- Code cannot be parsed by ghc module-      -- Fallback: try to get information via haskell-src-exts-      whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of-        HESignature loc names ty ->-          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)-        HEFamSignature loc flavour name vars ->-          let (rTy, initial) = initialTyFamString flavour-           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])--------------------------------------------------------------------- a. Code for getting the information---- Get signature from ghc parsing and typechecking-getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)-getSignature modSum lineNo colNo = do-    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum-    -- Inspect the parse tree to find the signature-    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of-#if __GLASGOW_HASKELL__ >= 710-      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->-#else-      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->-#endif-        -- We found a type signature-        return $ Just $ Signature loc (map G.unLoc names) ty-      [L _ (G.InstD _)] -> do-        -- We found an instance declaration-        TypecheckedModule{tm_renamed_source = Just tcs-                         ,tm_checked_module_info = minfo} <- G.typecheckModule p-        let lst = listifyRenamedSpans tcs (lineNo, colNo)-        case Gap.getClass lst of-            Just (clsName,loc) -> obtainClassInfo minfo clsName loc-            _                  -> return Nothing-#if __GLASGOW_HASKELL__ >= 708-      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do-#elif __GLASGOW_HASKELL__ >= 706-      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do-#else-      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do-#endif-#if __GLASGOW_HASKELL__ >= 708-        let flavour = case info of-                        G.ClosedTypeFamily _ -> Closed-                        G.OpenTypeFamily     -> Open-                        G.DataFamily         -> Data-#else-        let flavour = case info of  -- Closed type families where introduced in GHC 7.8-                        G.TypeFamily -> Open-                        G.DataFamily -> Data-#endif--#if __GLASGOW_HASKELL__ >= 710-            getTyFamVarName x = case x of-                L _ (G.UserTyVar n)     -> n-                L _ (G.KindedTyVar (G.L _ n) _) -> n-#elif __GLASGOW_HASKELL__ >= 706-            getTyFamVarName x = case x of-                L _ (G.UserTyVar n)     -> n-                L _ (G.KindedTyVar n _) -> n-#else-            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg-                L _ (G.UserTyVar n _)     -> n-                L _ (G.KindedTyVar n _ _) -> n-#endif-         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)-      _ -> return Nothing-  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)-        obtainClassInfo minfo clsName loc = do-          tyThing <- G.modInfoLookupName minfo clsName-          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe-                      cls <- G.tyConClass_maybe clsCon-                      return $ InstanceDecl loc cls---- Get signature from haskell-src-exts-getSignatureFromHE :: (MonadIO m, GhcMonad m) =>-    FilePath -> Int -> Int -> m (Maybe HESigInfo)-getSignatureFromHE file lineNo colNo = do-  presult <- liftIO $ HE.parseFile file-  return $ case presult of-             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do-               decl <- find (typeSigInRangeHE lineNo colNo) mdecls-               case decl of-                 HE.TypeSig (HE.SrcSpanInfo s _) names ty ->-                     return $ HESignature s names ty--                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ ->-                   let (name, tys) = dHeadTyVars declHead in-                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)--                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->-                   let (name, tys) = dHeadTyVars declHead in-                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)-                 _ -> fail ""-             _ -> Nothing-  where cleanTyVarBind (HE.KindedVar _ n _) = n-        cleanTyVarBind (HE.UnkindedVar _ n) = n--#if MIN_VERSION_haskell_src_exts(1,16,0)-        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])-        dHeadTyVars (HE.DHead _ name) = (name, [])-        dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)-        dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])-        dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r-#else-        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])-        dHeadTyVars (HE.DHead _ n tys) = (n, tys)-#endif--------------------------------------------------------------------- b. Code for generating initial code---- A list of function arguments, and whether they are functions or normal--- arguments is built from either a function signature or an instance signature-data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String--initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String-initialBody dflag style ty name =-    initialBody' (getFnName dflag style name) (getFnArgs ty)--initialBody' :: String -> [FnArg] -> String-initialBody' fname args =-    initialHead fname args ++ " = " ++ n ++ "_body"- where n = if isSymbolName fname then "" else '_':fname--initialFamBody :: FnArgsInfo ty name-               => DynFlags -> PprStyle -> name -> [name] -> String-initialFamBody dflag style name args =-    initialHead fnName fnArgs ++ " = ()"- where fnName = getFnName dflag style name-       fnArgs = map (FnExplicitName . getFnName dflag style) args--initialHead :: String -> [FnArg] -> String-initialHead fname args =-  case initialBodyArgs args infiniteVars infiniteFns of-    []      -> fname-    arglist -> if isSymbolName fname-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)-               else fname ++ " " ++ unwords arglist--initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]-initialBodyArgs [] _ _ = []-initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs-initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs-initialBodyArgs (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs-initialBodyArgs _                  _      _  =-    error "initialBodyArgs: This should never happen" -- Lists are infinite--initialHead1 :: String -> [FnArg] -> [String] -> String-initialHead1 fname args elts =-  case initialBodyArgs1 args elts of-    []      -> fname-    arglist-      | isSymbolName fname ->-        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)-      | otherwise ->-        fname ++ " " ++ unwords arglist--initialBodyArgs1 :: [FnArg] -> [String] -> [String]-initialBodyArgs1 args elts = take (length args) elts---- Getting the initial body of function and instances differ--- This is because for functions we only use the parsed file--- (so the full file doesn't have to be type correct)--- but for instances we need to get information about the class--class FnArgsInfo ty name | ty -> name, name -> ty where-  getFnName :: DynFlags -> PprStyle -> name -> String-  getFnArgs :: ty -> [FnArg]--instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where-  getFnName dflag style name = showOccName dflag style $ Gap.occName name-#if __GLASGOW_HASKELL__ >= 710-  getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))-#else-  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))-#endif-    = getFnArgs iTy--  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy-  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =-      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy-    where fnarg ty = case ty of-#if __GLASGOW_HASKELL__ >= 710-              (G.HsForAllTy _ _ _ _ (L _ iTy)) ->-#else-              (G.HsForAllTy _ _ _ (L _ iTy)) ->-#endif-                fnarg iTy--              (G.HsParTy (L _ iTy))          -> fnarg iTy-              (G.HsFunTy _ _)                -> True-              _                              -> False-  getFnArgs _ = []--instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where-  getFnName _ _ (HE.Ident  _ s) = s-  getFnName _ _ (HE.Symbol _ s) = s-  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy-  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy-  getFnArgs (HE.TyFun _ lTy rTy)    =-      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy-    where fnarg ty = case ty of-              (HE.TyForall _ _ _ iTy) -> fnarg iTy-              (HE.TyParen _ iTy)      -> fnarg iTy-              (HE.TyFun _ _ _)        -> True-              _                       -> False-  getFnArgs _ = []--instance FnArgsInfo Type Id where-  getFnName dflag style method = showOccName dflag style $ G.getOccName method-  getFnArgs = getFnArgs' . Ty.dropForAlls-    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =-            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)-                  (\_ -> FnArgFunction:getFnArgs' rTy)-                  $ Ty.splitFunTy_maybe lTy--          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =-              getFnArgs' iTy--          getFnArgs' _ = []---- Infinite supply of variable and function variable names-infiniteVars, infiniteFns :: [String]-infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]-infiniteFns  = infiniteSupply ["f","g","h"]-infiniteSupply :: [String] -> [String]-infiniteSupply initialSupply =-    initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)-                               ([1 .. ] :: [Integer])---- Check whether a String is a symbol name-isSymbolName :: String -> Bool-isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c-isSymbolName []    = error "This should never happen"---------------------------------------------------------------------- REWRITE A HOLE / UNDEFINED VIA A FUNCTION-------------------------------------------------------------------refine :: IOish m-       => FilePath     -- ^ A target file.-       -> Int          -- ^ Line number.-       -> Int          -- ^ Column number.-       -> Expression   -- ^ A Haskell expression.-       -> GhcModT m String-refine file lineNo colNo (Expression expr) =-  ghandle handler $-    runGmlT' [Left file] deferErrors $ do-      oopts <- outputOpts-      style <- getStyle-      dflag <- G.getSessionDynFlags-      modSum <- fileModSummaryWithMapping file-      p <- G.parseModule modSum-      tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-      ety <- G.exprType expr-      whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $-        \(loc, name, rty, paren) ->-            let eArgs = getFnArgs ety-                rArgs = getFnArgs rty-                diffArgs' = length eArgs - length rArgs-                diffArgs  = if diffArgs' < 0 then 0 else diffArgs'-                iArgs = take diffArgs eArgs-                txt = initialHead1 expr iArgs (infinitePrefixSupply name)-             in (fourInts loc, doParen paren txt)-  where-   handler (SomeException ex) = do-     gmLog GmException "refining" $-           text "" $$ nest 4 (showDoc ex)-     emptyResult =<< outputOpts---- Look for the variable in the specified position-findVar-  :: GhcMonad m-  => DynFlags-  -> PprStyle-  -> G.TypecheckedModule-  -> G.TypecheckedSource-  -> Int-  -> Int-  -> m (Maybe (SrcSpan, String, Type, Bool))-findVar dflag style tcm tcs lineNo colNo =-  case lst of-    e@(L _ (G.HsVar i)):others -> do-      tyInfo <- Gap.getType tcm e-      case tyInfo of-        Just (s, typ)-          | name == "undefined" || head name == '_' ->-            return $ Just (s, name, typ, b)-          where-            name = getFnName dflag style i-            -- If inside an App, we need parenthesis-            b = case others of-                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->-                    isSearchedVar i a1 || isSearchedVar i a2-                  _  -> False-        _ -> return Nothing-    _ -> return Nothing-  where-    lst :: [G.LHsExpr Id]-    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)--infinitePrefixSupply :: String -> [String]-infinitePrefixSupply "undefined" = repeat "undefined"-infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])--doParen :: Bool -> String -> String-doParen False s = s-doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s--isSearchedVar :: Id -> G.HsExpr Id -> Bool-isSearchedVar i (G.HsVar i2) = i == i2-isSearchedVar _ _ = False---------------------------------------------------------------------- REFINE AUTOMATICALLY-------------------------------------------------------------------auto :: IOish m-     => FilePath     -- ^ A target file.-     -> Int          -- ^ Line number.-     -> Int          -- ^ Column number.-     -> GhcModT m String-auto file lineNo colNo =-  ghandle handler $ runGmlT' [Left file] deferErrors $ do-        oopts <- outputOpts-        style <- getStyle-        dflag <- G.getSessionDynFlags-        modSum <- fileModSummaryWithMapping file-        p <- G.parseModule modSum-        tcm@TypecheckedModule {-                 tm_typechecked_source = tcs-               , tm_checked_module_info = minfo-               } <- G.typecheckModule p-        whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do-          topLevel <- getEverythingInTopLevel minfo-          let (f,pats) = getPatsForVariable tcs (lineNo,colNo)-              -- Remove self function to prevent recursion, and id to trim-              -- cases-              filterFn (n,_) = let funName = G.getOccString n-                                   recName = G.getOccString (G.getName f)-                               in funName `notElem` recName:notWantedFuns-              -- Find without using other functions in top-level-              localBnds = M.unions $-                  map (\(L _ pat) -> getBindingsForPat pat) pats-              lbn = filter filterFn (M.toList localBnds)-          djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000-          let -- Find with the entire top-level-              almostEnv = M.toList $ M.union localBnds topLevel-              env = filter filterFn almostEnv-          djinns <- djinn True (Just minfo) env rty (Max 10) 100000-          return ( fourInts loc-                 , map (doParen paren) $ nub (djinnsEmpty ++ djinns))- where-   handler (SomeException ex) = do-     gmLog GmException "auto-refining" $-           text "" $$ nest 4 (showDoc ex)-     emptyResult =<< outputOpts---- Functions we do not want in completions-notWantedFuns :: [String]-notWantedFuns = ["id", "asTypeOf", "const"]---- Get all things defined in top-level-getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)-getEverythingInTopLevel m = do-  let modInfo  = tyThingsToInfo (G.modInfoTyThings m)-      topNames = G.modInfoTopLevelScope m-  case topNames of-    Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'-                         let topThings' = catMaybes topThings-                             topInfo    = tyThingsToInfo topThings'-                         return $ M.union modInfo topInfo-    Nothing -> return modInfo--tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type-tyThingsToInfo [] = M.empty-tyThingsToInfo (G.AnId i : xs) =-    M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)--- Getting information about constructors is not needed--- because they will be added by djinn-ghc when traversing types--- #if __GLASGOW_HASKELL__ >= 708--- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]--- #else--- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]--- #endif-tyThingsToInfo (_:xs) = tyThingsToInfo xs---- Find the Id of the function and the pattern where the hole is located-getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])-getPatsForVariable tcs (lineNo, colNo) =-  let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $-                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]-   in case bnd of-        G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of-          Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])-          _                     -> (error "This should never happen", [])-        G.FunBind { Ty.fun_id = L _ funId } ->-          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)-#if __GLASGOW_HASKELL__ >= 708-                    :: [G.LMatch Id (G.LHsExpr Id)]-#else-                    :: [G.LMatch Id]-#endif-#if __GLASGOW_HASKELL__ >= 710-              (L _ (G.Match _ pats _ _):_) = m-#else-              (L _ (G.Match pats _ _):_) = m-#endif-           in (funId, pats)-        _ -> (error "This should never happen", [])--getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type-getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)-getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l-getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b-getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =-    M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)-#if __GLASGOW_HASKELL__ >= 708-getBindingsForPat (Ty.ListPat  l _ _) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-#else-getBindingsForPat (Ty.ListPat  l _)   =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-#endif-getBindingsForPat (Ty.TuplePat l _ _) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-getBindingsForPat (Ty.PArrPat  l _)   =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.ConPatIn (L _ i) d) =-    M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)-getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d-getBindingsForPat _ = M.empty--getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type-getBindingsForRecPat (Ty.PrefixCon args) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) args-getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =-    M.union (getBindingsForPat a1) (getBindingsForPat a2)-getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =-    getBindingsForRecFields (map unLoc' fields)- where-#if __GLASGOW_HASKELL__ >= 710-   unLoc' = unLoc-#else-   unLoc' = id-#endif-   getBindingsForRecFields [] = M.empty-   getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =-       M.union (getBindingsForPat a) (getBindingsForRecFields fs)
− Language/Haskell/GhcMod/Find.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE CPP, DeriveGeneric #-}--module Language.Haskell.GhcMod.Find-#ifndef SPEC-  ( Symbol-  , SymbolDb-  , loadSymbolDb-  , lookupSymbol-  , dumpSymbol-  , findSymbol-  , lookupSym-  , isOutdated-  -- * Load 'SymbolDb' asynchronously-  , AsyncSymbolDb-  , newAsyncSymbolDb-  , getAsyncSymbolDb-  )-#endif-  where--import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Gap-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Output-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils-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---------------------------------------------------------------------- | Type of function and operation names.-type Symbol = String--- | Database from 'Symbol' to \['ModuleString'\].-data SymbolDb = SymbolDb-  { sdTable             :: Map Symbol [ModuleString]-  , sdTimestamp         :: ModTime-  } deriving (Generic)--instance Binary SymbolDb-instance NFData SymbolDb--isOutdated :: IOish m => SymbolDb -> GhcModT m Bool-isOutdated db =-  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 = loadSymbolDb >>= lookupSymbol sym---- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]---   which will be concatenated.-lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String-lookupSymbol sym db = convert' $ lookupSym sym db--lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym db = M.findWithDefault [] sym $ sdTable db--------------------------------------------------------------------- | Loading a file and creates 'SymbolDb'.-loadSymbolDb :: IOish m => GhcModT m SymbolDb-loadSymbolDb = do-  ghcMod <- liftIO ghcModExecutable-  readProc <- gmReadProcess'-  out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""-  return $!! decode out--------------------------------------------------------------------- used 'ghc-mod dumpsym'---- | 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 :: 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])]-getGlobalSymbolTable = do-  df  <- G.getSessionDynFlags-  let mods = listVisibleModules df-  moduleInfos <- mapM G.getModuleInfo mods-  return $ collectModules-         $ extractBindings `concatMap` (moduleInfos `zip` mods)--extractBindings :: (Maybe G.ModuleInfo, G.Module)-                -> [(Symbol, ModuleString)]-extractBindings (Nothing,  _)   = []-extractBindings (Just inf, mdl) =-  map (\name -> (getOccString name, modStr)) names-  where-    names  = G.modInfoExports inf-    modStr = ModuleString $ moduleNameString $ moduleName mdl--collectModules :: [(Symbol, ModuleString)]-               -> [(Symbol, [ModuleString])]-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
− Language/Haskell/GhcMod/Flag.hs 
@@ -1,13 +0,0 @@-module Language.Haskell.GhcMod.Flag where--import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad---- | Listing GHC flags. (e.g -fno-warn-orphans)--flags :: IOish m => GhcModT m String-flags = convert' [ "-f" ++ prefix ++ option-                 | option <- Gap.fOptions-                 , prefix <- ["","no-"]-                 ]
− Language/Haskell/GhcMod/Gap.hs 
@@ -1,577 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}--module Language.Haskell.GhcMod.Gap (-    Language.Haskell.GhcMod.Gap.ClsInst-  , mkTarget-  , withStyle-  , GmLogAction-  , setLogAction-  , getSrcSpan-  , getSrcFile-  , withInteractiveContext-  , fOptions-  , toStringBuffer-  , showSeverityCaption-  , setCabalPkg-  , setHideAllPackages-  , setDeferTypeErrors-  , setDeferTypedHoles-  , setWarnTypedHoles-  , setDumpSplices-  , isDumpSplices-  , filterOutChildren-  , infoThing-  , pprInfo-  , HasType(..)-  , errorMsgSpan-  , typeForUser-  , nameForUser-  , occNameForUser-  , deSugar-  , showDocWith-  , GapThing(..)-  , fromTyThing-  , fileModSummary-  , WarnFlags-  , emptyWarnFlags-  , GLMatch-  , GLMatchI-  , getClass-  , occName-  , listVisibleModuleNames-  , listVisibleModules-  , lookupModulePackageInAllPackages-  , Language.Haskell.GhcMod.Gap.isSynTyCon-  , parseModuleHeader-  , mkErrStyle'-  ) where--import Control.Applicative hiding (empty)-import Control.Monad (filterM)-import CoreSyn (CoreExpr)-import Data.List (intersperse)-import Data.Maybe (catMaybes)-import Data.Time.Clock (UTCTime)-import Data.Traversable hiding (mapM)-import DataCon (dataConRepType)-import Desugar (deSugarExpr)-import DynFlags-import ErrUtils-import Exception-import FastString-import GhcMonad-import HscTypes-import NameSet-import OccName-import Outputable-import PprTyThing-import StringBuffer-import TcType-import Var (varType)-import System.Directory--import qualified Name-import qualified InstEnv-import qualified Pretty-import qualified StringBuffer as SB--#if __GLASGOW_HASKELL__ >= 708-import FamInstEnv-import ConLike (ConLike(..))-import PatSyn (patSynType)-#else-import TcRnTypes-#endif--#if __GLASGOW_HASKELL__ >= 706-import GHC hiding (ClsInst)-#else-import GHC hiding (Instance)-import Control.Arrow hiding ((<+>))-import Data.Convertible-import RdrName (rdrNameOcc)-#endif--#if __GLASGOW_HASKELL__ < 710-import UniqFM (eltsUFM)-import Module-#endif--#if __GLASGOW_HASKELL__ >= 704-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-import SrcLoc-import Packages--import Language.Haskell.GhcMod.Types (Expression(..))-import Prelude---------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 706-type ClsInst = InstEnv.ClsInst-#else-type ClsInst = InstEnv.Instance-#endif--mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target-#if __GLASGOW_HASKELL__ >= 706-mkTarget = Target-#else-mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert-#endif-------------------------------------------------------------------------------------------------------------------------------------withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc-#if __GLASGOW_HASKELL__ >= 706-withStyle = withPprStyleDoc-#else-withStyle _ = withPprStyleDoc-#endif--#if __GLASGOW_HASKELL__ >= 706-type GmLogAction = LogAction-#else-type GmLogAction = DynFlags -> LogAction-#endif--setLogAction :: DynFlags -> GmLogAction -> DynFlags-setLogAction df f =-#if __GLASGOW_HASKELL__ >= 706-    df { log_action = f }-#else-    df { log_action = f df }-#endif--showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String-#if __GLASGOW_HASKELL__ >= 708--- Pretty.showDocWith disappeard.--- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc-showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)-#else-showDocWith _ = Pretty.showDocWith-#endif-------------------------------------------------------------------------------------------------------------------------------------getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)-#if __GLASGOW_HASKELL__ >= 702-getSrcSpan (RealSrcSpan spn)-#else-getSrcSpan spn | isGoodSrcSpan spn-#endif-             = Just (srcSpanStartLine spn-                   , srcSpanStartCol spn-                   , srcSpanEndLine spn-                   , srcSpanEndCol spn)-getSrcSpan _ = Nothing--getSrcFile :: SrcSpan -> Maybe String-#if __GLASGOW_HASKELL__ >= 702-getSrcFile (RealSrcSpan spn)       = Just . unpackFS . srcSpanFile $ spn-#else-getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn-#endif-getSrcFile _ = Nothing--------------------------------------------------------------------toStringBuffer :: GhcMonad m => [String] -> m StringBuffer-#if __GLASGOW_HASKELL__ >= 702-toStringBuffer = return . stringToStringBuffer . unlines-#else-toStringBuffer = liftIO . stringToStringBuffer . unlines-#endif--------------------------------------------------------------------fOptions :: [String]-#if __GLASGOW_HASKELL__ >= 710-fOptions = [option | (FlagSpec option _ _ _) <- fFlags]-        ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]-        ++ [option | (FlagSpec option _ _ _) <- fLangFlags]-#elif __GLASGOW_HASKELL__ >= 704-fOptions = [option | (option,_,_) <- fFlags]-        ++ [option | (option,_,_) <- fWarningFlags]-        ++ [option | (option,_,_) <- fLangFlags]-#else-fOptions = [option | (option,_,_,_) <- fFlags]-        ++ [option | (option,_,_,_) <- fWarningFlags]-        ++ [option | (option,_,_,_) <- fLangFlags]-#endif-------------------------------------------------------------------------------------------------------------------------------------fileModSummary :: GhcMonad m => FilePath -> m ModSummary-fileModSummary file' = do-    mss <- getModuleGraph-    file <- liftIO $ canonicalizePath file'-    [ms] <- liftIO $ flip filterM mss $ \m ->-        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)-    return ms--withInteractiveContext :: GhcMonad m => m a -> m a-withInteractiveContext action = gbracket setup teardown body-  where-    setup = getContext-    teardown = setCtx-    body _ = do-        topImports >>= setCtx-        action-    topImports = do-        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph-        let iis = map (IIModule . modName) ms-#if __GLASGOW_HASKELL__ >= 704-        return iis-#else-        return (iis,[])-#endif-#if __GLASGOW_HASKELL__ >= 706-    modName = moduleName-    setCtx = setContext-#elif __GLASGOW_HASKELL__ >= 704-    modName = id-    setCtx = setContext-#else-    modName = ms_mod-    setCtx = uncurry setContext-#endif--showSeverityCaption :: Severity -> String-#if __GLASGOW_HASKELL__ >= 706-showSeverityCaption SevWarning = "Warning: "-showSeverityCaption _          = ""-#else-showSeverityCaption = const ""-#endif-------------------------------------------------------------------------------------------------------------------------------------setCabalPkg :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage-#else-setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage-#endif--------------------------------------------------------------------setHideAllPackages :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setHideAllPackages df = gopt_set df Opt_HideAllPackages-#else-setHideAllPackages df = dopt_set df Opt_HideAllPackages-#endif--------------------------------------------------------------------setDumpSplices :: DynFlags -> DynFlags-setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices--isDumpSplices :: DynFlags -> Bool-isDumpSplices dflag = dopt Opt_D_dump_splices dflag---------------------------------------------------------------------setDeferTypeErrors :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors-#elif __GLASGOW_HASKELL__ >= 706-setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors-#else-setDeferTypeErrors = id-#endif--setDeferTypedHoles :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 710-setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles-#else-setDeferTypedHoles = id-#endif--setWarnTypedHoles :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles-#else-setWarnTypedHoles = id-#endif-------------------------------------------------------------------------------------------------------------------------------------class HasType a where-    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))---instance HasType (LHsBind Id) where-#if __GLASGOW_HASKELL__ >= 708-    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)-      where in_tys = mg_arg_tys m-            out_typ = mg_res_ty m-            typ = mkFunTys in_tys out_typ-#else-    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)-#endif-    getType _ _ = return Nothing-------------------------------------------------------------------------------------------------------------------------------------- from ghc/InteractiveUI.hs--filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs-    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]-  where-    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]--infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc-infoThing m (Expression str) = do-    names <- parseName str-#if __GLASGOW_HASKELL__ >= 708-    mb_stuffs <- mapM (getInfo False) names-    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)-#else-    mb_stuffs <- mapM getInfo names-    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)-#endif-    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)--#if __GLASGOW_HASKELL__ >= 708-pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc-pprInfo m _ (thing, fixity, insts, famInsts)-    = pprTyThingInContextLoc' thing-   $$ show_fixity fixity-   $$ InstEnv.pprInstances insts-   $$ pprFamInsts famInsts-#else-pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc-pprInfo m pefas (thing, fixity, insts)-    = pprTyThingInContextLoc' pefas thing-   $$ show_fixity fixity-   $$ vcat (map pprInstance insts)-#endif-  where-    show_fixity fx-      | fx == defaultFixity = Outputable.empty-      | otherwise           = ppr fx <+> ppr (getName thing)-#if __GLASGOW_HASKELL__ >= 708-    pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2-                                        (char '\t' <> ptext (sLit "--") <+> loc)-                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')-#else-    pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2-                                    (char '\t' <> ptext (sLit "--") <+> loc)-                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')-#endif-    pprNameDefnLoc' name-      = case Name.nameSrcLoc name of-           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)-           UnhelpfulLoc s-             | Name.isInternalName name || Name.isSystemName name-             -> ptext (sLit "at") <+> ftext s-             | otherwise-             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))-      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)-            realFP = mkFastString . m . unpackFS . srcLocFile-------------------------------------------------------------------------------------------------------------------------------------errorMsgSpan :: ErrMsg -> SrcSpan-#if __GLASGOW_HASKELL__ >= 708-errorMsgSpan = errMsgSpan-#else-errorMsgSpan = head . errMsgSpans-#endif--typeForUser :: Type -> SDoc-#if __GLASGOW_HASKELL__ >= 708-typeForUser = pprTypeForUser-#else-typeForUser = pprTypeForUser False-#endif--nameForUser :: Name -> SDoc-nameForUser = pprOccName . getOccName--occNameForUser :: OccName -> SDoc-occNameForUser = pprOccName--deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv-         -> IO (Maybe CoreExpr)-#if __GLASGOW_HASKELL__ >= 708-deSugar _   e hs_env = snd <$> deSugarExpr hs_env e-#else-deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e-  where-    modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm-    tcgEnv = fst $ tm_internals_ tcm-    rn_env = tcg_rdr_env tcgEnv-    ty_env = tcg_type_env tcgEnv-#endif-------------------------------------------------------------------------------------------------------------------------------------data GapThing = GtA Type | GtT TyCon | GtN--fromTyThing :: TyThing -> GapThing-fromTyThing (AnId i)                   = GtA $ varType i-#if __GLASGOW_HASKELL__ >= 708-fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d-fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p-#else-fromTyThing (ADataCon d)               = GtA $ dataConRepType d-#endif-fromTyThing (ATyCon t)                 = GtT t-fromTyThing _                          = GtN-------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 704-type WarnFlags = I.IntSet-emptyWarnFlags :: WarnFlags-emptyWarnFlags = I.empty-#else-type WarnFlags = [WarningFlag]-emptyWarnFlags :: WarnFlags-emptyWarnFlags = []-#endif-------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 708-type GLMatch = LMatch RdrName (LHsExpr RdrName)-type GLMatchI = LMatch Id (LHsExpr Id)-#else-type GLMatch = LMatch RdrName-type GLMatchI = LMatch Id-#endif--getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)-#if __GLASGOW_HASKELL__ >= 710--- Instance declarations of sort 'instance F (G a)'-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)--- Instance declarations of sort 'instance F G' (no variables)-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)-#elif __GLASGOW_HASKELL__ >= 708--- Instance declarations of sort 'instance F (G a)'-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)--- Instance declarations of sort 'instance F G' (no variables)-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)-#elif __GLASGOW_HASKELL__ >= 706-getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)-getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)-#else-getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)-getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)-#endif-getClass _ = Nothing--#if __GLASGOW_HASKELL__ < 706-occName :: RdrName -> OccName-occName = rdrNameOcc-#endif--------------------------------------------------------------------#if __GLASGOW_HASKELL__ < 710--- Copied from ghc/InteractiveUI.hs-allExposedPackageConfigs :: DynFlags -> [PackageConfig]-allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df--allExposedModules :: DynFlags -> [ModuleName]-allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df--listVisibleModuleNames :: DynFlags -> [ModuleName]-listVisibleModuleNames = allExposedModules-#endif--lookupModulePackageInAllPackages ::-    DynFlags -> ModuleName -> [String]-lookupModulePackageInAllPackages df mn =-#if __GLASGOW_HASKELL__ >= 710-    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn- where-   unpackSPId (SourcePackageId fs) = unpackFS fs-#else-    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn- where-   unpackPId pid = packageIdString $ mkPackageId pid---       n ++ "-" ++ showVersion v-#endif--listVisibleModules :: DynFlags -> [GHC.Module]-listVisibleModules df = let-#if __GLASGOW_HASKELL__ >= 710-    modNames = listVisibleModuleNames df-    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]-#else-    pkgCfgs = allExposedPackageConfigs df-    mods = [ mkModule pid modname | p <- pkgCfgs-           , let pid = packageConfigId p-           , modname <- exposedModules p ]-#endif-    in mods--isSynTyCon :: TyCon -> Bool-#if __GLASGOW_HASKELL__ >= 710-isSynTyCon = GHC.isTypeSynonymTyCon-#else-isSynTyCon = GHC.isSynTyCon-#endif---parseModuleHeader-    :: String         -- ^ Haskell module source text (full Unicode is supported)-    -> DynFlags-    -> FilePath       -- ^ the filename (for source locations)-    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))-parseModuleHeader str dflags filename =-   let-       loc  = mkRealSrcLoc (mkFastString filename) 1 1-       buf  = stringToStringBuffer str-   in-   case L.unP Parser.parseHeader (mkPState dflags buf loc) of--     PFailed sp err   ->-#if __GLASGOW_HASKELL__ >= 706-         Left (unitBag (mkPlainErrMsg dflags sp err))-#else-         Left (unitBag (mkPlainErrMsg sp err))-#endif--     POk pst rdr_module ->-         let (warns,_) = getMessages pst in-         Right (warns, rdr_module)--mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle-#if __GLASGOW_HASKELL__ >= 706-mkErrStyle' = Outputable.mkErrStyle-#else-mkErrStyle' _ = Outputable.mkErrStyle-#endif--#if __GLASGOW_HASKELL__ < 706-instance NFData ByteString where-  rnf Empty       = ()-  rnf (Chunk _ b) = rnf b-#endif
− Language/Haskell/GhcMod/GhcPkg.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}-module Language.Haskell.GhcMod.GhcPkg (-    ghcPkgDbOpt-  , ghcPkgDbStackOpts-  , ghcDbStackOpts-  , ghcDbOpt-  , getPackageDbStack-  , getPackageCachePaths-  , getGhcPkgProgram-  ) where--import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)-import Control.Applicative-import Data.List.Split (splitOn)-import Data.Maybe-import Exception (handleIO)-import System.Directory (doesDirectoryExist, getAppUserDataDirectory)-import System.FilePath ((</>))-import Prelude--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.CabalHelper-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.CustomPackageDb-import Language.Haskell.GhcMod.Stack--ghcVersion :: Int-ghcVersion = read cProjectVersionInt---------------------------------------------------------------------- | Get options needed to add a list of package dbs to ghc-pkg's db stack-ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack-                  -> [String]-ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs---- | Get options needed to add a list of package dbs to ghc's db stack-ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack-               -> [String]-ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs--------------------------------------------------------------------ghcPkgDbOpt :: GhcPkgDb -> [String]-ghcPkgDbOpt GlobalDb = ["--global"]-ghcPkgDbOpt UserDb   = ["--user"]-ghcPkgDbOpt (PackageDb pkgDb)-  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]-  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]--ghcDbOpt :: GhcPkgDb -> [String]-ghcDbOpt GlobalDb-  | ghcVersion < 706 = ["-global-package-conf"]-  | otherwise        = ["-global-package-db"]-ghcDbOpt UserDb-  | ghcVersion < 706 = ["-user-package-conf"]-  | otherwise        = ["-user-package-db"]-ghcDbOpt (PackageDb pkgDb)-  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]-  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]--------------------------------------------------------------------getGhcPkgProgram :: IOish m => GhcModT m FilePath-getGhcPkgProgram = do-  crdl <- cradle-  progs <- optPrograms <$> options-  case cradleProject crdl of-    (StackProject senv) -> do-        Just ghcPkg <- getStackGhcPkgPath senv-        return ghcPkg-    _ ->-        return $ ghcPkgProgram progs--getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]-getPackageDbStack = do-  crdl <- cradle-  mCusPkgStack <- getCustomPkgDbStack-  stack <- case cradleProject crdl of-    PlainProject ->-        return [GlobalDb, UserDb]-    SandboxProject -> do-        Just db <- liftIO $ getSandboxDb crdl-        return $ [GlobalDb, db]-    CabalProject ->-        getCabalPackageDbStack-    (StackProject StackEnv {..}) ->-        return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb]-  return $ fromMaybe stack mCusPkgStack--getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]-getPackageCachePaths sysPkgCfg = do-  pkgDbStack <- getPackageDbStack-  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack---- TODO: use PkgConfRef---- Copied from ghc module `Packages' unfortunately it's not exported :/-resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)-resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg-resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do-  appdir <- getAppUserDataDirectory "ghc"-  let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)-      pkgconf = dir </> "package.conf.d"-  exist <- doesDirectoryExist pkgconf-  return $ if exist then Just pkgconf else Nothing- where-    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString-resolvePackageConfig _ (PackageDb name) = return $ Just name
− Language/Haskell/GhcMod/HomeModuleGraph.hs 
@@ -1,269 +0,0 @@--- 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 ScopedTypeVariables, RecordWildCards #-}-module Language.Haskell.GhcMod.HomeModuleGraph (-   GmModuleGraph(..)- , ModulePath(..)- , mkFileMap- , mkModuleMap- , mkMainModulePath- , findModulePath- , findModulePathSet- , fileModuleName- , canonicalizeModulePath- , homeModuleGraph- , updateHomeModuleGraph- , canonicalizeModuleGraph- , reachable- , moduleGraphToDot- ) where--import DriverPipeline-import DynFlags-import ErrUtils-import Exception-import Finder-import GHC-import HscTypes--import Control.Arrow ((&&&))-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)-import Control.Monad.State.Strict (execStateT)-import Control.Monad.State.Class-import Data.Maybe-import Data.Monoid as Monoid-import Data.Map  (Map)-import qualified Data.Map  as Map-import Data.Set (Set)-import qualified Data.Set as Set-import System.FilePath-import System.Directory-import System.IO-import Prelude--import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils (withMappedFile)-import Language.Haskell.GhcMod.Gap (parseModuleHeader)---- | Turn module graph into a graphviz dot file------ @dot -Tpng -o modules.png modules.dot@-moduleGraphToDot :: GmModuleGraph -> String-moduleGraphToDot GmModuleGraph { gmgGraph } =-    "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"- where-   graph = Map.map (Set.mapMonotonic mpPath)-         $ Map.mapKeysMonotonic mpPath gmgGraph-   edges :: (FilePath, (Set FilePath)) -> String-   edges (f, sf) =-       concatMap (\f' -> "    \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)--data S = S {-      sErrors   :: [(ModulePath, ErrorMessages)],-      sWarnings :: [(ModulePath, WarningMessages)],-      sGraph    :: GmModuleGraph-}--defaultS :: S-defaultS = S [] [] mempty--putErr :: MonadState S m-       => (ModulePath, ErrorMessages) -> m ()-putErr e = do-  s <- get-  put s { sErrors = e:sErrors s}--putWarn :: MonadState S m-       => (ModulePath, ErrorMessages) -> m ()-putWarn w = do-  s <- get-  put s { sWarnings = w:sWarnings s}--gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))-gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get--graphUnion :: MonadState S m => GmModuleGraph -> m ()-graphUnion gmg = do-  s <- get-  put s { sGraph = sGraph s `mappend` gmg }--reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath-reachable smp0 GmModuleGraph {..} = go smp0- where-   go smp = let-       δsmp = Set.unions $-                collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp-       smp' = smp `Set.union` δsmp-    in if smp == smp' then smp' else go smp'--pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph-pruneUnreachable smp0 gmg@GmModuleGraph {..} = let-    r = reachable smp0 gmg-  in-    GmModuleGraph {-      gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph-    }--collapseMaybeSet :: Maybe (Set a) -> Set a-collapseMaybeSet = maybe Set.empty id--homeModuleGraph :: (IOish m, Gm m)-    => HscEnv -> Set ModulePath -> m GmModuleGraph-homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp--mkMainModulePath :: FilePath -> ModulePath-mkMainModulePath = ModulePath (mkModuleName "Main")--findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)-findModulePath env mn = do-    fmap (ModulePath mn) <$> find env mn--findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)-findModulePathSet env mns = do-    Set.fromList . catMaybes <$> findModulePath env `mapM` mns--find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)-find env mn = liftIO $ do-  res <- findHomeModule env mn-  case res of-   -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc-    Found loc@ModLocation { ml_hs_file = Just _ } _mod ->-        return $ normalise <$> ml_hs_file loc-    _ -> return Nothing---canonicalizeModulePath :: ModulePath -> IO ModulePath-canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp--canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph-canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do-    GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph)- where-   fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))---updateHomeModuleGraph :: (IOish m, Gm m)-                      => HscEnv-                      -> GmModuleGraph-                      -> Set ModulePath -- ^ Initial set of modules-                      -> Set ModulePath -- ^ Updated set of modules-                      -> m GmModuleGraph-updateHomeModuleGraph env GmModuleGraph {..} smp sump = do-    -- TODO: It would be good if we could retain information about modules that-    -- stop to compile after we've already successfully parsed them at some-    -- point. Figure out a way to delete the modules about to be updated only-    -- after we're sure they won't fail to parse .. or something. Should probably-    -- push this whole prune logic deep into updateHomeModuleGraph'-   (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump)- where-   runS = flip execStateT defaultS { sGraph = graph' }-   graph' = GmModuleGraph {-       gmgGraph = Set.foldr Map.delete gmgGraph sump-    }--mkFileMap :: Set ModulePath -> Map FilePath ModulePath-mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp--mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath-mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp--updateHomeModuleGraph'-    :: forall m. (MonadState S m, IOish m, Gm m)-    => HscEnv-    -> Set ModulePath     -- ^ Initial set of modules-    -> m ()-updateHomeModuleGraph' env smp0 = do-    go `mapM_` Set.toList smp0- where-   go :: ModulePath -> m ()-   go mp = do-     msmp <- gmgLookupMP mp-     case msmp of-       Just _ -> return ()-       Nothing -> do-           smp <- collapseMaybeSet `liftM` step mp--           graphUnion GmModuleGraph {-               gmgGraph = Map.singleton mp smp-            }--           mapM_ go (Set.toList smp)--   step :: ModulePath -> m (Maybe (Set ModulePath))-   step mp = runMaybeT $ do-       (dflags, ppsrc_fn) <- MaybeT preprocess'-       src <- liftIO $ readFile ppsrc_fn-       imports mp src dflags-    where-      preprocess' :: m (Maybe (DynFlags, FilePath))-      preprocess' = do-        let fn = mpPath mp-        ep <- preprocessFile env fn-        case ep of-          Right (_, x) -> return $ Just x-          Left errs -> do-            -- TODO: Remember these and present them as proper errors if this is-            -- the file the user is looking at.-            gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs)-            return Nothing---   imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)-   imports mp@ModulePath {..} src dflags =-       case parseModuleHeader src dflags mpPath of-         Left err -> do-           putErr (mp, err)-           mzero--         Right (ws, lmdl) -> do-           putWarn (mp, ws)-           let HsModule {..} = unLoc lmdl-               mns = map (unLoc . ideclName)-                   $ filter (isNothing . ideclPkgQual)-                   $ map unLoc hsmodImports-           liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns--preprocessFile :: (IOish m, GmEnv m, GmState m) =>-  HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))-preprocessFile env file =-  withLogger' env $ \setDf -> do-    withMappedFile file $ \fn -> do-      let env' = env { hsc_dflags = setDf (hsc_dflags env) }-      liftIO $ preprocess env' (fn, Nothing)--fileModuleName :: (IOish m, GmEnv m, GmState m) =>-  HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))-fileModuleName env fn = do-    let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)-    ep <- preprocessFile env fn-    case ep of-      Left errs -> do-        return $ Left errs-      Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do-        src <- readFile procdFile-        case parseModuleHeader src dflags procdFile of-          Left errs -> return $ Left errs-          Right (_, lmdl) -> do-            let HsModule {..} = unLoc lmdl-            return $ Right $ unLoc <$> hsmodName)-  where-    leftM f = either (return . Left <=< f) (return . Right)
− Language/Haskell/GhcMod/Info.hs 
@@ -1,85 +0,0 @@-module Language.Haskell.GhcMod.Info (-    info-  , types-  ) where--import Data.Function (on)-import Data.List (sortBy)-import Data.Maybe (catMaybes)-import System.FilePath-import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)-import Prelude-import qualified GHC as G-import qualified Language.Haskell.GhcMod.Gap as Gap--import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Doc-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Gap-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)-import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)---------------------------------------------------------------------- | Obtaining information of a target expression. (GHCi's info:)-info :: IOish m-     => FilePath     -- ^ A target file.-     -> Expression   -- ^ A Haskell expression.-     -> GhcModT m String-info file expr =-  ghandle handler $-    runGmlT' [Left file] deferErrors $-      withInteractiveContext $ do-        convert' =<< body-  where-    handler (SomeException ex) = do-      gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)-      convert' "Cannot show info"--    body :: (GhcMonad m, GmState m, GmEnv m) => m String-    body = do-      m <- mkRevRedirMapFunc-      sdoc  <- Gap.infoThing m expr-      st    <- getStyle-      dflag <- G.getSessionDynFlags-      return $ showPage dflag st sdoc---------------------------------------------------------------------- | Obtaining type of a target expression. (GHCi's type:)-types :: IOish m-      => FilePath     -- ^ A target file.-      -> Int          -- ^ Line number.-      -> Int          -- ^ Column number.-      -> GhcModT m String-types file lineNo colNo =-  ghandle handler $-    runGmlT' [Left file] deferErrors $-      withInteractiveContext $ do-        crdl         <- cradle-        modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)-        srcSpanTypes <- getSrcSpanType modSum lineNo colNo-        dflag        <- G.getSessionDynFlags-        st           <- getStyle-        convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes- where-   handler (SomeException ex) = do-     gmLog GmException "types" $ showDoc ex-     return []--getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]-getSrcSpanType modSum lineNo colNo = do-  p <- G.parseModule modSum-  tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-  let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]-      es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]-      ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]-  bts <- mapM (getType tcm) bs-  ets <- mapM (getType tcm) es-  pts <- mapM (getType tcm) ps-  return $ catMaybes $ concat [ets, bts, pts]
− Language/Haskell/GhcMod/Internal.hs 
@@ -1,73 +0,0 @@--- | Low level access to the ghc-mod library.--module Language.Haskell.GhcMod.Internal (-  -- * Types-    GHCOption-  , IncludeDir-  , GmlT(..)-  , MonadIO(..)-  , GmEnv(..)-  -- * Various Paths-  , ghcLibDir-  , ghcModExecutable-  -- * Logging-  , withLogger-  , setNoWarningFlags-  , setAllWarningFlags-  -- * Environment, state and logging-  , GhcModEnv(..)-  , GhcModState-  , GhcModLog-  , GmLog(..)-  , GmLogLevel(..)-  , gmSetLogLevel-  -- * Monad utilities-  , runGhcModT'-  , hoistGhcModT-  , runGmlT-  , runGmlT'-  , gmlGetSession-  , gmlSetSession-  , loadTargets-  , cabalResolvedComponents-  -- ** Accessing 'GhcModEnv' and 'GhcModState'-  , options-  , cradle-  , targetGhcOptions-  , withOptions-  -- * 'GhcModError'-  , gmeDoc-  -- * World-  , World-  , getCurrentWorld-  , didWorldChange-  -- * Cabal Helper-  , ModulePath(..)-  , GmComponent(..)-  , GmComponentType(..)-  , GmModuleGraph(..)-  , prepareCabalHelper-  -- * Misc stuff-  , GHandler(..)-  , gcatches-  -- * FileMapping-  , module Language.Haskell.GhcMod.FileMapping-  ) where--import GHC.Paths (libdir)--import Language.Haskell.GhcMod.Target-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.World-import Language.Haskell.GhcMod.CabalHelper-import Language.Haskell.GhcMod.FileMapping---- | Obtaining the directory for ghc system libraries.-ghcLibDir :: FilePath-ghcLibDir = libdir
− Language/Haskell/GhcMod/Lang.hs 
@@ -1,10 +0,0 @@-module Language.Haskell.GhcMod.Lang where--import DynFlags (supportedLanguagesAndExtensions)-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad---- | Listing language extensions.--languages :: IOish m => GhcModT m String-languages = convert' supportedLanguagesAndExtensions
− Language/Haskell/GhcMod/LightGhc.hs 
@@ -1,44 +0,0 @@-module Language.Haskell.GhcMod.LightGhc where--import Control.Monad.Reader (runReaderT)-import Data.IORef--import GHC-import GHC.Paths (libdir)-import StaticFlags-import SysTools-import DynFlags-import HscMain-import HscTypes--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.DynFlags--withLightHscEnv :: forall m a. IOish m-    => [GHCOption] -> (HscEnv -> m a) -> m a-withLightHscEnv opts action = gbracket initEnv teardownEnv action- where-   teardownEnv :: HscEnv -> m ()-   teardownEnv env = liftIO $ do-       let dflags = hsc_dflags env-       cleanTempFiles dflags-       cleanTempDirs dflags--   initEnv :: m HscEnv-   initEnv = liftIO $ do-     initStaticOpts-     settings <- initSysTools (Just libdir)-     dflags  <- initDynFlags (defaultDynFlags settings)-     env <- newHscEnv dflags-     dflags' <- runLightGhc env $ do-         -- HomeModuleGraph and probably all other clients get into all sorts of-         -- trouble if the package state isn't initialized here-         _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags-         getSessionDynFlags-     newHscEnv dflags'--runLightGhc :: HscEnv -> LightGhc a -> IO a-runLightGhc env action = do-  renv <- newIORef env-  flip runReaderT renv $ unLightGhc action
− Language/Haskell/GhcMod/Lint.hs 
@@ -1,29 +0,0 @@-module Language.Haskell.GhcMod.Lint where--import Exception (ghandle)-import Control.Exception (SomeException(..))-import Language.Haskell.GhcMod.Logger (checkErrorPrefix)-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad-import Language.Haskell.HLint (hlint)--import Language.Haskell.GhcMod.Utils (withMappedFile)--import Data.List (stripPrefix)---- | Checking syntax of a target file using hlint.---   Warnings and errors are returned.-lint :: IOish m-     => LintOpts  -- ^ Configuration parameters-     -> FilePath  -- ^ A target file.-     -> GhcModT m String-lint opt file =-  withMappedFile file $ \tempfile ->-        liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)-    >>= mapM (replaceFileName tempfile)-    >>= ghandle handler . pack- where-    pack = convert' . map init -- init drops the last \n.-    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"-    replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s)
− Language/Haskell/GhcMod/Logger.hs 
@@ -1,174 +0,0 @@-module Language.Haskell.GhcMod.Logger (-    withLogger-  , withLogger'-  , checkErrorPrefix-  , errsToStr-  , errBagToStrList-  ) where--import Control.Arrow-import Control.Applicative-import Data.Ord-import Data.List-import Data.Maybe-import Data.Function-import Control.Monad.Reader (Reader, asks, runReader)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)-import System.FilePath (normalise)-import Text.PrettyPrint--import ErrUtils-import GHC-import HscTypes-import Outputable-import qualified GHC as G-import Bag--import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Doc (showPage)-import Language.Haskell.GhcMod.DynFlags (withDynFlags)-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Prelude--type Builder = [String] -> [String]--data Log = Log [String] Builder--newtype LogRef = LogRef (IORef Log)--data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags-                         , gpeMapFile :: FilePath -> FilePath-                         }--type GmPprEnvM a = Reader GmPprEnv a--emptyLog :: Log-emptyLog = Log [] id--newLogRef :: IO LogRef-newLogRef = LogRef <$> newIORef emptyLog--readAndClearLogRef :: LogRef -> IO [String]-readAndClearLogRef (LogRef ref) = do-    Log _ b <- readIORef ref-    writeIORef ref emptyLog-    return $ b []--appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef rfm df (LogRef ref) _ sev src st msg = do-    modifyIORef ref update-  where-    gpe = GmPprEnv {-            gpeDynFlags = df-          , gpeMapFile = rfm-          }-    l = runReader (ppMsg st src sev msg) gpe--    update lg@(Log ls b)-      | l `elem` ls = lg-      | otherwise   = Log (l:ls) (b . (l:))---------------------------------------------------------------------- | Logged messages are returned as 'String'.---   Right is success and Left is failure.-withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)-           => (DynFlags -> DynFlags)-           -> m a-           -> m (Either String (String, a))-withLogger f action = do-  env <- G.getSession-  oopts <- outputOpts-  let conv = convert oopts-  eres <- withLogger' env $ \setDf ->-      withDynFlags (f . setDf) action-  return $ either (Left . conv) (Right . first conv) eres--withLogger' :: (IOish m, GmState m, GmEnv m)-    => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))-withLogger' env action = do-    logref <- liftIO $ newLogRef--    rfm <- mkRevRedirMapFunc--    let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref-        handlers = [-            GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,-            GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]-          ]-        gpe = GmPprEnv {-                gpeDynFlags = hsc_dflags env-              , gpeMapFile = rfm-        }--    a <- gcatches (Right <$> action setLogger) handlers-    ls <- liftIO $ readAndClearLogRef logref--    return ((,) ls <$> a)--errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]-errBagToStrList env errs = do-   rfm <- mkRevRedirMapFunc-   return $ runReader-    (errsToStr (sortMsgBag errs))-    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }---------------------------------------------------------------------- | Converting 'SourceError' to 'String'.-sourceError :: SourceError -> GmPprEnvM [String]-sourceError = errsToStr . sortMsgBag . srcErrorMessages--errsToStr :: [ErrMsg] -> GmPprEnvM [String]-errsToStr = mapM ppErrMsg--sortMsgBag :: Bag ErrMsg -> [ErrMsg]-sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag--------------------------------------------------------------------ppErrMsg :: ErrMsg -> GmPprEnvM String-ppErrMsg err = do-    dflags <- asks gpeDynFlags-    let unqual = errMsgContext err-        st = Gap.mkErrStyle' dflags unqual-    let ext = showPage dflags st (errMsgExtraInfo err)-    m <- ppMsg st spn SevError msg-    return $ m ++ (if null ext then "" else "\n" ++ ext)-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err--ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String-ppMsg st spn sev msg = do-  dflags <- asks gpeDynFlags-  let cts  = showPage dflags st msg-  prefix <- ppMsgPrefix spn sev cts-  return $ prefix ++ cts--ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String-ppMsgPrefix spn sev cts = do-  dflags <- asks gpeDynFlags-  mr <- asks gpeMapFile-  let defaultPrefix-        | Gap.isDumpSplices dflags = ""-        | otherwise               = checkErrorPrefix-  return $ fromMaybe defaultPrefix $ do-    (line,col,_,_) <- Gap.getSrcSpan spn-    file <- mr <$> normalise <$> Gap.getSrcFile spn-    let severityCaption = Gap.showSeverityCaption sev-        pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)-                          = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"-              | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption-    return pref0--checkErrorPrefix :: String-checkErrorPrefix = "Dummy:0:0:Error:"--warningAsErrorPrefixes :: [String]-warningAsErrorPrefixes = ["Couldn't match expected type"-                         , "Couldn't match type"-                         , "No instance for"]
− Language/Haskell/GhcMod/Logging.hs 
@@ -1,114 +0,0 @@--- 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 GeneralizedNewtypeDeriving #-}--module Language.Haskell.GhcMod.Logging (-    module Language.Haskell.GhcMod.Logging-  , module Language.Haskell.GhcMod.Pretty-  , GmLogLevel(..)-  , module Text.PrettyPrint-  , module Data.Monoid-  ) where--import Control.Applicative hiding (empty)-import Control.Monad-import Control.Monad.Trans.Class-import Data.List-import Data.Char-import Data.Monoid-import Data.Maybe-import System.IO-import System.FilePath-import Text.PrettyPrint hiding (style, (<>))-import Prelude--import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Pretty-import Language.Haskell.GhcMod.Output--gmSetLogLevel :: GmLog m => GmLogLevel -> m ()-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)) []---increaseLogLevel :: GmLogLevel -> GmLogLevel-increaseLogLevel l | l == maxBound = l-increaseLogLevel l = succ l--decreaseLogLevel :: GmLogLevel -> GmLogLevel-decreaseLogLevel l | l == minBound = l-decreaseLogLevel l = pred l---- |--- >>> Just GmDebug <= Nothing--- False--- >>> Just GmException <= Just GmDebug--- True--- >>> Just GmDebug <= Just GmException--- False-gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()-gmLog level loc' doc = do-  GhcModLog { gmLogLevel = Just level' } <- gmlHistory--  let loc | loc' == "" = empty-          | otherwise = text loc' <+>: empty-      msgDoc = sep [loc, doc]-      msg = dropWhileEnd isSpace $ gmRenderDoc $ gmLogLevelDoc level <+>: msgDoc--  when (level <= level') $ gmErrStrLn msg-  gmLogQuiet level loc' doc--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-  gmLog GmVomit "" $ doc <+>: text content--  GhcModLog { gmLogVomitDump = Last mdump }-      <- gmlHistory--  dir <- cradleTempDir `liftM` cradle-  when (fromMaybe False mdump) $-       liftIO $ writeFile (dir </> filename) content---newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }-    deriving (Functor, Applicative, Monad)--instance MonadTrans LogDiscardT where-    lift = LogDiscardT--instance Monad m => GmLog (LogDiscardT m) where-    gmlJournal = const $ return ()-    gmlHistory = return mempty-    gmlClear = return ()
− Language/Haskell/GhcMod/Modules.hs 
@@ -1,27 +0,0 @@-module Language.Haskell.GhcMod.Modules (modules) where--import Control.Arrow-import Data.List-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames-                                   , lookupModulePackageInAllPackages-                                   )--import qualified GHC as G---------------------------------------------------------------------- | Listing installed modules.-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 detailed then pkg ++ " " ++ mn else mn-                 | (mn, pkgs) <- pmnss, pkg <- pkgs ]- where-   modulePkg df = lookupModulePackageInAllPackages df
− Language/Haskell/GhcMod/Monad.hs 
@@ -1,142 +0,0 @@--- 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.Monad (-    runGmOutT-  , runGmOutT'-  , runGhcModT-  , runGhcModT'-  , hoistGhcModT-  , runGmlT-  , runGmlT'-  , runGmlTWith-  , runGmPkgGhc-  , withGhcModEnv-  , withGhcModEnv'-  , module Language.Haskell.GhcMod.Monad.Types-  ) where--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Target-import Language.Haskell.GhcMod.Output--import Control.Arrow (first)-import Control.Applicative--import Control.Concurrent--import Control.Monad.Reader (runReaderT)-import Control.Monad.State.Strict (runStateT)-import Control.Monad.Trans.Journal (runJournalT)--import Exception--import System.Directory-import System.IO.Unsafe-import Prelude--withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a-withGhcModEnv = withGhcModEnv' withCradle- where-   withCradle dir =-       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)--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,lg) ->-      withCradleRootDir crdl $-        f (GhcModEnv opts crdl, lg)- where-   swapCurrentDirectory ndir = do-     odir <- canonicalizePath =<< getCurrentDirectory-     setCurrentDirectory ndir-     return odir--   withCradleRootDir (cradleRootDir -> projdir) a = do-       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--      teardown odir = liftIO $ do-        setCurrentDirectory odir-        void $ takeMVar cwdLock--runGmOutT :: IOish m => Options -> GmOutT m a -> m a-runGmOutT opts ma = do-    gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan-    let action = runGmOutT' gmo ma-    case ooptLinePrefix $ optOutput opts of-      Nothing -> action-      Just pfxs ->-        gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)-                  (const $ liftIO $ flushStdoutGateway gmoChan)-                  action--runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a-runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma---- | Run a @GhcModT m@ computation.-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,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--- state part of GhcModT this cannot be restored.-hoistGhcModT :: IOish m-             => (Either GhcModError a, GhcModLog)-             -> GhcModT m a-hoistGhcModT (r,l) = do-  gmlJournal l >> case r of-    Left e -> throwError e-    Right a -> return a----- | Run a computation inside @GhcModT@ providing the RWST environment and--- initial state. This is a low level function, use it only if you know what to--- do with 'GhcModEnv' and 'GhcModState'.------ You should probably look at 'runGhcModT' instead.-runGhcModT' :: IOish m-             => GhcModEnv-             -> GhcModState-             -> GhcModT m a-             -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)-runGhcModT' r s a = do-  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s--gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c-gbracket_ ma mb mc = gbracket ma mb (const mc)
− Language/Haskell/GhcMod/Monad/Compat.hs_h 
@@ -1,28 +0,0 @@--- 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
− Language/Haskell/GhcMod/Monad/Env.hs 
@@ -1,68 +0,0 @@--- 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)
− Language/Haskell/GhcMod/Monad/Log.hs 
@@ -1,71 +0,0 @@--- 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)
− Language/Haskell/GhcMod/Monad/Newtypes.hs 
@@ -1,176 +0,0 @@--- 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
− Language/Haskell/GhcMod/Monad/Orphans.hs 
@@ -1,83 +0,0 @@--- 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
− Language/Haskell/GhcMod/Monad/Out.hs 
@@ -1,52 +0,0 @@--- 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
− Language/Haskell/GhcMod/Monad/State.hs 
@@ -1,67 +0,0 @@--- 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)
− Language/Haskell/GhcMod/Monad/Types.hs 
@@ -1,239 +0,0 @@--- 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, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}-{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.Haskell.GhcMod.Monad.Types (-  -- * Monad Types-    GhcModT-  , GmOutT(..)-  , GmT(..)-  , GmlT(..)-  , LightGhc(..)-  , GmGhc-  , IOish-  -- * Environment, state and logging-  , GhcModEnv(..)-  , GhcModState(..)-  , GhcModCaches(..)-  , defaultGhcModState-  , GmGhcSession(..)-  , GmComponent(..)-  -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'-  , GmLogLevel(..)-  , GhcModLog(..)-  , GhcModError(..)-  , Gm-  , GmEnv(..)-  , GmState(..)-  , GmLog(..)-  , GmOut(..)-  , cradle-  , options-  , outputOpts-  , withOptions-  , getMMappedFiles-  , setMMappedFiles-  , addMMappedFile-  , delMMappedFile-  , lookupMMappedFile-  , getMMappedFilePaths-  -- * Re-exporting convenient stuff-  , MonadIO-  , liftIO-  , gmlGetSession-  , gmlSetSession-  ) where--#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-import HscTypes--import Control.Applicative-import Control.Monad--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.Trans.Control--import Control.Monad.Reader.Class--import qualified Data.Map as M-import Data.Maybe-import Data.Monoid-import Data.IORef-import Prelude--type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)------------------------------------------------------- GHC API instances --------------------------------- GHC cannot prove the following instances to be decidable automatically using--- the FlexibleContexts extension as they violate the second Paterson Condition,--- namely that: The assertion has fewer constructors and variables (taken--- together and counting repetitions) than the head. Specifically the--- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation.--type GmGhc m = (IOish m, GhcMonad m)--instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where-    getSession = gmlGetSession-    setSession = gmlSetSession---- | Get the underlying GHC session-gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv-gmlGetSession = do-        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 . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet-        liftIO $ flip writeIORef a ref--instance GhcMonad LightGhc where-    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-    getDynFlags = hsc_dflags <$> getSession--instance HasDynFlags LightGhc where-    getDynFlags = hsc_dflags <$> getSession-#endif--instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT 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 (GmT 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 (GmlT m) where-    gcatch act handler = control $ \run ->-        run act `gcatch` (run . handler)--    gmask = liftBaseOp gmask . liftRestore-     where liftRestore f r = f $ liftBaseOp_ r--instance ExceptionMonad LightGhc where-  gcatch act handl =-      LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)-  gmask f =-      LightGhc $ gmask $ \io_restore ->let-          g_restore (LightGhc m) = LightGhc $ io_restore m-      in-        unLightGhc (f g_restore)---instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s 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 (ReaderT s m) where-    gcatch act handler = control $ \run ->-        run act `gcatch` (run . handler)--    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-options = gmOptions `liftM` gmeAsk--outputOpts :: GmOut m => m OutputOpts-outputOpts = gmoOptions `liftM` gmoAsk--cradle :: GmEnv m => m Cradle-cradle = gmCradle `liftM` gmeAsk--getMMappedFiles :: GmState m => m FileMappingMap-getMMappedFiles = gmMMappedFiles `liftM` gmsGet--setMMappedFiles :: GmState m => FileMappingMap -> m ()-setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet--addMMappedFile  :: GmState m => FilePath -> FileMapping -> m ()-addMMappedFile t fm =-  getMMappedFiles >>= setMMappedFiles . M.insert t fm--delMMappedFile  :: GmState m => FilePath -> m ()-delMMappedFile t =-  getMMappedFiles >>= setMMappedFiles . M.delete t--lookupMMappedFile  :: GmState m => FilePath -> m (Maybe FileMapping)-lookupMMappedFile t =-  M.lookup t `liftM` getMMappedFiles--getMMappedFilePaths :: GmState m => m [FilePath]-getMMappedFilePaths = M.keys `liftM` getMMappedFiles--withOptions :: GmEnv m => (Options -> Options) -> m a -> m a-withOptions changeOpt action = gmeLocal changeEnv action-  where-    changeEnv e = e { gmOptions = changeOpt opt }-      where-        opt = gmOptions e
− Language/Haskell/GhcMod/Output.hs 
@@ -1,243 +0,0 @@--- 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/>.---- Derived from process:System.Process--- Copyright (c) The University of Glasgow 2004-2008--{-# LANGUAGE FlexibleInstances #-}-module Language.Haskell.GhcMod.Output (-    gmPutStr-  , gmErrStr-  , gmPutStrLn-  , gmErrStrLn--  , gmPutStrIO-  , 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-import System.Exit-import System.Process-import Control.Monad-import Control.Monad.State.Strict-import Control.DeepSeq-import Control.Exception-import Control.Concurrent (forkIO, killThread)-import Control.Concurrent.MVar-import Control.Concurrent.Chan-import Pipes-import Pipes.Lift-import Prelude--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 =-  outputFns' `liftM` gmoAsk--outputFns' ::-  MonadIO m => GhcModOut -> (String -> m (), String -> m ())-outputFns' (GhcModOut oopts c)  = let-  OutputOpts {..} = oopts- in-  case ooptLinePrefix of-    Nothing -> stdioOutputFns-    Just _  -> chanOutputFns c--stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())-stdioOutputFns =-    ( liftIO . putStr-    , liftIO . hPutStr stderr-    )--chanOutputFns :: MonadIO m-              => Chan (Either (MVar ()) (GmStream, String))-              -> (String -> m (), String -> m ())-chanOutputFns c = (write GmOutStream, write GmErrStream)- where-   write stream s = liftIO $ writeChan c $ Right $ (stream,s)--gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn-    :: (MonadIO m, GmOut m) => String -> m ()--gmPutStr str = do-  putOut <- gmPutStrIO-  putOut str--gmErrStr str = do-  putErr <- gmErrStrIO-  putErr str--gmPutStrLn = gmPutStr . (++"\n")-gmErrStrLn = gmErrStr . (++"\n")--gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())--gmPutStrIO = fst `liftM` outputFns-gmErrStrIO = snd `liftM` outputFns---gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)-gmReadProcess = do-  GhcModOut {..} <- gmoAsk-  case ooptLinePrefix gmoOptions of-    Just _ ->-        readProcessStderrChan-    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-  writeChan c $ Left mv-  takeMVar mv--type Line = String--stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()-stdoutGateway (outPf, errPf) chan = do-  runEffect $ commandProc >-> evalStateP ("","") seperateStreams- where-   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()-   commandProc = do-     cmd <- liftIO $ readChan chan-     case cmd of-       Left mv -> do-           yield $ Left mv-       Right input -> do-           yield $ Right input-           commandProc--   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()-   seperateStreams  = do-       ecmd <- await-       case ecmd of-         Left mv -> do-           -- flush buffers-           (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)-               `mapM_` [GmOutStream, GmErrStream]--           liftIO $ putMVar mv ()-         Right (stream, str) -> do-           ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)-           case ls of-               [] -> return ()-               _  -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls--           liftIO $ hFlush stdout-           seperateStreams--   sGetLine :: (Maybe String) -> StateT String IO [Line]-   sGetLine mstr' = do-     buf <- get-     let mstr = (buf++) `liftM` mstr'-     case mstr of-       Nothing -> put "" >> return [buf]-       Just "" -> return []-       Just s | last s == '\n' -> put "" >> return (lines s)-              | otherwise -> do-                  let (p:ls') = reverse $ lines s-                  put p-                  return $ reverse $ ls'--   streamLens GmOutStream = LB.fst-   streamLens GmErrStream = LB.snd--   streamPf GmOutStream = outPf-   streamPf GmErrStream = errPf--zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a-zoom l (StateT a) =-    StateT $ \f -> do-      (a', s') <- a $ L.get l f-      return (a', L.set l s' f)--readProcessStderrChan ::-    (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)-readProcessStderrChan = do-  (_, e :: String -> IO ()) <- outputFns-  return $ readProcessStderrChan' e--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-              , std_in  = CreatePipe-              }-     (Just i, Just o, Just e, h) <- createProcess cp--     _ <- forkIO $ reader e--     output  <- hGetContents' o-     withForkWait (evaluate $ rnf output) $ \waitOut -> do--       -- now write any input-       unless (null input) $-         ignoreSEx $ hPutStr i input-       -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE-       ignoreSEx $ hClose i--       -- wait on the output-       waitOut-       hClose o--     res <- waitForProcess h-     case res of-       ExitFailure rv ->-           throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv-       ExitSuccess ->-           return output-    where-      ignoreSEx = handle (\(SomeException _) -> return ())-      reader h = ignoreSEx $ do-        putErr . (++"\n") =<< hGetLine h-        reader h--withForkWait :: IO () -> (IO () ->  IO a) -> IO a-withForkWait async body = do-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))-  mask $ \restore -> do-    tid <- forkIO $ try (restore async) >>= putMVar waitVar-    let wait = takeMVar waitVar >>= either throwIO return-    restore (body wait) `onException` killThread tid
− Language/Haskell/GhcMod/PathsAndFiles.hs 
@@ -1,250 +0,0 @@--- 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.PathsAndFiles (-    module Language.Haskell.GhcMod.PathsAndFiles-  , module Language.Haskell.GhcMod.Caching-  ) where--import Config (cProjectVersion)-import Control.Arrow (second)-import Control.Applicative-import Control.Exception as E-import Control.Monad-import Data.List-import Data.Char-import Data.Maybe-import Data.Traversable hiding (mapM)-import Distribution.Helper (buildPlatform)-import System.Directory-import System.FilePath-import System.Process--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Caching-import qualified Language.Haskell.GhcMod.Utils as U-import Utils (mightExist)-import Prelude---- | Guaranteed to be a path to a directory with no trailing slash.-type DirPath = FilePath---- | Guaranteed to be the name of a file only (no slashes).-type FileName = String--newtype UnString = UnString { unString :: String }--instance Show UnString where-    show = unString--instance Read UnString where-    readsPrec _ = \str -> [(UnString str, "")]---- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent--- directories. The first parent directory containing more than one cabal file--- is assumed to be the project directory. If only one cabal file exists in this--- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'--- or 'GMETooManyCabalFiles'-findCabalFile :: FilePath -> IO (Maybe FilePath)-findCabalFile dir = do-    -- List of directories and all cabal file candidates-    dcs <- findFileInParentsP  isCabalFile dir :: IO ([(DirPath, [FileName])])-    let css = uncurry appendDir `map` dcs :: [[FilePath]]-    case find (not . null) css of-      Nothing -> return Nothing-      Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs-      Just (a:_)       -> return (Just a)-      Just []          -> error "findCabalFile"- where-   appendDir :: DirPath -> [FileName] -> [FilePath]-   appendDir d fs = (d </>) `map` fs--findStackConfigFile :: FilePath -> IO (Maybe FilePath)-findStackConfigFile dir = do-    fs <- map (second listToMaybe) <$> findFileInParentsP  (=="stack.yaml") dir-    case find (isJust . snd) fs of-      Nothing           -> return Nothing-      Just (d, Just a)  -> return $ Just $ d </> a-      Just (_, Nothing) -> error "findStackConfigFile"---- | Get path to sandbox config file-getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)-getSandboxDb crdl = do-  mConf <-traverse readFile =<< mightExist (sandboxConfigFile crdl)-  bp <- buildPlatform readProcess-  return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)-- where-   fixPkgDbVer bp dir =-       case takeFileName dir == ghcSandboxPkgDbDir bp of-         True -> dir-         False -> takeDirectory dir </> ghcSandboxPkgDbDir bp---- | Extract the sandbox package db directory from the cabal.sandbox.config--- file. Exception is thrown if the sandbox config file is broken.-extractSandboxDbDir :: String -> Maybe FilePath-extractSandboxDbDir conf = extractValue <$> parse conf-  where-    key = "package-db:"-    keyLen = length key--    parse = listToMaybe . filter (key `isPrefixOf`) . lines-    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen----- |--- >>> isCabalFile "/home/user/.cabal"--- False-isCabalFile :: FilePath -> Bool-isCabalFile f = takeExtension' f == ".cabal"---- |--- >>> takeExtension' "/some/dir/bla.cabal"--- ".cabal"------ >>> takeExtension' "some/reldir/bla.cabal"--- ".cabal"------ >>> takeExtension' "bla.cabal"--- ".cabal"------ >>> takeExtension' ".cabal"--- ""-takeExtension' :: FilePath -> String-takeExtension' p =-    if takeFileName p == takeExtension p-      then "" -- just ".cabal" is not a valid cabal file-      else takeExtension p---- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all--- it's parent directories.-findFileInParentsP :: (FilePath -> Bool) -> FilePath-                   -> IO [(DirPath, [FileName])]-findFileInParentsP p dir' = U.makeAbsolute' dir' >>= \dir ->-    getFilesP p `zipMapM` parents dir---- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.-getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]-getFilesP p dir = filterM p' =<< getDirectoryContents dir- where-   p' fn = do-     (p fn && ) <$> doesFileExist (dir </> fn)--findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)-findCabalSandboxDir dir = do-  dss <- findFileInParentsP isSandboxConfig dir-  return $ case find (not . null . snd) $ dss of-             Just (sbDir, _:_) -> Just sbDir-             _ -> Nothing-- where-   isSandboxConfig = (==sandboxConfigFileName)--zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]-zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as---- | @parents dir@. Returns all parent directories of @dir@ including @dir@.------ Examples------ >>> parents "foo"--- ["foo"]------ >>> parents "/foo"--- ["/foo","/"]------ >>> parents "/foo/bar"--- ["/foo/bar","/foo","/"]------ >>> parents "foo/bar"--- ["foo/bar","foo"]-parents :: FilePath -> [FilePath]-parents "" = []-parents dir' =-    let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'-    in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir- where-   parents' :: [String] -> [FilePath]-   parents' [] | isAbsolute dir' = "":[]-   parents' [] = []-   parents' dir = [joinPath dir] ++ parents' (init dir)--------------------------------------------------------------------setupConfigFile :: Cradle -> FilePath-setupConfigFile crdl =-    cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl)--sandboxConfigFile :: Cradle -> FilePath-sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName--sandboxConfigFileName :: String-sandboxConfigFileName = "cabal.sandbox.config"---- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@-setupConfigPath :: FilePath -> FilePath-setupConfigPath dist = dist </> "setup-config"- -- localBuildInfoFile defaultDistPref--macrosHeaderPath :: FilePath-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-    buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"--packageCache :: String-packageCache = "package.cache"---- | Filename of the symbol table cache file.-symbolCache :: Cradle -> FilePath-symbolCache crdl = cradleTempDir crdl </> symbolCacheFile--symbolCacheFile :: String-symbolCacheFile = "ghc-mod.symbol-cache"--resolvedComponentsCacheFile :: FilePath -> FilePath-resolvedComponentsCacheFile dist =-    setupConfigPath dist <.> "ghc-mod.resolved-components"--cabalHelperCacheFile :: FilePath -> FilePath-cabalHelperCacheFile dist =-    setupConfigPath dist <.> "ghc-mod.cabal-components"--mergedPkgOptsCacheFile :: FilePath -> FilePath-mergedPkgOptsCacheFile dist =-    setupConfigPath dist <.> "ghc-mod.package-options"--pkgDbStackCacheFile :: FilePath -> FilePath-pkgDbStackCacheFile dist =-    setupConfigPath dist <.> "ghc-mod.package-db-stack"---- | @findCustomPackageDbFile dir@. Searches for a @ghc-mod.package-db-stack@ file in @dir@.--- If it exists in the given directory it is returned otherwise @findCradleFile@--- returns @Nothing@-findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)-findCustomPackageDbFile directory = do-    let path = directory </> "ghc-mod.package-db-stack"-    mightExist path
− Language/Haskell/GhcMod/PkgDoc.hs 
@@ -1,29 +0,0 @@-module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Output--import Control.Applicative-import Prelude---- | Obtaining the package name and the doc path of a module.-pkgDoc :: IOish m => String -> GhcModT m String-pkgDoc mdl = do-    ghcPkg <- getGhcPkgProgram-    readProc <- gmReadProcess-    pkgDbStack <- getPackageDbStack-    pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) ""-    if pkg == "" then-        return "\n"-      else do-        htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) ""-        let ret = pkg ++ " " ++ drop 14 htmlpath-        return ret-  where-    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]-                   ++ ghcPkgDbStackOpts dbs-    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]-                       ++ ghcPkgDbStackOpts dbs-    trim = takeWhile (`notElem` " \n")
− Language/Haskell/GhcMod/Pretty.hs 
@@ -1,74 +0,0 @@--- 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.Pretty where--import Control.Arrow hiding ((<+>))-import Data.Char-import Data.List-import Distribution.Helper-import Text.PrettyPrint--import Language.Haskell.GhcMod.Types--docStyle :: Style-docStyle = style { ribbonsPerLine = 1.2 }--gmRenderDoc :: Doc -> String-gmRenderDoc = renderStyle docStyle--gmComponentNameDoc :: ChComponentName -> Doc-gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"-gmComponentNameDoc ChLibName       = text $ "library"-gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n-gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n-gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n--gmLogLevelDoc :: GmLogLevel -> Doc-gmLogLevelDoc GmSilent    = error "GmSilent MUST not be used for log messages"-gmLogLevelDoc GmPanic     = text "PANIC"-gmLogLevelDoc GmException = text "EXCEPTION"-gmLogLevelDoc GmError     = text "ERROR"-gmLogLevelDoc GmWarning   = text "Warning"-gmLogLevelDoc GmInfo      = text "info"-gmLogLevelDoc GmDebug     = text "DEBUG"-gmLogLevelDoc GmVomit     = text "VOMIT"--infixl 6 <+>:-(<+>:) :: Doc -> Doc -> Doc-a <+>: b = (a <> colon) <+> b--fnDoc :: FilePath -> Doc-fnDoc = doubleQuotes . text--showDoc :: Show a => a -> Doc-showDoc = strLnDoc . show--warnDoc :: Doc -> Doc-warnDoc d = text "Warning" <+>: d--strLnDoc :: String -> Doc-strLnDoc str = doc (dropWhileEnd isSpace str)- where-   doc = lines >>> map text >>> foldr ($+$) empty--strDoc :: String -> Doc-strDoc str = doc (dropWhileEnd isSpace str)- where-   doc :: String -> Doc-   doc = lines-         >>> map (words >>> map text >>> fsep)-         >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty
− Language/Haskell/GhcMod/Read.hs 
@@ -1,106 +0,0 @@-module Language.Haskell.GhcMod.Read where--import Text.Read (readPrec_to_S, readPrec, minPrec)-import qualified Text.ParserCombinators.ReadP as P-import Text.ParserCombinators.ReadPrec (lift)---- This library (libraries/base) is derived from code from several--- sources:----   * Code from the GHC project which is largely (c) The University of---     Glasgow, and distributable under a BSD-style license (see below),----   * Code from the Haskell 98 Report which is (c) Simon Peyton Jones---     and freely redistributable (but see the full license for---     restrictions).----   * Code from the Haskell Foreign Function Interface specification,---     which is (c) Manuel M. T. Chakravarty and freely redistributable---     (but see the full license for restrictions).---- The full text of these licenses is reproduced below.  All of the--- licenses are BSD-style or compatible.---- --------------------------------------------------------------------------------- The Glasgow Haskell Compiler License---- Copyright 2004, 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.---- --------------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language--- Haskell 98", is distributed under the following license:----   Copyright (c) 2002 Simon Peyton Jones----   The authors intend this Report to belong to the entire Haskell---   community, and so we grant permission to copy and distribute it for---   any purpose, provided that it is reproduced in its entirety,---   including this Notice.  Modified versions of this Report may also be---   copied and distributed for any purpose, provided that the modified---   version is clearly presented as such, and that it does not claim to---   be a definition of the Haskell 98 Language.---- --------------------------------------------------------------------------------- Code derived from the document "The Haskell 98 Foreign Function--- Interface, An Addendum to the Haskell 98 Report" is distributed under--- the following license:----   Copyright (c) 2002 Manuel M. T. Chakravarty----   The authors intend this Report to belong to the entire Haskell---   community, and so we grant permission to copy and distribute it for---   any purpose, provided that it is reproduced in its entirety,---   including this Notice.  Modified versions of this Report may also be---   copied and distributed for any purpose, provided that the modified---   version is clearly presented as such, and that it does not claim to---   be a definition of the Haskell 98 Foreign Function Interface.---- -------------------------------------------------------------------------------readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x--readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a
− Language/Haskell/GhcMod/SrcUtils.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.Haskell.GhcMod.SrcUtils where--import Control.Applicative-import CoreUtils (exprType)-import Data.Generics-import Data.Maybe (fromMaybe)-import Data.Ord as O-import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))-import qualified GHC as G-import GHC.SYB.Utils (Stage(..), everythingStaged)-import GhcMonad-import qualified Language.Haskell.Exts.Annotated as HE-import Language.Haskell.GhcMod.Doc-import Language.Haskell.GhcMod.Gap-import qualified Language.Haskell.GhcMod.Gap as Gap-import OccName (OccName)-import Outputable (PprStyle)-import TcHsSyn (hsPatType)-import Prelude--------------------------------------------------------------------instance HasType (LHsExpr Id) where-    getType tcm e = do-        hs_env <- G.getSession-        mbe <- liftIO $ Gap.deSugar tcm e hs_env-        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe--instance HasType (LPat Id) where-    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)--------------------------------------------------------------------listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]-listifySpans tcs lc = listifyStaged TypeChecker p tcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]-listifyParsedSpans pcs lc = listifyStaged Parser p pcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]-listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]-listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))--cmp :: SrcSpan -> SrcSpan -> Ordering-cmp a b-  | a `G.isSubspanOf` b = O.LT-  | b `G.isSubspanOf` a = O.GT-  | otherwise           = O.EQ--toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)-toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)--fourInts :: SrcSpan -> (Int,Int,Int,Int)-fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan--fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)-fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc-                 , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)---- Check whether (line,col) is inside a given SrcSpanInfo-typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool-typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE _  _ _= False--pretty :: DynFlags -> PprStyle -> Type -> String-pretty dflag style = showOneLine dflag style . Gap.typeForUser--showName :: DynFlags -> PprStyle -> G.Name -> String-showName dflag style name = showOneLine dflag style $ Gap.nameForUser name--showOccName :: DynFlags -> PprStyle -> OccName -> String-showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name
− Language/Haskell/GhcMod/Stack.hs 
@@ -1,95 +0,0 @@--- 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.Stack where--import Safe-import Control.Applicative-import Control.Exception as E-import Control.Monad-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Class-import Data.List-import Data.List.Split-import Data.Maybe-import System.Directory-import System.FilePath-import System.Info.Extra-import Exception--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--patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs-patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do-  Just ghc <- getStackGhcPath senv-  Just ghcPkg <- getStackGhcPkgPath senv-  return $ progs {-      ghcProgram = ghc-    , ghcPkgProgram = ghcPkg-    }-patchStackPrograms _crdl progs = return progs--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 = fromJustNote "getStackEnv" $ lookup k env-    return StackEnv {-        seDistDir       = look "dist-dir"-      , seBinPath       = splitSearchPath $ look "bin-path"-      , seSnapshotPkgDb = look "snapshot-pkg-db"-      , seLocalPkgDb    = look "local-pkg-db"-      }- where-   liToTup [k,v] = (k,v)-   liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")-   liToTup _ = error "getStackEnv"--getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)-getStackGhcPath = findExecutablesInStackBinPath "ghc"--getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)-getStackGhcPkgPath = findExecutablesInStackBinPath  "ghc-pkg"--findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)-findExecutablesInStackBinPath exe StackEnv {..} =-    liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe--findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]-findExecutablesInDirectories' path binary =-    U.findFilesWith' isExecutable path (binary <.> exeExtension)-   where isExecutable file = do-             perms <- getPermissions file-             return $ executable perms--         exeExtension = if isWindows then "exe" else ""--readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String-readStack args = do-  stack <- MaybeT $ liftIO $ findExecutable "stack"-  readProc <- lift gmReadProcess-  flip gcatch handler $ do-    liftIO $ evaluate =<< readProc stack args ""- where-   handler (e :: IOError) = do-     gmLog GmWarning "readStack" $ gmeDoc $ exToErr e-     mzero-   exToErr = GMEStackBootstrap . GMEString . show
− Language/Haskell/GhcMod/Target.hs 
@@ -1,492 +0,0 @@--- 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, ViewPatterns, NamedFieldPuns, RankNTypes #-}-module Language.Haskell.GhcMod.Target where--import Control.Arrow-import Control.Applicative-import Control.Category ((.))-import GHC-import GHC.Paths (libdir)-import SysTools-import DynFlags--import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.CabalHelper-import Language.Haskell.GhcMod.HomeModuleGraph-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils as U-import Language.Haskell.GhcMod.FileMapping-import Language.Haskell.GhcMod.LightGhc-import Language.Haskell.GhcMod.CustomPackageDb-import Language.Haskell.GhcMod.Output--import Safe-import Data.Maybe-import Data.Monoid as Monoid-import Data.Either-import Data.Foldable as Foldable (foldrM)-import qualified Data.Foldable as Foldable-import Data.Traversable hiding (mapM, forM)-import Data.IORef-import Data.List-import Data.Map (Map)-import qualified Data.Map  as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Function (on)-import Distribution.Helper-import Prelude hiding ((.))--import System.Directory-import System.FilePath--runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a-runGmPkgGhc action = do-    pkgOpts <- packageGhcOptions-    withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action--initSession :: IOish m-            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()-initSession opts mdf = do-   s <- gmsGet-   case gmGhcSession s of-     Just GmGhcSession {..} | gmgsOptions /= opts-> do-         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"-         putNewSession s-     Just _ -> return ()-     Nothing -> do-         gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"-         putNewSession s-- where-   putNewSession s = do-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }--   newSession Cradle { cradleTempDir } = liftIO $ do-     runGhc (Just libdir) $ do-       let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)-       _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags-       getSession---- | Drop the currently active GHC session, the next that requires a GHC session--- will initialize a new one.-dropSession :: IOish m => GhcModT m ()-dropSession = do-  s <- gmsGet-  case gmGhcSession s of-    Just (GmGhcSession _opts ref) -> do-      -- TODO: This is still not enough, there seem to still be references to-      -- GHC's state around afterwards.-      liftIO $ writeIORef ref (error "HscEnv: session was dropped")-      -- Not available on ghc<7.8; didn't really help anyways-      -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")-      gmsPut s { gmGhcSession = Nothing }--    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)-              -> GmlT m a-              -> 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)-                 -> (GmlT m a -> GmlT m b)-                 -> GmlT m a-                 -> GhcModT m b-runGmlTWith efnmns' mdf wrapper action = do-    crdl <- cradle-    Options { optGhcUserOptions } <- options--    let (fns, mns) = partitionEithers efnmns'-        ccfns = map (cradleCurrentDir crdl </>) fns-    cfns <- mapM getCanonicalFileNameSafe ccfns-    let serfnmn = Set.fromList $ map Right mns ++ map Left cfns-    opts <- targetGhcOptions crdl serfnmn-    let opts' = opts ++ ["-O0"] ++ optGhcUserOptions--    gmVomit-      "session-ghc-options"-      (text "Initializing GHC session with following options")-      (intercalate " " $ map (("\""++) . (++"\"")) opts')--    GhcModLog { gmLogLevel = Just level } <- gmlHistory-    putErr <- gmErrStrIO-    let setLogger | level >= GmDebug = setDebugLogger putErr-                  | otherwise = setEmptyLogger--    initSession opts' $-        setHscNothing >>> setLogger >>> mdf--    mappedStrs <- getMMappedFilePaths-    let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns--    unGmlT $ wrapper $ do-      loadTargets opts targetStrs-      action--targetGhcOptions :: forall m. IOish m-                  => Cradle-                  -> Set (Either FilePath ModuleName)-                  -> GhcModT m [GHCOption]-targetGhcOptions crdl sefnmn = do-    when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"--    case cradleProject crdl of-      proj-          | isCabalHelperProject proj -> cabalOpts crdl-          | otherwise -> sandboxOpts crdl- where-   zipMap f l = l `zip` (f `map` l)--   cabalOpts :: Cradle -> GhcModT m [String]-   cabalOpts Cradle{..} = do-       mcs <- cabalResolvedComponents--       let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn-           candidates = findCandidates $ map snd mdlcs--       let noCandidates = Set.null candidates-           noModuleHasAnyAssignment = all (Set.null . snd) mdlcs--       if noCandidates && noModuleHasAnyAssignment-          then do-            -- First component should be ChLibName, if no lib will take lexically first exe.-            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 $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs-          else do-            when noCandidates $-              throwError $ GMECabalCompAssignment mdlcs--            let cn = pickComponent candidates-            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs--resolvedComponentsCache :: IOish m => FilePath ->-    Cached (GhcModT m) GhcModState-    [GmComponent 'GMCRaw (Set.Set ModulePath)]-    (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))-resolvedComponentsCache distdir = Cached {-    cacheLens = Just (lGmcResolvedComponents . lGmCaches),-    cacheFile = resolvedComponentsCacheFile distdir,-    cachedAction = \tcfs comps ma -> do-        Cradle {..} <- cradle-        let iifs = invalidatingInputFiles tcfs--            setupChanged =-                (cradleRootDir </> setupConfigPath distdir) `elem` iifs--            mums :: Maybe [Either FilePath ModuleName]-            mums =-              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--            changed = map (text . mdesc) $ Foldable.concat mums-            changedDoc | [] <- changed = text "none"-                       | otherwise = sep changed--        gmLog GmDebug "resolvedComponentsCache" $-              text "files changed" <+>: changedDoc--        mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps--        return (setupConfigPath distdir : flatten mcs , mcs)- }-- where-   flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))-           -> [FilePath]-   flatten = Map.elems-      >>> map (gmcHomeModuleGraph >>> gmgGraph-               >>> (Map.keysSet &&& Map.elems)-               >>> uncurry insert-               >>> map (Set.map mpPath)-               >>> Set.unions-              )-      >>> Set.unions-      >>> Set.toList--moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))-                 -> Either FilePath ModuleName-                 -> Set ChComponentName-moduleComponents m efnmn =-    foldr' Set.empty m $ \c s ->-        let-            memb =-              case efnmn of-                Left fn  -> fn `Set.member` Set.map mpPath (smp c)-                Right mn -> mn `Set.member` Set.map mpModule (smp c)-        in if memb-           then Set.insert (gmcName c) s-           else s- where-   smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c--   foldr' b as f = Map.foldr f b as---findCandidates :: [Set ChComponentName] -> Set ChComponentName-findCandidates [] = Set.empty-findCandidates scns = foldl1 Set.intersection scns--pickComponent :: Set ChComponentName -> ChComponentName-pickComponent scn = Set.findMin scn--packageGhcOptions :: (Applicative m, IOish m, Gm m)-                  => m [GHCOption]-packageGhcOptions = do-    crdl <- cradle-    case cradleProject crdl of-      proj-          | isCabalHelperProject proj -> getGhcMergedPkgOptions-          | otherwise -> sandboxOpts crdl---- also works for plain projects!-sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]-sandboxOpts crdl = do-    mCusPkgDb <- getCustomPkgDbStack-    pkgDbStack <- liftIO $ getSandboxPackageDbStack-    let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb-    return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]-  where-    (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)--    getSandboxPackageDbStack :: IO [GhcPkgDb]-    getSandboxPackageDbStack =-        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl--resolveGmComponent :: (IOish m, Gm m)-    => Maybe [CompilationUnit] -- ^ Updated modules-    -> GmComponent 'GMCRaw (Set ModulePath)-    -> m (GmComponent 'GMCResolved (Set ModulePath))-resolveGmComponent mums c@GmComponent {..} = do-  distDir <- cradleDistDir <$> cradle-  gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir-  withLightHscEnv (ghcOpts distDir) $ \env -> do-    let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs-    let mg = gmcHomeModuleGraph-    let simp = gmcEntrypoints-    sump <- case mums of-        Nothing -> return simp-        Just ums ->-            Set.fromList . catMaybes <$>-               mapM (resolveModule env srcDirs) ums--    mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump--    return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }-- where ghcOpts distDir = concat [-           gmcGhcSrcOpts,-           gmcGhcLangOpts,-           [ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]-        ]--resolveEntrypoint :: (IOish m, Gm m)-    => Cradle-    -> GmComponent 'GMCRaw ChEntrypoint-    -> m (GmComponent 'GMCRaw (Set ModulePath))-resolveEntrypoint Cradle {..} c@GmComponent {..} = do-    gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts-    withLightHscEnv gmcGhcSrcOpts $ \env -> do-      let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs-      eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints-      rms <- resolveModule env srcDirs `mapM` eps-      return c { gmcEntrypoints = Set.fromList $ catMaybes rms }---- 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]-resolveChEntrypoints _ (ChLibEntrypoint em om) =-    return $ map (Right . chModToMod) (em ++ om)--resolveChEntrypoints _ (ChExeEntrypoint main om) =-    return $ [Left main] ++ map (Right . chModToMod) om--resolveChEntrypoints srcDir ChSetupEntrypoint = do-  shs <- doesFileExist (srcDir </> "Setup.hs")-  slhs <- doesFileExist (srcDir </> "Setup.lhs")-  return $ case (shs, slhs) of-    (True, _) -> [Left "Setup.hs"]-    (_, True) -> [Left "Setup.lhs"]-    (False, False) -> []--chModToMod :: ChModuleName -> ModuleName-chModToMod (ChModuleName mn) = mkModuleName mn---resolveModule :: (IOish m, Gm m) =>-  HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)-resolveModule env _srcDirs (Right mn) =-    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn-resolveModule env srcDirs (Left fn') = do-    mfn <-  liftIO $ findFile' srcDirs fn'-    case mfn of-      Nothing -> return Nothing-      Just fn'' -> do-          fn <-  liftIO $ canonicalizePath fn''-          emn <- fileModuleName env fn-          case emn of-              Left errs -> do-                gmLog GmWarning ("resolveModule " ++ show fn) $-                  Monoid.mempty $+$ (vcat $ map text errs)-                return Nothing -- TODO: should expose these errors otherwise-                               -- modules with preprocessor/parse errors are-                               -- going to be missing-              Right mmn -> return $ Just $-                  case mmn of-                    Nothing -> mkMainModulePath fn-                    Just mn -> ModulePath mn fn- where-   -- needed for ghc 7.4-   findFile' dirs file =-       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs--   -- fileModuleName fn (dir:dirs)-   --     | 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], ResolvedComponentsMap)-        -- ^ Updated modules-    -> 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-    return m'-- where-   foldrM' b fa f = foldrM f b fa-   insertUpdated m c = do-     rc <- resolveGmComponent (fst <$> mcache) c-     return $ Map.insert (gmcName rc) rc m--   same :: Eq b-        => (forall t a. GmComponent t a -> b)-        -> GmComponent u c -> GmComponent v d -> Bool-   same f a b = (f a) == (f b)---- | Set the files as targets and load them.-loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()-loadTargets opts targetStrs = do-    targets' <--        withLightHscEnv opts $ \env ->-                liftM (nubBy ((==) `on` targetId))-                  (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)-              >>= mapM relativize--    let targets = map (\t -> t { targetAllowObjCode = False }) targets'--    gmLog GmDebug "loadTargets" $-          text "Loading" <+>: fsep (map (text . showTargetId) targets)--    setTargets targets--    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-    relativize (Target (TargetFile filePath phase) taoc src) = do-      crdl <- cradle-      let tid = TargetFile relativeFilePath phase-          relativeFilePath = makeRelative (cradleRootDir crdl) filePath-      return $ Target tid taoc src-    relativize tgt = return tgt--    resetTargets targets' = do-        setTargets []-        void $ load LoadAllTargets-        setTargets targets'--    showTargetId (Target (TargetModule s) _ _) = moduleNameString s-    showTargetId (Target (TargetFile s _) _ _) = s--needsHscInterpreted :: ModuleGraph -> Bool-needsHscInterpreted = any $ \ms ->-                let df = ms_hspp_opts ms in-                   Opt_TemplateHaskell `xopt` df-                || Opt_QuasiQuotes     `xopt` df-#if __GLASGOW_HASKELL__ >= 708-                || (Opt_PatternSynonyms `xopt` df)-#endif--cabalResolvedComponents :: (IOish m) =>-   GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))-cabalResolvedComponents = do-    crdl@(Cradle{..}) <- cradle-    comps <- mapM (resolveEntrypoint crdl) =<< getComponents-    withAutogen $-      cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps
− Language/Haskell/GhcMod/Test.hs 
@@ -1,45 +0,0 @@-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"
− Language/Haskell/GhcMod/Types.hs 
@@ -1,401 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,-  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,-  GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}-module Language.Haskell.GhcMod.Types (-    module Language.Haskell.GhcMod.Types-  , ModuleName-  , mkModuleName-  , moduleNameString-  ) where--import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Error (Error(..))-import qualified Control.Monad.IO.Class as MTL-import Control.Exception (Exception)-import Control.Applicative-import Control.Concurrent-import Control.Monad-import Control.DeepSeq-import Data.Binary-import Data.Binary.Generic-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Monoid-import Data.Maybe-import Data.Typeable (Typeable)-import Data.IORef-import Data.Label.Derive-import Distribution.Helper hiding (Programs(..))-import qualified Distribution.Helper as CabalHelper-import Exception (ExceptionMonad)-#if __GLASGOW_HASKELL__ < 708-import qualified MonadUtils as GHC (MonadIO(..))-#endif-import GHC (ModuleName, moduleNameString, mkModuleName)-import HscTypes (HscEnv)-import GHC.Generics-import Text.PrettyPrint (Doc)-import Prelude--import Language.Haskell.GhcMod.Caching.Types---- | A constraint alias (-XConstraintKinds) to make functions dealing with--- 'GhcModT' somewhat cleaner.------ Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and--- exception handling. Usually this will simply be 'IO' but we parametrise it in--- the exported API so users have the option to use a custom inner monad.-type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)----- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.--- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.-#if __GLASGOW_HASKELL__ < 708-type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)-#else-type MonadIOC m = (MTL.MonadIO m)-#endif--class MonadIOC m => MonadIO m where-  liftIO :: IO a -> m a---- | Output style.-data OutputStyle = LispStyle  -- ^ S expression style.-                 | PlainStyle -- ^ Plain textstyle.-                   deriving (Show)---- | The type for line separator. Historically, a Null string is used.-newtype LineSeparator = LineSeparator String deriving (Show)--data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}-                  deriving Show--type FileMappingMap = Map FilePath FileMapping--data ProgramSource = ProgramSourceUser | ProgramSourceStack--data Programs = Programs {-  -- | @ghc@ program name.-    ghcProgram    :: FilePath-  -- | @ghc-pkg@ program name.-  , ghcPkgProgram :: FilePath-  -- | @cabal@ program name.-  , cabalProgram  :: FilePath-  -- | @stack@ program name.-  , stackProgram   :: FilePath-  } deriving (Show)--data OutputOpts = OutputOpts {-  -- | Verbosity-    ooptLogLevel      :: GmLogLevel-  , ooptStyle         :: OutputStyle-  -- | Line separator string.-  , ooptLineSeparator :: LineSeparator-  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,-  -- @snd@ is stderr prefix.-  , ooptLinePrefix    :: Maybe (String, String)-  } deriving (Show)--data Options = Options {-    optOutput         :: OutputOpts-  , optPrograms       :: Programs-    -- | GHC command line options set on the @ghc-mod@ command line-  , optGhcUserOptions :: [GHCOption]-  , optFileMappings   :: [(FilePath, Maybe FilePath)]-  } deriving (Show)---- | A default 'Options'.-defaultOptions :: Options-defaultOptions = Options {-    optOutput     = OutputOpts {-      ooptLogLevel       = GmWarning-    , ooptStyle          = PlainStyle-    , ooptLineSeparator  = LineSeparator "\0"-    , ooptLinePrefix     = Nothing-    }-  , optPrograms       = Programs {-      ghcProgram     = "ghc"-    , ghcPkgProgram  = "ghc-pkg"-    , cabalProgram   = "cabal"-    , stackProgram   = "stack"-    }-  , optGhcUserOptions = []-  , optFileMappings   = []-  }--------------------------------------------------------------------data Project = CabalProject-             | SandboxProject-             | PlainProject-             | StackProject StackEnv-               deriving (Eq, Show)--isCabalHelperProject :: Project -> Bool-isCabalHelperProject StackProject {} = True-isCabalHelperProject CabalProject {} = True-isCabalHelperProject _ = False--data StackEnv = StackEnv {-      seDistDir       :: FilePath-    , seBinPath       :: [FilePath]-    , seSnapshotPkgDb :: FilePath-    , seLocalPkgDb    :: FilePath-    } deriving (Eq, Show)---- | The environment where this library is used.-data Cradle = Cradle {-    cradleProject    :: Project-  -- | The directory where this library is executed.-  , cradleCurrentDir :: FilePath-  -- | The project root directory.-  , cradleRootDir    :: FilePath-  -- | Per-Project temporary directory-  , cradleTempDir    :: FilePath-  -- | The file name of the found cabal file.-  , cradleCabalFile  :: Maybe FilePath-  -- | The build info directory.-  , cradleDistDir    :: FilePath-  } deriving (Eq, Show)--data GmStream = GmOutStream | GmErrStream-                deriving (Show)--data GhcModEnv = GhcModEnv {-      gmOptions    :: Options-    , gmCradle     :: Cradle-    }--data GhcModOut = GhcModOut {-      gmoOptions :: OutputOpts-    , gmoChan    :: Chan (Either (MVar ()) (GmStream, String))-    }--data GhcModLog = GhcModLog {-      gmLogLevel     :: Maybe GmLogLevel,-      gmLogVomitDump :: Last Bool,-      gmLogMessages  :: [(GmLogLevel, String, Doc)]-    } deriving (Show)--instance Monoid GhcModLog where-    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty-    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =-        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')--data GmGhcSession = GmGhcSession {-      gmgsOptions :: ![GHCOption],-      gmgsSession :: !(IORef HscEnv)-    }--data GhcModCaches = GhcModCaches {-      gmcPackageDbStack   :: CacheContents ChCacheData [GhcPkgDb]-    , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]-    , gmcComponents       :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]-    , gmcResolvedComponents :: CacheContents-          [GmComponent 'GMCRaw (Set.Set ModulePath)]-          (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))-    }--data GhcModState = GhcModState {-      gmGhcSession   :: !(Maybe GmGhcSession)-    , gmCaches       :: !GhcModCaches-    , gmMMappedFiles :: !FileMappingMap-    }--defaultGhcModState :: GhcModState-defaultGhcModState =-    GhcModState n (GhcModCaches n n n n) Map.empty- where n = Nothing---------------------------------------------------------------------- | GHC package database flags.-data GhcPkgDb = GlobalDb-              | UserDb-              | PackageDb String-                deriving (Eq, Show, Generic)--instance Binary GhcPkgDb where-    put = ggput . from-    get = to `fmap` ggget---- | A single GHC command line option.-type GHCOption = String---- | An include directory for modules.-type IncludeDir = FilePath---- | Haskell expression.-newtype Expression = Expression { getExpression :: String }-  deriving (Show, Eq, Ord)---- | Module name.-newtype ModuleString = ModuleString { getModuleString :: String }-  deriving (Show, Eq, Ord, Binary, NFData)--data GmLogLevel =-    GmSilent-  | GmPanic-  | GmException-  | GmError-  | GmWarning-  | GmInfo-  | GmDebug-  | GmVomit-    deriving (Eq, Ord, Enum, Bounded, Show, Read)--data GmModuleGraph = GmModuleGraph {-    gmgGraph :: Map ModulePath (Set ModulePath)-  } deriving (Eq, Ord, Show, Read, Generic, Typeable)--instance Binary GmModuleGraph where-  put GmModuleGraph {..} = put (mpim, graph)-    where-      mpim :: Map ModulePath Integer-      mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]-      graph :: Map Integer (Set Integer)-      graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph-      mpToInt :: ModulePath -> Integer-      mpToInt mp = fromJust $ Map.lookup mp mpim--  get = do-    (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get-    let impm = swapMap mpim-        intToMp i = fromJust $ Map.lookup i impm-        mpGraph :: Map ModulePath (Set ModulePath)-        mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph-    return $ GmModuleGraph mpGraph-    where-      swapMap :: (Ord k, Ord v) => Map k v -> Map v k-      swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList--instance Monoid GmModuleGraph where-  mempty  = GmModuleGraph mempty-  mappend (GmModuleGraph a) (GmModuleGraph a') =-    GmModuleGraph (Map.unionWith Set.union a a')--data GmComponentType = GMCRaw-                     | GMCResolved-data GmComponent (t :: GmComponentType) eps = GmComponent {-    gmcHomeModuleGraph :: GmModuleGraph-  , gmcName            :: ChComponentName-  , gmcGhcOpts         :: [GHCOption]-  , gmcGhcPkgOpts      :: [GHCOption]-  , gmcGhcSrcOpts      :: [GHCOption]-  , gmcGhcLangOpts     :: [GHCOption]-  , gmcRawEntrypoints  :: ChEntrypoint-  , gmcEntrypoints     :: eps-  , gmcSourceDirs      :: [FilePath]-  } deriving (Eq, Ord, Show, Read, Generic, Functor)--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 Binary ModulePath where-    put = ggput . from-    get = to `fmap` ggget--instance Binary ModuleName where-  get = mkModuleName <$> get-  put mn = put (moduleNameString mn)--instance Show ModuleName where-  show mn = "ModuleName " ++ show (moduleNameString mn)--instance Read ModuleName where-  readsPrec d =-    readParen-      (d > app_prec)-      (\r' -> [ (mkModuleName m, t)-              | ("ModuleName", s) <- lex r'-              , (m, t)            <- readsPrec (app_prec + 1) s-              ])-    where-      app_prec = 10--data GhcModError-  = GMENoMsg-  -- ^ Unknown error--  | GMEString String-  -- ^ Some Error with a message. These are produced mostly by-  -- 'fail' calls on GhcModT.--  | GMECabalConfigure GhcModError-  -- ^ Configuring a cabal project failed.--  | GMEStackConfigure GhcModError-  -- ^ Configuring a stack project failed.--  | GMEStackBootstrap GhcModError-    -- ^ Bootstrapping @stack@ environment failed (process exited with failure)--  | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]-  -- ^ Could not find a consistent component assignment for modules--  | GMEProcess String String [String] (Either Int GhcModError)-  -- ^ Launching an operating system process failed. Fields in-  -- order: function, command, arguments, (stdout, stderr, exitcode)--  | GMENoCabalFile-  -- ^ No cabal file found.--  | GMETooManyCabalFiles [FilePath]-  -- ^ Too many cabal files found.--    deriving (Eq,Show,Typeable)--instance Error GhcModError where-  noMsg  = GMENoMsg-  strMsg = GMEString--instance Exception GhcModError--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---- | 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-mkLabel ''Options-mkLabel ''OutputOpts-mkLabel ''Programs
− Language/Haskell/GhcMod/Utils.hs 
@@ -1,220 +0,0 @@--- 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 #-}-{-# LANGUAGE DoAndIfThenElse #-}--module Language.Haskell.GhcMod.Utils (-    module Language.Haskell.GhcMod.Utils-  , module Utils-  , readProcess-  ) where--import Control.Applicative-import Data.Char-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Either (rights)-import Data.List (inits)-import Exception-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import System.Directory-import System.Environment-import System.FilePath-import System.IO.Temp (createTempDirectory)-import System.Process (readProcess)-import Text.Printf--import Paths_ghc_mod (getLibexecDir)-import Utils-import Prelude---- dropWhileEnd is not provided prior to base 4.5.0.0.-dropWhileEnd :: (a -> Bool) -> [a] -> [a]-dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []--withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a-withDirectory_ dir action =-  gbracket-    (liftIO getCurrentDirectory)-    (liftIO . setCurrentDirectory)-    (\_ -> liftIO (setCurrentDirectory dir) >> action)--uniqTempDirName :: FilePath -> FilePath-uniqTempDirName dir =-  "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path-  where-    (drive, path) = splitDrive dir-    escapeDriveChar :: Char -> Char-    escapeDriveChar c-      | isAlphaNum c = c-      | otherwise     = '-'-    escapePathChar :: Char -> Char-    escapePathChar c-      | c `elem` pathSeparators = '-'-      | otherwise               = c--newTempDir :: FilePath -> IO FilePath-newTempDir _dir =-  flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory--whenM :: Monad m => m Bool -> m () -> m ()-whenM mb ma = mb >>= flip when ma---- | Returns the path to the currently running ghc-mod executable. With ghc<7.6--- this is a guess but >=7.6 uses 'getExecutablePath'.-ghcModExecutable :: IO FilePath-#ifndef SPEC-ghcModExecutable = do-    dir <- takeDirectory <$> getExecutablePath'-    return $ (if dir == "." then "" else dir) </> "ghc-mod"-#else-ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory-#endif--findLibexecExe :: String -> IO FilePath-findLibexecExe "cabal-helper-wrapper" = do-  libexecdir <- getLibexecDir-  let exeName = "cabal-helper-wrapper"-      exe = libexecdir </> exeName--  exists <- doesFileExist exe--  if exists-  then return exe-  else do-    mdir <- tryFindGhcModTreeDataDir-    case mdir of-      Nothing ->-        error $ libexecNotExitsError exeName libexecdir-      Just dir ->-        return $ dir </> "dist" </> "build" </> exeName </> exeName-findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe--libexecNotExitsError :: String -> FilePath -> String-libexecNotExitsError exe dir = printf- ( "Could not find $libexecdir/%s\n"- ++"\n"- ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n"- ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n"- ++"\n"- ++"    $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n"- ++"\n"- ++"[1]: %s\n"- ++"\n"- ++"If you don't know what I'm talking about something went wrong with your\n"- ++"installation. Please report this problem here:\n"- ++"\n"- ++"    https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir--tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)-tryFindGhcModTreeLibexecDir  = do-  exe <- getExecutablePath'-  dir <- case takeFileName exe of-    "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD-    _     -> return $ (!!4) $ iterate takeDirectory exe-  exists <- doesFileExist $ dir </> "ghc-mod.cabal"-  return $ if exists-           then Just dir-           else Nothing--tryFindGhcModTreeDataDir :: IO (Maybe FilePath)-tryFindGhcModTreeDataDir  = do-  dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'-  exists <- doesFileExist $ dir </> "ghc-mod.cabal"-  return $ if exists-           then Just dir-           else Nothing--readLibExecProcess' :: (MonadIO m, ExceptionMonad m)-                    => String -> [String] -> m String-readLibExecProcess' cmd args = do-  exe <- liftIO $ findLibexecExe cmd-  liftIO $ readProcess exe args ""--getExecutablePath' :: IO FilePath-#if __GLASGOW_HASKELL__ >= 706-getExecutablePath' = getExecutablePath-#else-getExecutablePath' = getProgName-#endif--canonFilePath :: FilePath -> IO FilePath-canonFilePath f = do-  p <- canonicalizePath f-  e <- doesFileExist p-  when (not e) $ error $ "canonFilePath: not a file: " ++ p-  return p--withMappedFile :: (IOish m, GmState m, GmEnv m) =>-                  forall a. FilePath -> (FilePath -> m a) -> m a-withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile-  where-    runWithFile (Just to) = action $ fmPath to-    runWithFile _ = action file--getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath-getCanonicalFileNameSafe fn = do-  let fn' = normalise fn-  pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')-  return $-    if (length pl > 0)-    then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))-    else error "Current dir doesn't seem to exist?"-  where-#if __GLASGOW_HASKELL__ < 710-    splitPath' = (".":) . splitPath-#else-    splitPath' = splitPath-#endif--mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)-mkRevRedirMapFunc = do-  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles-  crdl <- cradle-  return $ \key ->-    fromMaybe key-    $ makeRelative (cradleRootDir crdl)-    <$> M.lookup key rm-  where-    mf :: FilePath -> FileMapping -> (FilePath, FilePath)-    mf from to = (fmPath to, from)--findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]-findFilesWith' _ [] _ = return []-findFilesWith' f (d:ds) fileName = do-    let file = d </> fileName-    exist <- doesFileExist file-    b <- if exist then f file else return False-    if b then do-               files <- findFilesWith' f ds fileName-               return $ file : files-        else findFilesWith' f ds fileName----- Copyright   :  (c) The University of Glasgow 2001--- | Make a path absolute by prepending the current directory (if it isn't--- already absolute) and applying 'normalise' to the result.------ If the path is already absolute, the operation never fails.  Otherwise, the--- operation may fail with the same exceptions as 'getCurrentDirectory'.-makeAbsolute' :: FilePath -> IO FilePath-makeAbsolute' = (normalise <$>) . absolutize-  where absolutize path -- avoid the call to `getCurrentDirectory` if we can-          | isRelative path = (</> path) <$> getCurrentDirectory-          | otherwise       = return path
− Language/Haskell/GhcMod/World.hs 
@@ -1,55 +0,0 @@-module Language.Haskell.GhcMod.World where--import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Monad.Types-import Language.Haskell.GhcMod.Utils--import Control.Applicative-import Data.Maybe-import Data.Traversable hiding (mapM)-import System.FilePath ((</>))--import GHC.Paths (libdir)-import Prelude--data World = World {-    worldPackageCaches :: [TimedFile]-  , worldCabalFile     :: Maybe TimedFile-  , worldCabalConfig   :: Maybe TimedFile-  , worldCabalSandboxConfig :: Maybe TimedFile-  , worldSymbolCache   :: Maybe TimedFile-  } deriving (Eq)--timedPackageCaches :: IOish m => GhcModT m [TimedFile]-timedPackageCaches = do-    fs <- mapM (liftIO . mightExist) . map (</> packageCache)-            =<< getPackageCachePaths libdir-    (liftIO . timeFile) `mapM` catMaybes fs--getCurrentWorld :: IOish m => GhcModT m World-getCurrentWorld = do-    crdl <- cradle-    pkgCaches    <- timedPackageCaches-    mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl-    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)-    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)-    mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)--    return World {-        worldPackageCaches = pkgCaches-      , worldCabalFile     = mCabalFile-      , worldCabalConfig   = mCabalConfig-      , worldCabalSandboxConfig = mCabalSandboxConfig-      , worldSymbolCache   = mSymbolCache-      }--didWorldChange :: IOish m => World -> GhcModT m Bool-didWorldChange world = do-    (world /=) <$> getCurrentWorld--isYoungerThanSetupConfig :: FilePath -> World -> IO Bool-isYoungerThanSetupConfig file World {..} = do-  tfile <- timeFile file-  return $ worldCabalConfig < Just tfile
− NotCPP/COPYING 
@@ -1,30 +0,0 @@-Copyright Ben Millwood 2012--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 the name of Ben Millwood nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT-OWNER OR 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.
− NotCPP/Declarations.hs 
@@ -1,164 +0,0 @@--- 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/>.--{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE CPP #-}--- Using CPP so you don't have to :)-module NotCPP.Declarations where--import Control.Arrow-import Control.Applicative-import Data.Maybe-import Language.Haskell.TH.Syntax--import NotCPP.LookupValueName--nT :: Monad m => String -> m Type-cT :: Monad m => String -> m Type-nE :: Monad m => String -> m Exp-nP :: Monad m => String -> m Pat--nT str = return $ VarT (mkName str)-cT str = return $ ConT (mkName str)-nE str = return $ VarE (mkName str)-nP str = return $ VarP (mkName str)-recUpdE' :: Q Exp -> Name -> Exp -> Q Exp-recUpdE' ex name assign = do-  RecUpdE <$> ex <*> pure [(name, assign)]--lookupName' :: (NameSpace, String) -> Q (Maybe Name)-lookupName' (VarName, n) = lookupValueName n-lookupName' (DataName, n) = lookupValueName n-lookupName' (TcClsName, n) = lookupTypeName n---- Does this even make sense?-ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec]-ifelseD if_decls' else_decls = do-  if_decls <- if_decls'-  alreadyDefined <- definedNames (boundNames `concatMap` if_decls)-  case alreadyDefined of-    [] -> if_decls'-    _ -> else_decls--ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec]-ifelsedefD = ifdefelseD-ifdefelseD ident if_decls else_decls = do-  exists <- isJust <$> lookupValueName ident-  if exists-    then if_decls-    else else_decls--ifdefD :: String -> Q [Dec] -> Q [Dec]-ifdefD ident decls  = ifdefelseD ident decls (return [])--ifndefD :: String -> Q [Dec] -> Q [Dec]-ifndefD ident decls  = ifdefelseD ident (return []) decls---- | Each of the given declarations is only spliced if the identifier it defines--- is not defined yet.------ For example:------ @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@------ If @someFunctionThatShouldExist@ doesn't actually exist the definition given--- in the splice will be the result of the splice otherwise nothing will be--- spliced.------ Currently this only works for function declarations but it can be easily--- extended to other kinds of declarations.-ifD :: Q [Dec] -> Q [Dec]-ifD decls' = do-  decls <- decls'-  concat <$> flip mapM decls (\decl -> do-    alreadyDefined <- definedNames (boundNames decl)-    case alreadyDefined of-      [] -> return [decl]-      _ -> return [])--definedNames :: [(NameSpace, Name)] -> Q [Name]-definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns--boundNames :: Dec -> [(NameSpace, Name)]-boundNames decl =-    case decl of-      SigD n _ -> [(VarName, n)]-      FunD n _cls -> [(VarName, n)]-#if __GLASGOW_HASKELL__ >= 706-      InfixD _ n -> [(VarName, n)]-#endif-      ValD p _ _ -> map ((,) VarName) $ patNames p--      TySynD n _ _ -> [(TcClsName, n)]-      ClassD _ n _ _ _ -> [(TcClsName, n)]-      FamilyD _ n _ _ -> [(TcClsName, n)]--      DataD _ n _ ctors _ ->-          [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors)--      NewtypeD _ n _ ctor _ ->-          [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor)--      DataInstD _ _n _ ctors _ ->-          map ((,) TcClsName) (conNames `concatMap` ctors)--      NewtypeInstD _ _n _ ctor _ ->-          map ((,) TcClsName) (conNames ctor)--      InstanceD _ _ty _ ->-          error "notcpp: Instance declarations are not supported yet"-      ForeignD _ ->-          error "notcpp: Foreign declarations are not supported yet"-      PragmaD _pragma -> error "notcpp: pragmas are not supported yet"--#if __GLASGOW_HASKELL__ >= 708-      TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet"-#else-      TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet"-#endif--#if __GLASGOW_HASKELL__ >= 708-      ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]-      RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"-#endif--conNames :: Con -> [Name]-conNames con =-    case con of-      NormalC n _ -> [n]-      RecC n _ -> [n]-      InfixC _ n _ -> [n]-      ForallC _ _ c -> conNames c--patNames :: Pat -> [Name]-patNames p'' =-    case p'' of-      LitP _         -> []-      VarP n         -> [n]-      TupP ps        -> patNames `concatMap` ps-      UnboxedTupP ps -> patNames `concatMap` ps-      ConP _ ps      -> patNames `concatMap` ps-      InfixP p _ p'  -> patNames `concatMap` [p,p']-      UInfixP p _ p' -> patNames `concatMap` [p,p']-      ParensP p      -> patNames p-      TildeP p       -> patNames p-      BangP p        -> patNames p-      AsP n p        -> n:(patNames p)-      WildP          -> []-      RecP _ fps     -> patNames `concatMap` map snd fps-      ListP ps       -> patNames `concatMap` ps-      SigP p _       -> patNames p-      ViewP _ p      -> patNames p
− NotCPP/LookupValueName.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | This module uses scope lookup techniques to either export--- 'lookupValueName' from @Language.Haskell.TH@, or define--- its own 'lookupValueName', which attempts to do the--- same job with just 'reify'. This will sometimes fail, but if it--- succeeds it will give the answer that the real function would have--- given.------ The idea is that if you use lookupValueName from this module,--- your client code will automatically use the best available name--- lookup mechanism. This means that e.g. 'scopeLookup' can work--- very well on recent GHCs and less well but still somewhat--- usefully on older GHCs.-module NotCPP.LookupValueName (-  lookupValueName- ) where--import Language.Haskell.TH--import NotCPP.Utils--bestValueGuess :: String -> Q (Maybe Name)-bestValueGuess s = do-  mi <- maybeReify (mkName s)-  case mi of-    Nothing -> no-    Just i -> case i of-      VarI n _ _ _ -> yes n-      DataConI n _ _ _ -> yes n-      _ -> err ["unexpected info:", show i]- where-  no = return Nothing-  yes = return . Just-  err = fail . showString "NotCPP.bestValueGuess: " . unwords--$(recover [d| lookupValueName = bestValueGuess |] $ do-  VarI _ _ _ _ <- reify (mkName "lookupValueName")-  return [])
− NotCPP/OrphanEvasion.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}--- | --- The orphan instance problem is well-known in Haskell. This module--- by no means purports to solve the problem, but provides a workaround--- that may be significantly less awful than the status quo in some--- cases.------ Say I think that the 'Name' type should have an 'IsString' instance.--- But I don't control either the class or the type, so if I define the--- instance, and then the template-haskell package defines one, my code--- is going to break.------ 'safeInstance' can help me to solve this problem:------ > safeInstance ''IsString [t| Name |] [d|--- >   fromString = mkName |]------ This will declare an instance only if one doesn't already exist.--- Now anyone importing your module is guaranteed to get an instance--- one way or the other.------ This module is still highly experimental. The example given above--- does work, but anything involving type variables or complex method--- bodies may be less fortunate. The names of the methods are mangled--- a bit, so using recursion to define them may not work. Define the--- method outside the code and then use a simple binding as above.------ If you use this code (successfully or unsuccessfully!), go fetch--- the maintainer address from the cabal file and let me know!-module NotCPP.OrphanEvasion (-  MultiParams,-  safeInstance,-  safeInstance',- ) where--import Control.Applicative--import Language.Haskell.TH-import Language.Haskell.TH.Syntax--import NotCPP.ScopeLookup---- | An empty type used only to signify a multiparameter typeclass in--- 'safeInstance'.-data MultiParams a---- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@.--- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return--- @(Cxt, [t1, t2, t3])@.------ This is used in 'safeInstance' to allow types to be specified more--- easily with TH typequotes.-fromTuple :: Type -> (Cxt, [Type])-fromTuple ty = unTuple <$> case ty of-  ForallT _ cxt ty' -> (cxt, ty')-  _ -> ([], ty)- where-  unTuple :: Type -> [Type]-  unTuple (AppT (ConT n) ta)-    | n == ''MultiParams = case unrollAppT ta of-      (TupleT{}, ts) -> ts-      _ -> [ty]-  unTuple t = [t]---- | A helper function to unwind type application. --- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@-unrollAppT :: Type -> (Type, [Type])-unrollAppT = go []- where-  go acc (AppT tc ta) = go (ta : acc) tc-  go acc ty = (ty, reverse acc)---- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@-rollAppT :: Type -> [Type] -> Type-rollAppT = foldl AppT---- | @'safeInstance'' className cxt types methods@ produces an instance--- of the given class if and only if one doesn't already exist.------ See 'safeInstance' for a simple way to construct the 'Cxt' and--- @['Type']@ parameters.-safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec]-safeInstance' cl cxt tys inst = do-  b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys-  if b-    then return []-    else do-      ds <- map fixInst <$> inst-      return [InstanceD cxt (rollAppT (ConT cl) tys) ds]- where-  fixInst (FunD n cls) = FunD (fixName n) cls-  fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh-  fixInst d = d-  fixName (Name n _) = Name n NameS---- | 'safeInstance' is a more convenient version of 'safeInstance''--- that takes the context and type from a @'Q' 'Type'@ with the intention--- that it be supplied using a type-quote.------ To define an instance @Show a => Show (Wrapper a)@, you'd use:------ > safeInstance ''Show [t| Show a => Wrapper a |]--- >   [d| show _ = "stuff" |]------ To define an instance of a multi-param type class, use the--- 'MultiParams' type constructor with a tuple:------ > safeInstance ''MonadState--- >   [t| MonadState s m => MultiParams (s, MaybeT m) |]--- >   [d| put = ... |]-safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec]-safeInstance n qty inst = do-  (cxt, tys) <- fromTuple <$> qty-  safeInstance' n cxt tys inst
− NotCPP/ScopeLookup.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- |--- This module exports 'scopeLookup', which will find a variable or--- value constructor for you and present it for your use. E.g. at some--- point in the history of the acid-state package, 'openAcidState' was--- renamed 'openLocalState'; for compatibility with both, you could--- use:------ > openState :: IO (AcidState st)--- > openState = case $(scopeLookup "openLocalState") of--- >   Just open -> open defaultState--- >   Nothing -> case $(scopeLookup "openAcidState") of--- >     Just open -> open defaultState--- >     Nothing -> error--- >       "openState: runtime name resolution has its drawbacks :/"------ Or, for this specific case, you can use 'scopeLookups':------ > openState :: IO (AcidState st)--- > openState = open defaultState--- >  where--- >   open = $(scopeLookups ["openLocalState","openAcidState"])------ Now if neither of the names are found then TH will throw a--- compile-time error.-module NotCPP.ScopeLookup (-  scopeLookup,-  scopeLookups,-  scopeLookup',-  liftMaybe,-  recoverMaybe,-  maybeReify,-  infoToExp,- ) where--import Control.Applicative ((<$>))--import Language.Haskell.TH (Q, Exp, recover, reify)--import NotCPP.LookupValueName-import NotCPP.Utils---- | Produces a spliceable expression which expands to @'Just' val@ if--- the given string refers to a value @val@ in scope, or 'Nothing'--- otherwise.------ @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@-scopeLookup :: String -> Q Exp-scopeLookup = fmap liftMaybe . scopeLookup'---- | Finds the first string in the list that names a value, and produces--- a spliceable expression of that value, or reports a compile error if--- it fails.-scopeLookups :: [String] -> Q Exp-scopeLookups xs = foldr-  (\s r -> maybe r return =<< scopeLookup' s)-  (fail ("scopeLookups: none found: " ++ show xs))-  xs---- | Produces @'Just' x@ if the given string names the value @x@,--- or 'Nothing' otherwise.-scopeLookup' :: String -> Q (Maybe Exp)-scopeLookup' s = recover (return Nothing) $ do-  Just n <- lookupValueName s-  infoToExp <$> reify n
− NotCPP/Utils.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module NotCPP.Utils where--import Control.Applicative ((<$>))-import Language.Haskell.TH---- | Turns 'Nothing' into an expression representing 'Nothing', and--- @'Just' x@ into an expression representing 'Just' applied to the--- expression in @x@.-liftMaybe :: Maybe Exp -> Exp-liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just))---- | A useful variant of 'reify' that returns 'Nothing' instead of--- halting compilation when an error occurs (e.g. because the given--- name was not in scope).-maybeReify :: Name -> Q (Maybe Info)-maybeReify = recoverMaybe . reify---- | Turns a possibly-failing 'Q' action into one returning a 'Maybe'--- value.-recoverMaybe :: Q a -> Q (Maybe a)-recoverMaybe q = recover (return Nothing) (Just <$> q)---- | Returns @'Just' ('VarE' n)@ if the info relates to a value called--- @n@, or 'Nothing' if it relates to a different sort of thing.-infoToExp :: Info -> Maybe Exp-infoToExp (VarI n _ _ _) = Just (VarE n)-infoToExp (DataConI n _ _ _) = Just (ConE n)-infoToExp _ = Nothing
+ README.md view
@@ -0,0 +1,99 @@+# ghc-mod: Happy Haskell Hacking+[![build status](https://gitlab.com/dxld/ghc-mod/badges/master/build.svg)](https://gitlab.com/dxld/ghc-mod/commits/master)++ghc-mod provides editors/IDEs with support for Haskell compiler features, it+supports both Cabal and Stack based projects and integrations exist for Emacs,+Vim, Atom, IntelliJ and VSCode.++- for [all Haskell developers (Using ghc-mod in your development environment)](#using-ghc-mod-in-your-development-environment)+- for [people developing Haskell IDEs (Using ghc-mod as an IDE backend program)](#using-ghc-mod-as-an-ide-backend-program)+- for [developing Haskell tooling (Using ghc-mod as a library)](#using-ghc-mod-as-a-library)++## Overview++### Using ghc-mod in your Development Environment++To use `ghc-mod` in your development environment of choice you need two things:++  - The `ghc-mod` program included in the package of the same name, see [Installing](https://github.com/DanielG/ghc-mod/wiki/Installing)+  - A ghc-mod frontend to integrate it into your development environment, see [Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend)++### Using ghc-mod as an IDE Backend Program++We provide two modes of operation for frontends: interactive and single shot+mode. The former is accessed by calling `$ ghc-mod legacy-interactive` this will+sit and wait for you to type a command and exit when an empty line is+entered. Interactive mode is pretty much always faster than single shot mode+since it gives ghc-mod the ability to cache the compiler session between+commands on the other hand it needs more memory because it keeps these things+cached. ++Single shot mode is pretty much only there for (backwards) compatibility with+Vim since it only recently got the ability to talk to background processes+without installing some external plugin. You can use single-shot mode by simply+calling the sub-comamnds of the `ghc-mod` program. Since re-compiling large+projects can be really, really slow you really shouldn't use this and use+interactive mode instead.++As a rule of thumb all commands available in single shot mode are available in+interactive mode, a list of the former can be obtained by running +`$ ghc-mod --help`.++If you're developing a new ghc-mod fronted we'd love to hear from you! Please+open an issue or e-mail the maintainer. Also we invite you to add installation+and configuration instructions to+[Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend).++### Using ghc-mod as a Library++Internally ghc-mod uses the Glasgow Haskell Compilers's API to implement most of+it's functionality.++In order to provide a hassle free experience to users ghc-mod tries hard to+automatically, and correctly, detect and if needed tweak the environment GHC+needs. It also handles some of the more cumbersome parts of getting a working+compiler session up and running.++This functionality can be very useful to all kinds of Haskell development tools+therefore want to expose all the useful abstractions ghc-mod provides.++Right now the ghc-mod API is pretty messy; a result of major internal rewrites+and reorganization coupled with too little time for cleanups over the course of+almost 100 releases! We would like to make a cut during v6.0 or so and+completely re-do the API but we need more input from downstream tool writers to+do that properly, see [Library API Redesign](Library-API-Redesign.md).++For example [The Haskell Refactorer (HaRe)](https://github.com/alanz/HaRe) uses+the build environment abstraction ghc-mod provides so it can concentrate on it's+core functionality instead of worrying about build environments and compiler+session setup.++Recently the+[`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine) project+has sprung up and if you're planning to write any kind of tool that needs editor+integration eventually you should definetly look into that. `haskell-ide-engine`+uses `ghc-mod` at it's core so you'll want to be familliar with it either way.++API "documentation" is here:+[Hackage docs](https://hackage.haskell.org/package/ghc-mod#modules).++## Reporting Bugs++Please report bugs on the GitHub issue tracker for ghc-mod:+https://github.com/DanielG/ghc-mod/issues++Including general environment information like the operating system+(distribution, version) you're using and the output of `$ ghc-mod debug` run in+your project directory is probably a good idea.++## IRC++If you have any problems, suggestions, comments swing by+[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on+Freenode. If you're reporting a bug please also create an issue+[here (GitHub issue tracker)](https://github.com/DanielG/ghc-mod/issues) so we+have a way to contact you if you don't have time to stay.++Do hang around for a while if no one answers and repeat your question if you+still haven't gotten any answer after a day or so (the maintainer was probably+asleep). You're most likely to get an answer during the day in GMT+1.
Setup.hs view
@@ -1,13 +1,19 @@ #!/usr/bin/env runhaskell-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} import Distribution.Simple+import Distribution.Simple.Utils import Distribution.Simple.Setup import Distribution.Simple.Install+import Distribution.Simple.Program import Distribution.Simple.Register-import Distribution.Simple.InstallDirs as ID+import Distribution.Simple.BuildPaths+import qualified Distribution.Simple.InstallDirs as ID import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription +import qualified Data.Map as M+import Data.Map (Map)+ import Control.Arrow import Control.Applicative import Control.Monad@@ -18,46 +24,23 @@ import System.Process import System.Exit import System.FilePath-import Text.ParserCombinators.ReadP--import SetupCompat+import System.Directory (renameFile)  main :: IO () main = defaultMainWithHooks $ simpleUserHooks {-   confHook = \(gpd, hbi) cf ->-              xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf-- , instHook = inst- , copyHook = copy---- , postConf = sanityCheckCabalVersions+   instHook = inst,+   copyHook = copy,+   buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags,+   hookedPrograms = [ simpleProgram "shelltest" ]  } -xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo-xBuildDependsLike lbi =-  let-      cc = componentsConfigs lbi-      pd = localPkgDescr lbi-      deps = dependsMap lbi-  in setComponentsConfigs lbi-        [ (cn, updateClbi deps comp clbi, cdeps)-        | (cn, clbi, cdeps) <- cc-        , let comp = getComponent pd cn-        ]-- where-   updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi--   dependsMap ::-    LocalBuildInfo -> [(ComponentName, Deps)]-   dependsMap lbi =-       second getDeps <$> allComponentsInBuildOrder lbi--   otherDeps :: [(ComponentName, Deps)] -> Component -> Deps-   otherDeps deps comp = fromMaybe noDeps $-       flip lookup deps =<< read <$> lookup "x-build-depends-like" fields-      where-        fields = customFieldsBI (componentBuildInfo comp)+patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo+patchLibexecdir lbi = let+    idirtpl     = installDirTemplates lbi+    libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) </> "$abi/$pkgid"+    lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } }+  in+    lbi'  -- mostly copypasta from 'defaultInstallHook' inst ::@@ -68,7 +51,7 @@                       copyDest       = toFlag NoCopyDest,                       copyVerbosity  = installVerbosity ifl                   }-  xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags)+  xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags)   let registerFlags = defaultRegisterFlags {                           regDistPref  = installDistPref ifl,                           regInPlace   = installInPlace ifl,@@ -79,124 +62,46 @@  copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () copy pd lbi _uh cf =-    xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf)+    xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf)  xInstallTarget :: PackageDescription                -> LocalBuildInfo+               -> CopyFlags                -> (PackageDescription -> LocalBuildInfo -> IO ())                -> IO ()-xInstallTarget pd lbi fn = do-  let (extended, regular) = partition (isJust . installTarget) (executables pd)+xInstallTarget pd lbi cf fn = do+  let (extended, regular) = partition isInternal (executables pd)    let pd_regular = pd { executables = regular }    _ <- flip mapM extended $ \exe -> do-    putStrLn $ "extended "  ++ show (exeName exe)+    let pd_extended = onlyExePackageDesc [exe] pd+    fn pd_extended lbi -    let-        idirtpl          = installDirTemplates lbi-        env              = installDirsTemplateEnv idirtpl-        libexecdir'      = fromPathTemplate (libexecdir idirtpl)+    let lbi' = patchLibexecdir lbi+        copydest  = fromFlag (copyDest cf)+        verbosity = fromFlag (copyVerbosity cf)+        InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest+        progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi)+        progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi)+        fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix -        pd_extended      = onlyExePackageDesc [exe] pd-        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'+        fixedExeFileName = bindir </> fixedExeBaseName <.> exeExtension+        newExeFileName   = libexecdir </> fixedExeBaseName <.> exeExtension -    let lbi' = lbi {-                 installDirTemplates =-                     (installDirTemplates lbi) {-                   bindir = install_target''-                 }-               }-    fn pd_extended lbi'+    when (exeName exe == "ghc-mod-real") $ do+        createDirectoryIfMissingVerbose verbosity True libexecdir+        renameFile fixedExeFileName newExeFileName    fn pd_regular lbi   where-   installTarget :: Executable -> Maybe PathTemplate-   installTarget exe =-    toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe)--   substLibExec libexecdir "$libexecdir" = libexecdir-   substLibExec _ comp = comp--   substLibExec' dir =-       withPT $-           withSP $ map (substLibExec dir . dropTrailingPathSeparator)---   withPT f pt = toPathTemplate $ f (fromPathTemplate pt)-   withSP f p  = joinPath $ f (splitPath p)+   isInternal :: Executable -> Bool+   isInternal exe =+    fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe)  onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription onlyExePackageDesc exes pd = emptyPackageDescription {                      package = package pd                    , executables = exes                    }--parseVer str =-    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----   let---         ghcVer = compilerVersion (compiler lbi)---         -- ghc >= 7.10?---         minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10")----   when minGhc710 $ do---     let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper")----     when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $---          failCabalVersionDifferent cabalVer cabalHelperCabalVer----   -- carry on as usual---   (postConf simpleUserHooks) args cf desc lbi----  where---    earlierVersionThan ver ver' =---        ver `withinRange` earlierVersion ver'---    sameMajorVersionAs ver ver' =---        ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') [])----    compCabalVer comp = let---        clbi = getComponentLocalBuildInfo lbi comp----        [cabalVer] =---            [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi---            , pkg == PackageName "Cabal" ]---      in cabalVer---- getCabalExecVer = do---   ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] ""---   return (parseVer cabalInstallVer, parseVer cabalVer)---- failCabalVersionDifferent cabalVer libCabalVer =---   putStrLn rerr  >> exitFailure---  where---    replace :: String -> String -> String -> String---    replace _ _ [] = []---    replace n r h@(h':hs)---        | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h)---        | otherwise = h':replace n r hs----    rerr = replace "X.XX.X.X" (showVersion libCabalVer) $---           replace "Y.YY.Y.Y" (showVersion cabalVer) err---    err = "\--- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\--- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\--- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\--- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\--- \Cabal version as your `cabal' executable or recompile cabal-install using\n\--- \this version of the Cabal library.\n\--- \\n\--- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n"
− SetupCompat.hs 
@@ -1,198 +0,0 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-}-module SetupCompat where--import Control.Arrow-import Control.Monad.Trans.State-import Data.List-import Data.Maybe-import Data.Functor-import Data.Function-import Distribution.Simple.LocalBuildInfo-import Distribution.PackageDescription--import Distribution.Simple-import Distribution.Simple.Setup-import Distribution.Simple.Install--import qualified Data.Map as M-import Data.Map (Map)---import NotCPP.Declarations-import Language.Haskell.TH---- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )--$(ifD [d|-- showComponentName :: ComponentName -> String- showComponentName CLibName          = "library"- showComponentName (CExeName   name) = "executable '" ++ name ++ "'"- showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"- showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"-- |])--$(ifelsedefD "componentsConfigs" [d|-- setComponentsConfigs-    :: LocalBuildInfo-    -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]-    -> LocalBuildInfo- setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs"))-- |] [d|-- setComponentsConfigs-    :: LocalBuildInfo-    -> [(ComponentName, ComponentLocalBuildInfo, a)]-    -> LocalBuildInfo- setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs-  where-   gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs--   fst3 (x,_,_) = x--   sameKind CLibName CLibName = True-   sameKind CLibName _ = False-   sameKind (CExeName _) (CExeName _) = True-   sameKind (CExeName _) _ = False-   sameKind (CTestName _) (CTestName _) = True-   sameKind (CTestName _) _ = False-   sameKind (CBenchName _) (CBenchName _) = True-   sameKind (CBenchName _) _ = False--   setClbis [(CLibName, clbi, _)] =-       get >>= \lbi ->-           put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi"))))--   setClbis cs@((CExeName _, _, _):_) =-       let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in-       get >>= \lbi ->-           put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg"))--   setClbis cs@((CTestName _, _, _):_) =-       let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in-       get >>= \lbi ->-           put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg"))--   setClbis cs@((CBenchName _, _, _):_) =-       let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in-       get >>= \lbi ->-           put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg"))-- |])---$(ifD [d|-- componentsConfigs ::-    LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]- componentsConfigs LocalBuildInfo {..} =-    (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig"))-    ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs"))-    ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs"))-    ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs"))-- getComponent :: PackageDescription -> ComponentName -> Component- getComponent pkg cname =-    case lookupComponent pkg cname of-      Just cpnt -> cpnt-      Nothing   -> missingComponent-  where-    missingComponent =-      error $ "internal error: the package description contains no "-           ++ "component corresponding to " ++ show cname-- lookupComponent :: PackageDescription -> ComponentName -> Maybe Component- lookupComponent pkg CLibName =-    fmap CLib $ library pkg- lookupComponent pkg (CExeName name) =-    fmap CExe $ find ((name ==) . exeName) (executables pkg)- lookupComponent pkg (CTestName name) =-    fmap CTest $ find ((name ==) . testName) (testSuites pkg)- lookupComponent pkg (CBenchName name) =-    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)---- We're lying here can't be bothered to order these- allComponentsInBuildOrder :: LocalBuildInfo-                          -> [(ComponentName, ComponentLocalBuildInfo)]- allComponentsInBuildOrder lbi =-      [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]-- getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo- getComponentLocalBuildInfo lbi cname =-    case [ clbi-         | (cname', clbi, _) <- componentsConfigs lbi-         , cname == cname' ] of-      [clbi] -> clbi-      _      -> missingComponent-  where-    missingComponent =-      error $ "internal error: there is no configuration data "-           ++ "for component " ++ show cname-- componentBuildInfo :: Component -> BuildInfo- componentBuildInfo =-   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo-- |])---$(ifelsedefD "componentPackageRenaming" [d|- -- M.Map PackageName- newtype Deps = Deps  { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) }--- $(return $ TySynD $(mkName "Deps") [] [t| |] )-- noDeps = Deps ([], M.empty)-- getDeps :: ComponentLocalBuildInfo -> Deps- getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps-- setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo- setUnionDeps (Deps (deps, rns)) clbi = let-         clbi' = setComponentPackageRenaming clbi rns-         cpdeps = componentPackageDeps clbi-       in-         clbi' {-           componentPackageDeps = cpdeps `union` deps-         }-- setComponentPackageRenaming clbi cprn =-     -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |]-     $(recUpdE'-       (nE "clbi")-       (mkName "componentPackageRenaming")-       (InfixE-        (Just-         (AppE-          (VarE-           (mkName "componentPackageRenaming"))-          (VarE (mkName "clbi"))-         ))-        (VarE (mkName "M.union"))-        (Just (VarE (mkName "cprn")))-       )-      )-- |] [d|-- newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] }-- noDeps = Deps []-- getDeps :: ComponentLocalBuildInfo -> Deps- getDeps lbi = Deps $ componentPackageDeps lbi-- setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo- setUnionDeps (Deps deps) clbi = let-         cpdeps = componentPackageDeps clbi-       in-         clbi {-           componentPackageDeps = cpdeps `union` deps-         }----- setComponentPackageRenaming clbi _cprn = clbi-- |])
− System/Directory/ModTime.hs 
@@ -1,63 +0,0 @@--- 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
− Utils.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}-module Utils where--import Control.Applicative-import Data.Traversable-import System.Directory-import System.Directory.ModTime--import Prelude--data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }-                 deriving (Eq)--instance Ord TimedFile where-    compare (TimedFile _ a) (TimedFile _ b) = compare a b--timeFile :: FilePath -> IO TimedFile-timeFile f = TimedFile <$> pure f <*> getModTime f--mightExist :: FilePath -> IO (Maybe FilePath)-mightExist f = do-  exists <- doesFileExist f-  return $ if exists then (Just f) else (Nothing)--timeMaybe :: FilePath -> IO (Maybe TimedFile)-timeMaybe f = traverse timeFile =<< mightExist f
+ bench/Bench.hs view
@@ -0,0 +1,30 @@+import Criterion.Main+import GhcMod.Target+import GhcMod.Monad+import GhcMod.Types+import Dir+import System.IO.Temp+import System.Process hiding (env)+import Control.Monad++main = defaultMain [+    env setup $ \dir -> bgroup "simple-cabal" [+        bench "nop" $ whnfIO (simpleCabalNop dir 1)+      , bench "nop10" $ whnfIO (simpleCabalNop dir 10)+      ]+  ]++setup = do+  tdir <- createTempDirectory "/tmp" "ghc-mod-bench"+  system $ "cp -rv \"bench/data/simple-cabal/\" \""++ tdir ++"\""++  simpleCabalNop tdir 1 -- warmup dist/++  return tdir++simpleCabalNop :: FilePath -> Int -> IO ()+simpleCabalNop dir n = withDirectory_ (dir </> "simple-cabal") $ do+  _ <- runGhcModT defaultOptions $+       forM_ [1..n] $ \_ -> do+           runGmlT [Left "Main.hs"] (return ())+  return ()
+ bench/data/simple-cabal/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ bench/data/simple-cabal/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/data/simple-cabal/simple-cabal.cabal view
@@ -0,0 +1,13 @@+name:                simple-cabal+version:             0.1.0.0+license:             BSD3+license-file:        LICENSE+author:              Daniel Gröber+maintainer:          dxld@darkboxed.org+build-type:          Simple+cabal-version:       >=1.10++executable simple-cabal+  main-is:             Main.hs+  build-depends:       base+  default-language:    Haskell2010
+ core/Data/Binary/Generic.hs view
@@ -0,0 +1,133 @@+{-# 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+         , 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) => 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
+ core/GhcMod/CabalHelper.hs view
@@ -0,0 +1,309 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.CabalHelper+  ( getComponents+  , getGhcMergedPkgOptions+  , getCabalPackageDbStack+  , prepareCabalHelper+  , withAutogen+  , withCabal+  ) where++import Control.Applicative+import Control.Monad+import Control.Category ((.))+import Data.Maybe+import Data.Monoid+import Data.Version+import Data.Binary (Binary)+import Data.Traversable+import Distribution.Helper hiding (Programs(..))+import qualified Distribution.Helper as CH+import qualified GhcMod.Types as T+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Utils+import GhcMod.PathsAndFiles+import GhcMod.Logging+import GhcMod.Output+import GhcMod.CustomPackageDb+import GhcMod.Stack+import System.FilePath+import System.Process+import System.Exit+import Prelude hiding ((.))++import Paths_ghc_mod as GhcMod++-- | Only package related GHC options, sufficient for things that don't need to+-- access home modules+getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)+  => m [GHCOption]+getGhcMergedPkgOptions = chCached $ \distdir -> Cached {+  cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),+  cacheFile = mergedPkgOptsCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    opts <- runCHQuery ghcMergedPkgOptions+    return ([setupConfigPath distdir], opts)+ }++getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]+getCabalPackageDbStack = chCached $ \distdir -> Cached {+  cacheLens = Just (lGmcPackageDbStack . lGmCaches),+  cacheFile = pkgDbStackCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    crdl <- cradle+    dbs <- map chPkgToGhcPkg <$>+             runCHQuery packageDbStack+    return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)+ }++chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb+chPkgToGhcPkg ChPkgGlobal = GlobalDb+chPkgToGhcPkg ChPkgUser = UserDb+chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f++-- | Primary interface to cabal-helper and intended single entrypoint to+-- constructing 'GmComponent's+--+-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by+-- 'resolveGmComponents'.+getComponents :: (Applicative m, IOish m, Gm m)+              => m [GmComponent 'GMCRaw ChEntrypoint]+getComponents = chCached $ \distdir -> Cached {+    cacheLens = Just (lGmcComponents . lGmCaches),+    cacheFile = cabalHelperCacheFile distdir,+    cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do+      runCHQuery $ do+        q <- join7+               <$> ghcOptions+               <*> ghcPkgOptions+               <*> ghcSrcOptions+               <*> ghcLangOptions+               <*> entrypoints+               <*> entrypoints+               <*> sourceDirs+        let cs = flip map q $ curry8 (GmComponent mempty)+        return ([setupConfigPath distdir], cs)+  }+ where+   curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h++   join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f+   join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]+   join' lb lc = [ (a, (b, c))+                 | (a, b)  <- lb+                 , (a', c) <- lc+                 , a == a'+                 ]++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+  return (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+  when (isCabalHelperProject $ cradleProject crdl) $+       withCabal $ prepare' =<< getQueryEnv++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+    let projdir = cradleRootDir crdl+        distdir = projdir </> cradleDistDir crdl++    (pkgName', _) <- runCHQuery packageId++    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalMacroHeader   <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)+    mCabalPathsModule   <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName')++    when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do+      gmLog GmDebug "" $ strDoc $ "autogen files out of sync"+      writeAutogen++    action++ where+   writeAutogen = do+     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"+     writeAutogenFiles' =<< getQueryEnv+++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"++    when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $+      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"++    when ( isSetupConfigOutOfDate mCabalFile mCabalConfig+        || pkgDbStackOutOfSync+        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do+          proj <- cradleProject <$> cradle+          opts <- options+          case proj of+            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 (optStackBuildDeps opts) crdl (optPrograms opts)+            _ ->+                error $ "withCabal: unsupported project type: " ++ show proj++    action++ where+   cabalReconfigure progs crdl flgs = do+     readProc <- gmReadProcess+     withDirectory_ (cradleRootDir crdl) $ do+        cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack+        let progOpts =+                [ "--with-ghc=" ++ T.ghcProgram progs ]+                -- Only pass ghc-pkg if it was actually set otherwise we+                -- might break cabal's guessing logic+                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)+                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]+                     else []+                ++ map pkgDbArg cusPkgStack+                ++ flagOpt++            toFlag (f, True) = f+            toFlag (f, False) = '-':f+            flagOpt = ["--flags", unwords $ map toFlag flgs]++        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""+   stackReconfigure deps crdl progs = do+     withDirectory_ (cradleRootDir crdl) $ do+       supported <- haveStackSupport+       if supported+          then do+            when deps $+              spawn [T.stackProgram progs, "build", "--only-dependencies", "."]+            spawn [T.stackProgram progs, "build", "--only-configure", "."]+          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)"++   spawn [] = return ()+   spawn (exe:args) = do+     readProc <- gmReadProcess+     liftIO $ void $ readProc exe args ""++   haveStackSupport = do+     (rv, _, _) <-+         liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""+     case rv of+       ExitSuccess -> return True+       ExitFailure _ -> return False++++pkgDbArg :: GhcPkgDb -> String+pkgDbArg GlobalDb      = "--package-db=global"+pkgDbArg UserDb        = "--package-db=user"+pkgDbArg (PackageDb p) = "--package-db=" ++ p++-- * Neither file exists -> should return False:+--   @Nothing < Nothing = False@+--   (since we don't need to @cabal configure@ when no cabal file exists.)+--+-- * Cabal file doesn't exist (impossible since cabal-helper is only used with+-- cabal projects) -> should return False+--   @Just cc < Nothing = False@+--+-- * dist/setup-config doesn't exist yet -> should return True:+--   @Nothing < Just cf = True@+--+-- * Both files exist+--   @Just cc < Just cf = cc < cf = cc `olderThan` cf@+isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool+isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do+  worldCabalConfig < worldCabalFile++helperProgs :: Programs -> CH.Programs+helperProgs progs = CH.Programs {+    cabalProgram  = T.cabalProgram progs,+    ghcProgram    = T.ghcProgram progs,+    ghcPkgProgram = T.ghcPkgProgram progs+  }++chCached :: (Applicative m, IOish m, Gm m, Binary a)+  => (FilePath -> Cached m GhcModState ChCacheData a) -> m a+chCached c = do+  projdir <- cradleRootDir <$> cradle+  distdir <- (projdir </>) . cradleDistDir <$> cradle+  d <- cacheInputData projdir+  withCabal $ cached projdir (c distdir) d+ where+   -- 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+               crdl <- cradle+               progs' <- patchStackPrograms crdl (optPrograms opts)+               return $ ( helperProgs progs'+                        , projdir+                        , (showVersion gmVer, chVer)+                        )++   gmVer = GhcMod.version+   chVer = VERSION_cabal_helper
+ core/GhcMod/Caching.hs view
@@ -0,0 +1,141 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Caching (+    module GhcMod.Caching+  , module GhcMod.Caching.Types+  ) where++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.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 GhcMod.Monad.Types+import GhcMod.Caching.Types+import GhcMod.Logging++-- | Cache a MonadIO action with proper invalidation.+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+    case mcc of+      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"++   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 (t, 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 (ModTime, [FilePath], d, a))+   readCache = runMaybeT $ do+       case cacheLens cd of+         Just label -> do+             c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile+             setLabel label $ Just c+             return c+         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 ->+            either (const Nothing) Just+                `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)+       _ -> return Nothing++   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+    return $ catMaybes ins++invalidatingInputFiles :: TimedCacheFiles -> [FilePath]+invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =+    map tfPath $+        -- get input files older than tcfile+        filter ((TimedFile "" tcreated)<) tcfs
+ core/GhcMod/Caching/Types.hs view
@@ -0,0 +1,67 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Caching.Types where++import Utils+import Data.Label+import System.Directory.ModTime+import Distribution.Helper++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 {+  cacheFile       :: FilePath,+  cacheLens       :: Maybe (CacheLens s d a),+  cachedAction    :: TimedCacheFiles+                  -> d+                  -> Maybe a+                  -> m ([FilePath], a)++  -- ^ @cachedAction tcf data ma@+  --+  -- * @tcf@: Input file timestamps. Not technically necessary, just an+  -- optimizazion when knowing which input files changed can make updating the+  -- cache faster+  --+  -- * @data@: Arbitrary static input data to cache action. Can be used to+  -- invalidate the cache using something other than file timestamps+  -- i.e. environment tool version numbers+  --+  -- * @ma@: Cached data if it existed+  --+  -- Returns:+  --+  -- * @fst@: Input files used in generating the cache+  --+  -- * @snd@: Cache data, will be stored alongside the static input data in the+  --   'cacheFile'+  --+  -- The cached action, will only run if one of the following is true:+  --+  -- * 'cacheFile' doesn\'t exist yet+  -- * 'cacheFile' exists and 'inputData' changed+  -- * any files returned by the cached action changed+ }++data TimedCacheFiles = TimedCacheFiles {+  tcCreated :: ModTime,+  -- ^ 'cacheFile' timestamp+  tcFiles     :: [TimedFile]+  -- ^ Timestamped files returned by the cached action+ } deriving (Eq, Ord)++type ChCacheData = (Programs, FilePath, (String, String))
+ core/GhcMod/Convert.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}++module GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where++import GhcMod.Monad.Types+import GhcMod.Types++import Control.Applicative+import Prelude++type Builder = String -> String++-- |+--+-- >>> replace '"' "\\\"" "foo\"bar" ""+-- "foo\\\"bar"+replace :: Char -> String -> String -> Builder+replace _ _  [] = id+replace c cs (x:xs)+  | x == c    = (cs ++) . replace c cs xs+  | otherwise = (x :) . replace c cs xs++inter :: Char -> [Builder] -> Builder+inter _ [] = id+inter c bs = foldr1 (\x y -> x . (c:) . y) bs++convert' :: (ToString a, IOish m, GmEnv m) => a -> m String+convert' x = flip convert x . optOutput <$> options++convert :: ToString a => OutputOpts -> a -> String+convert opt@OutputOpts { ooptStyle = LispStyle  } x = toLisp opt x "\n"+convert opt@OutputOpts { ooptStyle = PlainStyle } x+  | str == "\n" = ""+  | otherwise   = str+  where+    str = toPlain opt x "\n"++class ToString a where+  toLisp  :: OutputOpts -> a -> Builder+  toPlain :: OutputOpts -> a -> Builder++lineSep :: OutputOpts -> String+lineSep oopts = interpret lsep+  where+    interpret s = read $ "\"" ++ s ++ "\""+    LineSeparator lsep = ooptLineSeparator oopts++-- |+--+-- >>> toLisp (optOutput defaultOptions) "fo\"o" ""+-- "\"fo\\\"o\""+-- >>> toPlain (optOutput defaultOptions) "foo" ""+-- "foo"+instance ToString String where+  toLisp  oopts = quote oopts+  toPlain oopts = replace '\n' (lineSep oopts)++-- |+--+-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] ""+-- "(\"foo\" \"bar\" \"ba\\\"z\")"+-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] ""+-- "foo\nbar\nbaz"+instance ToString [String] where+  toLisp  oopts = toSexp1 oopts+  toPlain oopts = inter '\n' . map (toPlain oopts)++instance ToString [ModuleString] where+  toLisp  oopts = toLisp oopts . map getModuleString+  toPlain oopts = toPlain oopts . map getModuleString++-- |+--+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]+-- >>> toLisp (optOutput defaultOptions) inp ""+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"+-- >>> toPlain (optOutput defaultOptions) inp ""+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""+instance ToString [((Int,Int,Int,Int),String)] where+  toLisp  oopts = toSexp2 . map toS+    where+      toS x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts = inter '\n' . map (tupToString oopts)++instance ToString ((Int,Int,Int,Int),String) where+  toLisp  oopts x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts x = tupToString oopts x++instance ToString ((Int,Int,Int,Int),[String]) where+  toLisp  oopts (x,s) = ('(' :) .  fourIntsToString x .+                        (' ' :) . toLisp oopts s . (')' :)+  toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s++instance ToString (String, (Int,Int,Int,Int),[String]) where+  toLisp  oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]+  toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]++toSexp1 :: OutputOpts -> [String] -> Builder+toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)++toSexp2 :: [Builder] -> Builder+toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)++fourIntsToString :: (Int,Int,Int,Int) -> Builder+fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)+                           . (show b ++) . (' ' :)+                           . (show c ++) . (' ' :)+                           . (show d ++)++tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder+tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)+                                . (show b ++) . (' ' :)+                                . (show c ++) . (' ' :)+                                . (show d ++) . (' ' :)+                                . quote oopts s -- fixme: quote is not necessary++quote :: OutputOpts -> String -> Builder+quote oopts str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+  where+    lsep = lineSep oopts+    quote' [] = []+    quote' (x:xs)+      | x == '\n' = lsep   ++ quote' xs+      | x == '\\' = "\\\\" ++ quote' xs+      | x == '"'  = "\\\"" ++ quote' xs+      | otherwise = x       : quote' xs++----------------------------------------------------------------++-- Empty result to be returned when no info can be gathered+emptyResult :: Monad m => OutputOpts -> m String+emptyResult oopts = return $ convert oopts ([] :: [String])++-- Return an emptyResult when Nothing+whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String+whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from++-- Return an emptyResult when Nothing, inside a monad+whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String+whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from
+ core/GhcMod/Cradle.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}+module GhcMod.Cradle+  ( findCradle+  , findCradle'+  , findCradleNoLog+  , findSpecCradle+  , cleanupCradle++  -- * for @spec@+  , plainCradle+  ) where++import GhcMod.PathsAndFiles+import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Utils+import GhcMod.Stack+import GhcMod.Logging+import GhcMod.Error++import Safe+import Control.Applicative+import Control.Monad.Trans.Maybe+import Data.Maybe+import System.Directory+import System.FilePath+import System.Environment+import Prelude+import Control.Monad.Trans.Journal (runJournalT)++----------------------------------------------------------------++-- | Finding 'Cradle'.+--   Find a cabal file by tracing ancestor directories.+--   Find a sandbox according to a cabal sandbox config+--   in a cabal directory.+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory++findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle+findCradleNoLog progs =+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))++findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findCradle' Programs { stackProgram, cabalProgram } dir = run $+    msum [ stackCradle stackProgram dir+         , cabalCradle cabalProgram dir+         , sandboxCradle dir+         , plainCradle dir+         ]+ where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)++findSpecCradle ::+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findSpecCradle Programs { stackProgram, cabalProgram } dir = do+    let cfs = [ stackCradleSpec stackProgram+              , cabalCradle cabalProgram+              , sandboxCradle+              ]+    cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs+    gcs <- filterM isNotGmCradle cs+    fillTempDir =<< case gcs of+                      [] -> fromJust <$> runMaybeT (plainCradle dir)+                      c:_ -> return c+ where+   isNotGmCradle crdl =+     liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")++cleanupCradle :: Cradle -> IO ()+cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl++fillTempDir :: IOish m => Cradle -> m Cradle+fillTempDir crdl = do+  tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)+  return crdl { cradleTempDir = tmpDir }++cabalCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+cabalCradle cabalProg wdir = do+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir+    let cabalDir = takeDirectory cabalFile++    gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir++    -- If cabal doesn't exist the user probably wants to use something else+    whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do+      gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"+      mzero++    gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir+    return Cradle {+        cradleProject    = CabalProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = cabalDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Just cabalFile+      , cradleDistDir    = "dist"+      }++stackCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradle stackProg wdir = do+#if __GLASGOW_HASKELL__ < 708+    -- GHC < 7.8 is not supported by stack+    mzero+#endif++    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir+    let cabalDir = takeDirectory cabalFile+    _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir++    gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir++    stackExeSet    <- liftIO $ isJust <$> lookupEnv "STACK_EXE"+    stackExeExists <- liftIO $ isJust <$> findExecutable stackProg+    setupCfgExists <- liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist"++    case (stackExeExists, stackExeSet) of+      (False, True) -> do+        gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"+        mzero++      (False, False) -> do+        gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"+        mzero++      (True, True) -> do+        gmLog GmInfo "" $ text "STACK_EXE set, preferring Stack project"++      (True, False) | setupCfgExists -> do+        gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"+        mzero++      (True, False) -> return ()++    senv <- MaybeT $ getStackEnv cabalDir stackProg++    gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir+    return Cradle {+        cradleProject    = StackProject senv+      , cradleCurrentDir = wdir+      , cradleRootDir    = cabalDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Just cabalFile+      , cradleDistDir    = seDistDir senv+      }++stackCradleSpec ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradleSpec stackProg wdir = do+  crdl <- stackCradle stackProg wdir+  case crdl of+    Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do+      b <- isGmDistDir seDistDir+      when b mzero+      return crdl+    _ -> error "stackCradleSpec"+ where+   isGmDistDir dir =+       liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")++sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle+sandboxCradle wdir = do+    sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir+    gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir+    return Cradle {+        cradleProject    = SandboxProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = sbDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Nothing+      , cradleDistDir    = "dist"+      }++plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle+plainCradle wdir = do+    gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"+    return $ Cradle {+        cradleProject    = PlainProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = wdir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Nothing+      , cradleDistDir    = "dist"+      }
+ core/GhcMod/CustomPackageDb.hs view
@@ -0,0 +1,38 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.CustomPackageDb where++import Control.Applicative+import Control.Monad+import Control.Category ((.))+import Data.Maybe+import Data.Traversable+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.PathsAndFiles+import Prelude hiding ((.))++parseCustomPackageDb :: String -> [GhcPkgDb]+parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src+ where+   parsePkgDb "global" = GlobalDb+   parsePkgDb "user" = UserDb+   parsePkgDb s = PackageDb s++getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb])+getCustomPkgDbStack = do+    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle+    return $ parseCustomPackageDb <$> mCusPkgDbFile
+ core/GhcMod/DebugLogger.hs view
@@ -0,0 +1,138 @@+-- ghc-mod: Happy Haskell Hacking+-- 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, RankNTypes #-}+module 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+import Pretty+import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)+import qualified Outputable+import ErrUtils++import GhcMod.Error+import GhcMod.Gap+import Prelude++debugLogAction :: (String -> IO ()) -> GmLogAction+debugLogAction putErr _reason dflags severity srcSpan style' msg+    = case severity of+      SevOutput      -> printSDoc putErr msg style'++#if __GLASGOW_HASKELL__ >= 706+      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style'+#endif++#if __GLASGOW_HASKELL__ >= 708+      SevInteractive -> let+          putStrSDoc = debugLogActionHPutStrDoc dflags putErr+       in+          putStrSDoc msg style'+#endif+      SevInfo        -> printErrs putErr msg style'+      SevFatal       -> printErrs putErr msg style'+      _              -> do putErr "\n"+#if __GLASGOW_HASKELL__ >= 706+                           printErrs putErr (mkLocMessage severity srcSpan msg) style'+#else+                           printErrs putErr (mkLocMessage srcSpan msg) style'+#endif+                           -- careful (#2302): printErrs prints in UTF-8,+                           -- whereas converting to string first and using+                           -- hPutStr would just emit the low 8 bits of+                           -- each unicode char.+    where+#if __GLASGOW_HASKELL__ >= 706+      printSDoc put = debugLogActionHPrintDoc  dflags put+      printErrs put = debugLogActionHPrintDoc  dflags put+#endif+++#if __GLASGOW_HASKELL__ >= 706++debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()+debugLogActionHPrintDoc dflags put d sty+ = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty+      -- Adds a newline++debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()+debugLogActionHPutStrDoc dflags put d sty+  = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc+  where   -- Don't add a newline at the end, so that successive+          -- calls to this log-action can output all on the same line+    doc = runSDoc d (initSDocContext dflags sty)++#else++printSDoc = printErrs++printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()+printErrs put doc sty = do+  gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))++#endif++gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()+-- printDoc adds a newline to the end+gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")++gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()+gmPrintDoc_ mode pprCols putS doc+  = fullRender mode pprCols 1.5 put done doc+  where+    put (Chr c)  next = putS [c] >> next+    put (Str s)  next = putS s >> next+    put (PStr s) next = putS (unpackFS s) >> next+#if __GLASGOW_HASKELL__ >= 708+    put (ZStr s) next = putS (zString s) >> next+#endif+    put (LStr s _l) next = putS (unpackLitString s) >> next++    done = return () -- hPutChar hdl '\n'
+ core/GhcMod/Doc.hs view
@@ -0,0 +1,20 @@+module GhcMod.Doc where++import GHC+import GhcMod.Gap (withStyle, showDocWith)+import Outputable+import Pretty (Mode(..))++showPage :: DynFlags -> PprStyle -> SDoc -> String+showPage dflag style = showDocWith dflag PageMode . withStyle dflag style++showOneLine :: DynFlags -> PprStyle -> SDoc -> String+showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style++getStyle :: GhcMonad m => m PprStyle+getStyle = do+    unqual <- getPrintUnqual+    return $ mkUserStyle unqual AllTheWay++styleUnqualified :: PprStyle+styleUnqualified = mkUserStyle neverQualify AllTheWay
+ core/GhcMod/DynFlags.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell #-}++module GhcMod.DynFlags where++import Control.Applicative+import Control.Monad+import GHC+import qualified GHC as G+import GHC.Paths (libdir)+import qualified GhcMod.Gap as Gap+import GhcMod.Types+import GhcMod.DebugLogger+import GhcMod.DynFlagsTH+import System.IO.Unsafe (unsafePerformIO)+import Prelude++setEmptyLogger :: DynFlags -> DynFlags+setEmptyLogger df =+    Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()++setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags+setDebugLogger put df = do+  Gap.setLogAction df (debugLogAction put)++-- * Fast+-- * Friendly to foreign export+-- * Not friendly to -XTemplateHaskell and -XPatternSynonyms+-- * Uses little memory+setHscNothing :: DynFlags -> DynFlags+setHscNothing df = df {+    ghcMode   = CompManager+  , ghcLink   = NoLink+  , hscTarget = HscNothing+  , optLevel  = 0+  }++-- * Slow+-- * Not friendly to foreign export+-- * Friendly to -XTemplateHaskell and -XPatternSynonyms+-- * Uses lots of memory+setHscInterpreted :: DynFlags -> DynFlags+setHscInterpreted df = df {+    ghcMode   = CompManager+  , ghcLink   = LinkInMemory+  , hscTarget = HscInterpreted+  , optLevel  = 0+  }++-- | Parse command line ghc options and add them to the 'DynFlags' passed+addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags+addCmdOpts cmdOpts df =+    fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)+  where+    fst3 (a,_,_) = a++----------------------------------------------------------------++withDynFlags :: GhcMonad m+             => (DynFlags -> DynFlags)+             -> m a+             -> m a+withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflags <- G.getSessionDynFlags+        void $ G.setSessionDynFlags (setFlags dflags)+        return dflags+    teardown = void . G.setSessionDynFlags++withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a+withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflags <- G.getSessionDynFlags+        void $ G.setSessionDynFlags =<< addCmdOpts flags dflags+        return dflags+    teardown = void . G.setSessionDynFlags++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-w:".+setNoWarningFlags :: DynFlags -> DynFlags+setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags}++-- | Set 'DynFlags' equivalent to "-Wall".+setAllWarningFlags :: DynFlags -> DynFlags+setAllWarningFlags df = df { warningFlags = allWarningFlags }++allWarningFlags :: Gap.WarnFlags+allWarningFlags = unsafePerformIO $+    G.runGhc (Just libdir) $ do+        df <- G.getSessionDynFlags+        df' <- addCmdOpts ["-Wall"] df+        return $ G.warningFlags df'++----------------------------------------------------------------++deferErrors :: Monad m => DynFlags -> m DynFlags+deferErrors df = return $+  Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $+  Gap.setDeferTypeErrors $ setNoWarningFlags df++----------------------------------------------------------------++deriveEqDynFlags [d|+  eqDynFlags :: DynFlags -> DynFlags -> Bool+  eqDynFlags = undefined+ |]
+ core/GhcMod/DynFlagsTH.hs view
@@ -0,0 +1,144 @@+-- ghc-mod: Happy Haskell Hacking+-- 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, TemplateHaskell #-}+module GhcMod.DynFlagsTH where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Applicative+import Data.Maybe+import Data.Generics.Aliases+import Data.Generics.Schemes+import DynFlags+import Prelude++deriveEqDynFlags :: Q [Dec] -> Q [Dec]+deriveEqDynFlags qds = do+#if __GLASGOW_HASKELL__ <= 710+  ~(TyConI (DataD [] _ [] [ctor] _ ))+#else+  ~(TyConI (DataD [] _ [] _ [ctor] _ ))+#endif+      <- reify ''DynFlags+  let ~(RecC _ fs) = ctor++  a <- newName "a"+  b <- newName "b"++  e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)++  tysig@(SigD n _) :_ <- qds++  return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]++ where+   eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)+   eq a b (fun@(Name (OccName fon) _), _, ft)+       | not (isUneqable || isIgnored) = Just expr+       | otherwise = Nothing+    where+       isUneqable = everything (||) (mkQ False hasUnEqable) ft++       hasUnEqable (AppT (ConT (Name (OccName on) _)) _)+           | any (==on) ignoredConstructorNames = True+       hasUnEqable (ConT (Name (OccName on) _))+           | any (==on) ignoredTypeNames = True+           | any (==on) ignoredTypeOccNames = True+       hasUnEqable _ = False++       isIgnored = fon `elem` ignoredNames++       ignoredConstructorNames = [ "IORef" ]++       ignoredNames = [ "pkgDatabase" -- 7.8+#if __GLASGOW_HASKELL__ <= 706+                      , "ways" -- 'Ways' is not exported :/+#endif+                      ]+       ignoredTypeNames =+           [ "LogAction"+           , "PackageState"+           , "Hooks"+           , "FlushOut"+           , "FlushErr"+           , "Settings" -- I think these can't cange at runtime+           ]+       ignoredTypeOccNames = [ "OnOff" ]++       fa = AppE (VarE fun) (VarE a)+       fb = AppE (VarE fun) (VarE b)+       expr =+         case fon of+           "rtsOptsEnabled" -> do+               let eqfn = [| let fn RtsOptsNone RtsOptsNone = True+                                 fn RtsOptsSafeOnly RtsOptsSafeOnly = True+                                 fn RtsOptsAll RtsOptsAll = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]++           "extraPkgConfs" -> do+               let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' []))+                                        && length (a' []) == length (b' [])+                                 eqpr GlobalPkgConf GlobalPkgConf = True+                                 eqpr UserPkgConf UserPkgConf = True+                                 eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb+                                 eqpr _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]++#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800+           "sigOf" -> do+               let eqfn = [| let fn NotSigOf NotSigOf = True+                                 fn (SigOf a') (SigOf b') = a' == b'+                                 fn (SigOfMap a') (SigOfMap b') = a' == b'+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++#if __GLASGOW_HASKELL <= 706+           "profAuto" -> do+               let eqfn = [| let fn NoProfAuto NoProfAuto = True+                                 fn ProfAutoAll ProfAutoAll = True+                                 fn ProfAutoTop ProfAutoTop = True+                                 fn ProfAutoExports ProfAutoExports = True+                                 fn ProfAutoCalls ProfAutoCalls = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++#if __GLASGOW_HASKELL__ >= 706+           "language" -> do+               let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True+                                 fn (Just Haskell2010) (Just Haskell2010) = True+                                 fn Nothing Nothing = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++           _ ->+               [e| $(return fa) == $(return fb)  |]++--       expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |]
+ core/GhcMod/Error.hs view
@@ -0,0 +1,160 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 ExistentialQuantification #-}+module GhcMod.Error (+    GhcModError(..)+  , GmError+  , gmeDoc+  , ghcExceptionDoc+  , liftMaybe+  , overrideError+  , modifyError+  , modifyError'+  , modifyGmError+  , tryFix+  , GHandler(..)+  , gcatches+  , module Control.Monad.Error+  , module Control.Exception+  ) where++import Control.Arrow hiding ((<+>))+import Control.Exception+import Control.Monad.Error hiding (MonadIO, liftIO)+import qualified Data.Set as Set+import Data.List+import Data.Version+import System.Process (showCommandForUser)+import Text.Printf++import Exception+import Panic+import Pretty+import Config (cProjectVersion, cHostPlatformString)+import Paths_ghc_mod (version)++import GhcMod.Types+import GhcMod.Pretty++type GmError m = MonadError GhcModError m++gmeDoc :: GhcModError -> Doc+gmeDoc e = case e of+    GMENoMsg ->+        text "Unknown error"+    GMEString msg ->+        text msg+    GMECabalConfigure msg ->+        text "Configuring cabal project failed" <+>: gmeDoc msg+    GMEStackConfigure msg ->+        text "Configuring stack project failed" <+>: gmeDoc msg+    GMEStackBootstrap msg ->+        text "Bootstrapping stack project environment failed" <+>: gmeDoc msg+    GMECabalCompAssignment ctx ->+        text "Could not find a consistent component assignment for modules:" $$+          (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$+        text "" $$+        (if all (Set.null . snd) ctx+           then noComponentSuggestions+           else empty) $$+        text "- To find out which components ghc-mod knows about try:" $$+            nest 4 (backticks $ text "ghc-mod debug")++      where+        noComponentSuggestions =+          text "- Are some of these modules part of a test and or benchmark?\+               \ Try enabling them:" $$+              nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")++        backticks d = char '`' <> d <> char '`'+        ctxDoc = moduleDoc *** compsDoc+                 >>> first (<> colon) >>> uncurry (flip hang 4)++        moduleDoc (Left fn)   =+            text "File " <> quotes (text fn)+        moduleDoc (Right mdl) =+            text "Module " <> quotes (text $ moduleNameString mdl)++        compsDoc sc | Set.null sc = text "has no known components"+        compsDoc sc = fsep $ punctuate comma $+                        map gmComponentNameDoc $ Set.toList sc+    GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in+        case emsg of+          Right err ->+             text (printf "Launching system command `%s` failed: " c)+                  <> gmeDoc err+          Left rv -> text $+             printf "Launching system command `%s` failed (exited with %d)" c rv+    GMENoCabalFile ->+        text "No cabal file found."+    GMETooManyCabalFiles cfs ->+        text $ "Multiple cabal files found. Possible cabal files: \""+               ++ intercalate "\", \"" cfs ++"\"."++ghcExceptionDoc :: GhcException -> Doc+ghcExceptionDoc e@(CmdLineError _) =+    text $ "<command line>: " ++ showGhcException e ""+ghcExceptionDoc (UsageError str) = strDoc str+ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\+\GHC panic! (the 'impossible' happened)\n\+\  ghc-mod version %s\n\+\  GHC library version %s for %s:\n\+\       %s\n\+\\n\+\Please report this as a bug: %s\n"+    gmVer ghcVer platform msg url+ where+   gmVer = showVersion version+   ghcVer = cProjectVersion+   platform = cHostPlatformString+   url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String++ghcExceptionDoc e = text $ showGhcException e ""++liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a+liftMaybe e action = maybe (throwError e) return =<< action++overrideError :: MonadError e m => e -> m a -> m a+overrideError e action = modifyError (const e) action++modifyError :: MonadError e m => (e -> e) -> m a -> m a+modifyError f action = action `catchError` \e -> throwError $ f e++infixr 0 `modifyError'`+modifyError' :: MonadError e m => m a -> (e -> e) -> m a+modifyError' = flip modifyError++modifyGmError :: (MonadIO m, ExceptionMonad m)+              => (GhcModError -> GhcModError) -> m a -> m a+modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)++tryFix :: MonadError e m => m a -> (e -> m ()) -> m a+tryFix action f = do+  action `catchError` \e -> f e >> action++data GHandler m a = forall e . Exception e => GHandler (e -> m a)++gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a+gcatches io handlers = io `gcatch` gcatchesHandler handlers++gcatchesHandler :: (MonadIO m, ExceptionMonad m)+    => [GHandler m a] -> SomeException -> m a+gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers+    where tryHandler (GHandler handler) res+              = case fromException e of+                Just e' -> handler e'+                Nothing -> res
+ core/GhcMod/FileMapping.hs view
@@ -0,0 +1,104 @@+module GhcMod.FileMapping+    ( loadMappedFile+    , loadMappedFileSource+    , unloadMappedFile+    , mapFile+    , fileModSummaryWithMapping+    ) where++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Gap+import GhcMod.HomeModuleGraph+import GhcMod.Utils++import System.IO+import System.FilePath+import System.Directory++import Control.Monad.Trans.Maybe+import GHC+import Control.Monad++{- | 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++{- |+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+  enc <- liftIO . mkTextEncoding . optEncoding =<< options+  to <- liftIO $ do+    (fn, h) <- openTempFile tmpdir (takeFileName from)+    hSetEncoding h enc+    hPutStr h src+    hClose h+    return fn+  loadMappedFile' from to True++loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()+loadMappedFile' from to isTemp = do+  cfn <- getCanonicalFileNameSafe from+  unloadMappedFile' cfn+  crdl <- cradle+  let to' = makeRelative (cradleRootDir crdl) to+  addMMappedFile cfn (FileMapping to' isTemp)++mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target+mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do+  mapping <- lookupMMappedFile filePath+  return $ mkMappedTarget (Just filePath) tid taoc mapping+mapFile env (Target tid@(TargetModule moduleName) taoc _) = do+  (fp, mapping) <- do+    filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)+    mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile+    return (filePath, mmf)+  return $ mkMappedTarget fp tid taoc mapping++mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target+mkMappedTarget _ _ taoc (Just to) =+  mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing+mkMappedTarget _ tid taoc _ =+  mkTarget tid taoc Nothing++{-|+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 ()+unloadMappedFile' cfn = void $ runMaybeT $ do+  fm <- MaybeT $ lookupMMappedFile cfn+  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)+  delMMappedFile cfn++fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>+                            FilePath -> m ModSummary+fileModSummaryWithMapping fn =+  withMappedFile fn $ \fn' -> fileModSummary fn'
+ core/GhcMod/Gap.hs view
@@ -0,0 +1,723 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}++module GhcMod.Gap (+    GhcMod.Gap.ClsInst+  , mkTarget+  , withStyle+  , GmLogAction+  , setLogAction+  , getSrcSpan+  , getSrcFile+  , withInteractiveContext+  , ghcCmdOptions+  , toStringBuffer+  , showSeverityCaption+  , setCabalPkg+  , setHideAllPackages+  , setDeferTypeErrors+  , setDeferTypedHoles+  , setWarnTypedHoles+  , setDumpSplices+  , setNoMaxRelevantBindings+  , isDumpSplices+  , filterOutChildren+  , infoThing+  , pprInfo+  , HasType(..)+  , errorMsgSpan+  , setErrorMsgSpan+  , typeForUser+  , nameForUser+  , occNameForUser+  , deSugar+  , showDocWith+  , renderGm+  , GapThing(..)+  , fromTyThing+  , fileModSummary+  , WarnFlags+  , emptyWarnFlags+  , GLMatch+  , GLMatchI+  , getClass+  , occName+  , listVisibleModuleNames+  , listVisibleModules+  , lookupModulePackageInAllPackages+  , GhcMod.Gap.isSynTyCon+  , parseModuleHeader+  , mkErrStyle'+  , everythingStagedWithContext+  , withCleanupSession+  ) where++import Control.Applicative hiding (empty)+import Control.Monad (filterM)+import CoreSyn (CoreExpr)+import Data.List (intersperse)+import Data.Maybe (catMaybes)+import Data.Time.Clock (UTCTime)+import Data.Traversable hiding (mapM)+import DataCon (dataConUserType)+import Desugar (deSugarExpr)+import DynFlags+import ErrUtils+import Exception+import FastString+import GhcMonad+import HscTypes+import NameSet+import OccName+import Outputable+import PprTyThing+import StringBuffer+import TcType+import Var (varType)+import System.Directory+import SysTools+#if __GLASGOW_HASKELL__ >= 800+import GHCi (stopIServ)+#endif++import qualified Name+import qualified InstEnv+import qualified Pretty+import qualified StringBuffer as SB++#if __GLASGOW_HASKELL__ >= 710+import CoAxiom (coAxiomTyCon)+#endif++#if __GLASGOW_HASKELL__ >= 708+import FamInstEnv+import ConLike (ConLike(..))+import PatSyn+#else+import TcRnTypes+#endif++-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0+-- It IS defined from 7.10.1 and up though.+-- So we can only test for 7.10.1.0 and up with it.+#if __GLASGOW_HASKELL__ < 710+#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE+#endif+#endif++#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)+import GHC hiding (ClsInst, withCleanupSession)+import qualified GHC (withCleanupSession)+#elif __GLASGOW_HASKELL__ >= 706+import GHC hiding (ClsInst)+#else+import GHC hiding (Instance)+import Control.Arrow hiding ((<+>))+import Data.Convertible+import RdrName (rdrNameOcc)+#endif++#if __GLASGOW_HASKELL__ < 710+import UniqFM (eltsUFM)+import Module+#endif++#if __GLASGOW_HASKELL__ >= 704+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+import SrcLoc+import Packages+import Data.Generics (GenericQ, extQ, gmapQ)+import GHC.SYB.Utils (Stage(..))++import GhcMod.Types (Expression(..))+import Prelude++----------------------------------------------------------------+----------------------------------------------------------------+--+#if __GLASGOW_HASKELL__ >= 706+type ClsInst = InstEnv.ClsInst+#else+type ClsInst = InstEnv.Instance+#endif++mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target+#if __GLASGOW_HASKELL__ >= 706+mkTarget = Target+#else+mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert+#endif++----------------------------------------------------------------+----------------------------------------------------------------++withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc+#if __GLASGOW_HASKELL__ >= 706+withStyle = withPprStyleDoc+#else+withStyle _ = withPprStyleDoc+#endif++#if __GLASGOW_HASKELL__ >= 800+-- flip LogAction+type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()+#elif __GLASGOW_HASKELL__ >= 706+type GmLogAction = forall a. a -> LogAction+#else+type GmLogAction = forall a. a -> DynFlags -> LogAction+#endif++--  DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()++setLogAction :: DynFlags -> GmLogAction -> DynFlags+setLogAction df f =+#if __GLASGOW_HASKELL__ >= 800+    df { log_action = flip f }+#elif __GLASGOW_HASKELL__ >= 706+    df { log_action = f (error "setLogAction") }+#else+    df { log_action = f (error "setLogAction") df }+#endif++showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String+#if __GLASGOW_HASKELL__ >= 800+showDocWith dflags mode = Pretty.renderStyle mstyle where+    mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }+#elif __GLASGOW_HASKELL__ >= 708+-- Pretty.showDocWith disappeard.+-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc+showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)+#else+showDocWith _ = Pretty.showDocWith+#endif++renderGm :: Pretty.Doc -> String+#if __GLASGOW_HASKELL__ >= 800+renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""+#else+renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""+#endif+ where+   string_txt :: Pretty.TextDetails -> String -> String+   string_txt (Pretty.Chr c)   s  = c:s+   string_txt (Pretty.Str s1)  s2 = s1 ++ s2+   string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2+   string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2+#if __GLASGOW_HASKELL__ >= 708+   string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2+#endif+++----------------------------------------------------------------+----------------------------------------------------------------++getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)+#if __GLASGOW_HASKELL__ >= 702+getSrcSpan (RealSrcSpan spn)+#else+getSrcSpan spn | isGoodSrcSpan spn+#endif+             = Just (srcSpanStartLine spn+                   , srcSpanStartCol spn+                   , srcSpanEndLine spn+                   , srcSpanEndCol spn)+getSrcSpan _ = Nothing++getSrcFile :: SrcSpan -> Maybe String+#if __GLASGOW_HASKELL__ >= 702+getSrcFile (RealSrcSpan spn)       = Just . unpackFS . srcSpanFile $ spn+#else+getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn+#endif+getSrcFile _ = Nothing++----------------------------------------------------------------++toStringBuffer :: GhcMonad m => [String] -> m StringBuffer+#if __GLASGOW_HASKELL__ >= 702+toStringBuffer = return . stringToStringBuffer . unlines+#else+toStringBuffer = liftIO . stringToStringBuffer . unlines+#endif++----------------------------------------------------------------++ghcCmdOptions :: [String]+#if __GLASGOW_HASKELL__ >= 710+-- this also includes -X options and all sorts of other things so the+ghcCmdOptions = flagsForCompletion False+#else+ghcCmdOptions = [ "-f" ++ prefix ++ option+                | option <- opts+                , prefix <- ["","no-"]+                ]+#  if __GLASGOW_HASKELL__ >= 704+ where opts =+           [option | (option,_,_) <- fFlags]+        ++ [option | (option,_,_) <- fWarningFlags]+        ++ [option | (option,_,_) <- fLangFlags]+#  else+ where opts =+           [option | (option,_,_,_) <- fFlags]+        ++ [option | (option,_,_,_) <- fWarningFlags]+        ++ [option | (option,_,_,_) <- fLangFlags]+#  endif+#endif++----------------------------------------------------------------+----------------------------------------------------------------++fileModSummary :: GhcMonad m => FilePath -> m ModSummary+fileModSummary file' = do+    mss <- getModuleGraph+    file <- liftIO $ canonicalizePath file'+    [ms] <- liftIO $ flip filterM mss $ \m ->+        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)+    return ms++withInteractiveContext :: GhcMonad m => m a -> m a+withInteractiveContext action = gbracket setup teardown body+  where+    setup = getContext+    teardown = setCtx+    body _ = do+        topImports >>= setCtx+        action+    topImports = do+        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph+        let iis = map (IIModule . modName) ms+#if __GLASGOW_HASKELL__ >= 704+        return iis+#else+        return (iis,[])+#endif+#if __GLASGOW_HASKELL__ >= 706+    modName = moduleName+    setCtx = setContext+#elif __GLASGOW_HASKELL__ >= 704+    modName = id+    setCtx = setContext+#else+    modName = ms_mod+    setCtx = uncurry setContext+#endif++showSeverityCaption :: Severity -> String+#if __GLASGOW_HASKELL__ >= 706+showSeverityCaption SevWarning = "Warning: "+showSeverityCaption _          = ""+#else+showSeverityCaption = const ""+#endif++----------------------------------------------------------------+----------------------------------------------------------------++setCabalPkg :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage+#else+setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage+#endif++----------------------------------------------------------------++setHideAllPackages :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setHideAllPackages df = gopt_set df Opt_HideAllPackages+#else+setHideAllPackages df = dopt_set df Opt_HideAllPackages+#endif++----------------------------------------------------------------++setDumpSplices :: DynFlags -> DynFlags+setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices++isDumpSplices :: DynFlags -> Bool+isDumpSplices dflag = dopt Opt_D_dump_splices dflag++----------------------------------------------------------------+++setDeferTypeErrors :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors+#elif __GLASGOW_HASKELL__ >= 706+setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors+#else+setDeferTypeErrors = id+#endif++setDeferTypedHoles :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 710+setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles+#else+setDeferTypedHoles = id+#endif++setWarnTypedHoles :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles+#else+setWarnTypedHoles = id+#endif++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".+setNoMaxRelevantBindings :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }+#else+setNoMaxRelevantBindings = id+#endif++----------------------------------------------------------------+----------------------------------------------------------------++class HasType a where+    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))+++instance HasType (LHsBind Id) where+#if __GLASGOW_HASKELL__ >= 708+    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)+      where in_tys = mg_arg_tys m+            out_typ = mg_res_ty m+            typ = mkFunTys in_tys out_typ+#else+    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)+#endif+    getType _ _ = return Nothing++----------------------------------------------------------------+----------------------------------------------------------------+-- from ghc/InteractiveUI.hs++filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+  where+    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc+infoThing m (Expression str) = do+    names <- parseName str+#if __GLASGOW_HASKELL__ >= 708+    mb_stuffs <- mapM (getInfo False) names+    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)+#else+    mb_stuffs <- mapM getInfo names+    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+#endif+    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)++#if __GLASGOW_HASKELL__ >= 708+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc+pprInfo m _ (thing, fixity, insts, famInsts)+    = pprTyThingInContextLoc' thing+   $$ show_fixity fixity+   $$ vcat (map pprInstance' insts)+   $$ vcat (map pprFamInst' famInsts)+#else+pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc+pprInfo m pefas (thing, fixity, insts)+    = pprTyThingInContextLoc' pefas thing+   $$ show_fixity fixity+   $$ vcat (map pprInstance' insts)+#endif+  where+    show_fixity fx+      | fx == defaultFixity = Outputable.empty+      | otherwise           = ppr fx <+> ppr (getName thing)+#if __GLASGOW_HASKELL__ >= 708+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')+#if __GLASGOW_HASKELL__ >= 710+    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })+      = pprTyThingInContextLoc (ATyCon rep_tc)++    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                        , fi_tys = lhs_tys, fi_rhs = rhs })+      = showWithLoc (pprDefinedAt' (getName axiom)) $+        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+           2 (equals <+> ppr rhs)+#else+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)+#endif+#else+    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')+#endif+    showWithLoc loc doc+        = hang doc 2 (char '\t' <> comment <+> loc)+        -- The tab tries to make them line up a bit+      where+        comment = ptext (sLit "--")+    pprInstance' ispec = hang (pprInstanceHdr ispec)+        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))+    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')+    pprNameDefnLoc' name+      = case Name.nameSrcLoc name of+           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)+           UnhelpfulLoc s+             | Name.isInternalName name || Name.isSystemName name+             -> ptext (sLit "at") <+> ftext s+             | otherwise+             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))+      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)+            realFP = mkFastString . m . unpackFS . srcLocFile++----------------------------------------------------------------+----------------------------------------------------------------++errorMsgSpan :: ErrMsg -> SrcSpan+#if __GLASGOW_HASKELL__ >= 708+errorMsgSpan = errMsgSpan+#else+errorMsgSpan = head . errMsgSpans+#endif++setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg+#if __GLASGOW_HASKELL__ >= 708+setErrorMsgSpan err s = err { errMsgSpan = s }+#else+setErrorMsgSpan err s = err { errMsgSpans = [s] }+#endif++typeForUser :: Type -> SDoc+#if __GLASGOW_HASKELL__ >= 708+typeForUser = pprTypeForUser+#else+typeForUser = pprTypeForUser False+#endif++nameForUser :: Name -> SDoc+nameForUser = pprOccName . getOccName++occNameForUser :: OccName -> SDoc+occNameForUser = pprOccName++deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv+         -> IO (Maybe CoreExpr)+#if __GLASGOW_HASKELL__ >= 708+deSugar _   e hs_env = snd <$> deSugarExpr hs_env e+#else+deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e+  where+    modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm+    tcgEnv = fst $ tm_internals_ tcm+    rn_env = tcg_rdr_env tcgEnv+    ty_env = tcg_type_env tcgEnv+#endif++----------------------------------------------------------------+----------------------------------------------------------------++data GapThing = GtA Type+              | GtT TyCon+              | GtN+#if __GLASGOW_HASKELL__ >= 800+              | GtPatSyn PatSyn+#endif++fromTyThing :: TyThing -> GapThing+fromTyThing (AnId i)                   = GtA $ varType i+#if __GLASGOW_HASKELL__ >= 708+fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d+#if __GLASGOW_HASKELL__ >= 800+fromTyThing (AConLike (PatSynCon p))   = GtPatSyn p+#else+fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p+#endif+#else+fromTyThing (ADataCon d)               = GtA $ dataConUserType d+#endif+fromTyThing (ATyCon t)                 = GtT t+fromTyThing _                          = GtN++----------------------------------------------------------------+----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 704+type WarnFlags = I.IntSet+emptyWarnFlags :: WarnFlags+emptyWarnFlags = I.empty+#else+type WarnFlags = [WarningFlag]+emptyWarnFlags :: WarnFlags+emptyWarnFlags = []+#endif++----------------------------------------------------------------+----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 708+type GLMatch = LMatch RdrName (LHsExpr RdrName)+type GLMatchI = LMatch Id (LHsExpr Id)+#else+type GLMatch = LMatch RdrName+type GLMatchI = LMatch Id+#endif++getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)+#if __GLASGOW_HASKELL__ >= 800+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 710+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 708+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 706+getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)+getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)+#else+getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)+getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)+#endif+getClass _ = Nothing++#if __GLASGOW_HASKELL__ < 706+occName :: RdrName -> OccName+occName = rdrNameOcc+#endif++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ < 710+-- Copied from ghc/InteractiveUI.hs+allExposedPackageConfigs :: DynFlags -> [PackageConfig]+allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df++allExposedModules :: DynFlags -> [ModuleName]+allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df++listVisibleModuleNames :: DynFlags -> [ModuleName]+listVisibleModuleNames = allExposedModules+#endif++lookupModulePackageInAllPackages ::+    DynFlags -> ModuleName -> [String]+lookupModulePackageInAllPackages df mn =+#if __GLASGOW_HASKELL__ >= 710+    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn+ where+   unpackSPId (SourcePackageId fs) = unpackFS fs+#else+    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn+ where+   unpackPId pid = packageIdString $ mkPackageId pid+--       n ++ "-" ++ showVersion v+#endif++listVisibleModules :: DynFlags -> [GHC.Module]+listVisibleModules df = let+#if __GLASGOW_HASKELL__ >= 710+    modNames = listVisibleModuleNames df+    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]+#else+    pkgCfgs = allExposedPackageConfigs df+    mods = [ mkModule pid modname | p <- pkgCfgs+           , let pid = packageConfigId p+           , modname <- exposedModules p ]+#endif+    in mods++isSynTyCon :: TyCon -> Bool+#if __GLASGOW_HASKELL__ >= 710+isSynTyCon = GHC.isTypeSynonymTyCon+#else+isSynTyCon = GHC.isSynTyCon+#endif+++parseModuleHeader+    :: String         -- ^ Haskell module source text (full Unicode is supported)+    -> DynFlags+    -> FilePath       -- ^ the filename (for source locations)+    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))+parseModuleHeader str dflags filename =+   let+       loc  = mkRealSrcLoc (mkFastString filename) 1 1+       buf  = stringToStringBuffer str+   in+   case L.unP Parser.parseHeader (mkPState dflags buf loc) of++     PFailed sp err   ->+#if __GLASGOW_HASKELL__ >= 706+         Left (unitBag (mkPlainErrMsg dflags sp err))+#else+         Left (unitBag (mkPlainErrMsg sp err))+#endif++     POk pst rdr_module ->+         let (warns,_) = getMessages pst in+         Right (warns, rdr_module)++mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle+#if __GLASGOW_HASKELL__ >= 706+mkErrStyle' = Outputable.mkErrStyle+#else+mkErrStyle' _ = Outputable.mkErrStyle+#endif++#if __GLASGOW_HASKELL__ < 706+instance NFData ByteString where+  rnf Empty       = ()+  rnf (Chunk _ b) = rnf b+#endif++-- | Like 'everything', but avoid known potholes, based on the 'Stage' that+--   generated the Ast.+everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r+everythingStagedWithContext stage s0 f z q x+  | (const False+#if __GLASGOW_HASKELL__ <= 708+      `extQ` postTcType+#endif+      `extQ` fixity `extQ` nameSet) x = z+  | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)+  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool+#if __GLASGOW_HASKELL__ <= 708+        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool+#endif+        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool+        (r, s') = q x s0++withCleanupSession :: GhcMonad m => m a -> m a+#if __GLASGOW_HASKELL__ >= 800+#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)+withCleanupSession = GHC.withCleanupSession+#else+withCleanupSession ghc = ghc `gfinally` cleanup+  where+   cleanup = do+      hsc_env <- getSession+      let dflags = hsc_dflags hsc_env+      liftIO $ do+          cleanTempFiles dflags+          cleanTempDirs dflags+          stopIServ hsc_env+#endif+#else+withCleanupSession action = do+  df <- getSessionDynFlags+  GHC.defaultCleanupHandler df action+#endif
+ core/GhcMod/GhcPkg.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}+module GhcMod.GhcPkg (+    ghcPkgDbOpt+  , ghcPkgDbStackOpts+  , ghcDbStackOpts+  , ghcDbOpt+  , getPackageDbStack+  , getPackageCachePaths+  , getGhcPkgProgram+  ) where++import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)+import Control.Applicative+import Data.List.Split (splitOn)+import Data.Maybe+import Exception (handleIO)+import System.Directory (doesDirectoryExist, getAppUserDataDirectory)+import System.FilePath ((</>))+import Prelude++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.CabalHelper+import GhcMod.PathsAndFiles+import GhcMod.CustomPackageDb+import GhcMod.Stack++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++----------------------------------------------------------------++-- | Get options needed to add a list of package dbs to ghc-pkg's db stack+ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+                  -> [String]+ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs++-- | Get options needed to add a list of package dbs to ghc's db stack+ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+               -> [String]+ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs++----------------------------------------------------------------++ghcPkgDbOpt :: GhcPkgDb -> [String]+ghcPkgDbOpt GlobalDb = ["--global"]+ghcPkgDbOpt UserDb   = ["--user"]+ghcPkgDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]+  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]++ghcDbOpt :: GhcPkgDb -> [String]+ghcDbOpt GlobalDb+  | ghcVersion < 706 = ["-global-package-conf"]+  | otherwise        = ["-global-package-db"]+ghcDbOpt UserDb+  | ghcVersion < 706 = ["-user-package-conf"]+  | otherwise        = ["-user-package-db"]+ghcDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]+  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]++----------------------------------------------------------------++getGhcPkgProgram :: IOish m => GhcModT m FilePath+getGhcPkgProgram = do+  crdl <- cradle+  progs <- optPrograms <$> options+  case cradleProject crdl of+    (StackProject senv) -> do+        Just ghcPkg <- getStackGhcPkgPath senv+        return ghcPkg+    _ ->+        return $ ghcPkgProgram progs++getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]+getPackageDbStack = do+  crdl <- cradle+  mCusPkgStack <- getCustomPkgDbStack+  stack <- case cradleProject crdl of+    PlainProject ->+        return [GlobalDb, UserDb]+    SandboxProject -> do+        Just db <- liftIO $ getSandboxDb crdl+        return $ [GlobalDb, db]+    CabalProject ->+        getCabalPackageDbStack+    (StackProject StackEnv {..}) ->+        return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb]+  return $ fromMaybe stack mCusPkgStack++getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]+getPackageCachePaths sysPkgCfg = do+  pkgDbStack <- getPackageDbStack+  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack++-- TODO: use PkgConfRef+--- Copied from ghc module `Packages' unfortunately it's not exported :/+resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)+resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg+resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do+  appdir <- getAppUserDataDirectory "ghc"+  let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)+      pkgconf = dir </> "package.conf.d"+  exist <- doesDirectoryExist pkgconf+  return $ if exist then Just pkgconf else Nothing+ where+    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString+resolvePackageConfig _ (PackageDb name) = return $ Just name
+ core/GhcMod/HomeModuleGraph.hs view
@@ -0,0 +1,271 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 ScopedTypeVariables, RecordWildCards #-}+module GhcMod.HomeModuleGraph (+   GmModuleGraph(..)+ , ModulePath(..)+ , mkFileMap+ , mkModuleMap+ , mkMainModulePath+ , findModulePath+ , findModulePathSet+ , fileModuleName+ , canonicalizeModulePath+ , homeModuleGraph+ , updateHomeModuleGraph+ , canonicalizeModuleGraph+ , reachable+ , moduleGraphToDot+ ) where++import DriverPipeline+import DynFlags+import ErrUtils+import Exception+import Finder+import GHC+import HscTypes+import Pretty++import Control.Arrow ((&&&))+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.State.Strict (execStateT)+import Control.Monad.State.Class+import Data.Maybe+import Data.Monoid as Monoid+import Data.Map  (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import System.FilePath+import System.Directory+import System.IO+import Prelude++import GhcMod.Logging+import GhcMod.Logger+import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Utils (withMappedFile)+import GhcMod.Gap (parseModuleHeader)++-- | Turn module graph into a graphviz dot file+--+-- @dot -Tpng -o modules.png modules.dot@+moduleGraphToDot :: GmModuleGraph -> String+moduleGraphToDot GmModuleGraph { gmgGraph } =+    "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"+ where+   graph = Map.map (Set.mapMonotonic mpPath)+         $ Map.mapKeysMonotonic mpPath gmgGraph+   edges :: (FilePath, (Set FilePath)) -> String+   edges (f, sf) =+       concatMap (\f' -> "    \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)++data S = S {+      sErrors   :: [(ModulePath, ErrorMessages)],+      sWarnings :: [(ModulePath, WarningMessages)],+      sGraph    :: GmModuleGraph+}++defaultS :: S+defaultS = S [] [] mempty++putErr :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putErr e = do+  s <- get+  put s { sErrors = e:sErrors s}++putWarn :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putWarn w = do+  s <- get+  put s { sWarnings = w:sWarnings s}++gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))+gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get++graphUnion :: MonadState S m => GmModuleGraph -> m ()+graphUnion gmg = do+  s <- get+  put s { sGraph = sGraph s `mappend` gmg }++reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath+reachable smp0 GmModuleGraph {..} = go smp0+ where+   go smp = let+       δsmp = Set.unions $+                collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp+       smp' = smp `Set.union` δsmp+    in if smp == smp' then smp' else go smp'++pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph+pruneUnreachable smp0 gmg@GmModuleGraph {..} = let+    r = reachable smp0 gmg+  in+    GmModuleGraph {+      gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph+    }++collapseMaybeSet :: Maybe (Set a) -> Set a+collapseMaybeSet = maybe Set.empty id++homeModuleGraph :: (IOish m, Gm m)+    => HscEnv -> Set ModulePath -> m GmModuleGraph+homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp++mkMainModulePath :: FilePath -> ModulePath+mkMainModulePath = ModulePath (mkModuleName "Main")++findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)+findModulePath env mn = do+    fmap (ModulePath mn) <$> find env mn++findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)+findModulePathSet env mns = do+    Set.fromList . catMaybes <$> findModulePath env `mapM` mns++find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)+find env mn = liftIO $ do+  res <- findHomeModule env mn+  case res of+   -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc+    Found loc@ModLocation { ml_hs_file = Just _ } _mod ->+        return $ normalise <$> ml_hs_file loc+    _ -> return Nothing+++canonicalizeModulePath :: ModulePath -> IO ModulePath+canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp++canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph+canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do+    GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph)+ where+   fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))+++updateHomeModuleGraph :: (IOish m, Gm m)+                      => HscEnv+                      -> GmModuleGraph+                      -> Set ModulePath -- ^ Initial set of modules+                      -> Set ModulePath -- ^ Updated set of modules+                      -> m GmModuleGraph+updateHomeModuleGraph env GmModuleGraph {..} smp sump = do+    -- TODO: It would be good if we could retain information about modules that+    -- stop to compile after we've already successfully parsed them at some+    -- point. Figure out a way to delete the modules about to be updated only+    -- after we're sure they won't fail to parse .. or something. Should probably+    -- push this whole prune logic deep into updateHomeModuleGraph'+   (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump)+ where+   runS = flip execStateT defaultS { sGraph = graph' }+   graph' = GmModuleGraph {+       gmgGraph = Set.foldr Map.delete gmgGraph sump+    }++mkFileMap :: Set ModulePath -> Map FilePath ModulePath+mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp++mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath+mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp++updateHomeModuleGraph'+    :: forall m. (MonadState S m, IOish m, Gm m)+    => HscEnv+    -> Set ModulePath     -- ^ Initial set of modules+    -> m ()+updateHomeModuleGraph' env smp0 = do+    go `mapM_` Set.toList smp0+ where+   go :: ModulePath -> m ()+   go mp = do+     msmp <- gmgLookupMP mp+     case msmp of+       Just _ -> return ()+       Nothing -> do+           smp <- collapseMaybeSet `liftM` step mp++           graphUnion GmModuleGraph {+               gmgGraph = Map.singleton mp smp+            }++           mapM_ go (Set.toList smp)++   step :: ModulePath -> m (Maybe (Set ModulePath))+   step mp = runMaybeT $ do+       (dflags, ppsrc_fn) <- MaybeT preprocess'+       src <- liftIO $ readFile ppsrc_fn+       imports mp src dflags+    where+      preprocess' :: m (Maybe (DynFlags, FilePath))+      preprocess' = do+        let fn = mpPath mp+        ep <- preprocessFile env fn+        case ep of+          Right (_, x) -> return $ Just x+          Left errs -> do+            -- TODO: Remember these and present them as proper errors if this is+            -- the file the user is looking at.+            gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs)+            return Nothing+++   imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)+   imports mp@ModulePath {..} src dflags =+       case parseModuleHeader src dflags mpPath of+         Left err -> do+           putErr (mp, err)+           mzero++         Right (ws, lmdl) -> do+           putWarn (mp, ws)+           let HsModule {..} = unLoc lmdl+               mns = map (unLoc . ideclName)+                   $ filter (isNothing . ideclPkgQual)+                   $ map unLoc hsmodImports+           -- TODO: handle package qualifier "this"+           liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns++preprocessFile :: (IOish m, GmEnv m, GmState m) =>+  HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))+preprocessFile env file =+  withLogger' env $ \setDf -> do+    withMappedFile file $ \fn -> do+      let env' = env { hsc_dflags = setDf (hsc_dflags env) }+      liftIO $ preprocess env' (fn, Nothing)++fileModuleName :: (IOish m, GmEnv m, GmState m) =>+  HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))+fileModuleName env fn = do+    let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)+    ep <- preprocessFile env fn+    case ep of+      Left errs -> do+        return $ Left errs+      Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do+        src <- readFile procdFile+        case parseModuleHeader src dflags procdFile of+          Left errs -> return $ Left errs+          Right (_, lmdl) -> do+            let HsModule {..} = unLoc lmdl+            return $ Right $ unLoc <$> hsmodName)+  where+    leftM f = either (return . Left <=< f) (return . Right)
+ core/GhcMod/LightGhc.hs view
@@ -0,0 +1,60 @@+module GhcMod.LightGhc where++import Control.Monad+import Control.Monad.Reader (runReaderT)+import Data.IORef++import GHC+import GHC.Paths (libdir)+import StaticFlags+import SysTools+import DynFlags+import HscMain+import HscTypes++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap++-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an+-- out of process GHCI server which has to be shutdown.+newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv+newLightEnv mdf = do+  df <- liftIO $ do+     initStaticOpts+     settings <- initSysTools (Just libdir)+     initDynFlags $ defaultDynFlags settings++  hsc_env <- liftIO $ newHscEnv df+  df' <- runLightGhc hsc_env $ mdf df+  return $ hsc_env {+      hsc_dflags = df',+      hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' }+    }++teardownLightEnv :: MonadIO m => HscEnv -> m ()+teardownLightEnv env = runLightGhc env $ do+  Gap.withCleanupSession $ return ()++withLightHscEnv'+    :: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a+withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action++withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a+withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv)+ where+   f env = runLightGhc env $ do+         -- HomeModuleGraph and probably all other clients get into all sorts of+         -- trouble if the package state isn't initialized here+         _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags+         getSessionDynFlags++runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a+runLightGhc env action = liftIO $ do+  renv <- newIORef env+  flip runReaderT renv $ unLightGhc action++runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a+runLightGhc' renv action = liftIO $ do+  flip runReaderT renv $ unLightGhc action
+ core/GhcMod/Logger.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP, RankNTypes #-}++module GhcMod.Logger (+    withLogger+  , withLogger'+  , checkErrorPrefix+  , errsToStr+  , errBagToStrList+  ) where++import Control.Arrow+import Control.Applicative+import Data.Ord+import Data.List+import Data.Maybe+import Data.Function+import Control.Monad.Reader (Reader, ask, runReader)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import System.FilePath (normalise)++import ErrUtils+import GHC+import HscTypes+import Outputable+import qualified GHC as G+import Bag+import SrcLoc+import FastString++import GhcMod.Convert+import GhcMod.Doc (showPage)+import GhcMod.DynFlags (withDynFlags)+import GhcMod.Monad.Types+import GhcMod.Error+import GhcMod.Pretty+import GhcMod.Utils (mkRevRedirMapFunc)+import qualified GhcMod.Gap as Gap+import Prelude++type Builder = [String] -> [String]++data Log = Log [String] Builder++newtype LogRef = LogRef (IORef Log)++data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags+                         , gpeMapFile :: FilePath -> FilePath+                         }++type GmPprEnvM a = Reader GmPprEnv a++emptyLog :: Log+emptyLog = Log [] id++newLogRef :: IO LogRef+newLogRef = LogRef <$> newIORef emptyLog++readAndClearLogRef :: LogRef -> IO [String]+readAndClearLogRef (LogRef ref) = do+    Log _ b <- readIORef ref+    writeIORef ref emptyLog+    return $ b []++appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction+appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do+    modifyIORef ref update+  where+    -- TODO: get rid of ppMsg and just do more or less what ghc's+    -- defaultLogAction does+    l = ppMsg map_file df st src sev msg++    update lg@(Log ls b)+      | l `elem` ls = lg+      | otherwise   = Log (l:ls) (b . (l:))++----------------------------------------------------------------++-- | Logged messages are returned as 'String'.+--   Right is success and Left is failure.+withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)+           => (DynFlags -> DynFlags)+           -> m a+           -> m (Either String (String, a))+withLogger f action = do+  env <- G.getSession+  oopts <- outputOpts+  let conv = convert oopts+  eres <- withLogger' env $ \setDf ->+      withDynFlags (f . setDf) action+  return $ either (Left . conv) (Right . first conv) eres++withLogger' :: (IOish m, GmState m, GmEnv m)+    => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))+withLogger' env action = do+    logref <- liftIO $ newLogRef++    rfm <- mkRevRedirMapFunc++    let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref+        handlers = [+            GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,+            GHandler $ \ex -> return $ Left [renderGm $ ghcExceptionDoc ex]+          ]+        gpe = GmPprEnv {+                gpeDynFlags = hsc_dflags env+              , gpeMapFile = rfm+        }++    a <- gcatches (Right <$> action setLogger) handlers+    ls <- liftIO $ readAndClearLogRef logref++    return ((,) ls <$> a)++errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]+errBagToStrList env errs = do+   rfm <- mkRevRedirMapFunc+   return $ runReader+    (errsToStr (sortMsgBag errs))+    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }++----------------------------------------------------------------++-- | Converting 'SourceError' to 'String'.+sourceError :: SourceError -> GmPprEnvM [String]+sourceError = errsToStr . sortMsgBag . srcErrorMessages++errsToStr :: [ErrMsg] -> GmPprEnvM [String]+errsToStr = mapM ppErrMsg++sortMsgBag :: Bag ErrMsg -> [ErrMsg]+sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag++----------------------------------------------------------------++ppErrMsg :: ErrMsg -> GmPprEnvM String+ppErrMsg err = do+    GmPprEnv {..} <- ask+    let unqual = errMsgContext err+        st = Gap.mkErrStyle' gpeDynFlags unqual+        err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)+    return $ showPage gpeDynFlags st $ pprLocErrMsg err'++mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan+mapSrcSpanFile map_file (RealSrcSpan s)   =+    RealSrcSpan $ mapRealSrcSpanFile map_file s+mapSrcSpanFile _ (UnhelpfulSpan s) =+    UnhelpfulSpan s++mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan+mapRealSrcSpanFile map_file s = let+    start = mapRealSrcLocFile map_file $ realSrcSpanStart s+    end   = mapRealSrcLocFile map_file $ realSrcSpanEnd s+  in+    mkRealSrcSpan start end++mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc+mapRealSrcLocFile map_file l = let+    file = mkFastString $ map_file $ unpackFS $ srcLocFile l+    line = srcLocLine l+    col  = srcLocCol l+  in+    mkRealSrcLoc file line col++ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String+ppMsg map_file df st spn sev msg = let+    cts = showPage df st msg+  in+    ppMsgPrefix map_file df spn sev cts ++ cts++ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String+ppMsgPrefix map_file df spn sev cts =+  let+      defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix+  in+    fromMaybe defaultPrefix $ do+      (line,col,_,_) <- Gap.getSrcSpan spn+      file <- map_file <$> normalise <$> Gap.getSrcFile spn+      return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" +++        if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)+          then ""+          else Gap.showSeverityCaption sev++checkErrorPrefix :: String+checkErrorPrefix = "Dummy:0:0:Error:"++warningAsErrorPrefixes :: [String]+warningAsErrorPrefixes = [ "Couldn't match expected type"+                         , "Couldn't match type"+                         , "No instance for"]
+ core/GhcMod/Logging.hs view
@@ -0,0 +1,115 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GeneralizedNewtypeDeriving #-}++module GhcMod.Logging (+    module GhcMod.Logging+  , module GhcMod.Pretty+  , GmLogLevel(..)+  , module Data.Monoid+  , module Pretty+  ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.Trans.Class+import Data.List+import Data.Char+import Data.Monoid+import Data.Maybe+import System.IO+import System.FilePath+import Prelude++import Pretty hiding (style, (<>))++import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Pretty+import GhcMod.Output++gmSetLogLevel :: GmLog m => GmLogLevel -> m ()+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)) []+++increaseLogLevel :: GmLogLevel -> GmLogLevel+increaseLogLevel l | l == maxBound = l+increaseLogLevel l = succ l++decreaseLogLevel :: GmLogLevel -> GmLogLevel+decreaseLogLevel l | l == minBound = l+decreaseLogLevel l = pred l++-- |+-- >>> Just GmDebug <= Nothing+-- False+-- >>> Just GmException <= Just GmDebug+-- True+-- >>> Just GmDebug <= Just GmException+-- False+gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()+gmLog level loc' doc = do+  GhcModLog { gmLogLevel = Just level' } <- gmlHistory++  let loc | loc' == "" = empty+          | otherwise = text loc' <+>: empty+      msgDoc = sep [loc, doc]+      msg = dropWhileEnd isSpace $ renderGm $ gmLogLevelDoc level <+>: msgDoc++  when (level <= level') $ gmErrStrLn msg+  gmLogQuiet level loc' doc++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+  gmLog GmVomit "" $ doc <+>: text content++  GhcModLog { gmLogVomitDump = Last mdump }+      <- gmlHistory++  dir <- cradleTempDir `liftM` cradle+  when (fromMaybe False mdump) $+       liftIO $ writeFile (dir </> filename) content+++newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }+    deriving (Functor, Applicative, Monad)++instance MonadTrans LogDiscardT where+    lift = LogDiscardT++instance Monad m => GmLog (LogDiscardT m) where+    gmlJournal = const $ return ()+    gmlHistory = return mempty+    gmlClear = return ()
+ core/GhcMod/Monad.hs view
@@ -0,0 +1,148 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad (+    runGmOutT+  , runGmOutT'+  , runGhcModT+  , runGhcModT'+  , hoistGhcModT+  , runGmlT+  , runGmlT'+  , runGmlTWith+  , runGmPkgGhc+  , withGhcModEnv+  , withGhcModEnv'+  , module GhcMod.Monad.Types+  ) where++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Error+import GhcMod.Logging+import GhcMod.Cradle+import GhcMod.Target+import GhcMod.Output++import Control.Arrow (first)+import Control.Applicative++import Control.Concurrent++import Control.Monad.Reader (runReaderT)+import Control.Monad.State.Strict (runStateT)+import Control.Monad.Trans.Journal (runJournalT)++import Exception++import System.Directory+import System.IO.Unsafe+import Prelude++withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f+ where+   withCradle dir' =+       gbracket+         (runJournalT $ do+            gmSetLogLevel $ ooptLogLevel $ optOutput opts+            findCradle' (optPrograms opts) dir')+         (liftIO . cleanupCradle . fst)++++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,lg) ->+      withCradleRootDir crdl $+        f (GhcModEnv opts crdl, lg)+ where+   swapCurrentDirectory ndir = do+     odir <- canonicalizePath =<< getCurrentDirectory+     setCurrentDirectory ndir+     return odir++   withCradleRootDir (cradleRootDir -> projdir) a = do+       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++      teardown odir = liftIO $ do+        setCurrentDirectory odir+        void $ takeMVar cwdLock++runGmOutT :: IOish m => Options -> GmOutT m a -> m a+runGmOutT opts ma = do+    gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan+    let action = runGmOutT' gmo ma+    case ooptLinePrefix $ optOutput opts of+      Nothing -> action+      Just pfxs ->+        gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)+                  (const $ liftIO $ flushStdoutGateway gmoChan)+                  action++runGmOutT' :: GhcModOut -> GmOutT m a -> m a+runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma++-- | Run a @GhcModT m@ computation.+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,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+-- state part of GhcModT this cannot be restored.+hoistGhcModT :: IOish m+             => (Either GhcModError a, GhcModLog)+             -> GhcModT m a+hoistGhcModT (r,l) = do+  gmlJournal l >> case r of+    Left e -> throwError e+    Right a -> return a+++-- | Run a computation inside @GhcModT@ providing the RWST environment and+-- initial state. This is a low level function, use it only if you know what to+-- do with 'GhcModEnv' and 'GhcModState'.+--+-- You should probably look at 'runGhcModT' instead.+runGhcModT' :: IOish m+             => GhcModEnv+             -> GhcModState+             -> GhcModT m a+             -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)+runGhcModT' r s a = do+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s++gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c+gbracket_ ma mb mc = gbracket ma mb (const mc)
+ core/GhcMod/Monad/Compat.hs_h view
@@ -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
+ core/GhcMod/Monad/Env.hs view
@@ -0,0 +1,68 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.Env where++import GhcMod.Types+import 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)
+ core/GhcMod/Monad/Log.hs view
@@ -0,0 +1,71 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.Log where++import GhcMod.Types+import 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)
+ core/GhcMod/Monad/Newtypes.hs view
@@ -0,0 +1,176 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.Newtypes where++#include "Compat.hs_h"++import 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 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
+ core/GhcMod/Monad/Orphans.hs view
@@ -0,0 +1,83 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.Orphans where++#include "Compat.hs_h"++import GhcMod.Types+import 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
+ core/GhcMod/Monad/Out.hs view
@@ -0,0 +1,52 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.Out where++import GhcMod.Types+import 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
+ core/GhcMod/Monad/State.hs view
@@ -0,0 +1,67 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Monad.State where++import GhcMod.Types+import 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)
+ core/GhcMod/Monad/Types.hs view
@@ -0,0 +1,239 @@+-- ghc-mod: Happy Haskell Hacking+-- 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, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GhcMod.Monad.Types (+  -- * Monad Types+    GhcModT+  , GmOutT(..)+  , GmT(..)+  , GmlT(..)+  , LightGhc(..)+  , GmGhc+  , IOish+  -- * Environment, state and logging+  , GhcModEnv(..)+  , GhcModState(..)+  , GhcModCaches(..)+  , defaultGhcModState+  , GmGhcSession(..)+  , GmComponent(..)+  -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'+  , GmLogLevel(..)+  , GhcModLog(..)+  , GhcModError(..)+  , Gm+  , GmEnv(..)+  , GmState(..)+  , GmLog(..)+  , GmOut(..)+  , cradle+  , options+  , outputOpts+  , withOptions+  , getMMappedFiles+  , setMMappedFiles+  , addMMappedFile+  , delMMappedFile+  , lookupMMappedFile+  , getMMappedFilePaths+  -- * Re-exporting convenient stuff+  , MonadIO+  , liftIO+  , gmlGetSession+  , gmlSetSession+  ) where++#include "Compat.hs_h"++import GhcMod.Types++import GhcMod.Monad.Env+import GhcMod.Monad.State+import GhcMod.Monad.Log+import GhcMod.Monad.Out+import GhcMod.Monad.Newtypes+import GhcMod.Monad.Orphans ()++import Safe++import GHC+import DynFlags+import Exception+import HscTypes++import Control.Applicative+import Control.Monad++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.Trans.Control++import Control.Monad.Reader.Class++import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.IORef+import Prelude++type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)++--------------------------------------------------+-- GHC API instances -----------------------------++-- GHC cannot prove the following instances to be decidable automatically using+-- the FlexibleContexts extension as they violate the second Paterson Condition,+-- namely that: The assertion has fewer constructors and variables (taken+-- together and counting repetitions) than the head. Specifically the+-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation.++type GmGhc m = (IOish m, GhcMonad m)++instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where+    getSession = gmlGetSession+    setSession = gmlSetSession++-- | Get the underlying GHC session+gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv+gmlGetSession = do+        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 . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet+        liftIO $ flip writeIORef a ref++instance GhcMonad LightGhc where+    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+    getDynFlags = hsc_dflags <$> getSession++instance HasDynFlags LightGhc where+    getDynFlags = hsc_dflags <$> getSession+#endif++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT 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 (GmT 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 (GmlT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance ExceptionMonad LightGhc where+  gcatch act handl =+      LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)+  gmask f =+      LightGhc $ gmask $ \io_restore ->let+          g_restore (LightGhc m) = LightGhc $ io_restore m+      in+        unLightGhc (f g_restore)+++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s 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 (ReaderT s m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    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+options = gmOptions `liftM` gmeAsk++outputOpts :: GmOut m => m OutputOpts+outputOpts = gmoOptions `liftM` gmoAsk++cradle :: GmEnv m => m Cradle+cradle = gmCradle `liftM` gmeAsk++getMMappedFiles :: GmState m => m FileMappingMap+getMMappedFiles = gmMMappedFiles `liftM` gmsGet++setMMappedFiles :: GmState m => FileMappingMap -> m ()+setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet++addMMappedFile  :: GmState m => FilePath -> FileMapping -> m ()+addMMappedFile t fm =+  getMMappedFiles >>= setMMappedFiles . M.insert t fm++delMMappedFile  :: GmState m => FilePath -> m ()+delMMappedFile t =+  getMMappedFiles >>= setMMappedFiles . M.delete t++lookupMMappedFile  :: GmState m => FilePath -> m (Maybe FileMapping)+lookupMMappedFile t =+  M.lookup t `liftM` getMMappedFiles++getMMappedFilePaths :: GmState m => m [FilePath]+getMMappedFilePaths = M.keys `liftM` getMMappedFiles++withOptions :: GmEnv m => (Options -> Options) -> m a -> m a+withOptions changeOpt action = gmeLocal changeEnv action+  where+    changeEnv e = e { gmOptions = changeOpt opt }+      where+        opt = gmOptions e
+ core/GhcMod/Options/DocUtils.hs view
@@ -0,0 +1,48 @@+-- ghc-mod: Happy Haskell Hacking+-- 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+(<$$>) = (<$>)
+ core/GhcMod/Options/Help.hs view
@@ -0,0 +1,79 @@+-- ghc-mod: Happy Haskell Hacking+-- 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
+ core/GhcMod/Options/Options.hs view
@@ -0,0 +1,177 @@+-- ghc-mod: Happy Haskell Hacking+-- 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.Options (+    globalArgSpec+  , parseCmdLineOptions+) where++import Options.Applicative+import Options.Applicative.Types+import GhcMod.Types+import Control.Arrow+import Data.Char (toUpper, toLower)+import Data.List (intercalate)+import GhcMod.Read+import GhcMod.Options.DocUtils+import GhcMod.Options.Help+import Data.Monoid+import Prelude++-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing+-- @Options@ set accordingly.+parseCmdLineOptions :: [String] -> Maybe Options+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)++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"++-- | An optparse-applicative @Parser@ sepcification for @Options@ so that+-- applications making use of the ghc-mod API can have a consistent way of+-- parsing global options.+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+      <*> strOption+          $$  long "encoding"+          <=> value "UTF-8"+          <=> showDefault+          <=> help "I/O encoding"+      <*> switch+          $$  long "stack-build-deps"+          <=> showDefault+          <=> help "Build dependencies if needed when using stack"+  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)
+ core/GhcMod/Output.hs view
@@ -0,0 +1,243 @@+-- ghc-mod: Happy Haskell Hacking+-- 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/>.++-- Derived from process:System.Process+-- Copyright (c) The University of Glasgow 2004-2008++{-# LANGUAGE FlexibleInstances #-}+module GhcMod.Output (+    gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn++  , gmPutStrIO+  , 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+import System.Exit+import System.Process+import Control.Monad+import Control.Monad.State.Strict+import Control.DeepSeq+import Control.Exception+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Pipes+import Pipes.Lift+import Prelude++import GhcMod.Types hiding (LineSeparator, MonadIO(..))+import GhcMod.Monad.Types hiding (MonadIO(..))+import 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 =+  outputFns' `liftM` gmoAsk++outputFns' ::+  MonadIO m => GhcModOut -> (String -> m (), String -> m ())+outputFns' (GhcModOut oopts c)  = let+  OutputOpts {..} = oopts+ in+  case ooptLinePrefix of+    Nothing -> stdioOutputFns+    Just _  -> chanOutputFns c++stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())+stdioOutputFns =+    ( liftIO . putStr+    , liftIO . hPutStr stderr+    )++chanOutputFns :: MonadIO m+              => Chan (Either (MVar ()) (GmStream, String))+              -> (String -> m (), String -> m ())+chanOutputFns c = (write GmOutStream, write GmErrStream)+ where+   write stream s = liftIO $ writeChan c $ Right $ (stream,s)++gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn+    :: (MonadIO m, GmOut m) => String -> m ()++gmPutStr str = do+  putOut <- gmPutStrIO+  putOut str++gmErrStr str = do+  putErr <- gmErrStrIO+  putErr str++gmPutStrLn = gmPutStr . (++"\n")+gmErrStrLn = gmErrStr . (++"\n")++gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())++gmPutStrIO = fst `liftM` outputFns+gmErrStrIO = snd `liftM` outputFns+++gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)+gmReadProcess = do+  GhcModOut {..} <- gmoAsk+  case ooptLinePrefix gmoOptions of+    Just _ ->+        readProcessStderrChan+    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+  writeChan c $ Left mv+  takeMVar mv++type Line = String++stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()+stdoutGateway (outPf, errPf) chan = do+  runEffect $ commandProc >-> evalStateP ("","") seperateStreams+ where+   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()+   commandProc = do+     cmd <- liftIO $ readChan chan+     case cmd of+       Left mv -> do+           yield $ Left mv+       Right input -> do+           yield $ Right input+           commandProc++   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()+   seperateStreams  = do+       ecmd <- await+       case ecmd of+         Left mv -> do+           -- flush buffers+           (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)+               `mapM_` [GmOutStream, GmErrStream]++           liftIO $ putMVar mv ()+         Right (stream, str) -> do+           ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)+           case ls of+               [] -> return ()+               _  -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls++           liftIO $ hFlush stdout+           seperateStreams++   sGetLine :: (Maybe String) -> StateT String IO [Line]+   sGetLine mstr' = do+     buf <- get+     let mstr = (buf++) `liftM` mstr'+     case mstr of+       Nothing -> put "" >> return [buf]+       Just "" -> return []+       Just s | last s == '\n' -> put "" >> return (lines s)+              | otherwise -> do+                  let (p:ls') = reverse $ lines s+                  put p+                  return $ reverse $ ls'++   streamLens GmOutStream = LB.fst+   streamLens GmErrStream = LB.snd++   streamPf GmOutStream = outPf+   streamPf GmErrStream = errPf++zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a+zoom l (StateT a) =+    StateT $ \f -> do+      (a', s') <- a $ L.get l f+      return (a', L.set l s' f)++readProcessStderrChan ::+    (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)+readProcessStderrChan = do+  (_, e :: String -> IO ()) <- outputFns+  return $ readProcessStderrChan' e++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+              , std_in  = CreatePipe+              }+     (Just i, Just o, Just e, h) <- createProcess cp++     _ <- forkIO $ reader e++     output  <- hGetContents' o+     withForkWait (evaluate $ rnf output) $ \waitOut -> do++       -- now write any input+       unless (null input) $+         ignoreSEx $ hPutStr i input+       -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+       ignoreSEx $ hClose i++       -- wait on the output+       waitOut+       hClose o++     res <- waitForProcess h+     case res of+       ExitFailure rv ->+           throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv+       ExitSuccess ->+           return output+    where+      ignoreSEx = handle (\(SomeException _) -> return ())+      reader h = ignoreSEx $ do+        putErr . (++"\n") =<< hGetLine h+        reader h++withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait async body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore async) >>= putMVar waitVar+    let wait = takeMVar waitVar >>= either throwIO return+    restore (body wait) `onException` killThread tid
+ core/GhcMod/PathsAndFiles.hs view
@@ -0,0 +1,242 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.PathsAndFiles (+    module GhcMod.PathsAndFiles+  , module GhcMod.Caching+  ) where++import Config (cProjectVersion)+import Control.Arrow (second)+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Maybe+import Data.List+import Data.Char+import Data.Maybe+import Data.Traversable hiding (mapM)+import Distribution.Helper (buildPlatform)+import System.Directory+import System.FilePath+import System.Process++import GhcMod.Types+import GhcMod.Caching+import qualified GhcMod.Utils as U+import Utils (mightExist)+import Prelude++-- | Guaranteed to be a path to a directory with no trailing slash.+type DirPath = FilePath++-- | Guaranteed to be the name of a file only (no slashes).+type FileName = String++-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent+-- directories. The first parent directory containing more than one cabal file+-- is assumed to be the project directory. If only one cabal file exists in this+-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'+-- or 'GMETooManyCabalFiles'+findCabalFile :: FilePath -> IO (Maybe FilePath)+findCabalFile dir = findFileInParentsP isCabalFile pick dir+  where+    pick [] = Nothing+    pick [cf] = Just cf+    pick cfs  = throw $ GMETooManyCabalFiles cfs++findStackConfigFile :: FilePath -> IO (Maybe FilePath)+findStackConfigFile dir =+    findFileInParentsP (=="stack.yaml") pick dir+  where+    pick []     = Nothing+    pick (sf:_) = Just sf++findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)+findCabalSandboxDir dir =+  fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir+ where+   isSandboxConfig = (==sandboxConfigFileName)+   pick []     = Nothing+   pick (sc:_) = Just sc++findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)+findCustomPackageDbFile dir =+    mightExist $ dir </> "ghc-mod.package-db-stack"++-- | Get path to sandbox config file+getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)+getSandboxDb crdl = do+  mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl)+  bp <- buildPlatform readProcess+  return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)++ where+   fixPkgDbVer bp dir =+       case takeFileName dir == ghcSandboxPkgDbDir bp of+         True -> dir+         False -> takeDirectory dir </> ghcSandboxPkgDbDir bp++-- | Extract the sandbox package db directory from the cabal.sandbox.config+-- file. Exception is thrown if the sandbox config file is broken.+extractSandboxDbDir :: String -> Maybe FilePath+extractSandboxDbDir conf = extractValue <$> parse conf+  where+    key = "package-db:"+    keyLen = length key++    parse = listToMaybe . filter (key `isPrefixOf`) . lines+    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen+++-- |+-- >>> isCabalFile "/home/user/.cabal"+-- False+isCabalFile :: FilePath -> Bool+isCabalFile f = takeExtension' f == ".cabal"++-- |+-- >>> takeExtension' "/some/dir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "some/reldir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' ".cabal"+-- ""+takeExtension' :: FilePath -> String+takeExtension' p =+    if takeFileName p == takeExtension p+      then "" -- just ".cabal" is not a valid cabal file+      else takeExtension p++-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all+-- it's parent directories. Files found to satisfy @p@ in a given directory are+-- passed to @r@ and if this yields a 'Just' value the search finishes early+-- without examinig any more directories and this value is returned.+findFileInParentsP :: (FilePath -> Bool)+                   -> ([FilePath] -> Maybe a)+                   -> FilePath+                   -> IO (Maybe a)+findFileInParentsP p r dir = runMaybeT $+    join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir)++-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all+-- it's parent directories.+findFilesInParentsP :: (FilePath -> Bool) -> FilePath+                   -> IO [IO [FilePath]]+findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $+    map (\d -> (map (d </>)) <$> getFilesP p d) $ parents dir++-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.+getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]+getFilesP p dir = filterM p' =<< getDirectoryContentsSafe+ where+   p' fn = do+     (p fn && ) <$> doesFileExist (dir </> fn)+   getDirectoryContentsSafe = do+     rdable <- readable <$> getPermissions dir+     if rdable+        then getDirectoryContents dir+        else return []++-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.+--+-- Examples+--+-- >>> parents "foo"+-- ["foo"]+--+-- >>> parents "/foo"+-- ["/foo","/"]+--+-- >>> parents "/foo/bar"+-- ["/foo/bar","/foo","/"]+--+-- >>> parents "foo/bar"+-- ["foo/bar","foo"]+parents :: FilePath -> [FilePath]+parents "" = []+parents dir' =+    let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'+    in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir+ where+   parents' :: [String] -> [FilePath]+   parents' [] | isAbsolute dir' = "":[]+   parents' [] = []+   parents' dir = [joinPath dir] ++ parents' (init dir)++----------------------------------------------------------------++setupConfigFile :: Cradle -> FilePath+setupConfigFile crdl =+    cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl)++sandboxConfigFile :: Cradle -> FilePath+sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName++sandboxConfigFileName :: String+sandboxConfigFileName = "cabal.sandbox.config"++-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@+setupConfigPath :: FilePath -> FilePath+setupConfigPath dist = dist </> "setup-config"+ -- localBuildInfoFile defaultDistPref++macrosHeaderPath :: FilePath+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+    buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"++packageCache :: String+packageCache = "package.cache"++-- | Filename of the symbol table cache file.+symbolCache :: Cradle -> FilePath+symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile++symbolCacheFile :: String+symbolCacheFile = "ghc-mod.symbol-cache"++resolvedComponentsCacheFile :: FilePath -> FilePath+resolvedComponentsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.resolved-components"++cabalHelperCacheFile :: FilePath -> FilePath+cabalHelperCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.cabal-components"++mergedPkgOptsCacheFile :: FilePath -> FilePath+mergedPkgOptsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-options"++pkgDbStackCacheFile :: FilePath -> FilePath+pkgDbStackCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-db-stack"
+ core/GhcMod/Pretty.hs view
@@ -0,0 +1,90 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Pretty+  ( renderGm+  , renderSDoc+  , gmComponentNameDoc+  , gmLogLevelDoc+  , (<+>:)+  , fnDoc+  , showToDoc+  , warnDoc+  , strLnDoc+  , strDoc+  ) where++import Control.Arrow hiding ((<+>))+import Data.Char+import Data.List+import Distribution.Helper+import Pretty+import GHC+import Outputable (SDoc, withPprStyleDoc)++import GhcMod.Types+import GhcMod.Doc+import GhcMod.Gap (renderGm)++renderSDoc :: GhcMonad m => SDoc -> m Doc+renderSDoc sdoc = do+  df <- getSessionDynFlags+  ppsty <- getStyle+  return $ withPprStyleDoc df ppsty sdoc++gmComponentNameDoc :: ChComponentName -> Doc+gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"+gmComponentNameDoc (ChLibName "")  = text $ "library"+gmComponentNameDoc (ChLibName n)   = text $ "library:" ++ n+gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n+gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n+gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n++gmLogLevelDoc :: GmLogLevel -> Doc+gmLogLevelDoc GmSilent    = error "GmSilent MUST not be used for log messages"+gmLogLevelDoc GmPanic     = text "PANIC"+gmLogLevelDoc GmException = text "EXCEPTION"+gmLogLevelDoc GmError     = text "ERROR"+gmLogLevelDoc GmWarning   = text "Warning"+gmLogLevelDoc GmInfo      = text "info"+gmLogLevelDoc GmDebug     = text "DEBUG"+gmLogLevelDoc GmVomit     = text "VOMIT"++infixl 6 <+>:+(<+>:) :: Doc -> Doc -> Doc+a <+>: b = (a <> colon) <+> b++fnDoc :: FilePath -> Doc+fnDoc = doubleQuotes . text++showToDoc :: Show a => a -> Doc+showToDoc = strLnDoc . show++warnDoc :: Doc -> Doc+warnDoc d = text "Warning" <+>: d++strLnDoc :: String -> Doc+strLnDoc str = doc (dropWhileEnd isSpace str)+ where+   doc = lines >>> map text >>> foldr ($+$) empty++strDoc :: String -> Doc+strDoc str = doc (dropWhileEnd isSpace str)+ where+   doc :: String -> Doc+   doc = lines+         >>> map (words >>> map text >>> fsep)+         >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty
+ core/GhcMod/Read.hs view
@@ -0,0 +1,106 @@+module GhcMod.Read where++import Text.Read (readPrec_to_S, readPrec, minPrec)+import qualified Text.ParserCombinators.ReadP as P+import Text.ParserCombinators.ReadPrec (lift)++-- This library (libraries/base) is derived from code from several+-- sources:++--   * Code from the GHC project which is largely (c) The University of+--     Glasgow, and distributable under a BSD-style license (see below),++--   * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+--     and freely redistributable (but see the full license for+--     restrictions).++--   * Code from the Haskell Foreign Function Interface specification,+--     which is (c) Manuel M. T. Chakravarty and freely redistributable+--     (but see the full license for restrictions).++-- The full text of these licenses is reproduced below.  All of the+-- licenses are BSD-style or compatible.++-- -----------------------------------------------------------------------------++-- The Glasgow Haskell Compiler License++-- Copyright 2004, 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.++-- -----------------------------------------------------------------------------++-- Code derived from the document "Report on the Programming Language+-- Haskell 98", is distributed under the following license:++--   Copyright (c) 2002 Simon Peyton Jones++--   The authors intend this Report to belong to the entire Haskell+--   community, and so we grant permission to copy and distribute it for+--   any purpose, provided that it is reproduced in its entirety,+--   including this Notice.  Modified versions of this Report may also be+--   copied and distributed for any purpose, provided that the modified+--   version is clearly presented as such, and that it does not claim to+--   be a definition of the Haskell 98 Language.++-- -----------------------------------------------------------------------------++-- Code derived from the document "The Haskell 98 Foreign Function+-- Interface, An Addendum to the Haskell 98 Report" is distributed under+-- the following license:++--   Copyright (c) 2002 Manuel M. T. Chakravarty++--   The authors intend this Report to belong to the entire Haskell+--   community, and so we grant permission to copy and distribute it for+--   any purpose, provided that it is reproduced in its entirety,+--   including this Notice.  Modified versions of this Report may also be+--   copied and distributed for any purpose, provided that the modified+--   version is clearly presented as such, and that it does not claim to+--   be a definition of the Haskell 98 Foreign Function Interface.++-- -----------------------------------------------------------------------------++readEither :: Read a => String -> Either String a+readEither s =+  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+    [x] -> Right x+    []  -> Left "Prelude.read: no parse"+    _   -> Left "Prelude.read: ambiguous parse"+ where+  read' =+    do x <- readPrec+       lift P.skipSpaces+       return x++readMaybe :: Read a => String -> Maybe a+readMaybe s = case readEither s of+                Left _  -> Nothing+                Right a -> Just a
+ core/GhcMod/SrcUtils.hs view
@@ -0,0 +1,191 @@+-- TODO: remove CPP once Gap(ed)+{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GhcMod.SrcUtils where++import Control.Applicative+import CoreUtils (exprType)+import Data.Generics+import Data.Maybe+import Data.Ord as O+import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))+import Var (Var)+import qualified GHC as G+import qualified Var as G+import qualified Type as G+import GHC.SYB.Utils+import GhcMonad+import qualified Language.Haskell.Exts as HE+import GhcMod.Doc+import GhcMod.Gap+import qualified GhcMod.Gap as Gap+import OccName (OccName)+import Outputable (PprStyle)+import TcHsSyn (hsPatType)+import Prelude+import Control.Monad+import Data.List (nub)+import Control.Arrow+import qualified Data.Map as M++----------------------------------------------------------------++instance HasType (LHsExpr Id) where+    getType tcm e = do+        hs_env <- G.getSession+        mbe <- liftIO $ Gap.deSugar tcm e hs_env+        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe++instance HasType (LPat Id) where+    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)++----------------------------------------------------------------++-- | Stores mapping from monomorphic to polymorphic types+type CstGenQS = M.Map Var Type+-- | Generic type to simplify SYB definition+type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)++collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]+collectSpansTypes withConstraints tcs lc =+  -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree+  -- (but not left-to-right)+  everythingStagedWithContext TypeChecker M.empty (liftM2 (++))+    (return [])+    ((return [],)+      `mkQ`  (hsBind    :: CstGenQT G.LHsBind) -- matches on binds+      `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions+      `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns+      )+    (G.tm_typechecked_source tcs)+  where+    -- Helper function to insert mapping into CstGenQS+    insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)+    -- If there is AbsBinds here, insert mapping into CstGenQS if needed+    hsBind (L _ G.AbsBinds{abs_exports = es'}) s+      | withConstraints = (return [], foldr insExp s es')+      | otherwise       = (return [], s)+#if __GLASGOW_HASKELL__ >= 800+    -- TODO: move to Gap+    -- Note: this deals with bindings with explicit type signature, e.g.+    --    double :: Num a => a -> a+    --    double x = 2*x+    hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s+      | withConstraints =+          let new_s =+                case bind of+                  G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s+                  _ -> s+          in (return [], new_s)+      | otherwise       = (return [], s)+#endif+    -- Otherwise, it's the same as other cases+    hsBind x s = genericCT x s+    -- Generic SYB function to get type+    genericCT x s+      | withConstraints+      = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)+      | otherwise = (maybeToList <$> getType' x, s)+    -- Collects everything with Id from LHsBind, LHsExpr, or LPat+    collectBinders :: Data a => a -> [Id]+    collectBinders = listifyStaged TypeChecker (const True)+    -- Gets monomorphic type with location+    getType' x@(L spn _)+      | G.isGoodSrcSpan spn && spn `G.spans` lc+      = getType tcs x+      | otherwise = return Nothing+    -- Gets constrained type+    constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id+                    -> CstGenQS -- ^ Map from Id to polymorphic type+                    -> SrcSpan -- ^ extent of expression, copied to result+                    -> Type -- ^ monomorphic type+                    -> [(SrcSpan, Type)] -- ^ result+    constrainedType pids s spn genTyp =+      let+        -- runs build on every binder.+        ctys  = mapMaybe build (nub pids)+        -- Computes constrained type for x. Returns (constraints, substitutions)+        -- Substitutions are needed because type variables don't match+        -- between polymorphic and monomorphic types.+        -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()`+        build x | Just cti <- x `M.lookup` s+                = let+                    (preds', ctt) = getPreds cti+                    -- list of type variables in monomorphic type+                    vts = listifyStaged TypeChecker G.isTyVar $ G.varType x+                    -- list of type variables in polymorphic type+                    tvm = listifyStaged TypeChecker G.isTyVarTy ctt+                  in Just (preds', zip vts tvm)+                | otherwise = Nothing+        -- list of constraints+        preds = concatMap fst ctys+        -- Type variable substitutions+#if __GLASGOW_HASKELL__ >= 800+ -- TODO: move to Gap+        subs  = G.mkTvSubstPrs $ concatMap snd ctys+#else+        subs  = G.mkTopTvSubst $ concatMap snd ctys+#endif+        -- Constrained type+        ty    = G.substTy subs $ G.mkFunTys preds genTyp+      in [(spn, ty)]+    -- Splits a given type into list of constraints and simple type. Drops foralls.+    getPreds :: Type -> ([Type], Type)+    getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x+               | Just (c, t) <- G.splitFunTy_maybe x+               , G.isPredTy c = first (c:) $ getPreds t+               | otherwise = ([], x)++listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]+listifySpans tcs lc = listifyStaged TypeChecker p tcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]+listifyParsedSpans pcs lc = listifyStaged Parser p pcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]+listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))++cmp :: SrcSpan -> SrcSpan -> Ordering+cmp a b+  | a `G.isSubspanOf` b = O.LT+  | b `G.isSubspanOf` a = O.GT+  | otherwise           = O.EQ++toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)++fourInts :: SrcSpan -> (Int,Int,Int,Int)+fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan++fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)+fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc+                 , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)++-- Check whether (line,col) is inside a given SrcSpanInfo+typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool+typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE _  _ _= False++pretty :: DynFlags -> PprStyle -> Type -> String+pretty dflag style = showOneLine dflag style . Gap.typeForUser++showName :: DynFlags -> PprStyle -> G.Name -> String+showName dflag style name = showOneLine dflag style $ Gap.nameForUser name++showOccName :: DynFlags -> PprStyle -> OccName -> String+showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name
+ core/GhcMod/Stack.hs view
@@ -0,0 +1,97 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 GhcMod.Stack where++import Safe+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Data.List+import Data.List.Split+import Data.Maybe+import System.Directory+import System.FilePath+import System.Info.Extra+import Exception++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Output+import GhcMod.Logging+import GhcMod.Error+import qualified GhcMod.Utils as U+import Prelude++patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs+patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do+  Just ghc <- getStackGhcPath senv+  Just ghcPkg <- getStackGhcPkgPath senv+  return $ progs {+      ghcProgram = ghc+    , ghcPkgProgram = ghcPkg+    }+patchStackPrograms _crdl progs = return progs++getStackEnv :: (IOish m, GmOut m, GmLog m)+            => FilePath -> FilePath -> m (Maybe StackEnv)+getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do+    env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"]+    let look k = fromJustNote "getStackEnv" $ lookup k env+    return StackEnv {+        seDistDir       = look "dist-dir"+      , seBinPath       = splitSearchPath $ look "bin-path"+      , seSnapshotPkgDb = look "snapshot-pkg-db"+      , seLocalPkgDb    = look "local-pkg-db"+      }+ where+   liToTup [k,v] = (k,v)+   liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")+   liToTup _ = error "getStackEnv"++getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)+getStackGhcPath = findExecutablesInStackBinPath "ghc"++getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)+getStackGhcPkgPath = findExecutablesInStackBinPath  "ghc-pkg"++findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)+findExecutablesInStackBinPath exe StackEnv {..} =+    liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe++findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]+findExecutablesInDirectories' path binary =+    U.findFilesWith' isExecutable path (binary <.> exeExtension')+   where isExecutable file = do+             perms <- getPermissions file+             return $ executable perms++         exeExtension' = if isWindows then "exe" else ""++readStack :: (IOish m, GmOut m, GmLog m)+          => FilePath -> [String] -> MaybeT m String+readStack exe args = do+  stack <- MaybeT $ liftIO $ findExecutable exe+  readProc <- lift gmReadProcess+  flip gcatch handler $ do+    liftIO $ evaluate =<< readProc stack args ""+ where+   handler (e :: IOError) = do+     gmLog GmWarning "readStack" $ gmeDoc $ exToErr e+     mzero+   exToErr = GMEStackBootstrap . GMEString . show
+ core/GhcMod/Target.hs view
@@ -0,0 +1,515 @@+-- ghc-mod: Happy Haskell Hacking+-- 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, ViewPatterns, NamedFieldPuns, RankNTypes #-}+module GhcMod.Target where++import Control.Arrow+import Control.Applicative+import Control.Category ((.))+import GHC+#if __GLASGOW_HASKELL__ >= 800+import GHC.LanguageExtensions+#endif+import GHC.Paths (libdir)+import SysTools+import DynFlags+import HscTypes+import Pretty++import GhcMod.DynFlags+import GhcMod.Monad.Types+import GhcMod.CabalHelper+import GhcMod.HomeModuleGraph+import GhcMod.PathsAndFiles+import GhcMod.GhcPkg+import GhcMod.Error+import GhcMod.Logging+import GhcMod.Types+import GhcMod.Utils as U+import GhcMod.FileMapping+import GhcMod.LightGhc+import GhcMod.CustomPackageDb+import GhcMod.Output++import Safe+import Data.Maybe+import Data.Monoid as Monoid+import Data.Either+import Data.Foldable as Foldable (foldrM)+import qualified Data.Foldable as Foldable+import Data.Traversable hiding (mapM, forM)+import Data.IORef+import Data.List+import Data.Map (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Function (on)+import Distribution.Helper+import Prelude hiding ((.))++import System.Directory+import System.FilePath++runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a+runGmPkgGhc action = do+    pkgOpts <- packageGhcOptions+    withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action++initSession :: IOish m+            => [GHCOption]+            -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+            -> GhcModT m ()+initSession opts mdf = do+   s <- gmsGet+   case gmGhcSession s of+     Nothing -> do+         gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"+         putNewSession s+     Just (GmGhcSession hsc_env_ref) -> do+         crdl <- cradle++         df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref+         changed <-+             withLightHscEnv' (initDF crdl) $ \hsc_env ->+               return $ not $ hsc_dflags hsc_env `eqDynFlags` df++         if changed+            then do+              gmLog GmDebug "initSession" $ text "Flags changed, creating new session"+              teardownSession hsc_env_ref+              putNewSession s+            else+              gmLog GmDebug "initSession" $ text "Session already initialized"+ where+   initDF Cradle { cradleTempDir } df =+       setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)++   teardownSession hsc_env_ref = do+     hsc_env <- liftIO $ readIORef hsc_env_ref+     teardownLightEnv hsc_env++   putNewSession :: IOish m => GhcModState -> GhcModT m ()+   putNewSession s = do+     crdl <- cradle+     nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl)+     runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags+     gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref }+++-- | Drop the currently active GHC session, the next that requires a GHC session+-- will initialize a new one.+dropSession :: IOish m => GhcModT m ()+dropSession = do+  s <- gmsGet+  case gmGhcSession s of+    Just (GmGhcSession ref) -> do+      -- TODO: This is still not enough, there seem to still be references to+      -- GHC's state around afterwards.+      liftIO $ writeIORef ref (error "HscEnv: session was dropped")+      -- Not available on ghc<7.8; didn't really help anyways+      -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")+      gmsPut s { gmGhcSession = Nothing }++    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]+              -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+              -> GmlT m a+              -> 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]+                 -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+                 -> (GmlT m a -> GmlT m b)+                 -> GmlT m a+                 -> GhcModT m b+runGmlTWith efnmns' mdf wrapper action = do+    crdl <- cradle+    Options { optGhcUserOptions } <- options++    let (fns, mns) = partitionEithers efnmns'+        ccfns = map (cradleCurrentDir crdl </>) fns+    cfns <- mapM getCanonicalFileNameSafe ccfns+    let serfnmn = Set.fromList $ map Right mns ++ map Left cfns+    opts <- targetGhcOptions crdl serfnmn+    let opts' = opts ++ ["-O0"] ++ optGhcUserOptions++    gmVomit+      "session-ghc-options"+      (text "Initializing GHC session with following options")+      (intercalate " " $ map (("\""++) . (++"\"")) opts')++    GhcModLog { gmLogLevel = Just level } <- gmlHistory+    putErr <- gmErrStrIO+    let setLogger | level >= GmDebug = setDebugLogger putErr+                  | otherwise = setEmptyLogger++    initSession opts' $+        setHscNothing >>> setLogger >>> mdf++    mappedStrs <- getMMappedFilePaths+    let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns++    unGmlT $ wrapper $ do+      loadTargets opts targetStrs+      action++targetGhcOptions :: forall m. IOish m+                  => Cradle+                  -> Set (Either FilePath ModuleName)+                  -> GhcModT m [GHCOption]+targetGhcOptions crdl sefnmn = do+    when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"++    case cradleProject crdl of+      proj+          | isCabalHelperProject proj -> cabalOpts crdl+          | otherwise -> sandboxOpts crdl+ where+   zipMap f l = l `zip` (f `map` l)++   cabalOpts :: Cradle -> GhcModT m [String]+   cabalOpts Cradle{..} = do+       mcs <- cabalResolvedComponents++       let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+           candidates = findCandidates $ map snd mdlcs++       let noCandidates = Set.null candidates+           noModuleHasAnyAssignment = all (Set.null . snd) mdlcs++       if noCandidates && noModuleHasAnyAssignment+          then do+            -- First component should be ChLibName, if no lib will take lexically first exe.+            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 $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs+          else do+            when noCandidates $+              throwError $ GMECabalCompAssignment mdlcs++            let cn = pickComponent candidates+            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs++resolvedComponentsCache :: IOish m => FilePath ->+    Cached (GhcModT m) GhcModState+    [GmComponent 'GMCRaw (Set.Set ModulePath)]+    (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+resolvedComponentsCache distdir = Cached {+    cacheLens = Just (lGmcResolvedComponents . lGmCaches),+    cacheFile = resolvedComponentsCacheFile distdir,+    cachedAction = \tcfs comps ma -> do+        Cradle {..} <- cradle+        let iifs = invalidatingInputFiles tcfs++            setupChanged =+                (cradleRootDir </> setupConfigPath distdir) `elem` iifs++            mums :: Maybe [Either FilePath ModuleName]+            mums =+              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++            changed = map (text . mdesc) $ Foldable.concat mums+            changedDoc | [] <- changed = text "none"+                       | otherwise = sep changed++        gmLog GmDebug "resolvedComponentsCache" $+              text "files changed" <+>: changedDoc++        mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps++        return (setupConfigPath distdir : flatten mcs , mcs)+ }++ where+   flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))+           -> [FilePath]+   flatten = Map.elems+      >>> map (gmcHomeModuleGraph >>> gmgGraph+               >>> (Map.keysSet &&& Map.elems)+               >>> uncurry insert+               >>> map (Set.map mpPath)+               >>> Set.unions+              )+      >>> Set.unions+      >>> Set.toList++moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))+                 -> Either FilePath ModuleName+                 -> Set ChComponentName+moduleComponents m efnmn =+    foldr' Set.empty m $ \c s ->+        let+            memb =+              case efnmn of+                Left fn  -> fn `Set.member` Set.map mpPath (smp c)+                Right mn -> mn `Set.member` Set.map mpModule (smp c)+        in if memb+           then Set.insert (gmcName c) s+           else s+ where+   smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c++   foldr' b as f = Map.foldr f b as+++findCandidates :: [Set ChComponentName] -> Set ChComponentName+findCandidates [] = Set.empty+findCandidates scns = foldl1 Set.intersection scns++pickComponent :: Set ChComponentName -> ChComponentName+pickComponent scn = Set.findMin scn++packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption]+packageGhcOptions = do+    crdl <- cradle+    case cradleProject crdl of+      proj+          | isCabalHelperProject proj -> getGhcMergedPkgOptions+          | otherwise -> sandboxOpts crdl++-- also works for plain projects!+sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]+sandboxOpts crdl = do+    mCusPkgDb <- getCustomPkgDbStack+    pkgDbStack <- liftIO $ getSandboxPackageDbStack+    let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb+    return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]+  where+    (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)++    getSandboxPackageDbStack :: IO [GhcPkgDb]+    getSandboxPackageDbStack =+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl++resolveGmComponent :: (IOish m, Gm m)+    => Maybe [CompilationUnit] -- ^ Updated modules+    -> GmComponent 'GMCRaw (Set ModulePath)+    -> m (GmComponent 'GMCResolved (Set ModulePath))+resolveGmComponent mums c@GmComponent {..} = do+  distDir <- cradleDistDir <$> cradle+  gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir+  withLightHscEnv (ghcOpts distDir) $ \env -> do+    let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+    let mg = gmcHomeModuleGraph+    let simp = gmcEntrypoints+    sump <- case mums of+        Nothing -> return simp+        Just ums ->+            Set.fromList . catMaybes <$>+               mapM (resolveModule env srcDirs) ums++    mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump++    return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }++ where ghcOpts distDir = concat [+           gmcGhcSrcOpts,+           gmcGhcLangOpts,+           [ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]+        ]++resolveEntrypoint :: (IOish m, Gm m)+    => Cradle+    -> GmComponent 'GMCRaw ChEntrypoint+    -> m (GmComponent 'GMCRaw (Set ModulePath))+resolveEntrypoint Cradle {..} c@GmComponent {..} = do+    gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts+    withLightHscEnv gmcGhcSrcOpts $ \env -> do+      let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+      eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints+      rms <- resolveModule env srcDirs `mapM` eps+      return c { gmcEntrypoints = Set.fromList $ catMaybes rms }++-- 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]+resolveChEntrypoints _ (ChLibEntrypoint em om) =+    return $ map (Right . chModToMod) (em ++ om)++resolveChEntrypoints _ (ChExeEntrypoint main om) =+    return $ [Left main] ++ map (Right . chModToMod) om++resolveChEntrypoints srcDir ChSetupEntrypoint = do+  shs <- doesFileExist (srcDir </> "Setup.hs")+  slhs <- doesFileExist (srcDir </> "Setup.lhs")+  return $ case (shs, slhs) of+    (True, _) -> [Left "Setup.hs"]+    (_, True) -> [Left "Setup.lhs"]+    (False, False) -> []++chModToMod :: ChModuleName -> ModuleName+chModToMod (ChModuleName mn) = mkModuleName mn+++resolveModule :: (IOish m, Gm m) =>+  HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)+resolveModule env _srcDirs (Right mn) =+    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn+resolveModule env srcDirs (Left fn') = do+    mfn <-  liftIO $ findFile' srcDirs fn'+    case mfn of+      Nothing -> return Nothing+      Just fn'' -> do+          fn <-  liftIO $ canonicalizePath fn''+          emn <- fileModuleName env fn+          case emn of+              Left errs -> do+                gmLog GmWarning ("resolveModule " ++ show fn) $+                  Pretty.empty $+$ (vcat $ map text errs)+                return Nothing -- TODO: should expose these errors otherwise+                               -- modules with preprocessor/parse errors are+                               -- going to be missing+              Right mmn -> return $ Just $+                  case mmn of+                    Nothing -> mkMainModulePath fn+                    Just mn -> ModulePath mn fn+ where+   -- needed for ghc 7.4+   findFile' dirs file =+       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs++   -- fileModuleName fn (dir:dirs)+   --     | 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], ResolvedComponentsMap)+        -- ^ Updated modules+    -> 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+    return m'++ where+   foldrM' b fa f = foldrM f b fa+   insertUpdated m c = do+     rc <- resolveGmComponent (fst <$> mcache) c+     return $ Map.insert (gmcName rc) rc m++   same :: Eq b+        => (forall t a. GmComponent t a -> b)+        -> GmComponent u c -> GmComponent v d -> Bool+   same f a b = (f a) == (f b)++-- | Set the files as targets and load them.+loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()+loadTargets opts targetStrs = do+    targets' <-+        withLightHscEnv opts $ \env ->+                liftM (nubBy ((==) `on` targetId))+                  (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)+              >>= mapM relativize++    let targets = map (\t -> t { targetAllowObjCode = False }) targets'++    gmLog GmDebug "loadTargets" $+          text "Loading" <+>: fsep (map (text . showTargetId) targets)++    setTargets targets++    mg <- depanal [] False++    let interp = needsHscInterpreted mg+    target <- hscTarget <$> getSessionDynFlags+    when (interp && target /= HscInterpreted) $ do+      _ <- 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+        forM_ mg $+          handleSourceError (gmLog GmDebug "loadTargets" . text . show)+          . void . (parseModule >=> typecheckModule >=> desugarModule)+      HscInterpreted -> do+        void $ load LoadAllTargets+      _ -> error ("loadTargets: unsupported hscTarget")++    gmLog GmDebug "loadTargets" $ text "Loading done"++  where+    relativize (Target (TargetFile filePath phase) taoc src) = do+      crdl <- cradle+      let tid = TargetFile relativeFilePath phase+          relativeFilePath = makeRelative (cradleRootDir crdl) filePath+      return $ Target tid taoc src+    relativize tgt = return tgt++    showTargetId (Target (TargetModule s) _ _) = moduleNameString s+    showTargetId (Target (TargetFile s _) _ _) = s++needsHscInterpreted :: ModuleGraph -> Bool+needsHscInterpreted = any $ \ms ->+                let df = ms_hspp_opts ms in+#if __GLASGOW_HASKELL__ >= 800+                   TemplateHaskell `xopt` df+                || QuasiQuotes     `xopt` df+                || PatternSynonyms `xopt` df+#else+                   Opt_TemplateHaskell `xopt` df+                || Opt_QuasiQuotes     `xopt` df+#if __GLASGOW_HASKELL__ >= 708+                || (Opt_PatternSynonyms `xopt` df)+#endif+#endif++cabalResolvedComponents :: (IOish m) =>+   GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))+cabalResolvedComponents = do+    crdl@(Cradle{..}) <- cradle+    comps <- mapM (resolveEntrypoint crdl) =<< getComponents+    withAutogen $+      cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps
+ core/GhcMod/Types.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,+  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,+  GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}+module GhcMod.Types (+    module GhcMod.Types+  , ModuleName+  , mkModuleName+  , moduleNameString+  ) where++import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Error (Error(..))+import qualified Control.Monad.IO.Class as MTL+import Control.Exception (Exception)+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.DeepSeq+import Data.Binary+import Data.Binary.Generic+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Monoid+import Data.Maybe+import Data.Typeable (Typeable)+import Data.IORef+import Data.Label.Derive+import Distribution.Helper hiding (Programs(..))+import qualified Distribution.Helper as CabalHelper+import Exception (ExceptionMonad)+#if __GLASGOW_HASKELL__ < 708+import qualified MonadUtils as GHC (MonadIO(..))+#endif+import GHC (ModuleName, moduleNameString, mkModuleName)+import HscTypes (HscEnv)+import GHC.Generics+import Pretty (Doc)+import Prelude++import GhcMod.Caching.Types++-- | A constraint alias (-XConstraintKinds) to make functions dealing with+-- 'GhcModT' somewhat cleaner.+--+-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and+-- exception handling. Usually this will simply be 'IO' but we parametrise it in+-- the exported API so users have the option to use a custom inner monad.+type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)+++-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.+#if __GLASGOW_HASKELL__ < 708+type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)+#else+type MonadIOC m = (MTL.MonadIO m)+#endif++class MonadIOC m => MonadIO m where+  liftIO :: IO a -> m a++-- | Output style.+data OutputStyle = LispStyle  -- ^ S expression style.+                 | PlainStyle -- ^ Plain textstyle.+                   deriving (Show)++-- | The type for line separator. Historically, a Null string is used.+newtype LineSeparator = LineSeparator String deriving (Show)++data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}+                  deriving (Eq, Show)++type FileMappingMap = Map FilePath FileMapping++data ProgramSource = ProgramSourceUser | ProgramSourceStack++data Programs = Programs {+  -- | @ghc@ program name.+    ghcProgram    :: FilePath+  -- | @ghc-pkg@ program name.+  , ghcPkgProgram :: FilePath+  -- | @cabal@ program name.+  , cabalProgram  :: FilePath+  -- | @stack@ program name.+  , stackProgram   :: FilePath+  } deriving (Show)++data OutputOpts = OutputOpts {+  -- | Verbosity+    ooptLogLevel      :: GmLogLevel+  , ooptStyle         :: OutputStyle+  -- | Line separator string.+  , ooptLineSeparator :: LineSeparator+  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,+  -- @snd@ is stderr prefix.+  , ooptLinePrefix    :: Maybe (String, String)+  } deriving (Show)++data Options = Options {+    optOutput         :: OutputOpts+  , optPrograms       :: Programs+    -- | GHC command line options set on the @ghc-mod@ command line+  , optGhcUserOptions :: [GHCOption]+  , optFileMappings   :: [(FilePath, Maybe FilePath)]+  , optEncoding       :: String+  , optStackBuildDeps :: Bool+  } deriving (Show)++-- | A default 'Options'.+defaultOptions :: Options+defaultOptions = Options {+    optOutput     = OutputOpts {+      ooptLogLevel       = GmWarning+    , ooptStyle          = PlainStyle+    , ooptLineSeparator  = LineSeparator "\0"+    , ooptLinePrefix     = Nothing+    }+  , optPrograms       = Programs {+      ghcProgram     = "ghc"+    , ghcPkgProgram  = "ghc-pkg"+    , cabalProgram   = "cabal"+    , stackProgram   = "stack"+    }+  , optGhcUserOptions = []+  , optFileMappings   = []+  , optEncoding       = "UTF-8"+  , optStackBuildDeps = False+  }++----------------------------------------------------------------++data Project = CabalProject+             | SandboxProject+             | PlainProject+             | StackProject StackEnv+               deriving (Eq, Show, Ord)++isCabalHelperProject :: Project -> Bool+isCabalHelperProject StackProject {} = True+isCabalHelperProject CabalProject {} = True+isCabalHelperProject _ = False++data StackEnv = StackEnv {+      seDistDir       :: FilePath+    , seBinPath       :: [FilePath]+    , seSnapshotPkgDb :: FilePath+    , seLocalPkgDb    :: FilePath+    } deriving (Eq, Show, Ord)++-- | The environment where this library is used.+data Cradle = Cradle {+    cradleProject    :: Project+  -- | The directory where this library is executed.+  , cradleCurrentDir :: FilePath+  -- | The project root directory.+  , cradleRootDir    :: FilePath+  -- | Per-Project temporary directory+  , cradleTempDir    :: FilePath+  -- | The file name of the found cabal file.+  , cradleCabalFile  :: Maybe FilePath+  -- | The build info directory.+  , cradleDistDir    :: FilePath+  } deriving (Eq, Show, Ord)++data GmStream = GmOutStream | GmErrStream+                deriving (Show)++data GhcModEnv = GhcModEnv {+      gmOptions    :: Options+    , gmCradle     :: Cradle+    }++data GhcModOut = GhcModOut {+      gmoOptions :: OutputOpts+    , gmoChan    :: Chan (Either (MVar ()) (GmStream, String))+    }++data GhcModLog = GhcModLog {+      gmLogLevel     :: Maybe GmLogLevel,+      gmLogVomitDump :: Last Bool,+      gmLogMessages  :: [(GmLogLevel, String, Doc)]+    } deriving (Show)++instance Monoid GhcModLog where+    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty+    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =+        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')++data GmGhcSession = GmGhcSession {+      gmgsSession :: !(IORef HscEnv)+    }++data GhcModCaches = GhcModCaches {+      gmcPackageDbStack   :: CacheContents ChCacheData [GhcPkgDb]+    , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]+    , gmcComponents       :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]+    , gmcResolvedComponents :: CacheContents+          [GmComponent 'GMCRaw (Set.Set ModulePath)]+          (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+    }++data GhcModState = GhcModState {+      gmGhcSession   :: !(Maybe GmGhcSession)+    , gmCaches       :: !GhcModCaches+    , gmMMappedFiles :: !FileMappingMap+    }++defaultGhcModState :: GhcModState+defaultGhcModState =+    GhcModState n (GhcModCaches n n n n) Map.empty+ where n = Nothing++----------------------------------------------------------------++-- | GHC package database flags.+data GhcPkgDb = GlobalDb+              | UserDb+              | PackageDb String+                deriving (Eq, Show, Generic)++instance Binary GhcPkgDb where+    put = ggput . from+    get = to `fmap` ggget++-- | A single GHC command line option.+type GHCOption = String++-- | An include directory for modules.+type IncludeDir = FilePath++-- | Haskell expression.+newtype Expression = Expression { getExpression :: String }+  deriving (Show, Eq, Ord)++-- | Module name.+newtype ModuleString = ModuleString { getModuleString :: String }+  deriving (Show, Eq, Ord, Binary, NFData)++data GmLogLevel =+    GmSilent+  | GmPanic+  | GmException+  | GmError+  | GmWarning+  | GmInfo+  | GmDebug+  | GmVomit+    deriving (Eq, Ord, Enum, Bounded, Show, Read)++data GmModuleGraph = GmModuleGraph {+    gmgGraph :: Map ModulePath (Set ModulePath)+  } deriving (Eq, Ord, Show, Read, Generic, Typeable)++instance Binary GmModuleGraph where+  put GmModuleGraph {..} = put (mpim, graph)+    where+      mpim :: Map ModulePath Integer+      mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]+      graph :: Map Integer (Set Integer)+      graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph+      mpToInt :: ModulePath -> Integer+      mpToInt mp = fromJust $ Map.lookup mp mpim++  get = do+    (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get+    let impm = swapMap mpim+        intToMp i = fromJust $ Map.lookup i impm+        mpGraph :: Map ModulePath (Set ModulePath)+        mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph+    return $ GmModuleGraph mpGraph+    where+      swapMap :: Ord v => Map k v -> Map v k+      swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList++instance Monoid GmModuleGraph where+  mempty  = GmModuleGraph mempty+  mappend (GmModuleGraph a) (GmModuleGraph a') =+    GmModuleGraph (Map.unionWith Set.union a a')++data GmComponentType = GMCRaw+                     | GMCResolved+data GmComponent (t :: GmComponentType) eps = GmComponent {+    gmcHomeModuleGraph :: GmModuleGraph+  , gmcName            :: ChComponentName+  , gmcGhcOpts         :: [GHCOption]+  , gmcGhcPkgOpts      :: [GHCOption]+  , gmcGhcSrcOpts      :: [GHCOption]+  , gmcGhcLangOpts     :: [GHCOption]+  , gmcRawEntrypoints  :: ChEntrypoint+  , gmcEntrypoints     :: eps+  , gmcSourceDirs      :: [FilePath]+  } deriving (Eq, Ord, Show, Read, Generic, Functor)++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 Binary ModulePath where+    put = ggput . from+    get = to `fmap` ggget++instance Binary ModuleName where+  get = mkModuleName <$> get+  put mn = put (moduleNameString mn)++instance Show ModuleName where+  show mn = "ModuleName " ++ show (moduleNameString mn)++instance Read ModuleName where+  readsPrec d =+    readParen+      (d > app_prec)+      (\r' -> [ (mkModuleName m, t)+              | ("ModuleName", s) <- lex r'+              , (m, t)            <- readsPrec (app_prec + 1) s+              ])+    where+      app_prec = 10++data GhcModError+  = GMENoMsg+  -- ^ Unknown error++  | GMEString String+  -- ^ Some Error with a message. These are produced mostly by+  -- 'fail' calls on GhcModT.++  | GMECabalConfigure GhcModError+  -- ^ Configuring a cabal project failed.++  | GMEStackConfigure GhcModError+  -- ^ Configuring a stack project failed.++  | GMEStackBootstrap GhcModError+    -- ^ Bootstrapping @stack@ environment failed (process exited with failure)++  | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]+  -- ^ Could not find a consistent component assignment for modules++  | GMEProcess String String [String] (Either Int GhcModError)+  -- ^ Launching an operating system process failed. Fields in+  -- order: function, command, arguments, (stdout, stderr, exitcode)++  | GMENoCabalFile+  -- ^ No cabal file found.++  | GMETooManyCabalFiles [FilePath]+  -- ^ Too many cabal files found.++    deriving (Eq,Show,Typeable)++instance Error GhcModError where+  noMsg  = GMENoMsg+  strMsg = GMEString++instance Exception GhcModError++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++-- | 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.+      , optBrowseParents        :: Bool+        -- ^ If 'True', "browseWith" also returns parents.+      , optBrowseQualified      :: Bool+        -- ^ If 'True', "browseWith" will return fully qualified name+    } deriving (Show)++-- | Default "BrowseOpts" instance+defaultBrowseOpts :: BrowseOpts+defaultBrowseOpts = BrowseOpts False False False False++mkLabel ''GhcModCaches+mkLabel ''GhcModState+mkLabel ''Options+mkLabel ''OutputOpts+mkLabel ''Programs
+ core/GhcMod/Utils.hs view
@@ -0,0 +1,165 @@+-- ghc-mod: Happy Haskell Hacking+-- 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 #-}+{-# LANGUAGE DoAndIfThenElse #-}++module GhcMod.Utils (+    module GhcMod.Utils+  , module Utils+  , readProcess+  ) where++import Control.Applicative+import Data.Char+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Either (rights)+import Data.List (inits)+import Exception+import GhcMod.Error+import GhcMod.Types+import GhcMod.Monad.Types+import System.Directory+import System.Environment+import System.FilePath+import System.IO.Temp (createTempDirectory)+import System.Process (readProcess)+import Text.Printf++import Paths_ghc_mod (getLibexecDir, getBinDir)+import Utils+import Prelude++-- dropWhileEnd is not provided prior to base 4.5.0.0.+dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []++withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a+withDirectory_ dir action =+  gbracket+    (liftIO getCurrentDirectory)+    (liftIO . setCurrentDirectory)+    (\_ -> liftIO (setCurrentDirectory dir) >> action)++uniqTempDirName :: FilePath -> FilePath+uniqTempDirName dir =+  "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path+  where+    (drive, path) = splitDrive dir+    escapeDriveChar :: Char -> Char+    escapeDriveChar c+      | isAlphaNum c = c+      | otherwise     = '-'+    escapePathChar :: Char -> Char+    escapePathChar c+      | c `elem` pathSeparators = '-'+      | otherwise               = c++newTempDir :: FilePath -> IO FilePath+newTempDir _dir =+  flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory++whenM :: Monad m => m Bool -> m () -> m ()+whenM mb ma = mb >>= flip when ma++-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6+-- this is a guess but >=7.6 uses 'getExecutablePath'.+ghcModExecutable :: IO FilePath+ghcModExecutable = do+    exe <- getExecutablePath'+    stack <- lookupEnv "STACK_EXE"+    case takeBaseName exe of+      "spec" | Just _ <- stack ->+          (</> "ghc-mod") <$> getBinDir+      "spec" ->+          (</> "dist/build/ghc-mod/ghc-mod") <$> getCurrentDirectory+      "ghc-mod" ->+          return exe+      _ ->+          return $ takeDirectory exe </> "ghc-mod"++getExecutablePath' :: IO FilePath+#if __GLASGOW_HASKELL__ >= 706+getExecutablePath' = getExecutablePath+#else+getExecutablePath' = getProgName+#endif++canonFilePath :: FilePath -> IO FilePath+canonFilePath f = do+  p <- canonicalizePath f+  e <- doesFileExist p+  when (not e) $ error $ "canonFilePath: not a file: " ++ p+  return p++withMappedFile :: (IOish m, GmState m, GmEnv m) =>+                  forall a. FilePath -> (FilePath -> m a) -> m a+withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile+  where+    runWithFile (Just to) = action $ fmPath to+    runWithFile _ = action file++getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath+getCanonicalFileNameSafe fn = do+  let fn' = normalise fn+  pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')+  return $+    if (length pl > 0)+    then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))+    else error "Current dir doesn't seem to exist?"+  where+#if __GLASGOW_HASKELL__ < 710+    splitPath' = (".":) . splitPath+#else+    splitPath' = splitPath+#endif++mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)+mkRevRedirMapFunc = do+  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles+  crdl <- cradle+  return $ \key ->+    fromMaybe key+    $ makeRelative (cradleRootDir crdl)+    <$> M.lookup key rm+  where+    mf :: FilePath -> FileMapping -> (FilePath, FilePath)+    mf from to = (fmPath to, from)++findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]+findFilesWith' _ [] _ = return []+findFilesWith' f (d:ds) fileName = do+    let file = d </> fileName+    exist <- doesFileExist file+    b <- if exist then f file else return False+    if b then do+               files <- findFilesWith' f ds fileName+               return $ file : files+        else findFilesWith' f ds fileName+++-- Copyright   :  (c) The University of Glasgow 2001+-- | Make a path absolute by prepending the current directory (if it isn't+-- already absolute) and applying 'normalise' to the result.+--+-- If the path is already absolute, the operation never fails.  Otherwise, the+-- operation may fail with the same exceptions as 'getCurrentDirectory'.+makeAbsolute' :: FilePath -> IO FilePath+makeAbsolute' = (normalise <$>) . absolutize+  where absolutize path -- avoid the call to `getCurrentDirectory` if we can+          | isRelative path = (</> path) <$> getCurrentDirectory+          | otherwise       = return path
+ core/GhcMod/World.hs view
@@ -0,0 +1,55 @@+module GhcMod.World where++import GhcMod.GhcPkg+import GhcMod.PathsAndFiles+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Utils++import Control.Applicative+import Data.Maybe+import Data.Traversable hiding (mapM)+import System.FilePath ((</>))++import GHC.Paths (libdir)+import Prelude++data World = World {+    worldPackageCaches :: [TimedFile]+  , worldCabalFile     :: Maybe TimedFile+  , worldCabalConfig   :: Maybe TimedFile+  , worldCabalSandboxConfig :: Maybe TimedFile+  , worldMappedFiles   :: FileMappingMap+  } deriving (Eq)++timedPackageCaches :: IOish m => GhcModT m [TimedFile]+timedPackageCaches = do+    fs <- mapM (liftIO . mightExist) . map (</> packageCache)+            =<< getPackageCachePaths libdir+    (liftIO . timeFile) `mapM` catMaybes fs++getCurrentWorld :: IOish m => GhcModT m World+getCurrentWorld = do+    crdl <- cradle+    pkgCaches    <- timedPackageCaches+    mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)+    mFileMap     <- getMMappedFiles++    return World {+        worldPackageCaches = pkgCaches+      , worldCabalFile     = mCabalFile+      , worldCabalConfig   = mCabalConfig+      , worldCabalSandboxConfig = mCabalSandboxConfig+      , worldMappedFiles   = mFileMap+      }++didWorldChange :: IOish m => World -> GhcModT m Bool+didWorldChange world = do+    (world /=) <$> getCurrentWorld++isYoungerThanSetupConfig :: FilePath -> World -> IO Bool+isYoungerThanSetupConfig file World {..} = do+  tfile <- timeFile file+  return $ worldCabalConfig < Just tfile
elisp/ghc-func.el view
@@ -211,7 +211,7 @@ 		      default-directory))) ;; ghc-mod root 	(with-temp-buffer 	  (let ((default-directory cdir))-	    (apply 'ghc-call-process target nil t nil+	    (apply 'ghc-call-process target nil '(t nil) nil 		   (append (ghc-make-ghc-options) cmds)) 	    (buffer-substring (point-min) (1- (point-max)))))))))
elisp/ghc-process.el view
@@ -55,7 +55,7 @@ 	(let ((pro (ghc-get-process cpro name buf root)) 	      (map-cmd (format "map-file %s\n" file))) ;	       (unmap-cmd (format "unmap-file %s\n" file)))-	  (when (buffer-modified-p (current-buffer))+	  (when (buffer-modified-p cbuf) 	    (setq ghc-process-file-mapping t) 	    (setq ghc-process-async-after-callback nil) 	    (erase-buffer)
elisp/ghc.el view
@@ -28,7 +28,7 @@ 	       (< emacs-minor-version minor)))       (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.5.0.0")+(defconst ghc-version "5.8.0.0")  (defgroup ghc-mod '() "ghc-mod customization")
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name:                   ghc-mod-Version:                5.5.0.0+Version:                5.8.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,                         Daniel Gröber <dxld@darkboxed.org>,                         Alejandro Serrano <trupill@gmail.com>,@@ -8,8 +8,8 @@ License:                AGPL-3 License-File:           LICENSE License-Files:          COPYING.BSD3 COPYING.AGPL3-Homepage:               http://www.mew.org/~kazu/proj/ghc-mod/-Synopsis:               Happy Haskell Programming+Homepage:               https://github.com/DanielG/ghc-mod+Synopsis:               Happy Haskell Hacking Description:   ghc-mod is a backend program to enrich Haskell programming in editors. It   strives to offer most of the features one has come to expect from modern IDEs@@ -22,38 +22,30 @@   significantly extend ghc-mod you should submit these changes upstream instead   of implementing them on top of the library. -  For more information, please see its home page.  Category:               GHC, Development-Cabal-Version:          >= 1.14+Cabal-Version:          >= 1.18 Build-Type:             Custom Data-Files:             elisp/Makefile                         elisp/*.el-Data-Files:             LICENSE COPYING.BSD3 COPYING.AGPL3 Extra-Source-Files:     ChangeLog-                        SetupCompat.hs-                        NotCPP/*.hs-                        NotCPP/COPYING-                        Language/Haskell/GhcMod/Monad/Compat.hs_h+                        README.md+                        core/GhcMod/Monad/Compat.hs_h                         test/data/annotations/*.hs                         test/data/broken-cabal/*.cabal-                        test/data/broken-cabal/cabal.sandbox.config.in                         test/data/broken-sandbox/cabal.sandbox.config                         test/data/broken-sandbox/dummy.cabal                         test/data/cabal-flags/cabal-flags.cabal                         test/data/cabal-project/*.cabal                         test/data/cabal-project/*.hs                         test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf-                        test/data/cabal-project/cabal.sandbox.config.in                         test/data/cabal-project/subdir1/subdir2/dummy                         test/data/case-split/*.hs-                        test/data/check-packageid/cabal.sandbox.config.in                         test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf                         test/data/check-test-subdir/*.cabal                         test/data/check-test-subdir/src/Check/Test/*.hs                         test/data/check-test-subdir/test/*.hs                         test/data/check-test-subdir/test/Bar/*.hs-                        test/data/duplicate-pkgver/cabal.sandbox.config.in                         test/data/duplicate-pkgver/duplicate-pkgver.cabal                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf@@ -88,158 +80,193 @@                         test/data/file-mapping/preprocessor/*.hs                         test/data/file-mapping/lhs/*.lhs                         test/data/nice-qualification/*.hs-                        test/data/stack-project/stack.yaml+                        test/data/stack-project/stack.yaml.in                         test/data/stack-project/new-template.cabal                         test/data/stack-project/*.hs                         test/data/stack-project/app/*.hs                         test/data/stack-project/src/*.hs                         test/data/stack-project/test/*.hs+                        bench/data/simple-cabal/simple-cabal.cabal+                        bench/data/simple-cabal/*.hs ++Custom-Setup+  Setup-Depends:         base+                       , Cabal >= 1.18 && < 1.25+                       , containers+                       , filepath+                       , directory+                       , process+                       , template-haskell+                       , transformers++ Library   Default-Language:     Haskell2010   GHC-Options:          -Wall -fno-warn-deprecations   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,                         ConstraintKinds, FlexibleContexts,                         DataKinds, KindSignatures, TypeOperators, ViewPatterns-  Exposed-Modules:      Language.Haskell.GhcMod-                        Language.Haskell.GhcMod.Internal-                        Language.Haskell.GhcMod.Boot-                        Language.Haskell.GhcMod.Browse-                        Language.Haskell.GhcMod.CabalHelper-                        Language.Haskell.GhcMod.Caching-                        Language.Haskell.GhcMod.Caching.Types-                        Language.Haskell.GhcMod.CaseSplit-                        Language.Haskell.GhcMod.Check-                        Language.Haskell.GhcMod.Convert-                        Language.Haskell.GhcMod.Cradle-                        Language.Haskell.GhcMod.CustomPackageDb-                        Language.Haskell.GhcMod.Debug-                        Language.Haskell.GhcMod.DebugLogger-                        Language.Haskell.GhcMod.Doc-                        Language.Haskell.GhcMod.DynFlags-                        Language.Haskell.GhcMod.Error-                        Language.Haskell.GhcMod.FileMapping-                        Language.Haskell.GhcMod.FillSig-                        Language.Haskell.GhcMod.Find-                        Language.Haskell.GhcMod.Flag-                        Language.Haskell.GhcMod.Gap-                        Language.Haskell.GhcMod.GhcPkg-                        Language.Haskell.GhcMod.HomeModuleGraph-                        Language.Haskell.GhcMod.Info-                        Language.Haskell.GhcMod.Lang-                        Language.Haskell.GhcMod.Lint-                        Language.Haskell.GhcMod.LightGhc-                        Language.Haskell.GhcMod.Logger-                        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-                        Language.Haskell.GhcMod.PkgDoc-                        Language.Haskell.GhcMod.Pretty-                        Language.Haskell.GhcMod.Read-                        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+  HS-Source-Dirs:       ., core, shared+  Exposed-Modules:+                        GhcMod+                        GhcMod.Exe.Boot+                        GhcMod.Exe.Browse+                        GhcMod.Exe.CaseSplit+                        GhcMod.Exe.Check+                        GhcMod.Exe.Debug+                        GhcMod.Exe.FillSig+                        GhcMod.Exe.Find+                        GhcMod.Exe.Flag+                        GhcMod.Exe.Info+                        GhcMod.Exe.Internal+                        GhcMod.Exe.Lang+                        GhcMod.Exe.Lint+                        GhcMod.Exe.Modules+                        GhcMod.Exe.PkgDoc+                        GhcMod.Exe.Test+                        GhcMod.CabalHelper+                        GhcMod.Caching+                        GhcMod.Caching.Types+                        GhcMod.Convert+                        GhcMod.Cradle+                        GhcMod.CustomPackageDb+                        GhcMod.DebugLogger+                        GhcMod.Doc+                        GhcMod.DynFlags+                        GhcMod.DynFlagsTH+                        GhcMod.Error+                        GhcMod.FileMapping+                        GhcMod.Gap+                        GhcMod.GhcPkg+                        GhcMod.HomeModuleGraph+                        GhcMod.LightGhc+                        GhcMod.Logger+                        GhcMod.Logging+                        GhcMod.Monad+                        GhcMod.Monad.Env+                        GhcMod.Monad.Log+                        GhcMod.Monad.Newtypes+                        GhcMod.Monad.Orphans+                        GhcMod.Monad.Out+                        GhcMod.Monad.State+                        GhcMod.Monad.Types+                        GhcMod.Options.DocUtils+                        GhcMod.Options.Help+                        GhcMod.Options.Options+                        GhcMod.Output+                        GhcMod.PathsAndFiles+                        GhcMod.Pretty+                        GhcMod.Read+                        GhcMod.SrcUtils+                        GhcMod.Stack+                        GhcMod.Target+                        GhcMod.Types+                        GhcMod.Utils+                        GhcMod.World   Other-Modules:        Paths_ghc_mod                         Utils                         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+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        binary+                      , bytestring+                      , containers+                      , deepseq+                      , directory+                      , filepath+                      , mtl+                      , old-time+                      , process+                      , template-haskell+                      , time+                      , transformers++                      , base                 < 4.10 && >= 4.6.0.1+                      , djinn-ghc            < 0.1  && >= 0.0.2.2+                      , extra                < 1.6  && >= 1.4+                      , fclabels             < 2.1  && >= 2.0+                      , ghc-paths            < 0.2  && >= 0.1.0.9+                      , ghc-syb-utils        < 0.3  && >= 0.2.3+                      , haskell-src-exts     < 1.20 && >= 1.18+                      , hlint                < 2.1  && >= 2.0.8+                      , monad-control        < 1.1  && >= 1+                      , monad-journal        < 0.8  && >= 0.4+                      , optparse-applicative < 0.14 && >= 0.13.0.0+                      , pipes                < 4.4  && >= 4.1+                      , safe                 < 0.4  && >= 0.3.9+                      , semigroups           < 0.19 && >= 0.10.0+                      , split                < 0.3  && >= 0.2.2+                      , syb                  < 0.7  && >= 0.5.1+                      , temporary            < 1.3  && >= 1.2.0.3+                      , text                 < 1.3  && >= 1.2.1.3+                      , transformers-base    < 0.5  && >= 0.4.4++                      , cabal-helper         < 0.8  && >= 0.7.3.0+                      , ghc                  < 8.2  && >= 7.6++  if impl(ghc >= 8.0)+    Build-Depends:      ghc-boot   if impl(ghc < 7.8)-    Build-Depends:      convertible-  if impl(ghc < 7.5)-    -- Only used to constrain random to a version that still works with GHC 7.4-    Build-Depends:      random <= 1.0.1.1,-                        ghc-prim+    Build-Depends:      convertible          < 1.2  && >= 1.1.0.0  Executable ghc-mod   Default-Language:     Haskell2010-  Main-Is:              GHCMod.hs+  Main-Is:              GhcModMain.hs   Other-Modules:        Paths_ghc_mod-                      , GHCMod.Options-                      , GHCMod.Options.Commands-                      , GHCMod.Version-                      , GHCMod.Options.DocUtils-                      , GHCMod.Options.ShellParse-                      , GHCMod.Options.Help+                      , GhcMod.Exe.Options+                      , GhcMod.Exe.Options.Commands+                      , GhcMod.Exe.Version+                      , GhcMod.Exe.Options.ShellParse   GHC-Options:          -Wall -fno-warn-deprecations -threaded   Default-Extensions:   ConstraintKinds, FlexibleContexts-  HS-Source-Dirs:       src-  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+  HS-Source-Dirs:       src, shared+  X-Internal:           True+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        directory+                      , filepath+                      , mtl+                      , process++                      , base                 < 4.10 && >= 4.6.0.1+                      , fclabels             < 2.1  && >= 2.0+                      , monad-control        < 1.1  && >= 1+                      , optparse-applicative < 0.14 && >= 0.13.0.0+                      , semigroups           < 0.19 && >= 0.10.0+                      , split                < 0.3  && >= 0.2.2++                      , ghc                  < 8.2  && >= 7.6                       , ghc-mod + Executable ghc-modi   Default-Language:     Haskell2010-  Main-Is:              GHCModi.hs+  Main-Is:              GhcModi.hs   Other-Modules:        Paths_ghc_mod                         Utils+                        System.Directory.ModTime   GHC-Options:          -Wall -threaded -fno-warn-deprecations   if os(windows)       Cpp-Options:      -DWINDOWS   Default-Extensions:   ConstraintKinds, FlexibleContexts-  HS-Source-Dirs:       src, .-  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+  HS-Source-Dirs:       ., src, shared+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        binary+                      , deepseq+                      , directory+                      , filepath+                      , old-time+                      , process+                      , time++                      , base                 < 4.10 && >= 4.6.0.1+                       , ghc-mod + Test-Suite doctest   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010@@ -247,46 +274,116 @@   Ghc-Options:          -Wall   Default-Extensions:   ConstraintKinds, FlexibleContexts   Main-Is:              doctests.hs-  if impl(ghc == 7.4.*)-    Buildable:          False-  Build-Depends:        base-                      , doctest >= 0.9.3+  Build-Depends:        base                 < 4.10 && >= 4.6.0.1+                      , doctest              < 0.12 && >= 0.9.3 + Test-Suite spec   Default-Language:     Haskell2010   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,                         ConstraintKinds, FlexibleContexts,                         DataKinds, KindSignatures, TypeOperators, ViewPatterns   Main-Is:              Main.hs-  Hs-Source-Dirs:       test, ., src+  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                         Dir-                        Spec                         TestUtils++-- $ ls test/*Spec.hs | sed 's_^.*/\(.*\)\.hs$_\1_' | sort                         BrowseSpec-                        CustomPackageDbSpec+                        CabalHelperSpec+                        CaseSplitSpec                         CheckSpec+                        CradleSpec+                        CustomPackageDbSpec+                        FileMappingSpec+                        FindSpec                         FlagSpec+                        GhcPkgSpec+                        HomeModuleGraphSpec                         InfoSpec                         LangSpec                         LintSpec                         ListSpec                         MonadSpec                         PathsAndFilesSpec-                        HomeModuleGraphSpec-                        FileMappingSpec                         ShellParseSpec+                        TargetSpec -  Build-Depends:        hspec >= 2.0.0-  if impl(ghc == 7.4.*)-    Build-Depends:     executable-path-  X-Build-Depends-Like: CLibName+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        containers+                      , directory+                      , filepath+                      , mtl+                      , process+                      , transformers +                      , base                 < 4.10 && >= 4.6.0.1+                      , fclabels             < 2.1  && >= 2.0+                      , hspec                < 2.4  && >= 2.0.0+                      , monad-journal        < 0.8  && >= 0.4+                      , split                < 0.3  && >= 0.2.2+                      , temporary            < 1.3  && >= 1.2.0.3  +  if impl(ghc < 7.8)+    Build-Depends:      convertible          < 1.2  && >= 1.1.0.0+  if impl(ghc >= 8.0)+    Build-Depends:      ghc-boot++  Build-Depends:+                        cabal-helper         < 0.8  && >= 0.7.1.0+                      , ghc                  < 8.2  && >= 7.6+                      , ghc-mod+++Test-Suite shelltest+  Default-Language:     Haskell2010+  Main-Is:              ShellTest.hs+  Hs-Source-Dirs:       shelltest+  Type:                 exitcode-stdio-1.0+  Build-Tools:          shelltest+  Build-Depends:        base                 < 4.10 && >= 4.6.0.1+                      , process              < 1.5+                      -- , shelltestrunner >= 1.3.5+  if !flag(shelltest)+    Buildable: False+++Benchmark criterion+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,+                        ConstraintKinds, FlexibleContexts,+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns+  HS-Source-Dirs:       bench, test+  Main-Is:              Bench.hs+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        directory+                      , filepath++                      , base                 < 4.10 && >= 4.6.0.1+                      , criterion            < 1.2  && >= 1.1.1.0+                      , temporary            < 1.3  && >= 1.2.0.3++                      , ghc-mod+++Flag shelltest+  Description: Enable/disable shelltest test-suite+  Default: False+  Manual:  True++ Source-Repository head   Type:                 git-  Location:             https://github.com/kazu-yamamoto/ghc-mod.git+  Location:             https://github.com/DanielG/ghc-mod.git++-- Note [GHC Boot libraries]+--+-- We don't give bounds to GHC boot libraries as our dependency on 'ghc' already+-- constrains these packages to the version that shipped with GHC.
+ shared/System/Directory/ModTime.hs view
@@ -0,0 +1,63 @@+-- ghc-mod: Happy Haskell Hacking+-- 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
+ shared/Utils.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+module Utils where++import Control.Applicative+import Data.Traversable+import System.Directory+import System.Directory.ModTime++import Prelude++data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }+                 deriving (Eq)++instance Ord TimedFile where+    compare (TimedFile _ a) (TimedFile _ b) = compare a b++timeFile :: FilePath -> IO TimedFile+timeFile f = TimedFile <$> pure f <*> getModTime f++mightExist :: FilePath -> IO (Maybe FilePath)+mightExist f = do+  exists <- doesFileExist f+  return $ if exists then (Just f) else (Nothing)++timeMaybe :: FilePath -> IO (Maybe TimedFile)+timeMaybe f = traverse timeFile =<< mightExist f
+ shelltest/ShellTest.hs view
@@ -0,0 +1,23 @@+#!/usr/bin/env runhaskell+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2017  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 Main where++import System.Exit+import System.Process++main = exitWith =<< rawSystem "shelltest" [ "--execdir", "shelltest/" ]
− src/GHCMod.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}--module Main where--import Control.Applicative-import Control.Monad-import Data.Typeable (Typeable)-import Data.List-import Data.List.Split-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 Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb)-import System.FilePath ((</>))-import System.Directory (setCurrentDirectory, getAppUserDataDirectory,-                        removeDirectoryRecursive)-import System.IO-import System.Exit-import Text.PrettyPrint hiding ((<>))-import GHCMod.Options-import Prelude--ghcModStyle :: Style-ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }--------------------------------------------------------------------handler :: IOish m => GhcModT m a -> GhcModT m a-handler = flip gcatches-          [ GHandler $ \(e :: ExitCode) -> throw e-          , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e-          ]--main :: IO ()-main = do-    hSetEncoding stdout utf8-    parseArgs >>= \res@(globalOptions, _) ->-      catches (progMain res) [-              Handler $ \(e :: GhcModError) ->-                runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)-            ]--progMain :: (Options, GhcModCommands) -> IO ()-progMain (globalOptions, commands) = runGmOutT globalOptions $-  wrapGhcCommands globalOptions commands---- ghc-modi-legacyInteractive :: IOish m => GhcModT m ()-legacyInteractive = do-    prepareCabalHelper-    asyncSymbolDb <- newAsyncSymbolDb-    world <- getCurrentWorld-    legacyInteractiveLoop asyncSymbolDb world--legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()-legacyInteractiveLoop asyncSymbolDb world = do-    liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle--    -- blocking-    cmdArg <- liftIO getLine--    -- after blocking, we need to see if the world has changed.--    changed <- didWorldChange world--    world' <- if changed-                then getCurrentWorld -- TODO: gah, we're hitting the fs twice-                else return world--    when changed dropSession--    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 asyncSymbolDb world'- where-    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-  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 -> GhcModCommands -> m ()-wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo-wrapGhcCommands opts cmd =-    handleGmError $ runGhcModT opts $ handler $ do-      forM_ (reverse $ optFileMappings opts) $-        uncurry loadMMappedFiles--      gmPutStr =<< ghcCommands cmd- where-   handleGmError action = do-     (e, _l) <- liftIO . evaluate =<< action-     case e of-       Right _ ->-           return ()-       Left ed ->-           exitError $ renderStyle ghcModStyle (gmeDoc ed)--   loadMMappedFiles from (Just to) = loadMappedFile from to-   loadMMappedFiles from (Nothing) = do-       src <- liftIO getFileSourceFromStdin-       loadMappedFileSource from src---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)-instance Exception InvalidCommandLine--exitError :: (MonadIO m, GmOut m) => String -> m a-exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure--nukeCaches :: IOish m => GhcModT m ()-nukeCaches = do-  chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"-  c <- cradle--  when (isCabalHelperProject $ cradleProject c) $ do-    let root = cradleRootDir c-    let dist = cradleDistDir c-    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]--trySome :: IO a -> IO (Either SomeException a)-trySome = try
− src/GHCMod/Options.hs 
@@ -1,201 +0,0 @@--- 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)
− src/GHCMod/Options/Commands.hs 
@@ -1,292 +0,0 @@--- 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
− src/GHCMod/Options/DocUtils.hs 
@@ -1,48 +0,0 @@--- 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-(<$$>) = (<$>)
− src/GHCMod/Options/Help.hs 
@@ -1,79 +0,0 @@--- 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
− src/GHCMod/Options/ShellParse.hs 
@@ -1,44 +0,0 @@--- 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
− src/GHCMod/Version.hs 
@@ -1,32 +0,0 @@--- 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"
− src/GHCModi.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- | WARNING--- This program is deprecated, use `ghc-mod legacy-interactive` instead.--module Main where--import Control.Applicative-import Control.Monad-import Control.Exception-import Data.Version-import Data.Maybe-import System.IO-import System.Exit-import System.Process-import System.FilePath-import System.Environment-import Paths_ghc_mod-import Utils-import Prelude--main :: IO ()-main = do-  hPutStrLn stderr $-    "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"--  args <- getArgs-  bindir <- getBinDir-  let installedExe = bindir </> "ghc-mod"-  mexe <- mplus <$> mightExist installedExe <*> pathExe-  case mexe of-    Nothing -> do-      hPutStrLn stderr $-        "ghc-modi: Could not find '"++installedExe++"', check your installation!"-      exitWith $ ExitFailure 1--    Just exe -> do-      (_, _, _, h) <--          createProcess $ proc exe $ ["legacy-interactive"] ++ args-      exitWith =<< waitForProcess h--pathExe :: IO (Maybe String)-pathExe = do-  ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""-  let mexe = case ev of-               Left (SomeException _) -> Nothing-               Right ["ghc-mod", "version", ver-                     , "compiled", "by", "GHC", _]-                   | showVersion version == ver -> do-                       Just "ghc-mod"-               Right _ -> Nothing--  when (isNothing mexe) $-      hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"-  return mexe
+ src/GhcMod/Exe/Options.hs view
@@ -0,0 +1,72 @@+-- ghc-mod: Happy Haskell Hacking+-- 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.Exe.Options (+  parseArgs,+  parseArgsInteractive,+  GhcModCommands(..)+) where++import Options.Applicative+import Options.Applicative.Types++import GhcMod.Exe.Options.Commands+import GhcMod.Exe.Options.ShellParse+import GhcMod.Exe.Version+import GhcMod.Options.DocUtils+import GhcMod.Options.Options+import GhcMod.Types++parseArgs :: IO (Options, GhcModCommands)+parseArgs =+  execParser opts+  where+    opts = info (argAndCmdSpec <**> helpVersion)+           $$  fullDesc+           <=> header "ghc-mod: Happy Haskell Hacking"++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
+ src/GhcMod/Exe/Options/Commands.hs view
@@ -0,0 +1,301 @@+-- ghc-mod: Happy Haskell Hacking+-- 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.Exe.Options.Commands where++import Data.Semigroup+import Options.Applicative+import Options.Applicative.Types+import Options.Applicative.Builder.Internal+import GhcMod.Types+import 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 Bool 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/DanielG/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/DanielG/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/DanielG/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 :: Parser ([String] -> b) -> Parser b+filesArgsSpec x = x <*> some (strArg "FILES..")++locArgSpec :: Parser (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 "parents"+            <=> short 'p'+            <=> help "Print symbols parents"+        <*> switch+            $$  long "qualified"+            <=> short 'q'+            <=> help "Qualify symbols"+      )+  <*> some (strArg "MODULE")+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)+checkArgSpec = filesArgsSpec (pure CmdCheck)+expandArgSpec = filesArgsSpec (pure CmdExpand)+infoArgSpec = CmdInfo+    <$> strArg "FILE"+    <*> strArg "SYMBOL"+typeArgSpec = locArgSpec $ CmdType <$>+        switch+          $$  long "constraints"+          <=> short 'c'+          <=> help "Include constraints into type signature"+autoArgSpec = locArgSpec (pure CmdAuto)+splitArgSpec = locArgSpec (pure CmdSplit)+sigArgSpec = locArgSpec (pure CmdSig)+refineArgSpec = locArgSpec (pure 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 ""+    (ms, cmds, subs) = mkCommand m+    rdr = CmdReader ms 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
+ src/GhcMod/Exe/Options/ShellParse.hs view
@@ -0,0 +1,44 @@+-- ghc-mod: Happy Haskell Hacking+-- 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.Exe.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
+ src/GhcMod/Exe/Version.hs view
@@ -0,0 +1,32 @@+-- ghc-mod: Happy Haskell Hacking+-- 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.Exe.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"
+ src/GhcModMain.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Typeable (Typeable)+import Data.List+import Data.List.Split+import GhcMod.Pretty+import System.FilePath ((</>))+import System.Directory (setCurrentDirectory, getAppUserDataDirectory,+                        removeDirectoryRecursive)+import System.IO+import System.Exit+import Prelude++import GhcMod+import GhcMod.Exe.Find+import GhcMod.Exe.Options+import GhcMod.Exe.Internal hiding (MonadIO,liftIO)+import GhcMod.Monad+import GhcMod.Types++import Exception++handler :: IOish m => GhcModT m a -> GhcModT m a+handler = flip gcatches+          [ GHandler $ \(e :: ExitCode) -> throw e+          , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e+          ]++main :: IO ()+main =+    parseArgs >>= \res@(globalOptions, _) -> do+      enc <- mkTextEncoding $ optEncoding globalOptions+      hSetEncoding stdout enc+      hSetEncoding stderr enc+      hSetEncoding stdin enc+      catches (progMain res) [+              Handler $ \(e :: GhcModError) ->+                runGmOutT globalOptions $ exitError $ renderGm (gmeDoc e)+            ]++progMain :: (Options, GhcModCommands) -> IO ()+progMain (globalOptions, commands) = runGmOutT globalOptions $+  wrapGhcCommands globalOptions commands++-- ghc-modi+legacyInteractive :: IOish m => GhcModT m ()+legacyInteractive = do+    prepareCabalHelper+    asyncSymbolDb <- newAsyncSymbolDb+    world <- getCurrentWorld+    legacyInteractiveLoop asyncSymbolDb world++legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()+legacyInteractiveLoop asyncSymbolDb world = do+    liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle++    -- blocking+    cmdArg <- liftIO getLine++    -- after blocking, we need to see if the world has changed.++    changed <- didWorldChange world++    world' <- if changed+                then getCurrentWorld -- TODO: gah, we're hitting the fs twice+                else return world++    when changed dropSession++    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 asyncSymbolDb world'+ where+    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+  linesIn <- readStdin'+  return (intercalate "\n" linesIn)+  where+    readStdin' = do+      x <- getLine+      if x/="\EOT"+        then fmap (x:) readStdin'+        else return []++wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()+wrapGhcCommands opts cmd =+    handleGmError $ runGhcModT opts $ handler $ do+      forM_ (reverse $ optFileMappings opts) $+        uncurry loadMMappedFiles++      gmPutStr =<< ghcCommands cmd+ where+   handleGmError action = do+     (e, _l) <- liftIO . evaluate =<< action+     case e of+       Right _ ->+           return ()+       Left ed ->+           exitError $ renderGm (gmeDoc ed)++   loadMMappedFiles from (Just to) = loadMappedFile from to+   loadMMappedFiles from (Nothing) = do+       src <- liftIO getFileSourceFromStdin+       loadMappedFileSource from src+++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) = rootInfo+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 wCon file (line, col)) = types wCon 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)+instance Exception InvalidCommandLine++exitError :: (MonadIO m, GmOut m) => String -> m a+exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure++nukeCaches :: IOish m => GhcModT m ()+nukeCaches = do+  chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"+  c <- cradle++  when (isCabalHelperProject $ cradleProject c) $ do+    let root = cradleRootDir c+    let dist = cradleDistDir c+    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]++trySome :: IO a -> IO (Either SomeException a)+trySome = try
+ src/GhcModi.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | WARNING+-- This program is deprecated, use `ghc-mod legacy-interactive` instead.++module Main where++import Control.Applicative+import Control.Monad+import Control.Exception+import Data.Version+import Data.Maybe+import System.IO+import System.Exit+import System.Process+import System.FilePath+import System.Environment+import Paths_ghc_mod+import Utils+import Prelude++main :: IO ()+main = do+  hPutStrLn stderr $+    "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"++  args <- getArgs+  bindir <- getBinDir+  let installedExe = bindir </> "ghc-mod"+  mexe <- mplus <$> mightExist installedExe <*> pathExe+  case mexe of+    Nothing -> do+      hPutStrLn stderr $+        "ghc-modi: Could not find '"++installedExe++"', check your installation!"+      exitWith $ ExitFailure 1++    Just exe -> do+      (_, _, _, h) <-+          createProcess $ proc exe $ ["legacy-interactive"] ++ args+      exitWith =<< waitForProcess h++pathExe :: IO (Maybe String)+pathExe = do+  ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""+  let mexe = case ev of+               Left (SomeException _) -> Nothing+               Right ["ghc-mod", "version", ver+                     , "compiled", "by", "GHC", _]+                   | showVersion version == ver -> do+                       Just "ghc-mod"+               Right _ -> Nothing++  when (isNothing mexe) $+      hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"+  return mexe
test/BrowseSpec.hs view
@@ -1,7 +1,7 @@ module BrowseSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import Prelude
+ test/CabalHelperSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+module CabalHelperSpec where++import Control.Arrow+import Control.Applicative+import Distribution.Helper+import GhcMod.CabalHelper+import GhcMod.PathsAndFiles+import GhcMod.Error+import Test.Hspec+import System.Directory+import System.FilePath+import System.Process+import Prelude++import Dir+import TestUtils+import Data.List++import Config (cProjectVersionInt)++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++gmeProcessException :: GhcModError -> Bool+gmeProcessException GMEProcess {} = True+gmeProcessException _ = False++pkgOptions :: [String] -> [String]+pkgOptions [] = []+pkgOptions (_:[]) = []+pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs+                    | otherwise = pkgOptions (y:xs)+ where+   stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)+#if __GLASGOW_HASKELL__ >= 800+   name s = reverse $ stripDash $ reverse s+#else+   name s = reverse $ stripDash $ stripDash $ reverse s+#endif++idirOpts :: [(c, [String])] -> [(c, [String])]+idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))++spec :: Spec+spec = do+    describe "getComponents" $ do+        it "throws an exception if the cabal file is broken" $ do+            let tdir = "test/data/broken-cabal"+            runD' tdir getComponents `shouldThrow` anyIOException++        it "handles sandboxes correctly" $ do+            let tdir = "test/data/cabal-project"+            cwd <- getCurrentDirectory++            -- TODO: ChSetupHsName should also have sandbox stuff, see related+            -- comment in cabal-helper+            opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents++            bp <- buildPlatform readProcess+            if ghcVersion < 706+              then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])+              else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])++#if !MIN_VERSION_ghc(7,8,0)+        it "handles stack project" $ do+            let tdir = "test/data/stack-project"+            [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents+            let pkgs = pkgOptions ghcOpts+            sort pkgs `shouldBe` ["base", "bytestring"]+#endif++        it "extracts build dependencies" $ do+            let tdir = "test/data/cabal-project"+            opts <- map gmcGhcOpts <$> runD' tdir getComponents+            let ghcOpts:_ = opts+                pkgs = pkgOptions ghcOpts+            pkgs `shouldBe` ["Cabal","base","template-haskell"]++        it "uses non default flags and preserves them across reconfigures" $ do+            let tdir = "test/data/cabal-flags"+            _ <- withDirectory_ tdir $+                readProcess "cabal" ["configure", "-ftest-flag"] ""++            let test = do+                  opts <- map gmcGhcOpts <$> runD' tdir getComponents+                  let ghcOpts = head opts+                      pkgs = pkgOptions ghcOpts+                  pkgs `shouldBe` ["Cabal","base"]++            test++            touch $ tdir </> "cabal-flags.cabal"++            test++touch :: FilePath -> IO ()+touch fn = do+  f <- readFile fn+  writeFile (fn <.> "tmp") f+  renameFile (fn <.> "tmp") fn
+ test/CaseSplitSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+module CaseSplitSpec where++import GhcMod+import Test.Hspec+import TestUtils+import Dir++main :: IO ()+main = do+  hspec spec++spec :: Spec+spec = do+    describe "case split" $ do+#if __GLASGOW_HASKELL__ >= 708+        it "does not blow up on HsWithBndrs panic" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 24 10+                res `shouldBe` "24 1 24 30"+++                        " \"mlAppend Nil y = _mlAppend_body\NUL"+++                           "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n"++        it "works with case expressions" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 28 20+                res `shouldBe` "28 19 28 39"+++                        " \"Nil -> _mlAppend_body\NUL"+++                        "                  (Cons x'1 x'2) -> _mlAppend_body\"\n"++        it "works with where clauses" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 34 17+                res `shouldBe` "34 5 34 43"+++                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"+++                        "    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"++        it "works with let bindings" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 38 33+                res `shouldBe` "38 21 38 59"+++                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"+++                        "                    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"+#else+        it "does not blow up on HsWithBndrs panic" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 24 10+                res `shouldBe` "24 1 24 25"+++                        " \"mlAppend Nil y = undefined\NUL"+++                           "mlAppend (Cons x1 x2) y = undefined\"\n"++        it "works with case expressions" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 28 20+                res `shouldBe` "28 19 28 34"+++                        " \"Nil -> undefined\NUL"+++                        "                  (Cons x'1 x'2) -> undefined\"\n"++        it "works with where clauses" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 34 17+                res `shouldBe` "34 5 34 37"+++                        " \"mlReverse' Nil accum = undefined\NUL"+++                        "    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"++        it "works with let bindings" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 38 33+                res `shouldBe` "38 21 38 53"+++                        " \"mlReverse' Nil accum = undefined\NUL"+++                        "                    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"++#endif+        it "doesn't crash when source doesn't make sense" $+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Crash.hs" 4 6+#if __GLASGOW_HASKELL__ < 710+                res `shouldBe` "4 1 4 19 \"test x = undefined\"\n"+#else+                res `shouldBe` ""+#endif
test/CheckSpec.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Language.Haskell.GhcMod+import GhcMod  import Data.List import System.Process@@ -58,7 +58,7 @@         it "emits warnings generated in GHC's desugar stage" $ do             withDirectory_ "test/data/check-missing-warnings" $ do                 res <- runD $ checkSyntax ["DesugarWarnings.hs"]-                res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"+                res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`) #endif          it "works with cabal builtin preprocessors" $ do@@ -71,7 +71,9 @@         it "Uses the right qualification style" $ do             withDirectory_ "test/data/nice-qualification" $ do                 res <- runD $ checkSyntax ["NiceQualification.hs"]-#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 800+                res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL  In an equation for \8216main\8217: main = \"wrong type\"\n"+#elif __GLASGOW_HASKELL__ >= 708                 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n" #else                 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"
+ test/CradleSpec.hs view
@@ -0,0 +1,67 @@+module CradleSpec where++import Control.Applicative+import Data.List (isSuffixOf)+import GhcMod.Cradle+import GhcMod.Types+import System.Directory (canonicalizePath)+import System.FilePath (pathSeparator)+import Test.Hspec+import TestUtils+import Prelude++import Dir++clean_ :: IO Cradle -> IO Cradle+clean_ f = do+  crdl <- f+  cleanupCradle crdl+  return crdl++relativeCradle :: FilePath -> Cradle -> Cradle+relativeCradle dir crdl = crdl {+    cradleCurrentDir    = toRelativeDir dir  $  cradleCurrentDir crdl+  , cradleRootDir       = toRelativeDir dir  $  cradleRootDir    crdl+  , cradleCabalFile     = toRelativeDir dir <$> cradleCabalFile  crdl+  }++-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".+stripLastDot :: FilePath -> FilePath+stripLastDot path+  | (pathSeparator:'.':"") `isSuffixOf` path = init path+  | otherwise = path++spec :: Spec+spec = do+    describe "findCradle" $ do+        it "returns the current directory" $ do+            withDirectory_ "/" $ do+                curDir <- stripLastDot <$> canonicalizePath "/"+                res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions+                cradleCurrentDir res `shouldBe` curDir+                cradleRootDir    res `shouldBe` curDir+                cradleCabalFile  res `shouldBe` Nothing++        it "finds a cabal file and a sandbox" $ do+            withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)++                cradleCurrentDir res `shouldBe`+                    "test/data/cabal-project/subdir1/subdir2"++                cradleRootDir    res `shouldBe` "test/data/cabal-project"++                cradleCabalFile  res `shouldBe`+                    Just ("test/data/cabal-project/cabalapi.cabal")++        it "works even if a sandbox config file is broken" $ do+            withDirectory "test/data/broken-sandbox" $ \dir -> do+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)+                cradleCurrentDir res `shouldBe`+                    "test" </> "data" </> "broken-sandbox"++                cradleRootDir    res `shouldBe`+                    "test" </> "data" </> "broken-sandbox"++                cradleCabalFile  res `shouldBe`+                  Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
test/CustomPackageDbSpec.hs view
@@ -1,8 +1,8 @@ module CustomPackageDbSpec where -import Language.Haskell.GhcMod.CabalHelper-import Language.Haskell.GhcMod.CustomPackageDb-import Language.Haskell.GhcMod.Error+import GhcMod.CabalHelper+import GhcMod.CustomPackageDb+import GhcMod.Error import System.Process import Test.Hspec import Prelude
test/FileMappingSpec.hs view
@@ -1,7 +1,7 @@ module FileMappingSpec where -import Language.Haskell.GhcMod.FileMapping-import Language.Haskell.GhcMod.Utils (withMappedFile)+import GhcMod.FileMapping+import GhcMod.Utils (withMappedFile) import Test.Hspec import TestUtils import qualified Data.Map as M@@ -9,7 +9,7 @@ import System.IO.Temp import System.Directory -import Language.Haskell.GhcMod+import GhcMod  spec :: Spec spec = do@@ -122,25 +122,31 @@           withDirectory_ "test/data/file-mapping" $ do             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.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"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:4:1: Warning: 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 defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:1:1: Warning: 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"             res <- runD' tdir $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"-              types "File.hs" 4 12+              types False "File.hs" 4 12             res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n"+        it "shows types of the expression with constraints for redirected files" $ do --+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              types True "File.hs" 4 12+            res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n"         it "shows types of the expression for in-memory files" $ do             let tdir = "test/data/file-mapping"             res <- runD' tdir $ do               loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""-              types "File.hs" 1 14+              types False "File.hs" 1 14             res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n"         it "shows info for the expression for redirected files" $ do             let tdir = "test/data/file-mapping"@@ -183,15 +189,15 @@           withDirectory_ "test/data/file-mapping/preprocessor" $ do             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.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"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:6:1: Warning: 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 defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:6:1: Warning: 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           withDirectory_ "test/data/file-mapping/lhs" $ do@@ -234,7 +240,7 @@                        ,("Bar.hs", tmpdir </> "Bar_Redir.hs")]               res <- run defaultOptions $ do                 mapM_ (uncurry loadMappedFile) fm-                types "Bar.hs" 5 1+                types False "Bar.hs" 5 1               res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]         it "works with a memory module using TemplateHaskell" $ do           srcFoo <- readFile "test/data/template-haskell/Foo.hs"@@ -244,5 +250,10 @@                      ,("Bar.hs", srcBar)]             res <- run defaultOptions $ do               mapM_ (uncurry loadMappedFileSource) fm-              types "Bar.hs" 5 1+              types False "Bar.hs" 5 1             res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]+++lintOpts :: LintOpts+lintOpts =+    defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] }
+ test/FindSpec.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+module FindSpec where++import GhcMod.Exe.Find+import Test.Hspec+import TestUtils++spec :: Spec+spec = do+    describe "db <- loadSymbolDb" $ do+        it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do+            db <- runD $ loadSymbolDb+            lookupSym "head" db `shouldContain` [ModuleString "Data.List"]
test/FlagSpec.hs view
@@ -1,7 +1,7 @@ module FlagSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils import Prelude@@ -9,6 +9,6 @@ spec :: Spec spec = do     describe "flags" $ do-        it "contains at least `-fno-warn-orphans'" $ do+        it "contains at least `-fprint-explicit-foralls" $ do             f <- runD $ lines <$> flags-            f `shouldContain` ["-fno-warn-orphans"]+            f `shouldContain` ["-fprint-explicit-foralls"]
+ test/GhcPkgSpec.hs view
@@ -0,0 +1,23 @@+module GhcPkgSpec where++import GhcMod.GhcPkg+import GhcMod.CabalHelper+import GhcMod.CustomPackageDb+import Test.Hspec+import System.Process (system)++import Dir+import TestUtils++spec :: Spec+spec = do+    describe "getPackageDbStack'" $ do+        it "fixes out of sync custom pkg-db stack" $ do+            withDirectory_ "test/data/custom-cradle" $ do+                _ <- system "cabal configure"+                (s, s') <- runD $ do+                    Just stack <- getCustomPkgDbStack+                    withCabal $ do+                        stack' <- getPackageDbStack+                        return (stack, stack')+                s' `shouldBe` s
test/HomeModuleGraphSpec.hs view
@@ -1,4 +1,4 @@--- ghc-mod: Making Haskell development *more* fun+-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org> -- -- This program is free software: you can redistribute it and/or modify@@ -18,8 +18,8 @@  module HomeModuleGraphSpec where -import Language.Haskell.GhcMod.HomeModuleGraph-import Language.Haskell.GhcMod.LightGhc+import GhcMod.HomeModuleGraph+import GhcMod.LightGhc import TestUtils  import GHC
test/InfoSpec.hs view
@@ -3,7 +3,7 @@  import Control.Applicative import Data.List (isPrefixOf)-import Language.Haskell.GhcMod+import GhcMod #if __GLASGOW_HASKELL__ < 706 import System.Environment.Executable (getExecutablePath) #else@@ -19,17 +19,31 @@     describe "types" $ do         it "shows types of the expression and its outers" $ do             let tdir = "test/data/ghc-mod-check"-            res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5+            res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else             res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif ++        it "shows types of the expression with constraints and its outers" $ do+            let tdir = "test/data/ghc-mod-check"+            res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else+            res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif+         it "works with a module using TemplateHaskell" $ do             let tdir = "test/data/template-haskell"-            res <- runD' tdir $ types "Bar.hs" 5 1+            res <- runD' tdir $ types False "Bar.hs" 5 1             res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]          it "works with a module that imports another module using TemplateHaskell" $ do             let tdir = "test/data/template-haskell"-            res <- runD' tdir $ types "ImportsTH.hs" 3 8+            res <- runD' tdir $ types False "ImportsTH.hs" 3 8             res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]      describe "info" $ do
test/LangSpec.hs view
@@ -1,7 +1,7 @@ module LangSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils import Prelude
test/LintSpec.hs view
@@ -1,6 +1,6 @@ module LintSpec where -import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils @@ -8,10 +8,14 @@ spec = do     describe "lint" $ do         it "can detect a redundant import" $ do-            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"+            res <- runD $ lint lintOpts "test/data/hlint/hlint.hs"+            res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: 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 defaultLintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs"+                res <- runD $ lint lintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs"                 res `shouldBe` ""++lintOpts :: LintOpts+lintOpts =+    defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] }
test/ListSpec.hs view
@@ -1,7 +1,7 @@ module ListSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils import Prelude
test/Main.hs view
@@ -1,58 +1,92 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-}-import Spec import Dir  import Control.Exception as E import Control.Monad (void)-import Data.List-import Language.Haskell.GhcMod (debugInfo)+import GhcMod (debugInfo) import System.Process+import System.Environment import Test.Hspec import TestUtils +import qualified BrowseSpec+import qualified CabalHelperSpec+import qualified CaseSplitSpec+import qualified CheckSpec+import qualified CradleSpec+import qualified CustomPackageDbSpec+import qualified FileMappingSpec+import qualified FindSpec+import qualified FlagSpec+import qualified GhcPkgSpec+import qualified HomeModuleGraphSpec+import qualified InfoSpec+import qualified LangSpec+import qualified LintSpec+import qualified ListSpec+import qualified MonadSpec+import qualified PathsAndFilesSpec+import qualified ShellParseSpec+import qualified TargetSpec++spec :: Spec+spec = do+  describe "Browse"          BrowseSpec.spec+  describe "CabalHelper"     CabalHelperSpec.spec+  describe "CaseSplit"       CaseSplitSpec.spec+  describe "Check"           CheckSpec.spec+  describe "Cradle"          CradleSpec.spec+  describe "CustomPackageDb" CustomPackageDbSpec.spec+  describe "FileMapping"     FileMappingSpec.spec+  describe "Find"            FindSpec.spec+  describe "Flag"            FlagSpec.spec+  describe "GhcPkg"          GhcPkgSpec.spec+  describe "HomeModuleGraph" HomeModuleGraphSpec.spec+  describe "Info"            InfoSpec.spec+  describe "Lang"            LangSpec.spec+  describe "Lint"            LintSpec.spec+  describe "List"            ListSpec.spec+  describe "Monad"           MonadSpec.spec+  describe "PathsAndFiles"   PathsAndFilesSpec.spec+  describe "ShellParse"      ShellParseSpec.spec+  describe "Target"          TargetSpec.spec+ main :: IO () main = do+#if __GLASGOW_HASKELL__ >= 708+  unsetEnv "GHC_PACKAGE_PATH"+#endif   let sandboxes = [ "test/data/cabal-project"                   , "test/data/check-packageid"                   , "test/data/duplicate-pkgver/"                   , "test/data/broken-cabal/"                   ]       genSandboxCfg dir = withDirectory dir $ \cwdir -> do-         system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")+         system ("rm cabal.sandbox.config; cabal sandbox init")       pkgDirs =         [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"         , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"         , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]       genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir -  genSandboxCfg `mapM_` sandboxes-  genGhcPkgCache `mapM_` pkgDirs--  let caches = [ "setup-config"-               , "setup-config.ghc-mod.cabal-helper"-               , "setup-config.ghc-mod.cabal-components"-               , "setup-config.ghc-mod.resolved-components"-               , "setup-config.ghc-mod.package-options"-               , "setup-config.ghc-mod.package-db-stack"-               , "ghc-mod.cache"-               ]-      findExp = unwords $ intersperse "-o " $ concat [-                 stackWorkFindExp,-                 cachesFindExp-                ]-      cachesFindExp = map ("-name "++) caches-      stackWorkFindExp = ["-name .stack-work -type d"]--      cleanCmd = "find test \\( "++ findExp ++" \\) -exec rm -r {} \\;"-+  let cleanCmd = "git clean -dXf test/data/"   putStrLn $ "$ " ++ cleanCmd   void $ system cleanCmd   void $ system "cabal --version"   void $ system "ghc --version" +  genSandboxCfg `mapM_` sandboxes+  genGhcPkgCache `mapM_` pkgDirs+   let stackDir = "test/data/stack-project"   void $ withDirectory_ stackDir $ do---    void $ system "stack init --force"+    let ghcver = let gvn = show (__GLASGOW_HASKELL__ :: Int)+                     (major, minor') = splitAt (length gvn - 2) gvn+                     minor = case dropWhile (=='0') minor' of+                                  "" -> "0"+                                  x  -> x+                 in major ++ "." ++ minor+    void $ system $ "sed '$ a resolver: ghc-" ++ ghcver ++ "' stack.yaml.in > stack.yaml"     void $ system "stack setup"     void $ system "stack build"
test/MonadSpec.hs view
@@ -23,16 +23,18 @@            mv_ex :: MVar (Either SomeException ())               <- newEmptyMVar-          mv_startup_barrier :: MVar () <- 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+                 _ <- runD $ liftIO $ do+                            putMVar mv_startup_barrier ()+                            readMVar mv_ex                  return ()            _t2 <- forkOS $ do-                 readMVar mv_startup_barrier -- wait for t1 to start up+                 readMVar mv_startup_barrier -- wait for t1 to be in GhcModT                  res <- try $ runD $ return ()                  res' <- evaluate res                  putMVar mv_ex res'
test/PathsAndFilesSpec.hs view
@@ -1,9 +1,9 @@ module PathsAndFilesSpec where  -import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Cradle-import qualified Language.Haskell.GhcMod.Utils as U+import GhcMod.PathsAndFiles+import GhcMod.Cradle+import qualified GhcMod.Utils as U  import Control.Monad.Trans.Maybe import System.Directory@@ -16,12 +16,12 @@     describe "getSandboxDb" $ do         it "can parse a config file and extract the sandbox package-db" $ do             cwd <- getCurrentDirectory-            Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"             Just db <- getSandboxDb crdl             db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")          it "returns Nothing if the sandbox config file is broken" $ do-            Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"             getSandboxDb crdl  `shouldReturn` Nothing      describe "findCabalFile" $ do
test/ShellParseSpec.hs view
@@ -1,7 +1,7 @@ module ShellParseSpec where  -import GHCMod.Options.ShellParse+import GhcMod.Exe.Options.ShellParse  import Test.Hspec
− test/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/TargetSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+module TargetSpec where++import GhcMod.Target+import GhcMod.LightGhc+import GhcMod.Gap+import Test.Hspec++import TestUtils++import GHC+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath++spec :: Spec+spec = do+    describe "runLightGhc" $ do+        it "works at all" $ do+            withLightHscEnv [] $ \env ->+              runLightGhc env (return ()) `shouldReturn` ()++        it "has modules in scope" $ do+            (withLightHscEnv [] $ \env ->+              runLightGhc env $ do+               dflags <- getSessionDynFlags+               let i = intersect (listVisibleModuleNames dflags)+                                 ["Control.Applicative", "Control.Arrow"+                                 ,"Control.Exception", "GHC.Exts", "GHC.Float"]+               liftIO $ i `shouldSatisfy` not . null) :: IO ()++        it "can get module info" $ do+            (withLightHscEnv [] $ \env ->+              runLightGhc env $ do+                mdl <- findModule "Data.List" Nothing+                mmi <- getModuleInfo mdl+                liftIO $ isJust mmi `shouldBe` True) :: IO ()+++    describe "resolveModule" $ do+        it "Works when a module given as path uses CPP" $ do+            dir <- getCurrentDirectory+            let srcDirs = [dir </> "test/data/target/src"]+            x <- withLightHscEnv [] $ \env -> runD $ do+                resolveModule env srcDirs (Left $ dir </> "test/data/target/Cpp.hs")+            liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir </> "test/data/target/Cpp.hs")
test/TestUtils.hs view
@@ -6,17 +6,18 @@   , runE   , runNullLog   , runGmOutDef+  , runLogDef   , shouldReturnError   , isPkgDbAt   , isPkgConfDAt-  , module Language.Haskell.GhcMod.Monad-  , module Language.Haskell.GhcMod.Types+  , module GhcMod.Monad+  , module GhcMod.Types   ) where -import Language.Haskell.GhcMod.Logging-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Types+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Cradle+import GhcMod.Types  import Control.Arrow import Control.Category@@ -43,10 +44,6 @@     Right a ->  return a     Left e -> error $ show e -withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a-withSpecCradle cradledir f = do-    gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f- runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do   dir <- getCurrentDirectory@@ -59,7 +56,14 @@     withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do       first (fst <$>) <$> runGhcModT' env defaultGhcModState         (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)+ where+   withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a+   withSpecCradle cradledir f =+     gbracket+       (runJournalT $ findSpecCradle (optPrograms opt) cradledir)+       (liftIO . cleanupCradle . fst) f + -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a run opt a = extract $ runGhcModTSpec opt a@@ -87,6 +91,9 @@  runGmOutDef :: IOish m => GmOutT m a -> m a runGmOutDef = runGmOutT defaultOptions++runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a+runLogDef = fmap fst . runJournalT . runGmOutDef  shouldReturnError :: Show a                   => IO (Either GhcModError a, GhcModLog)
− test/data/broken-cabal/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/broken-cabal/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs-world-file: @CWD@/test/data/broken-cabal/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/broken-cabal/.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d-build-summary: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/broken-cabal/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
− test/data/cabal-project/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/cabal-project/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs-world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/cabal-project/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
+ test/data/case-split/Crash.hs view
@@ -0,0 +1,4 @@+module Crash where++test :: Maybe a+test x = undefined
+ test/data/case-split/Vect706.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}++module Vect706 where++data Nat = Z | S Nat++type family   (n :: Nat) :+ (m :: Nat) :: Nat+type instance Z :+ m = m+type instance S n :+ m = S (n :+ m)++data Vect :: Nat -> * -> * where+  VNil :: Vect Z a+  (:::) :: a -> Vect n a -> Vect (S n) a++vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a+vAppend x y = undefined++lAppend :: [a] -> [a] -> [a]+lAppend x y = undefined++data MyList a = Nil | Cons a (MyList a)++mlAppend :: MyList a -> MyList a -> MyList a+mlAppend x y = undefined++mlAppend2 :: MyList a -> MyList a -> MyList a+mlAppend2 x y = case x of+                  x' -> undefined++mlReverse :: MyList a -> MyList a+mlReverse xs = mlReverse' xs Nil+  where+    mlReverse' :: MyList a -> MyList a -> MyList a+    mlReverse' xs' accum = undefined++mlReverse2 :: MyList a -> MyList a+mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a+                    mlReverse' xs' accum = undefined+                 in mlReverse' xs Nil
− test/data/check-packageid/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/check-packageid/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/check-packageid/.cabal-sandbox/logs-world-file: @CWD@/test/data/check-packageid/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: @CWD@/test/data/check-packageid/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/check-packageid/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
− test/data/duplicate-pkgver/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs-world-file: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
test/data/home-module-graph/errors/A1.hs view
@@ -1,4 +1,4 @@ module A1 where-psogduapzsü9+psogduapzs9 import B-lxäö,vLMCks+lx,vLMCks
test/data/pattern-synonyms/A.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-}+ module A where  data SomeType a b = SomeType (a,b)
test/data/pattern-synonyms/pattern-synonyms.cabal view
@@ -23,3 +23,5 @@   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wall+  if impl(ghc >= 8.0.1)+    ghc-options: -Wno-missing-pattern-synonym-signatures
test/data/stack-project/new-template.cabal view
@@ -16,7 +16,7 @@ library   hs-source-dirs:      src   exposed-modules:     Lib-  build-depends:       base >= 4.7 && < 5+  build-depends:       base   default-language:    Haskell2010  executable new-template-exe
− test/data/stack-project/stack.yaml 
@@ -1,5 +0,0 @@-flags: {}-packages:-- '.'-extra-deps: []-resolver: lts-2.17
+ test/data/stack-project/stack.yaml.in view
@@ -0,0 +1,4 @@+flags: {}+packages:+- '.'+extra-deps: []
test/doctests.hs view
@@ -2,16 +2,22 @@ module Main where  import Test.DocTest+import System.Environment+import Data.Maybe  main :: IO ()-main = doctest-  [ "-package", "ghc-" ++ VERSION_ghc-  , "-package", "transformers-" ++ VERSION_transformers-  , "-package", "mtl-" ++ VERSION_mtl-  , "-package", "directory-" ++ VERSION_directory-  , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns"-  , "-idist/build/autogen/"-  , "-optP-include"-  , "-optPdist/build/autogen/cabal_macros.h"-  , "Language/Haskell/GhcMod.hs"-  ]+main = do+  distdir <- (fromMaybe "dist" . lookup "DOCTEST_DIST_DIR") `fmap` getEnvironment+  doctest+     [ "-package", "ghc-" ++ VERSION_ghc+     , "-package", "transformers-" ++ VERSION_transformers+     , "-package", "mtl-" ++ VERSION_mtl+     , "-package", "directory-" ++ VERSION_directory+     , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns"+     , "-i" ++ distdir ++ "/build/autogen/"+     , "-icore/"+     , "-ishared"+--     , "-optP-include"+--     , "-optP" ++ distdir ++ "/build/autogen/cabal_macros.h"+     , "GhcMod.hs"+     ]