From e87297184487844f425343244982dc216ffb9e13 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Fri, 3 Jun 2022 12:30:35 +1000 Subject: fixing typecheckedSource --- src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 197 ++++++++++++----------- 1 file 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 -- cgit v1.2.3