diff --git a/.gitignore b/.gitignore
index c3e127b1f..e7fac986e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -4,6 +4,8 @@ elisp/*.elc
/.cabal-sandbox/
/.stack-work/
/test/data/**/stack.yaml
+/test/data/**/.stack-work
+/test/data/**/.cabal-sandbox
add-source-timestamps
package.cache
cabal.sandbox.config
@@ -20,3 +22,6 @@ cabal.sandbox.config
cabal-dev
/TAGS
/tags
+/.bash_history
+/.travis.yml.orig
+/cabal.project.az
diff --git a/GhcMod.hs b/GhcMod.hs
index 893475901..7793d772d 100644
--- a/GhcMod.hs
+++ b/GhcMod.hs
@@ -48,7 +48,7 @@ module GhcMod (
, splits
, sig
, refine
- , auto
+ -- , auto
, modules
, languages
, flags
@@ -67,6 +67,9 @@ module GhcMod (
, loadMappedFile
, loadMappedFileSource
, unloadMappedFile
+ -- * API moving around stuff, temporary for now
+ , pretty
+ , collectAllSpansTypes
) where
import GhcMod.Exe.Boot
@@ -90,3 +93,6 @@ import GhcMod.Monad
import GhcMod.Output
import GhcMod.Target
import GhcMod.Types
+
+
+import GhcMod.SrcUtils (pretty,collectAllSpansTypes)
diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs
index d866fb6f2..4753f1db7 100644
--- a/GhcMod/Exe/CaseSplit.hs
+++ b/GhcMod/Exe/CaseSplit.hs
@@ -2,6 +2,8 @@
module GhcMod.Exe.CaseSplit (
splits
+ , splits'
+ , SplitResult(..)
) where
import Data.List (find, intercalate)
@@ -12,7 +14,6 @@ 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
@@ -35,15 +36,22 @@ import Control.DeepSeq
-- CASE SPLITTING
----------------------------------------------------------------
-data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]
- | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)
+data SplitInfo = SplitInfo G.Name G.SrcSpan (G.SrcSpan, G.Type) [G.SrcSpan]
+ | TySplitInfo G.Name G.SrcSpan (G.SrcSpan, Ty.Kind)
data SplitToTextInfo = SplitToTextInfo { sVarName :: String
- , sBindingSpan :: SrcSpan
- , sVarSpan :: SrcSpan
+ , sBindingSpan :: G.SrcSpan
+ , sVarSpan :: G.SrcSpan
, sTycons :: [String]
}
+data SplitResult = SplitResult { sStartLine :: Int
+ , sStartCol :: Int
+ , sEndLine :: Int
+ , sEndCol :: Int
+ , sNewText :: T.Text }
-- | Splitting a variable in a equation.
+-- Unlike splits', this performs parsing an type checking on every invocation.
+-- This is meant for consumption by tools that call ghc-mod as a binary.
splits :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
@@ -53,84 +61,122 @@ 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)
+ p <- G.parseModule modSum
+ tcm <- G.typecheckModule p
+ whenFound' oopts (performSplit file tcm lineNo colNo) $
+ \(SplitResult sLine sCol eLine eCol newText) ->
+ return $!! ((sLine, sCol, eLine, eCol), T.unpack newText)
where
handler (SomeException ex) = do
gmLog GmException "splits" $
text "" $$ nest 4 (showToDoc ex)
emptyResult =<< outputOpts
+-- | Split an identifier in a function definition.
+-- Meant for library-usage.
+splits' :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult)
+splits' file tcm lineNo colNo =
+ ghandle handler $ runGmlT' [Left file] deferErrors $ performSplit file tcm lineNo colNo
+ where
+ handler (SomeException ex) = do
+ gmLog GmException "splits'" $
+ text "" $$ nest 4 (showToDoc ex)
+ return Nothing
+
+performSplit :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GmlT m (Maybe SplitResult)
+performSplit file tcm lineNo colNo = do
+ style <- getStyle
+ dflag <- G.getSessionDynFlags
+ maybeSplitInfo <- getSrcSpanTypeForSplit tcm lineNo colNo
+ sequenceA $ constructSplitResult file maybeSplitInfo dflag style
+
+constructSplitResult :: (IOish m) => FilePath -> Maybe SplitInfo -> G.DynFlags -> PprStyle -> Maybe (GmlT m SplitResult)
+constructSplitResult file maybeSplitInfo dflag style = do
+ splitInfo <- maybeSplitInfo
+ let splitToTextInfo = constructSplitToTextInfo splitInfo dflag style
+ startLoc <- maybeSrcSpanStart $ sBindingSpan splitToTextInfo
+ endLoc <- maybeSrcSpanEnd $ sBindingSpan splitToTextInfo
+ let startLine = G.srcLocLine startLoc
+ startCol = G.srcLocCol startLoc
+ endLine = G.srcLocLine endLoc
+ endCol = G.srcLocCol endLoc
+ newText = genCaseSplitTextFile file splitToTextInfo
+ return $ SplitResult startLine startCol endLine endCol . T.pack <$> newText
+
+constructSplitToTextInfo :: SplitInfo -> G.DynFlags -> PprStyle -> SplitToTextInfo
+constructSplitToTextInfo splitInfo dflag style =
+ SplitToTextInfo varName' bndLoc varLoc typeCons
+ where
+ typeCons = getTyCons dflag style varName varT
+ varName' = showName dflag style varName -- Convert name to string
+ (varName, bndLoc, varLoc, varT) = case splitInfo of
+ (SplitInfo vn bl (vl, vt) _matches) -> (vn, bl, vl, vt)
+ (TySplitInfo vn bl (vl, vt)) -> (vn, bl, vl, vt)
+
+maybeSrcSpanStart :: G.SrcSpan -> Maybe G.RealSrcLoc
+maybeSrcSpanStart s = case G.srcSpanStart s of
+ (G.RealSrcLoc startLoc) -> Just startLoc
+ _ -> Nothing
+
+maybeSrcSpanEnd :: G.SrcSpan -> Maybe G.RealSrcLoc
+maybeSrcSpanEnd s = case G.srcSpanEnd s of
+ (G.RealSrcLoc endLoc) -> Just endLoc
+ _ -> Nothing
----------------------------------------------------------------
-- 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
+getSrcSpanTypeForSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForSplit tcm lineNo colNo = do
+ fn <- getSrcSpanTypeForFnSplit tcm lineNo colNo
if isJust fn
then return fn
- else getSrcSpanTypeForTypeSplit modSum lineNo colNo
+ else getSrcSpanTypeForTypeSplit tcm 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
+getSrcSpanTypeForFnSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForFnSplit tcm@G.TypecheckedModule{G.tm_typechecked_source = tcs} lineNo colNo = do
+ let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (G.LPat Gap.GhcTc)
+ match = last $ listifySpans tcs (lineNo, colNo) :: G.LMatch Gap.GhcTc (G.LHsExpr Gap.GhcTc)
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
+ let (G.L matchL (G.Match { G.m_grhss = G.GRHSs { G.grhssGRHSs = rhsLs }})) = match
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
+isPatternVar :: G.LPat Gap.GhcTc -> Bool
+isPatternVar (G.L _ (G.VarPat {})) = True
+isPatternVar _ = False
-getPatternVarName :: LPat Id -> G.Name
-#if __GLASGOW_HASKELL__ >= 800
-getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName
+getPatternVarName :: G.LPat Gap.GhcTc -> G.Name
+#if __GLASGOW_HASKELL__ >= 806
+getPatternVarName (G.L _ (G.VarPat _ (G.L _ vName))) = G.getName vName
+#elif __GLASGOW_HASKELL__ >= 800
+getPatternVarName (G.L _ (G.VarPat (G.L _ vName))) = G.getName vName
#else
-getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
+getPatternVarName (G.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
+getSrcSpanTypeForTypeSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForTypeSplit _tcm _lineNo _colNo = return Nothing
----------------------------------------------------------------
-- b. Code for getting the possible constructors
-getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String]
+getTyCons :: G.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]
+getTyCon :: G.DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]
-- 1. Non-matcheable type constructors
getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]
-- 2. Special cases
@@ -152,7 +198,7 @@ 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
+getDataCon :: G.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
@@ -196,7 +242,7 @@ 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 :: G.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
@@ -207,11 +253,13 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
----------------------------------------------------------------
-- 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
+
+genCaseSplitTextFile :: IOish m =>
+ FilePath -> SplitToTextInfo -> GmlT m String
+genCaseSplitTextFile file info =
+ withMappedFile file $ \file' -> liftIO $ do
+ t <- T.readFile file'
+ return $ getCaseSplitText (T.lines t) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
@@ -224,7 +272,7 @@ getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
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.Text] -> G.SrcSpan -> [T.Text]
getBindingText t srcSpan =
let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
lines_ = drop (sl - 1) $ take el t
@@ -235,7 +283,7 @@ getBindingText t srcSpan =
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 :: G.SrcSpan -> G.SrcSpan -> (Int,Int,Int,Int)
srcSpanDifference b v =
let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b
Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v
@@ -254,7 +302,7 @@ replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =
else T.replicate spacesToAdd (T.pack " ") `T.append` line)
[0 ..] t
-indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
+indentBindingTo :: G.SrcSpan -> [T.Text] -> [T.Text]
indentBindingTo bndLoc binds =
let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc
indent = (T.replicate (sl - 1) (T.pack " ") `T.append`)
diff --git a/GhcMod/Exe/Debug.hs b/GhcMod/Exe/Debug.hs
index 2ba7ac556..81db2cc8b 100644
--- a/GhcMod/Exe/Debug.hs
+++ b/GhcMod/Exe/Debug.hs
@@ -34,12 +34,15 @@ debugInfo = do
Options {..} <- options
Cradle {..} <- cradle
- [ghcPath, ghcPkgPath] <- liftIO $
+ mpaths <- liftIO $
case cradleProject of
StackProject se ->
catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]
_ ->
return ["ghc", "ghc-pkg"]
+ (ghcPath, ghcPkgPath) <- case mpaths of
+ [ghc,ghcp] -> return (ghc,ghcp)
+ _ -> error "pattern match fail"
cabal <-
case cradleProject of
@@ -67,13 +70,16 @@ debugInfo = do
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
- ]
+ Cradle { cradleProject = menv } <- cradle
+ case menv of
+ StackProject senv -> do
+ ghc <- getStackGhcPath senv
+ ghcPkg <- getStackGhcPkgPath senv
+ return $
+ [ "Stack ghc executable: " ++ show ghc
+ , "Stack ghc-pkg executable:" ++ show ghcPkg
+ ]
+ _ -> error "stackPaths:expected a stack project"
cabalDebug :: IOish m => FilePath -> GhcModT m [String]
cabalDebug ghcPkgPath = do
@@ -123,7 +129,7 @@ componentInfo ts = do
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = findCandidates $ map snd mdlcs
cn = pickComponent candidates
- opts <- targetGhcOptions crdl sefnmn
+ opts <- fst <$> targetGhcOptions crdl sefnmn
return $ unlines $
[ "Matching Components:\n" ++ renderGm (nest 4 $
diff --git a/GhcMod/Exe/FillSig.hs b/GhcMod/Exe/FillSig.hs
index c8bb9255a..9c7f8cdc0 100644
--- a/GhcMod/Exe/FillSig.hs
+++ b/GhcMod/Exe/FillSig.hs
@@ -4,15 +4,14 @@
module GhcMod.Exe.FillSig (
sig
, refine
- , auto
+ -- , auto
) where
import Data.Char (isSymbol)
import Data.Function (on)
import Data.Functor
-import Data.List (find, nub, sortBy)
+import Data.List (find, sortBy)
import qualified Data.Map as M
-import Data.Maybe (catMaybes)
import Prelude
import Exception (ghandle, SomeException(..))
@@ -20,7 +19,6 @@ 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
@@ -28,7 +26,7 @@ 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 Djinn.GHC
import qualified GhcMod.Gap as Gap
import GhcMod.Convert
@@ -51,7 +49,7 @@ import GHC (unLoc)
-- Possible signatures we can find: function or instance
data SigInfo
- = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
+ = Signature SrcSpan [G.RdrName] (G.HsType Gap.GhcPs)
| InstanceDecl SrcSpan G.Class
| TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
@@ -115,8 +113,10 @@ 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__ >= 802
+ case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl Gap.GhcPs] of
+#if __GLASGOW_HASKELL__ >= 806
+ [L loc (G.SigD _ (Ty.TypeSig _ names (G.HsWC _ (G.HsIB _ (L _ ty)))))] ->
+#elif __GLASGOW_HASKELL__ >= 802
[L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] ->
#elif __GLASGOW_HASKELL__ >= 800
[L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->
@@ -127,15 +127,19 @@ getSignature modSum lineNo colNo = do
#endif
-- We found a type signature
return $ Just $ Signature loc (map G.unLoc names) ty
- [L _ (G.InstD _)] -> do
+ [L _ (G.InstD {})] -> do
-- We found an instance declaration
- TypecheckedModule{tm_renamed_source = Just tcs
+ TypecheckedModule{tm_renamed_source = mtcs
,tm_checked_module_info = minfo} <- G.typecheckModule p
- let lst = listifyRenamedSpans tcs (lineNo, colNo)
+ let lst = case mtcs of
+ Just tcs -> listifyRenamedSpans tcs (lineNo, colNo)
+ _ -> error "pattern match fail"
case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing
-#if __GLASGOW_HASKELL__ >= 802
+#if __GLASGOW_HASKELL__ >= 806
+ [L loc (G.TyClD _ (G.FamDecl _ (G.FamilyDecl _ info (L _ name) (G.HsQTvs _ vars) _ _ _)))] -> do
+#elif __GLASGOW_HASKELL__ >= 802
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _ _)))] -> do
#elif __GLASGOW_HASKELL__ >= 800
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do
@@ -157,7 +161,11 @@ getSignature modSum lineNo colNo = do
G.DataFamily -> Data
#endif
-#if __GLASGOW_HASKELL__ >= 800
+#if __GLASGOW_HASKELL__ >= 806
+ getTyFamVarName x = case x of
+ L _ (G.UserTyVar _ (G.L _ n)) -> n
+ L _ (G.KindedTyVar _ (G.L _ n) _) -> n
+#elif __GLASGOW_HASKELL__ >= 800
getTyFamVarName x = case x of
L _ (G.UserTyVar (G.L _ n)) -> n
L _ (G.KindedTyVar (G.L _ n) _) -> n
@@ -279,9 +287,11 @@ 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
+instance FnArgsInfo (G.HsType Gap.GhcPs) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ Gap.occName name
-#if __GLASGOW_HASKELL__ >= 800
+#if __GLASGOW_HASKELL__ >= 806
+ getFnArgs (G.HsForAllTy _ _ (L _ iTy))
+#elif __GLASGOW_HASKELL__ >= 800
getFnArgs (G.HsForAllTy _ (L _ iTy))
#elif __GLASGOW_HASKELL__ >= 710
getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
@@ -290,11 +300,18 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
#endif
= getFnArgs iTy
+#if __GLASGOW_HASKELL__ >= 806
+ getFnArgs (G.HsParTy _ (L _ iTy)) = getFnArgs iTy
+ getFnArgs (G.HsFunTy _ (L _ lTy) (L _ rTy)) =
+#else
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
+#endif
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg ty = case ty of
-#if __GLASGOW_HASKELL__ >= 800
+#if __GLASGOW_HASKELL__ >= 806
+ (G.HsForAllTy _ _ (L _ iTy)) ->
+#elif __GLASGOW_HASKELL__ >= 800
(G.HsForAllTy _ (L _ iTy)) ->
#elif __GLASGOW_HASKELL__ >= 710
(G.HsForAllTy _ _ _ _ (L _ iTy)) ->
@@ -303,8 +320,12 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
#endif
fnarg iTy
+#if __GLASGOW_HASKELL__ >= 806
+ (G.HsParTy _ (L _ iTy)) -> fnarg iTy
+#else
(G.HsParTy (L _ iTy)) -> fnarg iTy
- (G.HsFunTy _ _) -> True
+#endif
+ (G.HsFunTy {} ) -> True
_ -> False
getFnArgs _ = []
@@ -401,7 +422,9 @@ findVar
-> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
case lst of
-#if __GLASGOW_HASKELL__ >= 800
+#if __GLASGOW_HASKELL__ >= 806
+ e@(L _ (G.HsVar _ (L _ i))):others -> do
+#elif __GLASGOW_HASKELL__ >= 800
e@(L _ (G.HsVar (L _ i))):others -> do
#else
e@(L _ (G.HsVar i)):others -> do
@@ -415,13 +438,17 @@ findVar dflag style tcm tcs lineNo colNo =
name = getFnName dflag style i
-- If inside an App, we need parenthesis
b = case others of
+#if __GLASGOW_HASKELL__ >= 806
+ L _ (G.HsApp _ (L _ a1) (L _ a2)):_ ->
+#else
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
+#endif
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
_ -> return Nothing
_ -> return Nothing
where
- lst :: [G.LHsExpr Id]
+ lst :: [G.LHsExpr Gap.GhcTc]
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
infinitePrefixSupply :: String -> [String]
@@ -432,8 +459,10 @@ 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 :: Id -> G.HsExpr Gap.GhcTc -> Bool
+#if __GLASGOW_HASKELL__ >= 806
+isSearchedVar i (G.HsVar _ (L _ i2)) = i == i2
+#elif __GLASGOW_HASKELL__ >= 800
isSearchedVar i (G.HsVar (L _ i2)) = i == i2
#else
isSearchedVar i (G.HsVar i2) = i == i2
@@ -444,7 +473,8 @@ isSearchedVar _ _ = False
----------------------------------------------------------------
-- REFINE AUTOMATICALLY
----------------------------------------------------------------
-
+{-
+This function needs djinn, which does not seem to be supported any more
auto :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
@@ -516,10 +546,10 @@ tyThingsToInfo (G.AnId i : xs) =
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 :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Gap.GhcTc])
getPatsForVariable tcs (lineNo, colNo) =
let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
- listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
+ listifySpans tcs (lineNo, colNo) :: [G.LHsBind Gap.GhcTc]
in case bnd of
G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of
Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
@@ -527,48 +557,74 @@ getPatsForVariable tcs (lineNo, colNo) =
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)]
+ :: [G.LMatch Gap.GhcTc (G.LHsExpr Gap.GhcTc)]
#else
- :: [G.LMatch Id]
+ :: [G.LMatch Gap.GhcTc]
#endif
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 804
+ (L _ (G.Match _ pats _):_) = m
+#elif __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.Pat Gap.GhcTc -> M.Map G.Name Type
+#if __GLASGOW_HASKELL__ >= 806
+getBindingsForPat (Ty.VarPat _ (L _ i)) = M.singleton (G.getName i) (Ty.varType i)
+#elif __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
+#if __GLASGOW_HASKELL__ >= 806
+getBindingsForPat (Ty.LazyPat _ (L _ l)) = getBindingsForPat l
+getBindingsForPat (Ty.BangPat _ (L _ b)) = getBindingsForPat b
+getBindingsForPat (Ty.AsPat _ (L _ a) (L _ i)) =
+#else
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
+#endif
M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 806
+getBindingsForPat (Ty.ListPat _ l) =
+ M.unions $ map (\(L _ i) -> getBindingsForPat i) l
+#elif __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
+#if __GLASGOW_HASKELL__ >= 806
+getBindingsForPat (Ty.TuplePat _ l _) =
+ M.unions $ map (\(L _ i) -> getBindingsForPat i) l
+#else
getBindingsForPat (Ty.TuplePat l _ _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
+#endif
+#if __GLASGOW_HASKELL__ < 806
getBindingsForPat (Ty.PArrPat l _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
+#endif
+#if __GLASGOW_HASKELL__ >= 806
+getBindingsForPat (Ty.ViewPat _ _ (L _ i)) = getBindingsForPat i
+getBindingsForPat (Ty.SigPat _ (L _ i)) = getBindingsForPat i
+#else
getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
+#endif
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.HsConPatDetails Gap.GhcTc -> M.Map G.Name Type
#if __GLASGOW_HASKELL__ >= 800
getBindingsForRecPat (G.PrefixCon args) =
#else
diff --git a/GhcMod/Exe/Test.hs b/GhcMod/Exe/Test.hs
index d3901270f..e3fd7df5d 100644
--- a/GhcMod/Exe/Test.hs
+++ b/GhcMod/Exe/Test.hs
@@ -22,11 +22,18 @@ test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do
mg <- getModuleGraph
root <- cradleRootDir <$> cradle
f' <- makeRelative root <$> liftIO (canonicalizePath f)
+#if __GLASGOW_HASKELL__ >= 804
+ let Just ms = find ((==Just f') . ml_hs_file . ms_location) (mgModSummaries mg)
+#else
let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg
+#endif
mdl = ms_mod ms
mn = moduleName mdl
- Just mi <- getModuleInfo mdl
+ mmi <- getModuleInfo mdl
+ mi <- case mmi of
+ Just mi -> return mi
+ _ -> error "pattern match fail"
let exs = map (occNameString . getOccName) $ modInfoExports mi
cqs = filter ("prop_" `isPrefixOf`) exs
diff --git a/core/GhcMod/SrcUtils.hs b/GhcMod/SrcUtils.hs
similarity index 69%
rename from core/GhcMod/SrcUtils.hs
rename to GhcMod/SrcUtils.hs
index 30999f3f1..4a5f5be4b 100644
--- a/core/GhcMod/SrcUtils.hs
+++ b/GhcMod/SrcUtils.hs
@@ -1,5 +1,7 @@
-- TODO: remove CPP once Gap(ed)
{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GhcMod.SrcUtils where
@@ -9,12 +11,13 @@ 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 GHC (LHsExpr, LPat, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
import qualified GHC as G
import qualified Var as G
import qualified Type as G
+#if __GLASGOW_HASKELL__ < 804
import GHC.SYB.Utils
+#endif
import GhcMonad
import qualified Language.Haskell.Exts as HE
import GhcMod.Doc
@@ -31,42 +34,63 @@ import qualified Data.Map as M
----------------------------------------------------------------
-instance HasType (LHsExpr Id) where
+instance HasType (LHsExpr GhcTc) 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
+instance HasType (LPat GhcTc) where
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
----------------------------------------------------------------
+#if __GLASGOW_HASKELL__ >= 804
+-- | Stores mapping from monomorphic to polymorphic types
+type CstGenQS = M.Map (G.IdP GhcTc) Type
+-- | Generic type to simplify SYB definition
+type CstGenQT m a = a GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
+#else
-- | Stores mapping from monomorphic to polymorphic types
-type CstGenQS = M.Map Var Type
+type CstGenQS = M.Map G.Var Type
-- | Generic type to simplify SYB definition
-type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
+type CstGenQT a = forall m. GhcMonad m => a G.Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
+#endif
+
+collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int,Int) -> m [(SrcSpan, Type)]
+collectSpansTypes withConstraints tcs lc = collectSpansTypes' withConstraints tcs (`G.spans` lc)
+
+collectAllSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> m [(SrcSpan, Type)]
+collectAllSpansTypes withConstraints tcs = collectSpansTypes' withConstraints tcs (const True)
-collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
-collectSpansTypes withConstraints tcs lc =
+collectSpansTypes' :: forall m. (GhcMonad m) => Bool -> G.TypecheckedModule -> (SrcSpan -> Bool) -> m [(SrcSpan, Type)]
+-- collectSpansTypes' :: forall m.(GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
+collectSpansTypes' withConstraints tcs f =
-- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree
-- (but not left-to-right)
+#if __GLASGOW_HASKELL__ >= 804
+ everythingWithContext M.empty (liftM2 (++))
+#else
everythingStagedWithContext TypeChecker M.empty (liftM2 (++))
(return [])
+#endif
((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
+ `mkQ` (hsBind :: G.LHsBind GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- matches on binds
+ `extQ` (genericCT :: G.LHsExpr GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- matches on expressions
+ `extQ` (genericCT :: G.LPat GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- 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
+#if __GLASGOW_HASKELL__ >= 804
+#elif __GLASGOW_HASKELL__ >= 800
-- TODO: move to Gap
-- Note: this deals with bindings with explicit type signature, e.g.
-- double :: Num a => a -> a
@@ -83,20 +107,33 @@ collectSpansTypes withConstraints tcs lc =
-- Otherwise, it's the same as other cases
hsBind x s = genericCT x s
-- Generic SYB function to get type
+ genericCT :: forall b . (Data (b GhcTc), HasType (Located (b GhcTc)))
+ => Located (b GhcTc) -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
genericCT x s
| withConstraints
= (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)
| otherwise = (maybeToList <$> getType' x, s)
+#if __GLASGOW_HASKELL__ >= 804
+ -- Collects everything with Id from LHsBind, LHsExpr, or LPat
+ collectBinders :: Data a => a -> [G.IdP GhcTc]
+ collectBinders = listify (const True)
+#else
-- Collects everything with Id from LHsBind, LHsExpr, or LPat
- collectBinders :: Data a => a -> [Id]
+ collectBinders :: Data a => a -> [G.Id]
collectBinders = listifyStaged TypeChecker (const True)
+#endif
-- Gets monomorphic type with location
+ getType' :: forall t . (HasType (Located t)) => Located t -> m (Maybe (SrcSpan, Type))
getType' x@(L spn _)
- | G.isGoodSrcSpan spn && spn `G.spans` lc
+ | G.isGoodSrcSpan spn && f spn
= getType tcs x
| otherwise = return Nothing
-- Gets constrained type
- constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id
+#if __GLASGOW_HASKELL__ >= 804
+ constrainedType :: [G.IdP GhcTc] -- ^ Binders in expression, i.e. anything with Id
+#else
+ constrainedType :: [G.Var] -- ^ Binders in expression, i.e. anything with Id
+#endif
-> CstGenQS -- ^ Map from Id to polymorphic type
-> SrcSpan -- ^ extent of expression, copied to result
-> Type -- ^ monomorphic type
@@ -112,10 +149,17 @@ collectSpansTypes withConstraints tcs lc =
build x | Just cti <- x `M.lookup` s
= let
(preds', ctt) = getPreds cti
+#if __GLASGOW_HASKELL__ >= 804
+ -- list of type variables in monomorphic type
+ vts = listify G.isTyVar $ G.varType x
+ -- list of type variables in polymorphic type
+ tvm = listify G.isTyVarTy ctt
+#else
-- 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
+#endif
in Just (preds', zip vts tvm)
| otherwise = Nothing
-- list of constraints
@@ -138,22 +182,36 @@ collectSpansTypes withConstraints tcs lc =
| otherwise = ([], x)
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
+#if __GLASGOW_HASKELL__ >= 804
+listifySpans tcs lc = listify p tcs
+#else
listifySpans tcs lc = listifyStaged TypeChecker p tcs
+#endif
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
+#if __GLASGOW_HASKELL__ >= 804
+listifyParsedSpans pcs lc = listify p pcs
+#else
listifyParsedSpans pcs lc = listifyStaged Parser p pcs
+#endif
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]
+#if __GLASGOW_HASKELL__ >= 804
+listifyRenamedSpans pcs lc = listify p pcs
+#else
listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs
+#endif
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
+#if __GLASGOW_HASKELL__ < 804
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
+#endif
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
diff --git a/cabal.project b/cabal.project
index 0d3711349..834156e56 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,2 +1,10 @@
packages: .
./core
+ ../cabal-helper
+
+
+-- source-repository-package
+-- type: git
+-- location: https://github.com/alanz/cabal-helper
+-- tag: 3d13936af2f8fa565e0a64431c6ed309b91b2695
+
diff --git a/core/GhcMod/CabalHelper.hs b/core/GhcMod/CabalHelper.hs
index 1e82c39e9..c15663a6b 100644
--- a/core/GhcMod/CabalHelper.hs
+++ b/core/GhcMod/CabalHelper.hs
@@ -15,6 +15,9 @@
-- along with this program. If not, see .
{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module GhcMod.CabalHelper
( getComponents
, getGhcMergedPkgOptions
@@ -22,18 +25,27 @@ module GhcMod.CabalHelper
, prepareCabalHelper
, withAutogen
, withCabal
+ , withProjSetup
+
+ , runCHQuery
+ -- , packageId
) where
import Control.Applicative
import Control.Monad
import Control.Category ((.))
+import Data.Dynamic (toDyn, fromDynamic, Dynamic)
+import Data.List.NonEmpty ( NonEmpty(..), toList)
+import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
+import Data.Typeable (Typeable)
import Data.Version
import Data.Binary (Binary)
import Data.Traversable
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CH
+import GhcMod.Cradle
import qualified GhcMod.Types as T
import GhcMod.Types
import GhcMod.Monad.Types
@@ -54,24 +66,26 @@ import Paths_ghc_mod_core as GhcMod
-- 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)
- }
+getGhcMergedPkgOptions = undefined
+-- 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)
- }
+getCabalPackageDbStack = undefined
+-- 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
@@ -83,56 +97,183 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
--
-- 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
- cs <- runCHQuery $ components $
- GmComponent mempty
- CH.<$> ghcOptions
- CH.<.> ghcPkgOptions
- CH.<.> ghcSrcOptions
- CH.<.> ghcLangOptions
- CH.<.> entrypoints
- CH.<.> entrypoints
- CH.<.> sourceDirs
- return ([setupConfigPath distdir], cs)
- }
-
-getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
+getComponents :: (Applicative m, IOish m, Gm m, Typeable pt)
+ => ProjSetup pt -> m [GmComponent 'GMCRaw ChEntrypoint]
+getComponents ps = do
+ let
+ doComp :: (ChComponentName, ChComponentInfo) -> GmComponent 'GMCRaw ChEntrypoint
+ doComp (cn,ci) =
+ GmComponent
+ { gmcHomeModuleGraph = mempty
+ , gmcGhcOpts = ciGhcOptions ci
+ , gmcGhcPkgOpts = ciGhcPkgOptions ci
+ , gmcGhcSrcOpts = ciGhcSrcOptions ci
+ , gmcGhcLangOpts = ciGhcLangOptions ci
+ , gmcRawEntrypoints = ciEntrypoints ci
+ , gmcEntrypoints = ciEntrypoints ci
+ , gmcSourceDirs = ciSourceDirs ci
+ , gmcName = ciComponentName ci
+ , gmcNeedsBuildOutput = ciNeedsBuildOutput ci
+ }
+ foo :: UnitInfo -> [GmComponent 'GMCRaw ChEntrypoint]
+ foo ui = map doComp $ Map.toList $ uiComponents ui
+
+ ff <- runCHQuery ps $ allUnits foo
+ let cs = concat $ toList ff
+ return cs
+
+-- getComponents = chCached $ \distdir -> Cached {
+-- cacheLens = Just (lGmcComponents . lGmCaches),
+-- cacheFile = cabalHelperCacheFile distdir,
+-- cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do
+-- cs <- runCHQuery $ components $
+-- GmComponent mempty
+-- CH.<$> ghcOptions
+-- CH.<.> ghcPkgOptions
+-- CH.<.> ghcSrcOptions
+-- CH.<.> ghcLangOptions
+-- CH.<.> entrypoints
+-- CH.<.> entrypoints
+-- CH.<.> sourceDirs
+-- return ([setupConfigPath distdir], cs)
+-- }
+
+-- getQueryEnv :: forall m pt. (IOish m, GmOut m, GmEnv m) => m (Maybe ( QueryEnv pt))
+getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m (QueryEnv pt)
+getQueryEnv = undefined
+ {-
getQueryEnv = do
crdl <- cradle
progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
readProc <- gmReadProcess
- let projdir = cradleRootDir crdl
- distdir = projdir cradleDistDir crdl
- return (mkQueryEnv 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
+ case cradleCabalFile crdl of
+ Nothing -> return Nothing
+ Just cabalFile -> do
+ let
+ distdirCradle = cradleDistDir crdl
+ (projdir,distdir) = case cradleProject crdl of
+ CabalProject -> (ProjLocCabalFile cabalFile,DistDirV1 distdirCradle)
+ CabalNewProject -> (ProjLocCabalFile cabalFile,DistDirV2 distdirCradle)
+ SandboxProject -> (ProjLocCabalFile cabalFile,DistDirV1 distdirCradle)
+ PlainProject -> (ProjLocCabalFile cabalFile,DistDirV1 distdirCradle)
+ StackProject env -> (ProjLocCabalFile cabalFile,DistDirStack distdirCradle)
+ qe <- liftIO $ mkQueryEnv projdir distdir
+ return (Just qe)
+ -- let
+ -- (projdir,distdir) = case cradleProject crdl of
+ -- CabalProject -> (ProjLocCabalFile cabalFile,DisDirV1 distdir)
+ -- CabalNewProject -> (ProjLocCabalFile cabalFile,DisDirV1 distdir)
+ -- SandboxProject -> (ProjLocCabalFile cabalFile,DisDirV1 distdir)
+ -- PlainProject -> (ProjLocCabalFile cabalFile,DisDirV1 distdir)
+ -- StackProject env -> (ProjLocCabalFile cabalFile,DisDirV1 distdir)
+ -- return (mkQueryEnv projdir distdir) {
+ -- qeReadProcess = readProc
+ -- , qePrograms = helperProgs progs
+ -- }
+ {-
+ let projdir = takeDirectory cabal_file
+ qe <- mkQueryEnv
+ (psProjDir cabal_file)
+ (psDistDir projdir)
+
+-}
+-- getQueryEnv = do
+-- crdl <- cradle
+-- progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+-- readProc <- gmReadProcess
+-- let projdir = cradleRootDir crdl
+-- distdir = projdir cradleDistDir crdl
+-- return (mkQueryEnv projdir distdir) {
+-- qeReadProcess = readProc
+-- , qePrograms = helperProgs progs
+-- }
+-}
+
+runCHQuery :: (IOish m, GmOut m, GmEnv m, Typeable pt)
+ => ProjSetup (pt :: ProjType) -> Query (pt :: ProjType) b -> m b
+runCHQuery ps a = do
+ crdl <- cradle
+ progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+ readProc <- gmReadProcess
+ case cradleCabalFile crdl of
+ Nothing -> error "runCHQuery 1"
+ Just cabalFile -> runProjSetup ps cabalFile (\qe -> runQuery a qe)
+-- ---------------------------------------------------------------------
-prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
-prepareCabalHelper = do
+runProjSetup :: (IOish m, GmOut m, GmEnv m, Typeable pt)
+ => ProjSetup (pt :: ProjType) -> FilePath -> (QueryEnv (pt :: ProjType) -> IO a) -> m a
+runProjSetup ps cabalFile f = do
+ let projdir = takeDirectory cabalFile
+ crdl <- cradle
+ -- progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+ -- readProc <- gmReadProcess
+ -- qeBare <- liftIO $ mkQueryEnv
+ -- (psProjDir ps $ cabalFile)
+ -- (psDistDir ps $ projdir)
+ -- let qe = qeBare
+ -- -- { qeReadProcess = \_ -> readProc
+ -- -- , qePrograms = helperProgs progs
+ -- -- }
+ -- r <- liftIO $ f qe
+ -- return r
+ r <- case cradleCabalFile crdl of
+ Nothing -> error "runProjSetup:Nothing"
+ Just cabalFile -> do
+ runF ps (cradleQueryEnv crdl) f
+ -- case cradleProject crdl of
+ -- CabalProject -> runF ps (cradleQueryEnv crdl) f
+ -- CabalNewProject -> liftIO $ f (fromJust $ cradleQueryEnvV2 crdl)
+ -- SandboxProject -> liftIO $ f (fromJust $ cradleQueryEnvV1 crdl)
+ -- StackProject _env -> liftIO $ f (fromJust $ cradleQueryEnvSt crdl)
+ -- PlainProject -> error $ "runProjSetup:PlainProject"
+ return r
+
+runF :: (MonadIO m, Typeable pt) => ProjSetup (pt :: ProjType) -> (Maybe Dynamic) -> (QueryEnv (pt :: ProjType) -> IO a) -> m a
+runF _ Nothing _ = error "CabalHelper.runF"
+runF _ (Just dqe) f = liftIO $ f qe
+ where
+ qe = case fromDynamic dqe of
+ Nothing -> error "CabalHelper.runF 2"
+ Just qe -> qe
+
+-- ---------------------------------------------------------------------
+
+withProjSetup :: (IOish m, GmOut m, GmEnv m) => (forall pt . Typeable pt => ProjSetup pt -> m a) -> m (Maybe a)
+withProjSetup f = do
+ crdl <- cradle
+ progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+ readProc <- gmReadProcess
+ case cradleCabalFile crdl of
+ Nothing -> return Nothing
+ Just cabalFile -> do
+ -- liftIO $ putStrLn $ "withProjSetup:project=" ++ show (cradleProject crdl)
+ case cradleProject crdl of
+ CabalProject -> Just <$> f oldBuild
+ CabalNewProject -> Just <$> f newBuild
+ SandboxProject -> Just <$> f oldBuild
+ StackProject _env -> Just <$> f stackBuild
+ PlainProject -> return Nothing
+
+-- ---------------------------------------------------------------------
+
+prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m, Typeable pt) => ProjSetup (pt :: ProjType) -> m ()
+prepareCabalHelper ps = do
crdl <- cradle
- when (isCabalHelperProject $ cradleProject crdl) $
- withCabal $ prepare =<< getQueryEnv
+ when (isCabalHelperProject $ cradleProject crdl) $ do
+ qe <- getQueryEnv
+ withCabal ps $ liftIO (prepare qe)
-withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
-withAutogen action = do
- gmLog GmDebug "" $ strDoc $ "making sure autogen files exist"
+withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m, Typeable pt) => ProjSetup pt -> m a -> m a
+withAutogen ps action = do
+ gmLog GmDebug "" $ strDoc "making sure autogen files exist"
crdl <- cradle
let projdir = cradleRootDir crdl
distdir = projdir cradleDistDir crdl
- (pkgName', _) <- runCHQuery packageId
+ unit :| _ <- runCHQuery ps projectUnits
+ unitInfo <- runCHQuery ps $ unitInfo unit
+ let (pkgName',_) = uiPackageId unitInfo
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalMacroHeader <- liftIO $ timeMaybe (distdir macrosHeaderPath)
@@ -140,18 +281,19 @@ withAutogen action = do
when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do
gmLog GmDebug "" $ strDoc $ "autogen files out of sync"
- writeAutogen
+ writeAutogen unit
action
where
- writeAutogen = do
- gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
- writeAutogenFiles =<< getQueryEnv
+ writeAutogen unit = do
+ gmLog GmDebug "" $ strDoc "writing Cabal autogen files"
+ runCHQuery ps $ writeAutogenFiles unit
+-- ---------------------------------------------------------------------
-withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
-withCabal action = do
+withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m, Typeable pt) => ProjSetup (pt :: ProjType) -> m a -> m a
+withCabal ps action = do
crdl <- cradle
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
@@ -162,9 +304,13 @@ withCabal action = do
cusPkgDb <- getCustomPkgDbStack
(flgs, pkgDbStackOutOfSync) <- do
if haveSetupConfig
- then runCHQuery $ do
- flgs <- nonDefaultConfigFlags
- pkgDb <- map chPkgToGhcPkg <$> packageDbStack
+ then runCHQuery ps $ do
+ unit :| _ <- projectUnits
+ ui <- unitInfo unit
+ -- flgs <- nonDefaultConfigFlags
+ let flgs = uiNonDefaultConfigFlags ui
+ -- pkgDb <- map chPkgToGhcPkg <$> packageDbStack
+ let pkgDb = map chPkgToGhcPkg (uiPackageDbStack ui)
return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb)
else return ([], False)
@@ -185,7 +331,10 @@ withCabal action = do
case proj of
CabalProject -> do
gmLog GmDebug "" $ strDoc "reconfiguring Cabal project"
- cabalReconfigure (optPrograms opts) crdl flgs
+ cabalReconfigure "configure" (optPrograms opts) crdl flgs
+ CabalNewProject -> do
+ gmLog GmDebug "" $ strDoc "reconfiguring Cabal new-build project"
+ cabalReconfigure "new-configure" (optPrograms opts) crdl flgs
StackProject {} -> do
gmLog GmDebug "" $ strDoc "reconfiguring Stack project"
-- TODO: we could support flags for stack too, but it seems
@@ -202,7 +351,7 @@ withCabal action = do
action
where
- cabalReconfigure progs crdl flgs = do
+ cabalReconfigure cmd progs crdl flgs = do
readProc <- gmReadProcess
withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
@@ -220,7 +369,7 @@ withCabal action = do
toFlag (f, False) = '-':f
flagOpt = ["--flags", unwords $ map toFlag flgs]
- liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
+ liftIO $ void $ readProc (T.cabalProgram progs) (cmd:progOpts) ""
stackReconfigure deps crdl progs = do
withDirectory_ (cradleRootDir crdl) $ do
supported <- haveStackSupport
@@ -269,19 +418,20 @@ 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
+helperProgs = undefined
+-- 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, Typeable pt)
+ => ProjSetup pt -> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
+chCached ps c = do
projdir <- cradleRootDir <$> cradle
distdir <- (projdir ) . cradleDistDir <$> cradle
d <- cacheInputData projdir
- withCabal $ cached projdir (c distdir) d
+ withCabal ps $ 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 ;)
diff --git a/core/GhcMod/Cradle.hs b/core/GhcMod/Cradle.hs
index 9226fd580..b8815ab58 100644
--- a/core/GhcMod/Cradle.hs
+++ b/core/GhcMod/Cradle.hs
@@ -1,11 +1,23 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+
+
module GhcMod.Cradle
( findCradle
, findCradle'
, findCradleNoLog
, findSpecCradle
, cleanupCradle
+ , shouldLoadGhcEnvironment
+ , oldBuild
+ , newBuild
+ , stackBuild
-- * for @spec@
, plainCradle
) where
@@ -21,12 +33,18 @@ import GhcMod.Error
import Safe
import Control.Applicative
import Control.Monad.Trans.Maybe
+import Data.Dynamic (toDyn, fromDynamic, Dynamic)
import Data.Maybe
import System.Directory
import System.FilePath
import System.Environment
import Prelude
import Control.Monad.Trans.Journal (runJournalT)
+-- import Distribution.Helper (runQuery, mkQueryEnv, compilerVersion, distDir)
+import Distribution.Helper (runQuery, mkQueryEnv, compilerVersion, DistDir(..), ProjType(..), ProjLoc(..), QueryEnv )
+-- import Distribution.System (buildPlatform)
+import Data.List (intercalate)
+import Data.Version (Version(..))
----------------------------------------------------------------
@@ -37,7 +55,7 @@ import Control.Monad.Trans.Journal (runJournalT)
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 :: forall m pt. (IOish m, GmOut m) => Programs -> m Cradle
findCradleNoLog progs =
fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
@@ -74,6 +92,16 @@ fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
+-- run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a
+-- run e s action = flip runReaderT e (flip evalStateT s (unQuery action))
+
+-- -- | @runQuery env query@. Run a 'Query' under a given 'QueryEnv'.
+-- runQuery :: Monad m
+-- => QueryEnv
+-- -> Query m a
+-- -> m a
+-- runQuery qe action = run qe Nothing action
+
cabalCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
cabalCradle cabalProg wdir = do
@@ -87,15 +115,40 @@ cabalCradle cabalProg wdir = 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"
- }
+ isDistNewstyle <- liftIO $ doesDirectoryExist $ cabalDir "dist-newstyle"
+ -- TODO: consider a flag to choose new-build if neither "dist" nor "dist-newstyle" exist
+ -- Or default to is for cabal >= 2.0 ?, unless flag saying old style
+ if isDistNewstyle
+ then do
+ -- dd <- liftIO $ runQuery (mkQueryEnv cabalDir "dist-newstyle") distDir
+
+ -- runQuery :: Query pt a -> QueryEnv pt -> IO a
+ -- dd <- liftIO $ runQuery (mkQueryEnv cabalDir "dist-newstyle") distDir
+ let dd = "dist-newstyle"
+ qe <- MaybeT $ Just <$> makeQueryEnv newBuild cabalFile
+
+ gmLog GmInfo "" $ text "Using Cabal new-build project at" <+>: text cabalDir
+ return Cradle {
+ cradleProject = CabalNewProject
+ , cradleCurrentDir = wdir
+ , cradleRootDir = cabalDir
+ , cradleTempDir = error "tmpDir"
+ , cradleCabalFile = Just cabalFile
+ , cradleDistDir = dd
+ , cradleQueryEnv = Just $ toDyn qe
+ }
+ else do
+ qe <- MaybeT $ Just <$> makeQueryEnv oldBuild cabalFile
+ 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"
+ , cradleQueryEnv = Just $ toDyn qe
+ }
stackCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
@@ -136,6 +189,8 @@ stackCradle stackProg wdir = do
senv <- MaybeT $ getStackEnv cabalDir stackProg
gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir
+ gmLog GmInfo "" $ text "Using Stack dist dir at" <+>: text (seDistDir senv) -- AZ
+ qe <- MaybeT $ Just <$> makeQueryEnv stackBuild cabalFile
return Cradle {
cradleProject = StackProject senv
, cradleCurrentDir = wdir
@@ -143,6 +198,7 @@ stackCradle stackProg wdir = do
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradleDistDir = seDistDir senv
+ , cradleQueryEnv = Just $ toDyn qe
}
stackCradleSpec ::
@@ -170,6 +226,7 @@ sandboxCradle wdir = do
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradleDistDir = "dist"
+ , cradleQueryEnv = Nothing
}
plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
@@ -182,4 +239,57 @@ plainCradle wdir = do
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradleDistDir = "dist"
+ , cradleQueryEnv = Nothing
}
+
+-- | Cabal produces .ghc.environment files which are loaded by GHC if
+-- they exist. For all bar a plain style project this is incorrect
+-- behaviour for ghc-mod, as ghc-mod works out which packages should
+-- be loaded.
+-- Identify whether this should be inhibited or not
+shouldLoadGhcEnvironment :: Cradle -> LoadGhcEnvironment
+shouldLoadGhcEnvironment crdl =
+ if cradleProject crdl == PlainProject
+ then LoadGhcEnvironment
+ else DontLoadGhcEnvironment
+
+-- ---------------------------------------------------------------------
+-- The following is moved here from cabal-helper test/GhcSession.hs
+
+oldBuild :: ProjSetup 'V1
+oldBuild = ProjSetup
+ { psDistDir = \dir -> DistDirV1 (dir "dist")
+ , psProjDir = \cabal_file -> ProjLocCabalFile cabal_file
+ }
+
+newBuild :: ProjSetup 'V2
+newBuild = ProjSetup
+ { psDistDir = \dir -> DistDirV2 (dir "dist-newstyle")
+ , psProjDir = \cabal_file -> ProjLocV2Dir (takeDirectory cabal_file)
+ }
+
+stackBuild :: ProjSetup 'Stack
+stackBuild = ProjSetup
+ { psDistDir = \_dir -> DistDirStack Nothing
+ , psProjDir = \cabal_file -> ProjLocStackYaml ((takeDirectory cabal_file) "stack.yaml")
+ }
+
+-- ---------------------------------------------------------------------
+
+makeQueryEnv :: (IOish m, GmOut m)
+ => forall pt. ProjSetup (pt :: ProjType) -> FilePath -> m (QueryEnv (pt :: ProjType))
+makeQueryEnv ps cabalFile = do
+ let projdir = takeDirectory cabalFile
+ -- crdl <- cradle
+ -- progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+ -- readProc <- gmReadProcess
+ qeBare <- liftIO $ mkQueryEnv
+ (psProjDir ps $ cabalFile)
+ (psDistDir ps $ projdir)
+ let qe = qeBare
+ -- { qeReadProcess = \_ -> readProc
+ -- , qePrograms = helperProgs progs
+ -- }
+ return qe
+
+-- ---------------------------------------------------------------------
diff --git a/core/GhcMod/DebugLogger.hs b/core/GhcMod/DebugLogger.hs
index 6e9dfa821..b40a3f724 100644
--- a/core/GhcMod/DebugLogger.hs
+++ b/core/GhcMod/DebugLogger.hs
@@ -133,6 +133,11 @@ gmPrintDoc_ mode pprCols putS doc
#if __GLASGOW_HASKELL__ >= 708
put (ZStr s) next = putS (zString s) >> next
#endif
+#if __GLASGOW_HASKELL__ >= 806
+ put (LStr s) next = putS (unpackLitString s) >> next
+ put (RStr n c) next = putS (replicate n c) >> next
+#else
put (LStr s _l) next = putS (unpackLitString s) >> next
+#endif
done = return () -- hPutChar hdl '\n'
diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs
index 2021dcf0e..ba4fadb51 100644
--- a/core/GhcMod/DynFlags.hs
+++ b/core/GhcMod/DynFlags.hs
@@ -55,9 +55,19 @@ setHscInterpreted df = df {
}
-- | 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)
+addCmdOpts :: GhcMonad m => LoadGhcEnvironment -> [GHCOption] -> DynFlags -> m DynFlags
+addCmdOpts loadGhcEnv cmdOpts df =
+ if loadGhcEnv == LoadGhcEnvironment
+ then fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
+ else
+ --
+ -- Passes "-hide-all-packages" to the GHC API to prevent parsing of
+ -- package environment files. However this only works if there is no
+ -- invocation of `setSessionDynFlags` before calling `initDynFlagsPure`.
+ -- See ghc tickets #15513, #15541.
+ -- Thanks @lspitzner
+ fst3 <$> G.parseDynamicFlags df (map G.noLoc ("-hide-all-packages":cmdOpts))
+ -- fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where
fst3 (a,_,_) = a
@@ -75,12 +85,12 @@ withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
return dflags
teardown = void . G.setSessionDynFlags
-withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
-withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
+withCmdFlags :: GhcMonad m => LoadGhcEnvironment -> [GHCOption] -> m a -> m a
+withCmdFlags loadGhcEnv flags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags
- void $ G.setSessionDynFlags =<< addCmdOpts flags dflags
+ void $ G.setSessionDynFlags =<< addCmdOpts loadGhcEnv flags dflags
return dflags
teardown = void . G.setSessionDynFlags
@@ -98,7 +108,7 @@ allWarningFlags :: Gap.WarnFlags
allWarningFlags = unsafePerformIO $
G.runGhc (Just libdir) $ do
df <- G.getSessionDynFlags
- df' <- addCmdOpts ["-Wall"] df
+ df' <- addCmdOpts LoadGhcEnvironment ["-Wall"] df
return $ G.warningFlags df'
----------------------------------------------------------------
diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs
index 776c588f9..ffd81439b 100644
--- a/core/GhcMod/DynFlagsTH.hs
+++ b/core/GhcMod/DynFlagsTH.hs
@@ -22,7 +22,13 @@ module GhcMod.DynFlagsTH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Applicative
+#if __GLASGOW_HASKELL__ >= 804
+import GHC.LanguageExtensions
+import qualified EnumSet as E
+import qualified Data.Set as IS
+#else
import qualified Data.IntSet as IS
+#endif
import Data.Maybe
import Data.Generics.Aliases
import Data.Generics.Schemes
@@ -83,6 +89,11 @@ deriveEqDynFlags qds = do
, "FlushOut"
, "FlushErr"
, "Settings" -- I think these can't cange at runtime
+ , "LogFinaliser" -- added for ghc-8.2
+ , "LogOutput" -- added for ghc-8.2
+ , "OverridingBool" -- added for ghc-8.2
+ , "Scheme" -- added for ghc-8.2
+ , "LoadedPlugin" -- added for ghc-8.6
]
ignoredTypeOccNames = [ "OnOff" ]
@@ -164,13 +175,26 @@ deriveEqDynFlags qds = do
"generalFlags" -> checkIntSet "generalFlags"
"warningFlags" -> checkIntSet "warningFlags"
+#if __GLASGOW_HASKELL__ >= 804
+ "dumpFlags" -> checkIntSet "dumpFlags"
+ "fatalWarningFlags" -> checkIntSet "fatalWarningFlags"
+ "extensionFlags" -> checkIntSet "extensionFlags"
+#endif
_ ->
[e| [($(return fa) == $(return fb), if $(return fa) == $(return fb) then "" else ("default changed:" ++ fon) )] |]
checkIntSet fieldName = do
- let eqfn = [| let fn aa bb = r
+ let eqfn = [| let fn aa' bb' = r
where
+#if __GLASGOW_HASKELL__ >= 804
+ aa = toSet aa'
+ bb = toSet bb'
+#else
+ aa = aa'
+ bb = bb'
+#endif
+
uni = IS.union aa bb
dif = IS.intersection aa bb
delta = IS.difference uni dif
@@ -180,3 +204,18 @@ deriveEqDynFlags qds = do
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
+
+
+#if __GLASGOW_HASKELL__ >= 806
+deriving instance Eq IncludeSpecs
+#endif
+#if __GLASGOW_HASKELL__ >= 804
+toSet es = IS.fromList $ E.toList es
+
+deriving instance Ord GeneralFlag
+deriving instance Ord DynFlags.WarningFlag
+deriving instance Ord DynFlags.DumpFlag
+deriving instance Ord DynFlags.LlvmTarget
+deriving instance Ord Extension
+deriving instance Eq LlvmTarget
+#endif
diff --git a/core/GhcMod/Error.hs b/core/GhcMod/Error.hs
index 968c357b0..e04e1713a 100644
--- a/core/GhcMod/Error.hs
+++ b/core/GhcMod/Error.hs
@@ -49,6 +49,7 @@ import Paths_ghc_mod_core (version)
import GhcMod.Types
import GhcMod.Pretty
+import Prelude hiding ( (<>) )
type GmError m = MonadError GhcModError m
diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs
index e05a54066..76f34414c 100644
--- a/core/GhcMod/FileMapping.hs
+++ b/core/GhcMod/FileMapping.hs
@@ -48,7 +48,8 @@ loadMappedFileSource from src = do
tmpdir <- cradleTempDir `fmap` cradle
enc <- liftIO . mkTextEncoding . optEncoding =<< options
to <- liftIO $ do
- (fn, h) <- openTempFile tmpdir (takeFileName from)
+ (fn', h) <- openTempFile tmpdir (takeFileName from)
+ fn <- getCanonicalFileNameSafe fn'
hSetEncoding h enc
hPutStr h src
hClose h
@@ -57,11 +58,12 @@ loadMappedFileSource from src = do
loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()
loadMappedFile' from to isTemp = do
- cfn <- getCanonicalFileNameSafe from
+ cfn <- liftIO $ canonicalizePath from
unloadMappedFile' cfn
crdl <- cradle
- let to' = makeRelative (cradleRootDir crdl) to
- addMMappedFile cfn (FileMapping to' isTemp)
+ to' <- liftIO $ canonicalizePath to
+ 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
diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs
index dff6b87f3..f04e6b420 100644
--- a/core/GhcMod/Gap.hs
+++ b/core/GhcMod/Gap.hs
@@ -37,8 +37,6 @@ module GhcMod.Gap (
, fileModSummary
, WarnFlags
, emptyWarnFlags
- , GLMatch
- , GLMatchI
, getClass
, occName
, listVisibleModuleNames
@@ -47,8 +45,19 @@ module GhcMod.Gap (
, GhcMod.Gap.isSynTyCon
, parseModuleHeader
, mkErrStyle'
+#if __GLASGOW_HASKELL__ < 804
, everythingStagedWithContext
+#endif
, withCleanupSession
+#if __GLASGOW_HASKELL__ >= 804
+ , GHC.GhcPs
+ , GHC.GhcRn
+ , GHC.GhcTc
+#else
+ , GhcPs
+ , GhcRn
+ , GhcTc
+#endif
) where
import Control.Applicative hiding (empty)
@@ -70,6 +79,7 @@ import NameSet
import OccName
import Outputable
import PprTyThing
+import IfaceSyn
import StringBuffer
import TcType
import Var (varType)
@@ -108,7 +118,10 @@ import TcRnTypes
#endif
#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
+import GHC hiding (ClsInst, withCleanupSession, setLogAction)
+import qualified GHC (withCleanupSession)
+#elif MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
import GHC hiding (ClsInst, withCleanupSession)
import qualified GHC (withCleanupSession)
#elif __GLASGOW_HASKELL__ >= 706
@@ -125,7 +138,9 @@ import UniqFM (eltsUFM)
import Module
#endif
-#if __GLASGOW_HASKELL__ >= 704
+#if __GLASGOW_HASKELL__ >= 804
+import qualified EnumSet as E (EnumSet, empty)
+#elif __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
#endif
@@ -140,10 +155,12 @@ import Parser
import SrcLoc
import Packages
import Data.Generics (GenericQ, extQ, gmapQ)
+#if __GLASGOW_HASKELL__ < 804
import GHC.SYB.Utils (Stage(..))
+#endif
import GhcMod.Types (Expression(..))
-import Prelude
+import Prelude hiding ( (<>) )
----------------------------------------------------------------
----------------------------------------------------------------
@@ -215,12 +232,18 @@ renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
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
+#if __GLASGOW_HASKELL__ >= 806
+ string_txt (Pretty.LStr s1) s2 = unpackLitString s1 ++ s2
+ -- a '\0'-terminated array of bytes
+ string_txt (Pretty.RStr n c) s2 = replicate n c ++ s2
+ -- a repeated character (e.g., ' ')
+#else
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
+#endif
#if __GLASGOW_HASKELL__ >= 708
string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2
#endif
-
----------------------------------------------------------------
----------------------------------------------------------------
@@ -284,9 +307,15 @@ fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file' = do
mss <- getModuleGraph
file <- liftIO $ canonicalizePath file'
- [ms] <- liftIO $ flip filterM mss $ \m ->
+#if __GLASGOW_HASKELL__ >= 804
+ mss <- liftIO $ flip filterM (mgModSummaries mss) $ \m ->
+#else
+ mss <- liftIO $ flip filterM mss $ \m ->
+#endif
(Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
- return ms
+ case mss of
+ [ms] -> return ms
+ _ -> error "pattern match Fail"
withInteractiveContext :: GhcMonad m => m a -> m a
withInteractiveContext action = gbracket setup teardown body
@@ -296,8 +325,14 @@ withInteractiveContext action = gbracket setup teardown body
body _ = do
topImports >>= setCtx
action
+ topImports :: GhcMonad m => m [InteractiveImport]
topImports = do
+#if __GLASGOW_HASKELL__ >= 804
+ mg <- getModuleGraph
+ ms <- filterM moduleIsInterpreted =<< map ms_mod <$> (return $ mgModSummaries mg)
+#else
ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph
+#endif
let iis = map (IIModule . modName) ms
#if __GLASGOW_HASKELL__ >= 704
return iis
@@ -393,8 +428,13 @@ class HasType a where
getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
-instance HasType (LHsBind Id) where
-#if __GLASGOW_HASKELL__ >= 708
+instance HasType (LHsBind GhcTc) where
+#if __GLASGOW_HASKELL__ >= 806
+ getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)
+ where in_tys = mg_arg_tys $ mg_ext m
+ out_typ = mg_res_ty $ mg_ext m
+ typ = mkFunTys in_tys out_typ
+#elif __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
@@ -417,7 +457,10 @@ filterOutChildren get_thing xs
infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
infoThing m (Expression str) = do
names <- parseName str
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 804
+ mb_stuffs <- mapM (getInfo False) names
+ let filtered = filterOutChildren (\(t,_f,_i,_fam,_doc) -> t) (catMaybes mb_stuffs)
+#elif __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names
let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
#else
@@ -426,7 +469,14 @@ infoThing m (Expression str) = do
#endif
return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 804
+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst],SDoc) -> SDoc
+pprInfo m _ (thing, fixity, insts, famInsts,_doc)
+ = pprTyThingInContextLoc' thing
+ $$ show_fixity fixity
+ $$ vcat (map pprInstance' insts)
+ $$ vcat (map pprFamInst' famInsts)
+#elif __GLASGOW_HASKELL__ >= 708
pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo m _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc' thing
@@ -459,9 +509,9 @@ pprInfo m pefas (thing, fixity, insts)
= showWithLoc (pprDefinedAt' (getName axiom)) $
hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
2 (equals <+> ppr rhs)
-#else
+# else
pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
-#endif
+# endif
#else
pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
#endif
@@ -514,7 +564,7 @@ nameForUser = pprOccName . getOccName
occNameForUser :: OccName -> SDoc
occNameForUser = pprOccName
-deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
+deSugar :: TypecheckedModule -> LHsExpr GhcTc -> HscEnv
-> IO (Maybe CoreExpr)
#if __GLASGOW_HASKELL__ >= 708
deSugar _ e hs_env = snd <$> deSugarExpr hs_env e
@@ -555,7 +605,11 @@ fromTyThing _ = GtN
----------------------------------------------------------------
----------------------------------------------------------------
-#if __GLASGOW_HASKELL__ >= 704
+#if __GLASGOW_HASKELL__ >= 804
+type WarnFlags = E.EnumSet WarningFlag
+emptyWarnFlags :: WarnFlags
+emptyWarnFlags = E.empty
+#elif __GLASGOW_HASKELL__ >= 704
type WarnFlags = I.IntSet
emptyWarnFlags :: WarnFlags
emptyWarnFlags = I.empty
@@ -568,16 +622,20 @@ emptyWarnFlags = []
----------------------------------------------------------------
----------------------------------------------------------------
-#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
+-- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.4#GHCAPIchanges
+#if __GLASGOW_HASKELL__ <= 802
+type GhcPs = RdrName
+type GhcRn = Name
+type GhcTc = Id
#endif
-getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
-#if __GLASGOW_HASKELL__ >= 802
+getClass :: [LInstDecl GhcRn] -> Maybe (Name, SrcSpan)
+#if __GLASGOW_HASKELL__ >= 806
+-- 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__ >= 802
-- 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)
@@ -664,7 +722,7 @@ parseModuleHeader
:: String -- ^ Haskell module source text (full Unicode is supported)
-> DynFlags
-> FilePath -- ^ the filename (for source locations)
- -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+ -> Either ErrorMessages (WarningMessages, Located (HsModule GhcPs))
parseModuleHeader str dflags filename =
let
loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -672,7 +730,11 @@ parseModuleHeader str dflags filename =
in
case L.unP Parser.parseHeader (mkPState dflags buf loc) of
+#if __GLASGOW_HASKELL__ >= 804
+ PFailed _ sp err ->
+#else
PFailed sp err ->
+#endif
#if __GLASGOW_HASKELL__ >= 706
Left (unitBag (mkPlainErrMsg dflags sp err))
#else
@@ -700,8 +762,10 @@ instance NFData ByteString where
rnf (Chunk _ b) = rnf b
#endif
+#if __GLASGOW_HASKELL__ < 804
-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
-- generated the Ast.
+-- everythingWithContext :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r
everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r
everythingStagedWithContext stage s0 f z q x
| (const False
@@ -716,6 +780,7 @@ everythingStagedWithContext stage s0 f z q x
#endif
fixity = const (stage Bool
(r, s') = q x s0
+#endif
withCleanupSession :: GhcMonad m => m a -> m a
#if __GLASGOW_HASKELL__ >= 800
diff --git a/core/GhcMod/GhcPkg.hs b/core/GhcMod/GhcPkg.hs
index 746b2eac9..5b802f308 100644
--- a/core/GhcMod/GhcPkg.hs
+++ b/core/GhcMod/GhcPkg.hs
@@ -68,8 +68,10 @@ getGhcPkgProgram = do
progs <- optPrograms <$> options
case cradleProject crdl of
(StackProject senv) -> do
- Just ghcPkg <- getStackGhcPkgPath senv
- return ghcPkg
+ mghcPkg <- getStackGhcPkgPath senv
+ case mghcPkg of
+ Just ghcPkg -> return ghcPkg
+ _ -> error "pattern match fail"
_ ->
return $ ghcPkgProgram progs
@@ -81,10 +83,14 @@ getPackageDbStack = do
PlainProject ->
return [GlobalDb, UserDb]
SandboxProject -> do
- Just db <- liftIO $ getSandboxDb crdl
- return $ [GlobalDb, db]
+ mdb <- liftIO $ getSandboxDb crdl
+ case mdb of
+ Just db -> return $ [GlobalDb, db]
+ _ -> error "pattern match fail"
CabalProject ->
getCabalPackageDbStack
+ CabalNewProject ->
+ getCabalPackageDbStack
(StackProject StackEnv {..}) ->
return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb]
return $ fromMaybe stack mCusPkgStack
diff --git a/core/GhcMod/LightGhc.hs b/core/GhcMod/LightGhc.hs
index 146f2c095..b9f758250 100644
--- a/core/GhcMod/LightGhc.hs
+++ b/core/GhcMod/LightGhc.hs
@@ -31,9 +31,20 @@ initStaticOpts = return ()
newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv
newLightEnv mdf = do
df <- liftIO $ do
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
+#else
initStaticOpts
+#endif
settings <- initSysTools (Just libdir)
+#if __GLASGOW_HASKELL__ >= 806
+ let llvmTgtList = ([],[]) -- TODO: where should this come from?
+ initDynFlags $ defaultDynFlags settings llvmTgtList
+#elif __GLASGOW_HASKELL__ >= 804
+ let llvmTgtList = [] -- TODO: where should this come from?
+ initDynFlags $ defaultDynFlags settings llvmTgtList
+#else
initDynFlags $ defaultDynFlags settings
+#endif
hsc_env <- liftIO $ newHscEnv df
df' <- runLightGhc hsc_env $ mdf df
@@ -50,13 +61,13 @@ 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)
+withLightHscEnv :: IOish m => LoadGhcEnvironment -> [GHCOption] -> (HscEnv -> m a) -> m a
+withLightHscEnv loadGhcEnv 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
+ _ <- setSessionDynFlags =<< addCmdOpts loadGhcEnv opts =<< getSessionDynFlags
getSessionDynFlags
runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a
diff --git a/core/GhcMod/Logger.hs b/core/GhcMod/Logger.hs
index 3ccf89bdb..6fd99f4f9 100644
--- a/core/GhcMod/Logger.hs
+++ b/core/GhcMod/Logger.hs
@@ -19,7 +19,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import ErrUtils
-import GHC
+import GHC hiding ( convert )
import HscTypes
import Outputable
import qualified GHC as G
@@ -27,7 +27,7 @@ import Bag
import SrcLoc
import FastString
-import GhcMod.Convert
+import GhcMod.Convert (convert)
import GhcMod.Doc (showPage)
import GhcMod.DynFlags (withDynFlags)
import GhcMod.Monad.Types
diff --git a/core/GhcMod/Logging.hs b/core/GhcMod/Logging.hs
index 930a56b68..7d5ffc878 100644
--- a/core/GhcMod/Logging.hs
+++ b/core/GhcMod/Logging.hs
@@ -48,8 +48,10 @@ gmSetLogLevel level =
gmGetLogLevel :: forall m. GmLog m => m GmLogLevel
gmGetLogLevel = do
- GhcModLog { gmLogLevel = Just level } <- gmlHistory
- return level
+ GhcModLog { gmLogLevel = mlevel } <- gmlHistory
+ case mlevel of
+ Just level -> return level
+ _ -> error "mempty value for GhcModLog must use a Just value"
gmSetDumpLevel :: GmLog m => Bool -> m ()
gmSetDumpLevel level =
@@ -73,7 +75,10 @@ decreaseLogLevel l = pred l
-- False
gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
gmLog level loc' doc = do
- GhcModLog { gmLogLevel = Just level' } <- gmlHistory
+ GhcModLog { gmLogLevel = mlevel' } <- gmlHistory
+ level' <- case mlevel' of
+ Nothing -> error "mempty value for GhcModLog must use a Just value"
+ Just l -> return l
let loc | loc' == "" = empty
| otherwise = text loc' <+>: empty
diff --git a/core/GhcMod/ModuleLoader.hs b/core/GhcMod/ModuleLoader.hs
new file mode 100644
index 000000000..b34a5e52d
--- /dev/null
+++ b/core/GhcMod/ModuleLoader.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Uses GHC hooks to load a TypecheckedModule
+
+module GhcMod.ModuleLoader
+ ( getModulesGhc
+ , getModulesGhc'
+ ) where
+
+import Control.Monad.IO.Class
+
+import qualified Data.Map as Map
+import Data.IORef
+
+import qualified GhcMod.Monad as GM
+import qualified GhcMod.Target as GM
+import qualified GhcMod.Types as GM
+
+import GHC (TypecheckedModule, ParsedModule)
+import qualified GHC
+import qualified DynFlags as GHC
+import qualified GhcMonad as GHC
+import qualified Hooks as GHC
+import qualified HscMain as GHC
+import qualified HscTypes as GHC
+import qualified TcRnMonad as GHC
+
+import System.Directory
+import System.FilePath
+
+-- ---------------------------------------------------------------------
+
+getMappedFileName :: FilePath -> GM.FileMappingMap -> FilePath
+getMappedFileName fname mfs =
+ case Map.lookup fname mfs of
+ Just fm -> GM.fmPath fm
+ Nothing -> fname
+
+canonicalizeModSummary :: (MonadIO m) =>
+ GHC.ModSummary -> m (Maybe FilePath)
+canonicalizeModSummary =
+ traverse (liftIO . canonicalizePath) . GHC.ml_hs_file . GHC.ms_location
+
+tweakModSummaryDynFlags :: GHC.ModSummary -> GHC.ModSummary
+tweakModSummaryDynFlags ms =
+ let df = GHC.ms_hspp_opts ms
+ in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream }
+
+-- | Gets a TypecheckedModule and/or ParsedModule from a given file
+-- The `wrapper` allows arbitary data to be captured during
+-- the compilation process, like errors and warnings
+-- Appends the parent directories of all the mapped files
+-- to the includePaths for CPP purposes.
+-- Use in combination with `runActionInContext` for best results
+getModulesGhc' :: GM.IOish m
+ => (GM.GmlT m () -> GM.GmlT m a) -> FilePath -> GM.GhcModT m (a, Maybe TypecheckedModule, Maybe ParsedModule)
+getModulesGhc' wrapper targetFile = do
+ cfileName <- liftIO $ canonicalizePath targetFile
+ mfs <- GM.getMMappedFiles
+ mFileName <- liftIO . canonicalizePath $ getMappedFileName cfileName mfs
+ refTypechecked <- liftIO $ newIORef Nothing
+ refParsed <- liftIO $ newIORef Nothing
+ let keepInfo = pure . (mFileName ==)
+ saveTypechecked = writeIORef refTypechecked . Just
+ saveParsed = writeIORef refParsed . Just
+ res <- getModulesGhc wrapper [cfileName] keepInfo saveTypechecked saveParsed
+ mtm <- liftIO $ readIORef refTypechecked
+ mpm <- liftIO $ readIORef refParsed
+ return (res, mtm, mpm)
+
+-- | like getModulesGhc' but allows you to keep an arbitary number of Modules
+-- `keepInfo` decides which module to keep
+-- `saveTypechecked` is the callback that is passed the TypecheckedModule
+-- `saveParsed` is the callback that is passed the ParsedModule
+getModulesGhc :: GM.IOish m
+ => (GM.GmlT m () -> GM.GmlT m a) -> [FilePath] -> (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> (ParsedModule -> IO ()) -> GM.GhcModT m a
+getModulesGhc wrapper targetFiles keepInfo saveTypechecked saveParsed = do
+ mfs <- GM.getMMappedFiles
+
+#if __GLASGOW_HASKELL__ >= 806
+ let ips = map takeDirectory $ Map.keys mfs
+ getPaths ips' df = GHC.IncludeSpecs qpaths (ips' ++ gpaths)
+ where
+ -- Note, introduced for include path issues on windows, see
+ -- https://ghc.haskell.org/trac/ghc/ticket/14312
+ GHC.IncludeSpecs qpaths gpaths = GHC.includePaths df
+ setIncludePaths df = df { GHC.includePaths = getPaths ips df }
+#else
+ let ips = map takeDirectory $ Map.keys mfs
+ setIncludePaths df = df { GHC.includePaths = ips ++ GHC.includePaths df }
+#endif
+ GM.runGmlTWith' (map Left targetFiles)
+ (return . setIncludePaths)
+ (Just $ updateHooks keepInfo saveTypechecked saveParsed)
+ wrapper
+ (return ())
+
+updateHooks
+ :: (FilePath -> IO Bool)
+ -> (TypecheckedModule -> IO ())
+ -> (ParsedModule -> IO ())
+ -> GHC.Hooks
+ -> GHC.Hooks
+updateHooks fp ref refParsed hooks = hooks {
+#if __GLASGOW_HASKELL__ <= 710
+ GHC.hscFrontendHook = Just $ hscFrontend fp ref
+#else
+ GHC.hscFrontendHook = Just $ fmap GHC.FrontendTypecheck . hscFrontend fp ref refParsed
+#endif
+ }
+
+
+-- | Warning: discards all changes to Session
+runGhcInHsc :: GHC.Ghc a -> GHC.Hsc a
+runGhcInHsc action = do
+ env <- GHC.getHscEnv
+ session <- liftIO $ newIORef env
+ liftIO $ GHC.reflectGhc action $ GHC.Session session
+
+
+-- | Frontend hook that keeps the TypecheckedModule for its first argument
+-- and stores it in the IORef passed to it
+hscFrontend :: (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> (ParsedModule -> IO ()) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv
+hscFrontend keepInfoFunc saveTypechecked saveParsed mod_summary = do
+ mfn <- canonicalizeModSummary mod_summary
+ -- md = GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod mod_summary
+ keepInfo <- case mfn of
+ Just fileName -> liftIO $ keepInfoFunc fileName
+ Nothing -> pure False
+
+ if keepInfo
+ then runGhcInHsc $ do
+ let modSumWithRaw = tweakModSummaryDynFlags mod_summary
+
+ p' <- GHC.parseModule modSumWithRaw
+ let p = p' {GHC.pm_mod_summary = mod_summary}
+ liftIO $ saveParsed p
+
+ tc <- GHC.typecheckModule p
+ let tc_gbl_env = fst $ GHC.tm_internals_ tc
+
+ liftIO $ saveTypechecked tc
+ return tc_gbl_env
+ else do
+ hpm <- GHC.hscParse' mod_summary
+ hsc_env <- GHC.getHscEnv
+#if __GLASGOW_HASKELL__ >= 804
+ -- tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
+ GHC.tcRnModule' mod_summary False hpm
+#else
+ GHC.tcRnModule' hsc_env mod_summary False hpm
+#endif
+
+-- ---------------------------------------------------------------------
+
diff --git a/core/GhcMod/Monad/Compat.hs_h b/core/GhcMod/Monad/Compat.hs_h
index 7437bfc90..cd90e5f1a 100644
--- a/core/GhcMod/Monad/Compat.hs_h
+++ b/core/GhcMod/Monad/Compat.hs_h
@@ -22,7 +22,4 @@
-- '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
diff --git a/core/GhcMod/Options/Help.hs b/core/GhcMod/Options/Help.hs
index b23487cc5..5156f588f 100644
--- a/core/GhcMod/Options/Help.hs
+++ b/core/GhcMod/Options/Help.hs
@@ -14,6 +14,7 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
module GhcMod.Options.Help where
@@ -33,6 +34,11 @@ type MyDoc = MyDocM (Maybe Doc) ()
instance IsString (MyDocM (Maybe Doc) a) where
fromString = append . para
+#if __GLASGOW_HASKELL__ >= 804
+instance Semigroup (MyDocM (Maybe Doc) ()) where
+ (<>) = mappend
+#endif
+
instance Monoid (MyDocM (Maybe Doc) ()) where
mappend a b = append $ doc a <> doc b
mempty = append PP.empty
@@ -47,7 +53,7 @@ append s = modify m >> return undefined
m Nothing = Just s
m (Just old) = Just $ old PP..$. s
-infixr 7 \\
+infixr 7 \\ -- comment to sort out CPP
(\\) :: MyDoc -> MyDoc -> MyDoc
(\\) a b = append $ doc a PP.<+> doc b
diff --git a/core/GhcMod/PathsAndFiles.hs b/core/GhcMod/PathsAndFiles.hs
index c55987c24..560dcaaad 100644
--- a/core/GhcMod/PathsAndFiles.hs
+++ b/core/GhcMod/PathsAndFiles.hs
@@ -14,6 +14,7 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
+{-# LANGUAGE CPP #-}
module GhcMod.PathsAndFiles (
module GhcMod.PathsAndFiles
, module GhcMod.Caching
@@ -81,7 +82,12 @@ findCustomPackageDbFile dir =
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
getSandboxDb crdl = do
mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl)
+
+#if MIN_VERSION_cabal_helper(1,0,0)
+ bp <- return buildPlatform
+#else
bp <- buildPlatform readProcess
+#endif
return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)
where
diff --git a/core/GhcMod/Pretty.hs b/core/GhcMod/Pretty.hs
index d2737888c..c83d4356a 100644
--- a/core/GhcMod/Pretty.hs
+++ b/core/GhcMod/Pretty.hs
@@ -38,8 +38,10 @@ import GHC
import Outputable (SDoc, withPprStyleDoc)
import GhcMod.Types
+import Distribution.Helper
import GhcMod.Doc
import GhcMod.Gap (renderGm)
+import Prelude hiding ( (<>))
renderSDoc :: GhcMonad m => SDoc -> m Doc
renderSDoc sdoc = do
@@ -49,7 +51,11 @@ renderSDoc sdoc = do
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
-#if MIN_VERSION_cabal_helper(0,8,0)
+#if MIN_VERSION_cabal_helper(1,0,0)
+gmComponentNameDoc (ChLibName ChMainLibName) = text $ "library"
+gmComponentNameDoc (ChLibName (ChSubLibName n)) = text $ "library:" ++ n
+gmComponentNameDoc (ChFLibName _) = text $ "flibrary"
+#elif MIN_VERSION_cabal_helper(0,8,0)
gmComponentNameDoc ChLibName = text $ "library"
gmComponentNameDoc (ChSubLibName _)= text $ "library"
gmComponentNameDoc (ChFLibName _) = text $ "flibrary"
diff --git a/core/GhcMod/Stack.hs b/core/GhcMod/Stack.hs
index 0c0ada00e..4a1605fb1 100644
--- a/core/GhcMod/Stack.hs
+++ b/core/GhcMod/Stack.hs
@@ -40,12 +40,15 @@ 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
- }
+ mghc <- getStackGhcPath senv
+ mghcPkg <- getStackGhcPkgPath senv
+ case (mghc,mghcPkg) of
+ (Just ghc,Just ghcPkg) ->
+ return $ progs {
+ ghcProgram = ghc
+ , ghcPkgProgram = ghcPkg
+ }
+ _ -> error "pattern match fail"
patchStackPrograms _crdl progs = return progs
getStackEnv :: (IOish m, GmOut m, GmLog m)
diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs
index 2294cfa8d..859774a1c 100644
--- a/core/GhcMod/Target.hs
+++ b/core/GhcMod/Target.hs
@@ -21,6 +21,9 @@ import Control.Arrow
import Control.Applicative
import Control.Category ((.))
import GHC
+import qualified Hooks as GHC
+import qualified HscTypes as GHC
+import qualified GhcMonad as G
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
#endif
@@ -30,6 +33,7 @@ import DynFlags
import HscTypes
import Pretty
+import GhcMod.Cradle
import GhcMod.DynFlags
import GhcMod.Monad.Types
import GhcMod.CabalHelper
@@ -67,8 +71,10 @@ import System.FilePath
runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a
runGmPkgGhc action = do
+ crdl <- cradle
+ let loadGhcEnv = shouldLoadGhcEnvironment crdl
pkgOpts <- packageGhcOptions
- withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
+ withLightHscEnv loadGhcEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
initSession :: IOish m
=> [GHCOption]
@@ -101,8 +107,8 @@ initSession opts mdf = do
else
gmLog GmDebug "initSession" $ text "Session already initialized"
where
- initDF Cradle { cradleTempDir } df =
- setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
+ initDF c@Cradle { cradleTempDir, cradleProject } df =
+ setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts (shouldLoadGhcEnvironment c) opts df)
teardownSession hsc_env_ref = do
hsc_env <- liftIO $ readIORef hsc_env_ref
@@ -146,16 +152,42 @@ runGmlT' :: IOish m
-> 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
+-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context of
+-- certain files or modules, with updated GHC flags, and updated ModuleGraph
+runGmlTfm :: IOish m
+ => [Either FilePath ModuleName]
+ -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
+ -> Maybe (GHC.Hooks -> GHC.Hooks)
+ -> GmlT m a
+ -> GhcModT m a
+runGmlTfm fns mdf mUpdateHooks action
+ = runGmlTWith' fns mdf mUpdateHooks 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, updated ModuleGraph 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
+runGmlTWith efnmns' mdf wrapper action =
+ runGmlTWith' efnmns' mdf Nothing wrapper action
+
+-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context of
+-- certain files or modules, with updated GHC flags, updated ModuleGraph and a
+-- final transformation
+runGmlTWith' :: IOish m
+ => [Either FilePath ModuleName]
+ -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
+ -> Maybe (GHC.Hooks -> GHC.Hooks)
+ -- ^ If a hook update is provided, force the reloading
+ -- of the specified targets
+ -> (GmlT m a -> GmlT m b)
+ -> GmlT m a
+ -> GhcModT m b
+runGmlTWith' efnmns' mdf mUpdateHooks wrapper action = do
crdl <- cradle
Options { optGhcUserOptions } <- options
@@ -163,15 +195,34 @@ runGmlTWith efnmns' mdf wrapper action = do
ccfns = map (cradleCurrentDir crdl ) fns
cfns <- mapM getCanonicalFileNameSafe ccfns
let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
- opts <- targetGhcOptions crdl serfnmn
+ (opts, mappedStrs) <- targetGhcOptions crdl serfnmn
+
let opts' = opts ++ ["-O0", "-fno-warn-missing-home-modules"] ++ optGhcUserOptions
+ gmVomit
+ "session-ghc-options"
+ (text "hide all packages(ignore .ghc.environment):")
+ (show $ shouldLoadGhcEnvironment crdl)
+
+ gmVomit
+ "session-ghc-options"
+ (text "Using the following mapped files")
+ (intercalate " " $ map (("\""++) . (++"\"")) mappedStrs)
+
+ gmVomit
+ "session-ghc-options"
+ (text "Using the following mapped files")
+ (intercalate " " $ map (("\""++) . (++"\"")) mappedStrs)
+
gmVomit
"session-ghc-options"
(text "Initializing GHC session with following options")
(intercalate " " $ map (("\""++) . (++"\"")) opts')
- GhcModLog { gmLogLevel = Just level } <- gmlHistory
+ GhcModLog { gmLogLevel = mlevel } <- gmlHistory
+ level <- case mlevel of
+ Just level -> return level
+ _ -> error "pattern match fail"
putErr <- gmErrStrIO
let setLogger | level >= GmDebug = setDebugLogger putErr
| otherwise = setEmptyLogger
@@ -179,31 +230,39 @@ runGmlTWith efnmns' mdf wrapper action = do
initSession opts' $
setHscNothing >>> setLogger >>> mdf
- mappedStrs <- getMMappedFilePaths
let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns
+ gmVomit
+ "session-ghc-options"
+ (text "Using the following targets")
+ (intercalate " " $ map (("\""++) . (++"\"")) targetStrs)
+
unGmlT $ wrapper $ do
- loadTargets opts targetStrs
+ loadTargets opts targetStrs mUpdateHooks
action
targetGhcOptions :: forall m. IOish m
=> Cradle
-> Set (Either FilePath ModuleName)
- -> GhcModT m [GHCOption]
+ -> GhcModT m ([GHCOption],[FilePath])
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
+ | otherwise -> do
+ opts <- sandboxOpts crdl
+ mappedStrs <- getMMappedFilePaths
+ return (opts, mappedStrs)
where
zipMap f l = l `zip` (f `map` l)
- cabalOpts :: Cradle -> GhcModT m [String]
+ cabalOpts :: Cradle -> GhcModT m ([GHCOption],[FilePath])
cabalOpts Cradle{..} = do
mcs <- cabalResolvedComponents
-
+ mappedStrs <- getMMappedFilePaths
+ let mappedComps = zipMap (moduleComponents mcs . Left) mappedStrs
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = findCandidates $ map snd mdlcs
@@ -214,15 +273,22 @@ targetGhcOptions crdl sefnmn = do
then do
-- First component should be ChLibName, if no lib will take lexically first exe.
let cns = filter (/= ChSetupHsName) $ Map.keys mcs
+ cn = head cns
+ mappedStrsInComp = map fst $ filter (Set.member cn . snd) mappedComps
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
+ let opts = gmcGhcOpts (fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup cn mcs)
+ ++ ["-Wno-missing-home-modules"]
+ return (opts, mappedStrsInComp)
else do
when noCandidates $
throwError $ GMECabalCompAssignment mdlcs
let cn = pickComponent candidates
- return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs
+ mappedStrsInComp = map fst $ filter (Set.member cn . snd) mappedComps
+ opts = gmcGhcOpts (fromJustNote "targetGhcOptions" $ Map.lookup cn mcs)
+ ++ ["-Wno-missing-home-modules"]
+ return (opts, mappedStrsInComp)
resolvedComponentsCache :: IOish m => FilePath ->
Cached (GhcModT m) GhcModState
@@ -311,7 +377,7 @@ packageGhcOptions = do
| otherwise -> sandboxOpts crdl
-- also works for plain projects!
-sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]
+sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [GHCOption]
sandboxOpts crdl = do
mCusPkgDb <- getCustomPkgDbStack
pkgDbStack <- liftIO $ getSandboxPackageDbStack
@@ -330,8 +396,10 @@ resolveGmComponent :: (IOish m, Gm m)
-> m (GmComponent 'GMCResolved (Set ModulePath))
resolveGmComponent mums c@GmComponent {..} = do
distDir <- cradleDistDir <$> cradle
+ crdl <- cradle
+ let loadGhcEnv = shouldLoadGhcEnvironment crdl
gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir
- withLightHscEnv (ghcOpts distDir) $ \env -> do
+ withLightHscEnv loadGhcEnv (ghcOpts distDir) $ \env -> do
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
let mg = gmcHomeModuleGraph
let simp = gmcEntrypoints
@@ -355,9 +423,9 @@ resolveEntrypoint :: (IOish m, Gm m)
=> Cradle
-> GmComponent 'GMCRaw ChEntrypoint
-> m (GmComponent 'GMCRaw (Set ModulePath))
-resolveEntrypoint Cradle {..} c@GmComponent {..} = do
+resolveEntrypoint crdl@Cradle {..} c@GmComponent {..} = do
gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts
- withLightHscEnv gmcGhcSrcOpts $ \env -> do
+ withLightHscEnv (shouldLoadGhcEnvironment crdl) gmcGhcSrcOpts $ \env -> do
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
rms <- resolveModule env srcDirs `mapM` eps
@@ -367,8 +435,8 @@ resolveEntrypoint Cradle {..} c@GmComponent {..} = do
-- 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 _ (ChLibEntrypoint em om sm) =
+ return $ map (Right . chModToMod) (em ++ om ++ sm)
resolveChEntrypoints _ (ChExeEntrypoint main om) =
return $ [Left main] ++ map (Right . chModToMod) om
@@ -448,41 +516,62 @@ resolveGmComponents mcache cs = do
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
+loadTargets :: IOish m => [GHCOption] -> [FilePath] -> Maybe (GHC.Hooks -> GHC.Hooks) -> GmlT m ()
+loadTargets opts targetStrs mUpdateHooks = do
+ crdl <- cradle
+ let loadGhcEnv = shouldLoadGhcEnvironment crdl
targets' <-
- withLightHscEnv opts $ \env ->
+ withLightHscEnv loadGhcEnv opts $ \env ->
liftM (nubBy ((==) `on` targetId))
(mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)
>>= mapM relativize
let targets = map (\t -> t { targetAllowObjCode = False }) targets'
+ targetFileNames = concatMap filePathFromTarget targets
gmLog GmDebug "loadTargets" $
text "Loading" <+>: fsep (map (text . showTargetId) targets)
+
+ let filterModSums = isJust mUpdateHooks
+ gmLog GmDebug "loadTargets" $
+ text "filterModSums" <+>: text (show filterModSums)
+
setTargets targets
+ when filterModSums $ updateModuleGraph setDynFlagsRecompile targetFileNames
+
mg <- depanal [] False
let interp = needsHscInterpreted mg
target <- hscTarget <$> getSessionDynFlags
when (interp && target /= HscInterpreted) $ do
- _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags
+ let
+ setHooks :: DynFlags -> DynFlags
+ setHooks df = df { GHC.hooks = (fromMaybe id mUpdateHooks) (GHC.hooks df) }
+ _ <- setSessionDynFlags . setHscInterpreted . setHooks =<< getSessionDynFlags
gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
+ when filterModSums $ updateModuleGraph setDynFlagsRecompile targetFileNames
+
target' <- hscTarget <$> getSessionDynFlags
case target' of
HscNothing -> do
void $ load LoadAllTargets
+#if __GLASGOW_HASKELL__ >= 804
+ forM_ (mgModSummaries mg) $
+#else
forM_ mg $
+#endif
handleSourceError (gmLog GmDebug "loadTargets" . text . show)
. void . (parseModule >=> typecheckModule >=> desugarModule)
HscInterpreted -> do
void $ load LoadAllTargets
_ -> error ("loadTargets: unsupported hscTarget")
+ when filterModSums $ updateModuleGraph unSetDynFlagsRecompile targetFileNames
+
gmLog GmDebug "loadTargets" $ text "Loading done"
where
@@ -496,8 +585,41 @@ loadTargets opts targetStrs = do
showTargetId (Target (TargetModule s) _ _) = moduleNameString s
showTargetId (Target (TargetFile s _) _ _) = s
+ filePathFromTarget (Target (TargetModule _) _ _) = []
+ filePathFromTarget (Target (TargetFile s _) _ _) = [s]
+
+ updateModuleGraph :: (GhcMonad m, GmState m, GmEnv m,
+ MonadIO m, GmLog m, GmOut m)
+ => (DynFlags -> DynFlags) -> [FilePath] -> m ()
+ updateModuleGraph df fps = do
+ let
+ fpSet = Set.fromList fps
+ updateHooks df = df { GHC.hooks = (fromMaybe id mUpdateHooks) (GHC.hooks df)}
+ mustRecompile ms = case (ml_hs_file . ms_location) ms of
+ Nothing -> ms
+ Just f -> if Set.member f fpSet
+ then ms {ms_hspp_opts = (df . updateHooks) (ms_hspp_opts ms)}
+ else ms
+#if __GLASGOW_HASKELL__ >= 804
+ update s = s {hsc_mod_graph = mkModuleGraph $ map mustRecompile (mgModSummaries $ hsc_mod_graph s)}
+#else
+ update s = s {hsc_mod_graph = map mustRecompile (hsc_mod_graph s)}
+#endif
+ G.modifySession update
+
+ setDynFlagsRecompile :: DynFlags -> DynFlags
+ setDynFlagsRecompile df = gopt_set df Opt_ForceRecomp
+
+ unSetDynFlagsRecompile :: DynFlags -> DynFlags
+ unSetDynFlagsRecompile df = gopt_unset df Opt_ForceRecomp
+
needsHscInterpreted :: ModuleGraph -> Bool
+#if __GLASGOW_HASKELL__ >= 804
+needsHscInterpreted mg = foo (mgModSummaries mg)
+ where foo = any $ \ms ->
+#else
needsHscInterpreted = any $ \ms ->
+#endif
let df = ms_hspp_opts ms in
#if __GLASGOW_HASKELL__ >= 800
TemplateHaskell `xopt` df
@@ -515,6 +637,10 @@ 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
+ r <- withProjSetup $ \ps -> do
+ comps <- mapM (resolveEntrypoint crdl) =<< (getComponents ps)
+ withAutogen ps $
+ cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps
+ case r of
+ Just foo -> return foo
+ Nothing -> error "cabalResolvedComponents"
diff --git a/core/GhcMod/Types.hs b/core/GhcMod/Types.hs
index 06d3a625a..98450dea4 100644
--- a/core/GhcMod/Types.hs
+++ b/core/GhcMod/Types.hs
@@ -19,6 +19,7 @@ import Control.Monad
import Control.DeepSeq
import Data.Binary
import Data.Binary.Generic
+import Data.Dynamic (Dynamic)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -30,6 +31,7 @@ import Data.IORef
import Data.Label.Derive
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CabalHelper
+-- CabalHelper.Shared.InterfaceTypes
import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..))
@@ -133,6 +135,7 @@ defaultOptions = Options {
----------------------------------------------------------------
data Project = CabalProject
+ | CabalNewProject
| SandboxProject
| PlainProject
| StackProject StackEnv
@@ -141,6 +144,7 @@ data Project = CabalProject
isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True
isCabalHelperProject CabalProject {} = True
+isCabalHelperProject CabalNewProject {} = True
isCabalHelperProject _ = False
data StackEnv = StackEnv {
@@ -163,7 +167,19 @@ data Cradle = Cradle {
, cradleCabalFile :: Maybe FilePath
-- | The build info directory.
, cradleDistDir :: FilePath
- } deriving (Eq, Show, Ord)
+ , cradleQueryEnv :: !(Maybe Dynamic) -- QueryEnv pt
+ }
+ -- } deriving (Eq, Ord, Show)
+
+data ProjSetup (pt :: ProjType) =
+ ProjSetup
+ { psDistDir :: FilePath -> DistDir pt
+ , psProjDir :: FilePath -> ProjLoc pt
+ }
+
+data LoadGhcEnvironment = LoadGhcEnvironment
+ | DontLoadGhcEnvironment
+ deriving (Show,Eq)
data GmStream = GmOutStream | GmErrStream
deriving (Show)
@@ -184,6 +200,11 @@ data GhcModLog = GhcModLog {
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
+#if __GLASGOW_HASKELL__ >= 804
+instance Semigroup GhcModLog where
+ (<>) = mappend
+#endif
+
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
@@ -206,6 +227,7 @@ data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmCaches :: !GhcModCaches
, gmMMappedFiles :: !FileMappingMap
+ -- , gmQueryEnvs :: !
}
defaultGhcModState :: GhcModState
@@ -275,6 +297,11 @@ instance Binary GmModuleGraph where
swapMap :: Ord v => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
+#if __GLASGOW_HASKELL__ >= 804
+instance Semigroup GmModuleGraph where
+ (<>) = mappend
+#endif
+
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') =
@@ -283,20 +310,21 @@ instance Monoid GmModuleGraph where
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
- gmcHomeModuleGraph :: GmModuleGraph
- , gmcGhcOpts :: [GHCOption]
- , gmcGhcPkgOpts :: [GHCOption]
- , gmcGhcSrcOpts :: [GHCOption]
- , gmcGhcLangOpts :: [GHCOption]
- , gmcRawEntrypoints :: ChEntrypoint
- , gmcEntrypoints :: eps
- , gmcSourceDirs :: [FilePath]
- , gmcName :: ChComponentName
+ gmcHomeModuleGraph :: GmModuleGraph
+ , gmcGhcOpts :: [GHCOption]
+ , gmcGhcPkgOpts :: [GHCOption]
+ , gmcGhcSrcOpts :: [GHCOption]
+ , gmcGhcLangOpts :: [GHCOption]
+ , gmcRawEntrypoints :: ChEntrypoint
+ , gmcEntrypoints :: eps
+ , gmcSourceDirs :: [FilePath]
+ , gmcName :: ChComponentName
+ , gmcNeedsBuildOutput :: NeedsBuildOutput
} deriving (Eq, Ord, Show, Read, Generic, Functor)
-instance Binary eps => Binary (GmComponent t eps) where
- put = ggput . from
- get = to `fmap` ggget
+-- 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)
@@ -372,6 +400,18 @@ instance Binary ChComponentName where
instance Binary ChEntrypoint where
put = ggput . from
get = to `fmap` ggget
+instance Binary CabalHelper.ChLibraryName where
+ put = ggput . from
+ get = to `fmap` ggget
+instance Binary NeedsBuildOutput where
+ put = ggput . from
+ get = to `fmap` ggget
+instance Binary (GmComponent 'GMCResolved (Set ModulePath)) where
+ put = ggput . from
+ get = to `fmap` ggget
+instance Binary (GmComponent 'GMCRaw (Set ModulePath)) where
+ put = ggput . from
+ get = to `fmap` ggget
-- | Options for "lintWith" function
data LintOpts = LintOpts {
diff --git a/core/GhcMod/Utils.hs b/core/GhcMod/Utils.hs
index 7c282357b..0d18ce81c 100644
--- a/core/GhcMod/Utils.hs
+++ b/core/GhcMod/Utils.hs
@@ -113,7 +113,7 @@ withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile
runWithFile (Just to) = action $ fmPath to
runWithFile _ = action file
-getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
+getCanonicalFileNameSafe :: (IOish 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')
diff --git a/core/GhcModCore.hs b/core/GhcModCore.hs
index a7ba32d13..d010879c5 100644
--- a/core/GhcModCore.hs
+++ b/core/GhcModCore.hs
@@ -12,7 +12,7 @@ module GhcModCore (
, FileMapping(..)
, defaultOptions
-- * Logging
- , GmLogLevel
+ , GmLogLevel(..)
, increaseLogLevel
, decreaseLogLevel
, gmSetLogLevel
@@ -27,6 +27,7 @@ module GhcModCore (
-- * Monad Types
, GhcModT
, IOish
+ , MonadIO(..)
-- * Monad utilities
, runGhcModT
, withOptions
@@ -40,12 +41,64 @@ module GhcModCore (
, loadMappedFile
, loadMappedFileSource
, unloadMappedFile
+ -- * HIE integration utilities
+ , getModulesGhc
+ , getModulesGhc'
+ -- * Manage GHC AST index vars for older GHCs
+ , GhcPs,GhcRn,GhcTc
+ -- Temporary home, see what there is, before strippint out
+ , findCradle'
+ , GmEnv
+ , gmeLocal
+ , gmCradle
+ , mkRevRedirMapFunc
+ , cradle
+ , GmOut(..)
+ , options
+ , GmLog(..)
+ , makeAbsolute'
+ , withMappedFile
+ , listVisibleModuleNames
+ , runLightGhc
+ , GHandler(..)
+ , gcatches
+ , GmlT(..)
+ , defaultLintOpts
+ , gmsGet
+ , gmGhcSession
+ , gmgsSession
+ , getMMappedFiles
+ , withDynFlags
+ , ghcExceptionDoc
+ , mkErrStyle'
+ , renderGm
+ , LightGhc(..)
+ , OutputOpts(..)
+ , gmlGetSession
+ , gmlSetSession
+ , cabalResolvedComponents
+ , ModulePath(..)
+ , GmComponent(..)
+ , GmComponentType(..)
+ , GmModuleGraph(..)
+
+ -- * Used in ghc-mod
+ , convert
) where
import GhcMod.Cradle
import GhcMod.FileMapping
import GhcMod.Logging
import GhcMod.Monad
+import GhcMod.ModuleLoader
import GhcMod.Output
import GhcMod.Target
import GhcMod.Types
+
+import GhcMod.Gap (GhcPs,GhcRn,GhcTc,listVisibleModuleNames,mkErrStyle')
+import GhcMod.Utils (mkRevRedirMapFunc,makeAbsolute',withMappedFile)
+import GhcMod.LightGhc (runLightGhc)
+import GhcMod.Error (GHandler(..),gcatches,ghcExceptionDoc)
+-- import GhcMod.SrcUtils (pretty,collectAllSpansTypes)
+import GhcMod.DynFlags (withDynFlags)
+import GhcMod.Convert ( convert )
diff --git a/core/LICENSE b/core/LICENSE
new file mode 100644
index 000000000..9f26b637f
--- /dev/null
+++ b/core/LICENSE
@@ -0,0 +1 @@
+Foo
\ No newline at end of file
diff --git a/core/ghc-mod-core.cabal b/core/ghc-mod-core.cabal
index e077f3a61..16ca8a471 100644
--- a/core/ghc-mod-core.cabal
+++ b/core/ghc-mod-core.cabal
@@ -26,6 +26,7 @@ Description:
Category: GHC, Development
Cabal-Version: >= 1.24
Build-Type: Simple
+Extra-Source-Files: GhcMod/Monad/Compat.hs_h
Library
Default-Language: Haskell2010
@@ -54,6 +55,7 @@ Library
GhcMod.LightGhc
GhcMod.Logger
GhcMod.Logging
+ GhcMod.ModuleLoader
GhcMod.Monad
GhcMod.Monad.Env
GhcMod.Monad.Log
@@ -69,7 +71,6 @@ Library
GhcMod.PathsAndFiles
GhcMod.Pretty
GhcMod.Read
- GhcMod.SrcUtils
GhcMod.Stack
GhcMod.Target
GhcMod.Types
@@ -88,40 +89,35 @@ Library
, directory
, filepath
, mtl
- , old-time
, process
, template-haskell
, time
, transformers
- , base < 4.11 && >= 4.6.0.1
- , djinn-ghc < 0.1 && >= 0.0.2.2
+ , base < 4.14 && >= 4.6.0.1
, extra < 1.7 && >= 1.4
, fclabels < 2.1 && >= 2.0
- , fingertree < 0.2 && >= 0.1.1.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 < 3.0 && >= 2.0.8
+ -- , haskell-src-exts < 1.22 && >= 1.18
, monad-control < 1.1 && >= 1
, monad-journal < 0.9 && >= 0.4
, optparse-applicative < 0.15 && >= 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.8 && >= 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.9 && >= 0.8.0.2
- , ghc < 8.4 && >= 7.6
+ , cabal-helper < 1.10 && >= 1.0.0.0
+ , ghc < 8.7 && >= 7.6
if impl(ghc >= 8.0)
Build-Depends: ghc-boot
if impl(ghc < 7.8)
Build-Depends: convertible < 1.2 && >= 1.1.0.0
+ if impl(ghc < 8.4)
+ Build-Depends: ghc-syb-utils < 0.3 && >= 0.2.3
Source-Repository head
Type: git
diff --git a/ghc-mod.cabal b/ghc-mod.cabal
index 71ebb09b4..c01b6302d 100644
--- a/ghc-mod.cabal
+++ b/ghc-mod.cabal
@@ -30,7 +30,7 @@ Data-Files: elisp/Makefile
elisp/*.el
Extra-Source-Files: ChangeLog
README.md
- core/GhcMod/Monad/Compat.hs_h
+ -- core/GhcMod/Monad/Compat.hs_h
test/data/annotations/*.hs
test/data/broken-cabal/*.cabal
test/data/broken-sandbox/cabal.sandbox.config
@@ -92,7 +92,7 @@ Extra-Source-Files: ChangeLog
Custom-Setup
Setup-Depends: base
- , Cabal < 2.1 && >= 1.24
+ , Cabal < 2.5 && >= 1.24
, cabal-doctest < 1.1 && >= 1
Library
@@ -119,6 +119,7 @@ Library
GhcMod.Exe.Modules
GhcMod.Exe.PkgDoc
GhcMod.Exe.Test
+ GhcMod.SrcUtils
Other-Modules: Paths_ghc_mod
Build-Depends:
-- See Note [GHC Boot libraries]
@@ -135,33 +136,33 @@ Library
, time
, transformers
- , base < 4.11 && >= 4.6.0.1
- , djinn-ghc < 0.1 && >= 0.0.2.2
- , extra < 1.6 && >= 1.4
+ , base < 4.14 && >= 4.6.0.1
+ -- , djinn-ghc < 0.1 && >= 0.0.2.2
+ , extra < 1.7 && >= 1.4
, fclabels < 2.1 && >= 2.0
, ghc-paths < 0.2 && >= 0.1.0.9
- , ghc-syb-utils < 0.3 && >= 0.2.3
, ghc-mod-core == 5.9.0.0
- , haskell-src-exts < 1.20 && >= 1.18
- , hlint < 2.1 && >= 2.0.8
+ , haskell-src-exts < 1.22 && >= 1.18
+ , hlint < 2.2 && >= 2.0.8
, monad-control < 1.1 && >= 1
- , monad-journal < 0.8 && >= 0.4
- , optparse-applicative < 0.14 && >= 0.13.0.0
+ , monad-journal < 0.9 && >= 0.4
+ , optparse-applicative < 0.15 && >= 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.8 && >= 0.5.1
, temporary < 1.3 && >= 1.2.0.3
- , text < 1.3 && >= 1.2.1.3
+ , text < 1.4 && >= 1.2.1.3
, transformers-base < 0.5 && >= 0.4.4
- , cabal-helper < 0.9 && >= 0.8.0.0
- , ghc < 8.4 && >= 7.8
- , ghc-mod-core
+ , cabal-helper < 1.10 && >= 1.0.0.0
+ , ghc < 8.7 && >= 7.8
if impl(ghc >= 8.0)
Build-Depends: ghc-boot
+ if impl(ghc < 8.4)
+ Build-Depends: ghc-syb-utils < 0.3 && >= 0.2.3
Executable ghc-mod
Default-Language: Haskell2010
@@ -182,14 +183,14 @@ Executable ghc-mod
, mtl
, process
- , base < 4.11 && >= 4.6.0.1
+ , base < 4.14 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0
, monad-control < 1.1 && >= 1
- , optparse-applicative < 0.14 && >= 0.13.0.0
+ , optparse-applicative < 0.15 && >= 0.13.0.0
, semigroups < 0.19 && >= 0.10.0
, split < 0.3 && >= 0.2.2
- , ghc < 8.4 && >= 7.8
+ , ghc < 8.7 && >= 7.8
, ghc-mod
, ghc-mod-core
@@ -213,7 +214,7 @@ Executable ghc-modi
, process
, time
- , base < 4.11 && >= 4.6.0.1
+ , base < 4.14 && >= 4.6.0.1
, ghc-mod
, ghc-mod-core
@@ -226,8 +227,8 @@ Test-Suite doctest
Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
- Build-Depends: base < 4.11 && >= 4.6.0.1
- , doctest < 0.14 && >= 0.11.3
+ Build-Depends: base < 4.14 && >= 4.6.0.1
+ , doctest < 0.17 && >= 0.11.3
Test-Suite spec
Default-Language: Haskell2010
@@ -273,22 +274,21 @@ Test-Suite spec
, process
, transformers
- , base < 4.11 && >= 4.6.0.1
+ , base < 4.14 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0
- , hspec < 2.5 && >= 2.0.0
- , monad-journal < 0.8 && >= 0.4
+ , hspec < 2.6 && >= 2.0.0
+ , monad-journal < 0.9 && >= 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.9 && >= 0.8.0.0
- , ghc < 8.4 && >= 7.8
+ cabal-helper < 1.10 && >= 1.0.0.0
+ , ghc < 8.7 && >= 7.8
, ghc-mod
, ghc-mod-core
@@ -300,7 +300,7 @@ Test-Suite shelltest
Type: exitcode-stdio-1.0
if flag(shelltest)
Build-Tools: shelltest
- Build-Depends: base < 4.11 && >= 4.6.0.1
+ Build-Depends: base < 4.14 && >= 4.6.0.1
, process < 1.5
-- , shelltestrunner >= 1.3.5
if !flag(shelltest)
@@ -320,7 +320,7 @@ Benchmark criterion
directory
, filepath
- , base < 4.11 && >= 4.6.0.1
+ , base < 4.14 && >= 4.6.0.1
, criterion < 1.2 && >= 1.1.1.0
, temporary < 1.3 && >= 1.2.0.3
diff --git a/rundocker.sh b/rundocker.sh
new file mode 100755
index 000000000..6a938c125
--- /dev/null
+++ b/rundocker.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+# Start up a docker vm using the gitlab CI container
+
+# docker run --rm -i -t registry.gitlab.com/dxld/ghc-mod:ghc8.2.1-cabal-install2.0.0.0 /bin/bash
+docker run --rm -i -t -v `pwd`:/root registry.gitlab.com/dxld/ghc-mod:ghc8.2.1-cabal-install2.0.0.0 /bin/bash
diff --git a/src/GhcMod/Exe/Options/Commands.hs b/src/GhcMod/Exe/Options/Commands.hs
index cd8ef550a..e4929246b 100644
--- a/src/GhcMod/Exe/Options/Commands.hs
+++ b/src/GhcMod/Exe/Options/Commands.hs
@@ -13,12 +13,15 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module GhcMod.Exe.Options.Commands where
+#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
+#endif
import Options.Applicative
import Options.Applicative.Types
import Options.Applicative.Builder.Internal
@@ -55,7 +58,7 @@ data GhcModCommands =
| CmdType Bool FilePath Point
| CmdSplit FilePath Point
| CmdSig FilePath Point
- | CmdAuto FilePath Point
+ -- | CmdAuto FilePath Point
| CmdRefine FilePath Point Expr
| CmdTest FilePath
-- interactive-only commands
@@ -167,9 +170,9 @@ commands =
"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 "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"
@@ -229,7 +232,7 @@ locArgSpec x = x
modulesArgSpec, docArgSpec, findArgSpec,
lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
- infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
+ infoArgSpec, typeArgSpec, splitArgSpec,
sigArgSpec, refineArgSpec, debugComponentArgSpec,
mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands
@@ -277,7 +280,7 @@ typeArgSpec = locArgSpec $ CmdType <$>
$$ long "constraints"
<=> short 'c'
<=> help "Include constraints into type signature"
-autoArgSpec = locArgSpec (pure CmdAuto)
+-- autoArgSpec = locArgSpec (pure CmdAuto)
splitArgSpec = locArgSpec (pure CmdSplit)
sigArgSpec = locArgSpec (pure CmdSig)
refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL"
diff --git a/src/GhcModMain.hs b/src/GhcModMain.hs
index d4c011661..4517de98e 100644
--- a/src/GhcModMain.hs
+++ b/src/GhcModMain.hs
@@ -48,11 +48,12 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $
-- ghc-modi
legacyInteractive :: IOish m => GhcModT m ()
-legacyInteractive = do
- prepareCabalHelper
- asyncSymbolDb <- newAsyncSymbolDb
- world <- getCurrentWorld
- legacyInteractiveLoop asyncSymbolDb world
+legacyInteractive = undefined
+-- legacyInteractive = do
+-- prepareCabalHelper
+-- asyncSymbolDb <- newAsyncSymbolDb
+-- world <- getCurrentWorld
+-- legacyInteractiveLoop asyncSymbolDb world
legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()
legacyInteractiveLoop asyncSymbolDb world = do
@@ -151,7 +152,7 @@ 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 (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) =
diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs
index f2119b024..43cd33506 100644
--- a/test/CabalHelperSpec.hs
+++ b/test/CabalHelperSpec.hs
@@ -86,7 +86,7 @@ spec = do
opts <- map gmcGhcOpts <$> runD' tdir getComponents
let ghcOpts = head opts
pkgs = pkgOptions ghcOpts
- pkgs `shouldBe` ["Cabal","base"]
+ pkgs `shouldBe` ["base","Cabal"]
test
diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs
index efe024cd2..c14d1603c 100644
--- a/test/CheckSpec.hs
+++ b/test/CheckSpec.hs
@@ -64,8 +64,10 @@ spec = do
it "works with cabal builtin preprocessors" $ do
withDirectory_ "test/data/cabal-preprocessors" $ do
_ <- system "cabal clean"
- _ <- system "cabal build"
- res <- runD $ checkSyntax ["Main.hs"]
+ -- _ <- system "cabal build"
+ _ <- system "cabal build -v3"
+ -- res <- runD $ checkSyntax ["Main.hs"]
+ res <- runV $ checkSyntax ["Main.hs"]
res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"
it "Uses the right qualification style" $ do
diff --git a/test/CustomPackageDbSpec.hs b/test/CustomPackageDbSpec.hs
index f25d59a5c..a1a3207e8 100644
--- a/test/CustomPackageDbSpec.hs
+++ b/test/CustomPackageDbSpec.hs
@@ -28,7 +28,10 @@ spec = do
withDirectory_ "test/data/custom-cradle" $ do
_ <- system "cabal configure"
(s, s') <- runD $ do
- Just stack <- getCustomPkgDbStack
+ mstack <- getCustomPkgDbStack
+ stack <- case mstack of
+ Just stack -> return stack
+ _ -> error "match failed"
withCabal $ do
stack' <- getCabalPackageDbStack
return (stack, stack')
diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs
index 19a160491..8ecdb4dbf 100644
--- a/test/GhcPkgSpec.hs
+++ b/test/GhcPkgSpec.hs
@@ -16,7 +16,10 @@ spec = do
withDirectory_ "test/data/custom-cradle" $ do
_ <- system "cabal configure"
(s, s') <- runD $ do
- Just stack <- getCustomPkgDbStack
+ mstack <- getCustomPkgDbStack
+ stack <- case mstack of
+ Just stack -> return stack
+ _ -> error "match failed"
withCabal $ do
stack' <- getPackageDbStack
return (stack, stack')
diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs
index 1110e7666..be02b2a1d 100644
--- a/test/MonadSpec.hs
+++ b/test/MonadSpec.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGe CPP #-}
module MonadSpec where
import Test.Hspec
@@ -13,8 +14,14 @@ spec = do
(a, _h)
<- runGmOutDef $ runGhcModT defaultOptions $
do
+#if __GLASGOW_HASKELL__ >= 806
+ mj <- return Nothing
+ case mj of
+ Just _ -> return "hello"
+ Nothing -> fail "oh noes"
+#else
Just _ <- return Nothing
- return "hello"
+#endif
`catchError` (const $ fail "oh noes")
a `shouldBe` (Left $ GMEString "oh noes")
diff --git a/test/TestUtils.hs b/test/TestUtils.hs
index 3d252f151..9be17968c 100644
--- a/test/TestUtils.hs
+++ b/test/TestUtils.hs
@@ -3,6 +3,7 @@ module TestUtils (
run
, runD
, runD'
+ , runV
, runE
, runNullLog
, runGmOutDef
@@ -77,6 +78,11 @@ runD' :: FilePath -> GhcModT IO a -> IO a
runD' dir =
extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions)
+-- | Run GhcMod with default options, and vomit log level
+runV :: GhcModT IO a -> IO a
+runV =
+ extract . runGhcModTSpec (setLogLevel GmVomit defaultOptions)
+
setLogLevel :: GmLogLevel -> Options -> Options
setLogLevel = set (lOoptLogLevel . lOptOutput)