From 166265e93de140c4a33f7a61bc004fb64be18275 Mon Sep 17 00:00:00 2001
From: alexwl <alexey.a.kiryushin@gmail.com>
Date: Tue, 9 Oct 2018 23:13:07 +0300
Subject: WIP. It compiles with ghc-8.4.3, but not all features of the indexer
are supported yet.
---
app/Indexer.hs | 5 +-
app/Server.hs | 6 +-
src/HaskellCodeExplorer/AST/RenamedSource.hs | 105 ++++++++++++++-----
src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 128 +++++++++++++++++------
src/HaskellCodeExplorer/GhcUtils.hs | 56 +++++++---
src/HaskellCodeExplorer/ModuleInfo.hs | 39 +++++--
stack-8.2.2.yaml | 10 ++
stack-8.4.3.yaml | 9 --
stack.yaml | 12 +--
9 files changed, 269 insertions(+), 101 deletions(-)
create mode 100644 stack-8.2.2.yaml
delete mode 100644 stack-8.4.3.yaml
diff --git a/app/Indexer.hs b/app/Indexer.hs
index 083c94d..3a23df5 100644
--- a/app/Indexer.hs
+++ b/app/Indexer.hs
@@ -73,7 +73,10 @@ data Compression
| NoCompression
deriving (Show, Eq)
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 4, 3, 0], versionTags = []}
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
ghcVersion :: Version
ghcVersion = Version {versionBranch = [8, 2, 2, 0], versionTags = []}
#else
diff --git a/app/Server.hs b/app/Server.hs
index 39f550f..fd70454 100644
--- a/app/Server.hs
+++ b/app/Server.hs
@@ -343,9 +343,11 @@ loadPackageInfo config path =
HCE.source :: HCE.CompactModuleInfo -> V.Vector T.Text
in if not enableExpressionInfo
then modInfo
- { HCE.exprInfoMap = IVM.empty
+ { HCE.exprInfoMap = IVM.empty
+ , HCE.source = V.force $ source modInfo
+ -- 'force' fixes this error: Data.Vector.Mutable: uninitialised element CallStack (from HasCallStack): error, called at ./Data/Vector/Mutable.hs:188:17 in vector-0.12.0.1-GGZqQZyzchy8YFPCF67wxL:Data.Vector.Mutable
}
- else modInfo)
+ else modInfo {HCE.source = V.force $ source modInfo})
, path)
Left e -> return . Left $ (e, path)
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs
index c1bf463..ea5a87a 100644
--- a/src/HaskellCodeExplorer/AST/RenamedSource.hs
+++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
@@ -54,10 +55,16 @@ import GHC
, PatSynBind(..)
, Sig(..)
, TyClDecl(..)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
, TyFamEqn(..)
+#endif
, Type
, unLoc
)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+import HsExtension (GhcRn)
+#endif
import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames)
import Prelude hiding (span)
import TysWiredIn
@@ -86,9 +93,12 @@ namesFromRenamedSource =
hsTypeNames `extQ`
tyClDeclNames `extQ`
familyDeclNames `extQ`
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
tyFamilyEqNames `extQ`
tyFamilyDefEqNames `extQ`
dataFamInstDeclNames `extQ`
+#endif
conDeclNames `extQ`
importNames `extQ`
hsTyVarBndrNames `extQ`
@@ -99,7 +109,9 @@ namesFromRenamedSource =
hsRecFieldPatNames `extQ`
foreignDeclNames)
-fieldOccName :: Bool -> FieldOcc Name -> NameOccurrence
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence
+#endif
fieldOccName isBinder (FieldOcc (L span _) name) =
NameOccurrence
{ locatedName = L span (Just name)
@@ -107,16 +119,20 @@ fieldOccName isBinder (FieldOcc (L span _) name) =
, isBinder = isBinder
}
-conDeclFieldNames :: ConDeclField Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence]
+#endif
conDeclFieldNames ConDeclField {..} =
map (fieldOccName True . unLoc) cd_fld_names
-hsRecFieldExprNames ::
- HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
+#endif
hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
-hsRecAmbFieldExprNames ::
- HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
+#endif
hsRecAmbFieldExprNames HsRecField {..} =
let (L span recField) = hsRecFieldLbl
mbName =
@@ -130,11 +146,14 @@ hsRecAmbFieldExprNames HsRecField {..} =
}
]
-hsRecFieldPatNames ::
- HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence]
+#endif
hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
-hsExprNames :: LHsExpr Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsExprNames :: LHsExpr GhcRn -> [NameOccurrence]
+#endif
hsExprNames (L _span (HsVar name)) =
[ NameOccurrence
{ locatedName = Just <$> name
@@ -174,7 +193,9 @@ hsExprNames (L _span (HsRecFld (Ambiguous (L span _) _name))) =
]
hsExprNames _ = []
-matchGroupNames :: MatchGroup Name (LHsExpr Name) -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence]
+#endif
matchGroupNames =
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) .
@@ -184,20 +205,22 @@ matchGroupNames =
unLoc . mg_alts
where
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- matchContextName :: HsMatchContext Name -> Maybe (Located Name)
+ --matchContextName :: HsMatchContext Name -> Maybe (Located Name)
matchContextName (FunRhs name _ _bool) = Just name
matchContextName _ = Nothing
#else
- matchFixityName :: MatchFixity Name -> Maybe (Located Name)
+ --matchFixityName :: MatchFixity Name -> Maybe (Located Name)
matchFixityName NonFunBindMatch = Nothing
matchFixityName (FunBindMatch name _bool) = Just name
#endif
- toNameOcc :: Located Name -> NameOccurrence
+ --toNameOcc :: Located Name -> NameOccurrence
toNameOcc n =
NameOccurrence
{locatedName = Just <$> n, description = "Match", isBinder = True}
-bindNames :: LHsBindLR Name Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence]
+#endif
bindNames (L _span (PatSynBind PSB {..})) =
[ NameOccurrence
{ locatedName = Just <$> psb_id
@@ -207,7 +230,6 @@ bindNames (L _span (PatSynBind PSB {..})) =
]
bindNames _ = []
-hsPatSynDetailsNames :: HsPatSynDetails (Located Name) -> [NameOccurrence]
hsPatSynDetailsNames =
map
(\name ->
@@ -218,7 +240,10 @@ hsPatSynDetailsNames =
}) .
hsPatSynDetails
-importNames :: IE Name -> [NameOccurrence]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+importNames :: IE GhcRn -> [NameOccurrence]
+#endif
importNames =
map
(\name ->
@@ -229,7 +254,10 @@ importNames =
}) .
ieLocNames
-patNames :: LPat Name -> [NameOccurrence]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+patNames :: LPat GhcRn -> [NameOccurrence]
+#endif
patNames (L _span (VarPat name)) =
[ NameOccurrence
{ locatedName = Just <$> name
@@ -260,7 +288,10 @@ patNames (L _span (NPlusKPat name _ _ _ _ _)) =
]
patNames _ = []
-sigNames :: LSig Name -> [NameOccurrence]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+sigNames :: LSig GhcRn -> [NameOccurrence]
+#endif
sigNames (L _span (TypeSig names _)) =
map
(\n ->
@@ -332,7 +363,10 @@ sigNames (L _span (MinimalSig _ (L _ boolFormula))) =
boolFormulaNames (Parens (L _ f)) = boolFormulaNames f
sigNames (L _ _) = []
-hsTypeNames :: LHsType Name -> [NameOccurrence]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsTypeNames :: LHsType GhcRn -> [NameOccurrence]
+#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
hsTypeNames (L _span (HsTyVar _promoted name)) =
#else
@@ -382,7 +416,10 @@ hsTypeNames (L span (HsTupleTy tupleSort types))
--hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ...
hsTypeNames _ = []
-hsTyVarBndrNames :: HsTyVarBndr Name -> [NameOccurrence]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsTyVarBndrNames :: HsTyVarBndr GhcRn -> [NameOccurrence]
+#endif
hsTyVarBndrNames (UserTyVar n) =
[ NameOccurrence
{ locatedName = Just <$> n
@@ -398,7 +435,9 @@ hsTyVarBndrNames (KindedTyVar n _) =
}
]
-tyClDeclNames :: LTyClDecl Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence]
+#endif
tyClDeclNames (L _span DataDecl {..}) =
[ NameOccurrence
{ locatedName = Just <$> tcdLName
@@ -432,7 +471,9 @@ tyClDeclNames (L _span ClassDecl {..}) =
}
tyClDeclNames _ = []
-familyDeclNames :: FamilyDecl Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence]
+#endif
familyDeclNames FamilyDecl {..} =
[ NameOccurrence
{ locatedName = Just <$> fdLName
@@ -441,7 +482,11 @@ familyDeclNames FamilyDecl {..} =
}
]
-tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence]
+
+--TODO
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
+--tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence]
tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} =
[ NameOccurrence
{ locatedName = Just <$> tyCon
@@ -450,7 +495,7 @@ tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} =
}
]
-tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence]
+--tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence]
tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} =
[ NameOccurrence
{ locatedName = Just <$> tyCon
@@ -459,7 +504,8 @@ tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} =
}
]
-dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence]
+
+--dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence]
dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} =
[ NameOccurrence
{ locatedName = Just <$> tyCon
@@ -467,8 +513,11 @@ dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} =
, isBinder = False
}
]
+#endif
-conDeclNames :: ConDecl Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+conDeclNames :: ConDecl GhcRn -> [NameOccurrence]
+#endif
conDeclNames con =
case con of
ConDeclGADT {con_names = names} ->
@@ -488,7 +537,9 @@ conDeclNames con =
}
]
-foreignDeclNames :: ForeignDecl Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence]
+#endif
foreignDeclNames decl =
[ NameOccurrence
{ locatedName = Just <$> fd_name decl
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index f97c33b..4dfbd8b 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -80,6 +80,7 @@ import HsSyn
, selectorAmbiguousFieldOcc
)
import HscTypes (TypeEnv, lookupTypeEnv)
+import HsExtension (GhcTc)
import Id (idType)
import IdInfo (IdDetails(..))
import InstEnv
@@ -541,11 +542,15 @@ tidyType typ = do
let (tidyEnv', typ') = tidyOpenType tidyEnv typ
modify' (\s -> s {astStateTidyEnv = tidyEnv'})
return typ'
-
-foldTypecheckedSource :: LHsBinds Id -> State ASTState ()
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState ()
+#endif
foldTypecheckedSource = foldLHsBindsLR
-foldLHsExpr :: LHsExpr Var -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
+#endif
foldLHsExpr (L span (HsVar (L _ identifier))) =
restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
@@ -801,8 +806,10 @@ foldLHsExpr (L span (HsWrap wrapper expr)) =
Composite -> return () -- Not sure if it is possible
typ <- foldLHsExpr (L span expr)
return $ applyWrapper wrapper <$> typ
-
-foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldHsRecFields HsRecFields {..} = do
let userWritten =
case rec_dotdot of
@@ -810,8 +817,10 @@ foldHsRecFields HsRecFields {..} = do
Nothing -> id
mapM_ foldLHsRecField $ userWritten rec_flds
return Nothing
-
-foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) =
restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
@@ -820,7 +829,9 @@ foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun))
unless pun $ void (foldLHsExpr arg)
return . Just . varType $ identifier'
-foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsRecUpdField :: LHsRecUpdField GhcTc -> State ASTState (Maybe Type)
+#endif
foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) =
restoreTidyEnv $ do
let selectorId = selectorAmbiguousFieldOcc recField
@@ -844,7 +855,9 @@ data TupArg
| TupArgMissing
deriving (Show, Eq)
-foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsTupArg :: LHsTupArg GhcTc -> State ASTState (Maybe Type, TupArg)
+#endif
foldLHsTupArg (L _span (Present expr)) =
restoreTidyEnv $ do
typ <- foldLHsExpr expr
@@ -858,31 +871,41 @@ foldLHsTupArg (L _ (Missing typ)) =
typ' <- tidyType typ
return (Just typ', TupArgMissing)
-foldLMatch :: LMatch Id (LHsExpr Var) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLMatch (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSs m_grhss
return Nothing
-
-foldLMatchCmd :: LMatch Id (LHsCmd Var) -> State ASTState (Maybe Type)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLMatchCmd (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSsCmd m_grhss
return Nothing
-foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
+#endif
foldGRHSsCmd GRHSs {..} = do
mapM_ foldLGRHSCmd grhssGRHSs
_ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
return Nothing
-foldGRHSs :: GRHSs Id (LHsExpr Var) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldGRHSs GRHSs {..} = do
mapM_ foldLGRHS grhssGRHSs
_ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
return Nothing
-foldLStmtLR :: LStmtLR Id Id (LHsExpr Var) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLStmtLR (L span (LastStmt body _ _)) =
do typ <- foldLHsExpr body
addExprInfo span typ "LastStmt" Composite
@@ -916,10 +939,16 @@ foldLStmtLR (L span (ApplicativeStmt args _ typ)) =
addExprInfo span (Just typ') "ApplicativeStmt" Composite
return Nothing
-foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type)
+#endif
foldApplicativeArg appArg =
case appArg of
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ ApplicativeArgOne pat expr _bool -> do
+#else
ApplicativeArgOne pat expr -> do
+#endif
_ <- foldLPat pat
_ <- foldLHsExpr expr
return Nothing
@@ -927,9 +956,10 @@ foldApplicativeArg appArg =
_ <- mapM_ foldLStmtLR exprStmts
_ <- foldLPat pat
return Nothing
-
-foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Var)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLStmtLRCmd :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc)
-> State ASTState (Maybe Type)
+#endif
foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do
typ <- foldLHsCmd body
addExprInfo span typ "LastStmt Cmd" Composite
@@ -962,43 +992,57 @@ foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) =
mapM_ (foldApplicativeArg . snd) args
addExprInfo span (Just typ') "ApplicativeStmt Cmd" Composite
return Nothing
-
-foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLGRHS (L _span (GRHS guards body)) = do
typ <- foldLHsExpr body
mapM_ foldLStmtLR guards
return typ
-
-foldLGRHSCmd :: LGRHS Id (LHsCmd Var) -> State ASTState (Maybe Type)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLGRHSCmd :: LGRHS GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLGRHSCmd (L _span (GRHS guards body)) = do
typ <- foldLHsCmd body
mapM_ foldLStmtLR guards
return typ
-foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldParStmtBlock :: ParStmtBlock GhcTc GhcTc -> State ASTState (Maybe Type)
+#endif
foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do
mapM_ foldLStmtLR exprStmts
return Nothing
-foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
+#endif
foldHsLocalBindsLR (HsValBinds binds) = do
_ <- foldHsValBindsLR binds
return Nothing
foldHsLocalBindsLR (HsIPBinds _binds) = return Nothing
foldHsLocalBindsLR EmptyLocalBinds = return Nothing
-foldHsValBindsLR :: HsValBindsLR Id Var -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
+#endif
foldHsValBindsLR (ValBindsIn _ _) = return Nothing
foldHsValBindsLR (ValBindsOut binds _) = do
_ <- mapM_ (foldLHsBindsLR . snd) binds
return Nothing
-foldLHsBindsLR :: LHsBinds Id -> State ASTState ()
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState ()
+#endif
foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList
-foldLHsBindLR :: LHsBindLR Id Var
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsBindLR :: LHsBindLR GhcTc GhcTc
-> Maybe Id -- ^ Polymorphic id
-> State ASTState (Maybe Type)
+#endif
foldLHsBindLR (L _span FunBind {..}) mbPolyId
| mg_origin fun_matches == FromSource =
restoreTidyEnv $ do
@@ -1024,12 +1068,17 @@ foldLHsBindLR (L _ AbsBinds {..}) _ = do
mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $
zip (bagToList abs_binds) (map abe_poly abs_exports)
return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
foldLHsBindLR (L _ AbsBindsSig {..}) _ = do
_ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export)
return Nothing
+#endif
foldLHsBindLR (L _ (PatSynBind PSB {..})) _ =
restoreTidyEnv $ do
_ <- foldLPat psb_def
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
_ <-
let addId :: GenLocated SrcSpan Id -> State ASTState ()
addId (L span i) = do
@@ -1043,9 +1092,12 @@ foldLHsBindLR (L _ (PatSynBind PSB {..})) _ =
(\(RecordPatSynField selId patVar) ->
addId selId >> addId patVar)
recs
+#endif
return Nothing
-foldLPat :: LPat Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLPat :: LPat GhcTc -> State ASTState (Maybe Type)
+#endif
foldLPat (L span (VarPat (L _ identifier))) = do
(identifier', _) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap span identifier' Nothing
@@ -1151,9 +1203,11 @@ foldLPat (L span p@(CoPat _ pat typ)) = do
_ <- foldLPat (L span pat)
return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsConPatDetails
- :: HsConPatDetails Id
+ :: HsConPatDetails GhcTc
-> State ASTState (Maybe Type)
+#endif
foldHsConPatDetails (PrefixCon args) = do
_ <- mapM_ foldLPat args
return Nothing
@@ -1165,7 +1219,9 @@ foldHsConPatDetails (InfixCon arg1 arg2) = do
_ <- foldLPat arg2
return Nothing
-foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
+#endif
foldHsRecFieldsPat HsRecFields {..} = do
let onlyUserWritten =
case rec_dotdot of
@@ -1174,20 +1230,26 @@ foldHsRecFieldsPat HsRecFields {..} = do
_ <- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
return Nothing
-foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
+#endif
foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = do
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
unless pun $ void $ foldLPat arg
return . Just . varType $ identifier'
-foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
+#endif
foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do
mbTyp <- foldLHsCmd cmd
addExprInfo span mbTyp "HsCmdTop" Composite
return mbTyp
-foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type)
+#endif
foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do
_ <- foldLHsExpr expr1
_ <- foldLHsExpr expr2
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index 714e429..09be369 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -3,6 +3,8 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module HaskellCodeExplorer.GhcUtils
@@ -138,11 +140,18 @@ import GHC
, tyFamInstDeclName
, idType
, hsib_body
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#else
, tfe_pats
+#endif
, tfid_eqn
)
+
import qualified HaskellCodeExplorer.Types as HCE
import HscTypes (TypeEnv, lookupTypeEnv)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+import HsExtension (GhcPs, GhcRn, GhcTc, IdP(..), Pass(..))
+#endif
import IdInfo (IdDetails(..))
import InstEnv (ClsInst(..))
import Lexer (ParseResult(POk), mkPState, unP)
@@ -250,9 +259,12 @@ instanceToText :: DynFlags -> ClsInst -> T.Text
instanceToText flags ClsInst {..} =
T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun)
-instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text
+--instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text
instanceDeclToText flags decl =
case decl of
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ _ -> ""
+#else
ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty)
DataFamInstD di ->
let args =
@@ -266,6 +278,7 @@ instanceDeclToText flags decl =
ti
in T.concat
["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
+#endif
nameToText :: Name -> T.Text
nameToText = T.pack . unpackFS . occNameFS . nameOccName
@@ -366,7 +379,9 @@ mbIdDetails _ = Nothing
-- Syntax transformation
--------------------------------------------------------------------------------
-hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
+#endif
hsGroupVals hsGroup =
filter (isGoodSrcSpan . getLoc) $
case hs_valds hsGroup of
@@ -375,6 +390,9 @@ hsGroupVals hsGroup =
hsPatSynDetails :: HsPatSynDetails a -> [a]
hsPatSynDetails patDetails =
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ []
+#else
case patDetails of
InfixPatSyn name1 name2 -> [name1, name2]
PrefixPatSyn name -> name
@@ -382,8 +400,13 @@ hsPatSynDetails patDetails =
concatMap
(\field -> [recordPatSynSelectorId field, recordPatSynPatVar field])
fields
+#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+--unwrapName :: LIEWrappedName n -> Located n
+unwrapName = ieLWrappedName
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
unwrapName :: LIEWrappedName Name -> Located Name
unwrapName = ieLWrappedName
#else
@@ -391,7 +414,7 @@ unwrapName :: Located Name -> Located Name
unwrapName n = n
#endif
-ieLocNames :: IE Name -> [Located Name]
+--ieLocNames :: IE (IdP GhcTc) -> [Located Name]
ieLocNames (IEVar n) = [unwrapName n]
ieLocNames (IEThingAbs n) = [unwrapName n]
ieLocNames (IEThingAll n) = [unwrapName n]
@@ -909,7 +932,7 @@ collectDocs = go Nothing []
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
finished decl docs rest = (decl, reverse docs) : rest
-ungroup :: HsGroup Name -> [LHsDecl Name]
+--ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
@@ -939,7 +962,7 @@ mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
sortByLoc :: [Located a] -> [Located a]
sortByLoc = L.sortBy (comparing getLoc)
-classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
+--classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
classDeclDocs class_ = collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
@@ -948,13 +971,13 @@ classDeclDocs class_ = collectDocs . sortByLoc $ decls
sigs = mkDecls tcdSigs SigD class_
ats = mkDecls tcdATs (TyClD . FamDecl) class_
-conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
+--conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
conDeclDocs conDecl =
map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) .
getConNames $
conDecl
-selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)]
+--selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)]
selectorDocs con =
case getConDetails con of
RecCon (L _ flds) ->
@@ -967,9 +990,14 @@ selectorDocs con =
flds
_ -> []
-subordinateNamesWithDocs ::
- [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)]
-subordinateNamesWithDocs =
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl GhcRn)] -> [(Name, [HsDocString], SrcSpan)]
+#endif
+subordinateNamesWithDocs _ =
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ []
+#else
concatMap
(\(L span tyClDecl) ->
case tyClDecl of
@@ -983,13 +1011,14 @@ subordinateNamesWithDocs =
InstD (DataFamInstD DataFamInstDecl {..}) ->
concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn
_ -> [])
+#endif
isUserLSig :: LSig name -> Bool
isUserLSig (L _ TypeSig {}) = True
isUserLSig (L _ ClassOpSig {}) = True
isUserLSig _ = False
-getMainDeclBinder :: HsDecl name -> [name]
+--getMainDeclBinder :: HsDecl name -> [name]
getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
case collectHsBindBinders d of
@@ -1000,7 +1029,7 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
getMainDeclBinder (ForD ForeignExport {}) = []
getMainDeclBinder _ = []
-sigNameNoLoc :: Sig name -> [name]
+--sigNameNoLoc :: Sig name -> [name]
sigNameNoLoc (TypeSig ns _) = map unLoc ns
sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
@@ -1108,6 +1137,7 @@ outOfScope dflags x =
Orig _ occ -> monospaced occ
Exact name -> monospaced name -- Shouldn't happen since x is out of scope
where
+ monospaced :: (Outputable a) => a -> Doc b
monospaced a = DocMonospaced (DocString (showPpr dflags a))
makeAnchorId :: String -> String
diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs
index cc81a36..5145fa5 100644
--- a/src/HaskellCodeExplorer/ModuleInfo.hs
+++ b/src/HaskellCodeExplorer/ModuleInfo.hs
@@ -23,8 +23,9 @@ import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import qualified Data.IntervalMap.Strict as IVM
import qualified Data.List as L hiding (span)
-import Data.Maybe(fromMaybe,mapMaybe)
-import Data.Ord(comparing)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Ord (comparing)
+import HsExtension (GhcRn)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -307,10 +308,17 @@ createDefinitionSiteMap ::
-> HCE.SourceCodeTransformation
-> ModuleInfo
-> [Name]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ -> HsGroup GhcRn
+#else
-> HsGroup Name
+#endif
-> (HCE.DefinitionSiteMap, [Name])
createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup =
- let allDecls :: [GenLocated SrcSpan (HsDecl Name)]
+ let
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ allDecls :: [GenLocated SrcSpan (HsDecl GhcRn)]
+#endif
allDecls = L.sortBy (comparing getLoc) . ungroup $ hsGroup
(instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) =
L.partition
@@ -465,7 +473,9 @@ docWithNamesToHtml flags packageId compId transformation fileMap defSiteMap =
createDeclarations ::
DynFlags
- -> HsGroup Name
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ -> HsGroup GhcRn
+#endif
-> TypeEnv
-> S.Set Name
-> HCE.SourceCodeTransformation
@@ -483,8 +493,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation =
Nothing -> Nothing
-- | Top-level functions
--------------------------------------------------------------------------------
- valToDeclarations ::
- GenLocated SrcSpan (HsBindLR Name Name) -> [HCE.Declaration]
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ valToDeclarations :: GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> [HCE.Declaration]
+#endif
valToDeclarations (L loc bind) =
map
(\name ->
@@ -498,7 +509,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation =
vals = concatMap valToDeclarations $ hsGroupVals hsGroup
-- | Data, newtype, type, type family, data family or class declaration
--------------------------------------------------------------------------------
- tyClToDeclaration :: GenLocated SrcSpan (TyClDecl Name) -> HCE.Declaration
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ tyClToDeclaration :: GenLocated SrcSpan (TyClDecl GhcRn) -> HCE.Declaration
+#endif
tyClToDeclaration (L loc tyClDecl) =
HCE.Declaration
HCE.TyClD
@@ -512,7 +525,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation =
hsGroup
-- | Instances
--------------------------------------------------------------------------------
- instToDeclaration :: GenLocated SrcSpan (InstDecl Name) -> HCE.Declaration
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ instToDeclaration :: GenLocated SrcSpan (InstDecl GhcRn) -> HCE.Declaration
+#endif
instToDeclaration (L loc inst) =
HCE.Declaration
HCE.InstD
@@ -529,8 +544,10 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation =
hsGroup
-- | Foreign functions
--------------------------------------------------------------------------------
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foreignFunToDeclaration ::
- GenLocated SrcSpan (ForeignDecl Name) -> HCE.Declaration
+ GenLocated SrcSpan (ForeignDecl GhcRn) -> HCE.Declaration
+#endif
foreignFunToDeclaration (L loc fd) =
let name = unLoc $ fd_name fd
in HCE.Declaration
@@ -588,7 +605,11 @@ foldAST environment typecheckedModule =
case mbExported of
Just lieNames ->
mapMaybe
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ (\(L span ie,_) ->
+#else
(\(L span ie) ->
+#endif
case ie of
IEModuleContents (L _ modName) ->
Just
diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml
new file mode 100644
index 0000000..96d1825
--- /dev/null
+++ b/stack-8.2.2.yaml
@@ -0,0 +1,10 @@
+resolver: lts-11.3
+packages:
+- '.'
+packages:
+ - .
+ - location: vendor/cabal-helper-0.8.1.2
+ extra-dep: true
+extra-deps:
+ - cabal-plan-0.4.0.0
+ - pretty-show-1.8.2
diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml
deleted file mode 100644
index f3b6036..0000000
--- a/stack-8.4.3.yaml
+++ /dev/null
@@ -1,9 +0,0 @@
-# stack build haskell-code-explorer:haskell-code-server --stack-yaml=stack-8.4.3.yaml
-resolver: lts-12.4
-packages:
-- '.'
-allow-newer: true
-extra-deps:
- - cabal-helper-0.8.1.0
- - cabal-plan-0.3.0.0
-
diff --git a/stack.yaml b/stack.yaml
index 96d1825..89f09bb 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,10 +1,8 @@
-resolver: lts-11.3
+resolver: lts-12.4
packages:
- '.'
-packages:
- - .
- - location: vendor/cabal-helper-0.8.1.2
- extra-dep: true
+- location: vendor/cabal-helper-0.8.1.2
+ extra-dep: true
+allow-newer: true
extra-deps:
- - cabal-plan-0.4.0.0
- - pretty-show-1.8.2
+ - cabal-plan-0.4.0.0
--
cgit v1.2.3