aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/AST
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer/AST')
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs197
1 files changed, 104 insertions, 93 deletions
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index 41a202e..7cf5157 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -18,13 +18,11 @@ module HaskellCodeExplorer.AST.TypecheckedSource
, removeOverlappingInterval
) where
-import Bag (bagToList)
-import BasicTypes (Origin(..))
-import Class (Class, classTyVars)
-import ConLike (ConLike(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- , conLikeWrapId_maybe
-#endif
+import GHC.Data.Bag (bagToList)
+import GHC.Types.Basic (Origin(..))
+import GHC.Core.Class (Class, classTyVars)
+import GHC.Core.ConLike (ConLike(..)
+-- , conLikeWrapId_maybe
)
import Control.Monad (return, unless, void)
import Control.Monad.State.Strict (State, get, modify')
@@ -35,18 +33,23 @@ import qualified Data.Map.Strict as M
import Data.Maybe (Maybe, fromMaybe, mapMaybe)
import qualified Data.Set as S
import qualified Data.Text as T
-import DataCon (dataConWorkId)
-import DynFlags (DynFlags)
-import FastString (mkFastString)
+import GHC.Core.DataCon (dataConWorkId)
+import GHC
+ ( DynFlags
+ , TyThing(..)
+ , CoPat(..)
+ )
+import GHC.Data.FastString (mkFastString)
+import GHC.Unit.State (UnitState)
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
-import HsBinds (RecordPatSynField(..)
+import GHC.Hs.Binds (RecordPatSynField(..)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#else
, HsPatSynDetails (..)
#endif
)
-import HsSyn
+import GHC.Hs
( ABExport(..)
, ApplicativeArg(..)
, ArithSeqInfo(..)
@@ -88,7 +91,7 @@ import HsSyn
, StmtLR(..)
, selectorAmbiguousFieldOcc
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- , RecordConTc (..)
+-- , RecordConTc (..)
, RecordUpdTc (..)
, ListPatTc (..)
, OverLitTc (..)
@@ -96,36 +99,36 @@ import HsSyn
, NHsValBindsLR (..)
#endif
)
-import HscTypes (TypeEnv, lookupTypeEnv)
+import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-import HsExtension (GhcTc)
+import GHC.Hs.Extension (GhcTc)
#endif
-import Id (idType)
-import IdInfo (IdDetails(..))
-import InstEnv
+import GHC.Types.Id (idType)
+import GHC.Types.Id.Info (IdDetails(..))
+import GHC.Core.InstEnv
( ClsInst(..)
, InstEnvs
, instanceSig
, is_dfun
, lookupUniqueInstEnv
)
-import Name (Name, nameOccName, nameUnique)
+import GHC.Types.Name (Name, nameOccName, nameUnique)
import Prelude hiding (span)
-import SrcLoc
+import GHC.Types.SrcLoc
( GenLocated(..)
, SrcSpan(..)
, isGoodSrcSpan
, isOneLineSpan
, unLoc
-#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
- , cL
-#endif
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
+-- , cL
+-- #endif
)
-import TcEvidence (HsWrapper(..))
-import TcHsSyn (conLikeResTy, hsLitType)
-import Type
- ( TyThing(..)
- , Type
+import GHC.Tc.Types.Evidence (HsWrapper(..))
+import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType)
+import GHC.Core.Predicate (getClassPredTys_maybe)
+import GHC.Core.Type
+ ( Type
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
, nonDetCmpTypes
#else
@@ -133,20 +136,19 @@ import Type
#endif
, eqTypes
, eqType
- , getClassPredTys_maybe
, mkFunTy
- , mkFunTys
- , splitForAllTys
+-- , mkFunTys
+-- , splitForAllTys
, splitFunTy_maybe
, splitFunTys
, substTys
, tidyOpenType
, zipTvSubst
)
-import TysWiredIn (mkListTy, mkTupleTy)
-import Unique (getKey)
-import Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
-import VarEnv (TidyEnv)
+import GHC.Builtin.Types (mkListTy, mkTupleTy)
+import GHC.Types.Unique (getKey)
+import GHC.Types.Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
+import GHC.Types.Var.Env (TidyEnv)
data ASTState = ASTState
{ astStateExprInfoMap :: !HCE.ExpressionInfoMap
@@ -180,6 +182,7 @@ data TypeError = TypeError
data Environment = Environment
{ envDynFlags :: DynFlags
+ , envUnitState :: UnitState
, envTypeEnv :: TypeEnv
, envInstEnv :: InstEnvs
, envTransformation :: HCE.SourceCodeTransformation
@@ -213,7 +216,7 @@ exprSort (ExplicitTuple args _)
#endif
| null args = Simple
| otherwise = Composite
-exprSort (ExplicitList _ _ args)
+exprSort (ExplicitList _ args)
| null args = Simple
| otherwise = Composite
exprSort _ = Composite
@@ -447,6 +450,7 @@ mkIdentifierInfo environment identifier mbNameFromRenamedSource =
sort = nameSort name
nameSpace = occNameNameSpace . nameOccName $ name
flags = envDynFlags environment
+ unitState = envUnitState environment
currentPackageId = envPackageId environment
compId = envComponentId environment
transformation = envTransformation environment
@@ -454,7 +458,7 @@ mkIdentifierInfo environment identifier mbNameFromRenamedSource =
defSiteMap = envDefSiteMap environment
locationInfo =
nameLocationInfo
- flags
+ unitState
currentPackageId
compId
transformation
@@ -618,10 +622,11 @@ foldLHsExpr (L _ (HsConLikeOut _ conLike)) =
#else
foldLHsExpr (L _ (HsConLikeOut conLike)) =
#endif
- restoreTidyEnv $ do
- let mbType = varType <$> conLikeWrapId_maybe conLike
- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
- return mbType'
+ -- restoreTidyEnv $ do
+ -- let mbType = varType <$> conLikeWrapId_maybe conLike
+ -- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
+ -- return mbType'
+ restoreTidyEnv $ return Nothing
#endif
foldLHsExpr (L _ HsRecFld {}) = return Nothing
foldLHsExpr (L _ HsOverLabel {}) = return Nothing
@@ -846,7 +851,7 @@ foldLHsExpr (L span e@(ExplicitPArr typ exprs)) =
return $ Just typ'
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L span e@(RecordCon (RecordConTc _ conExpr) _ binds)) = do
+foldLHsExpr (L span e@(RecordCon conExpr _ binds)) = do
#else
foldLHsExpr (L span e@(RecordCon (L _ _) _conLike conExpr binds)) = do
#endif
@@ -900,22 +905,22 @@ foldLHsExpr (L span e@(PArrSeq postTcExpr _seqInfo)) = do
addExprInfo span typ "ArithSeq" (exprSort e)
return typ
#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L span e@(HsSCC _ _sourceText _fastString expr)) = do
-#else
-foldLHsExpr (L span e@(HsSCC _sourceText _fastString expr)) = do
-#endif
- typ <- foldLHsExpr expr
- addExprInfo span typ "HsSCC" (exprSort e)
- return typ
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L span e@(HsCoreAnn _ _sourceText _fastString expr)) = do
-#else
-foldLHsExpr (L span e@(HsCoreAnn _sourceText _fastString expr)) = do
-#endif
- typ <- foldLHsExpr expr
- addExprInfo span typ "HsCoreAnn" (exprSort e)
- return typ
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- foldLHsExpr (L span e@(HsSCC _ _sourceText _fastString expr)) = do
+-- #else
+-- foldLHsExpr (L span e@(HsSCC _sourceText _fastString expr)) = do
+-- #endif
+-- typ <- foldLHsExpr expr
+-- addExprInfo span typ "HsSCC" (exprSort e)
+-- return typ
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- foldLHsExpr (L span e@(HsCoreAnn _ _sourceText _fastString expr)) = do
+-- #else
+-- foldLHsExpr (L span e@(HsCoreAnn _sourceText _fastString expr)) = do
+-- #endif
+-- typ <- foldLHsExpr expr
+-- addExprInfo span typ "HsCoreAnn" (exprSort e)
+-- return typ
foldLHsExpr (L _span HsBracket {}) = return Nothing
foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing
foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing
@@ -937,8 +942,8 @@ foldLHsExpr (L span e@(HsStatic expr)) = do
typ <- foldLHsExpr expr
addExprInfo span typ "HsStatic" (exprSort e)
return typ
-foldLHsExpr (L _ HsArrForm {}) = return Nothing
-foldLHsExpr (L _ HsArrApp {}) = return Nothing
+-- foldLHsExpr (L _ HsArrForm {}) = return Nothing
+-- foldLHsExpr (L _ HsArrApp {}) = return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsExpr (L span e@(HsTick _ _ expr)) = do
#else
@@ -955,29 +960,33 @@ foldLHsExpr (L span e@(HsBinTick _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo span typ "HsBinTick" (exprSort e)
return typ
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do
-#else
-foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
-#endif
- typ <- foldLHsExpr expr
- addExprInfo span typ "HsTickPragma" (exprSort e)
- return typ
-foldLHsExpr (L _span EWildPat {}) = return Nothing
-foldLHsExpr (L _span EAsPat {}) = return Nothing
-foldLHsExpr (L _span EViewPat {}) = return Nothing
-foldLHsExpr (L _span ELazyPat {}) = return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L span (HsWrap _ wrapper expr)) =
-#else
-foldLHsExpr (L span (HsWrap wrapper expr)) =
-#endif
- restoreHsWrapper $ do
- case exprSort expr of
- Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper})
- Composite -> return () -- Not sure if it is possible
- typ <- foldLHsExpr (L span expr)
- return $ applyWrapper wrapper <$> typ
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do
+-- #else
+-- foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
+-- #endif
+-- typ <- foldLHsExpr expr
+-- addExprInfo span typ "HsTickPragma" (exprSort e)
+-- return typ
+
+-- A few similarly named symbols are in GHC.Hs.Pat
+-- foldLHsExpr (L _span EWildPat {}) = return Nothing
+-- foldLHsExpr (L _span EAsPat {}) = return Nothing
+-- foldLHsExpr (L _span EViewPat {}) = return Nothing
+-- foldLHsExpr (L _span ELazyPat {}) = return Nothing
+
+-- there's an hswrap but it is not in hsexpr
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- foldLHsExpr (L span (HsWrap _ wrapper expr)) =
+-- #else
+-- foldLHsExpr (L span (HsWrap wrapper expr)) =
+-- #endif
+-- restoreHsWrapper $ do
+-- case exprSort expr of
+-- Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper})
+-- Composite -> return () -- Not sure if it is possible
+-- typ <- foldLHsExpr (L span expr)
+-- return $ applyWrapper wrapper <$> typ
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
@@ -1519,8 +1528,9 @@ foldLPat (L span pat@(PArrPat pats typ)) = do
mapM_ foldLPat pats
return $ Just typ'
#endif
-foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-foldLPat (ghcDL -> L span pat@ConPatOut {..}) = do
+-- no more conpatin / conpatout, just conpat
+-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
+foldLPat (ghcDL -> L span pat@ConPat {..}) = do
let (L idSpan conLike) = pat_con
conId =
case conLike of
@@ -1530,7 +1540,7 @@ foldLPat (ghcDL -> L span pat@ConPatOut {..}) = do
(identifier', mbTypes) <- tidyIdentifier conId
addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
typ' <- tidyType typ
- addExprInfo span (Just typ') "ConPatOut" (patSort pat)
+ addExprInfo span (Just typ') "ConPat" (patSort pat)
_ <- foldHsConPatDetails pat_args
return . Just . varType $ identifier'
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
@@ -1766,10 +1776,11 @@ foldLHsCmd (L _ (HsCmdDo stmts _)) = do
#endif
mapM_ foldLStmtLRCmd $ unLoc stmts
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do
-#else
-foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
-#endif
- _ <- foldLHsCmd (L span cmd)
- return Nothing
+-- no more hscmdwrap
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do
+-- #else
+-- foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
+-- #endif
+-- _ <- foldLHsCmd (L span cmd)
+-- return Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 20:00:14 +0000