From 198d1649f3e428b47d812726604f2e89b07147ac Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Fri, 10 Jun 2022 18:28:08 +1000
Subject: Fixing some typechecked "holes"
two "holes"
- Expanded
- ConPat
also added some pprTrace for debugging
---
src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 104 +++++++++++++++++++++--
1 file changed, 98 insertions(+), 6 deletions(-)
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index 22911df..213671b 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -40,6 +40,7 @@ import qualified Data.Set as S
import qualified Data.Text as T
import GHC ( DynFlags
, SrcLoc(..)
+ , SrcSpanAnnA
, TyThing(..)
, getLocA
, reLocA
@@ -83,9 +84,11 @@ import GHC.Data.FastString ( FastString
, mkFastString
, unpackFS
)
+import GHC.Driver.Ppr ( pprTrace )
import GHC.Hs ( ABExport(..)
, ApplicativeArg(..)
, ArithSeqInfo(..)
+ , ConPatTc(..)
, FieldOcc(..)
, GRHS(..)
, GRHSs(..)
@@ -93,6 +96,7 @@ import GHC.Hs ( ABExport(..)
, HsCmd(..)
, HsCmdTop(..)
, HsConDetails(..)
+ , HsConPatDetails(..)
, HsExpr(..)
, HsLocalBindsLR(..)
, HsOverLit(..)
@@ -126,6 +130,14 @@ import GHC.Hs ( ABExport(..)
, selectorAmbiguousFieldOcc
)
import GHC.Hs.Binds ( RecordPatSynField(..) )
+import GHC.Hs.Dump ( BlankEpAnnotations(..)
+ , BlankSrcSpan(..)
+ , showAstData
+ )
+import GHC.Hs.Expr ( HsExpansion(..)
+ , HsWrap(..)
+ , XXExprGhcTc(..)
+ )
import GHC.Hs.Extension ( GhcTc )
import GHC.Tc.Types.Evidence ( HsWrapper(..) )
import GHC.Tc.Utils.Zonk ( conLikeResTy
@@ -161,6 +173,7 @@ import GHC.Types.Var ( Id
import GHC.Types.Var.Env ( TidyEnv )
import GHC.Unit.State ( UnitState )
import GHC.Utils.Misc ( thenCmp )
+import GHC.Utils.Outputable ( showPprUnsafe )
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
import Prelude hiding ( span )
@@ -593,8 +606,15 @@ foldTypecheckedSource = foldLHsBindsLR
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsGetField _ _ _)
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsProjection _ _)
foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
-foldLHsExpr ( L _span (XExpr _ )) = return Nothing
-foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do
+-- foldLHsExpr lhe
+-- | pprTrace "foldLHsExpr"
+-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
+-- False
+-- = undefined
+foldLHsExpr (L span (XExpr (ExpansionExpr (HsExpanded _ r)))) =
+ foldLHsExpr (L span r)
+foldLHsExpr ( L span (XExpr (WrapExpr wrap) )) = foldLHsWrap (L span wrap)
+foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
return . Just . varType $ identifier'
@@ -611,6 +631,11 @@ foldLHsExpr ( L _ HsOverLabel{} ) = return Nothing
foldLHsExpr lhe@(L _ expr@HsIPVar{}) = do
addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr)
return Nothing
+-- foldLHsExpr lhe@(L _ (HsOverLit _ _))
+-- | pprTrace "foldLHsExpr with hsoverlit"
+-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
+-- False
+-- = undefined
foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) =
restoreTidyEnv $ do
typ <- tidyType ol_type
@@ -619,6 +644,11 @@ foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) =
"HsOverLit"
(if isOneLineSpan (getLocA lhe) then Simple else Composite)
return $ Just typ
+-- foldLHsExpr lhe@(L _ (HsLit _ _))
+-- | pprTrace "foldLHsExpr with hslit"
+-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
+-- False
+-- = undefined
foldLHsExpr lhe@(L _ (HsLit _ lit)) = restoreTidyEnv $ do
typ <- tidyType $ hsLitType lit
addExprInfo (getLocA lhe)
@@ -1039,6 +1069,11 @@ foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = restoreTidyEnv $ do
return Nothing
foldLPat :: LPat GhcTc -> State ASTState (Maybe Type)
+-- foldLPat lp
+-- | pprTrace "foldLPat"
+-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lp)
+-- False
+-- = undefined
foldLPat ( L _span (XPat _ )) = return Nothing
foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do
(identifier', _) <- tidyIdentifier identifier
@@ -1081,19 +1116,28 @@ foldLPat (L _span (SumPat _ pat _ _)) = do
-- no more conpatin / conpatout, just conpat (in the wildcard pattern _)
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- TODO: FIXME
--- foldLPat (ghcDL -> cp@lp@(L _ pat@ConPat {..})) = do
--- let pc@(L _ conLike) = pat_con
+
+-- original
+-- foldLPat (ghcDL -> L span pat@ConPatOut {..}) = do
+-- let (L idSpan conLike) = pat_con
-- conId =
-- case conLike of
-- RealDataCon dc -> dataConWorkId dc
-- PatSynCon ps -> patSynId ps
-- typ = conLikeResTy (unLoc pat_con) pat_arg_tys
-- (identifier', mbTypes) <- tidyIdentifier conId
--- addIdentifierToIdSrcSpanMap (getLocA pc) identifier' mbTypes
+-- addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
-- typ' <- tidyType typ
--- addExprInfo (getLocA cp) (Just typ') "ConPat" (patSort pat)
+-- addExprInfo span (Just typ') "ConPatOut" (patSort pat)
-- _ <- foldHsConPatDetails pat_args
-- return . Just . varType $ identifier'
+
+foldLPat lp@(L span pat@(ConPat ConPatTc {..} (L _ conLike) args)) = do
+ let typ = conLikeResTy conLike cpt_arg_tys
+ typ' <- tidyType typ
+ addExprInfo (getLocA lp) (Just typ') "ConPat" (patSort pat)
+ _ <- foldHsConPatDetails args
+ return Nothing
foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do
typ' <- tidyType typ
addExprInfo (getLocA lp) (Just typ') "ViewPat" (patSort p)
@@ -1178,3 +1222,51 @@ foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do
foldLHsCmd (L _ (HsCmdDo _ stmts)) = do
mapM_ foldLStmtLRCmd $ unLoc stmts
return Nothing
+
+foldLHsWrap
+ :: GenLocated SrcSpanAnnA (HsWrap HsExpr) -> State ASTState (Maybe Type)
+foldLHsWrap (L span (HsWrap wrapper expr)) = 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
+
+restoreHsWrapper :: (State ASTState) a -> (State ASTState) a
+restoreHsWrapper action = do
+ wrapper <- astStateHsWrapper <$> get
+ res <- action
+ modify' $ \s -> s { astStateHsWrapper = wrapper }
+ return res
+
+foldHsConPatDetails :: HsConPatDetails GhcTc -> State ASTState (Maybe Type)
+foldHsConPatDetails (PrefixCon _ args) = do
+ mapM_ foldLPat args
+ return Nothing
+foldHsConPatDetails (RecCon rec) = do
+ _ <- foldHsRecFieldsPat rec
+ return Nothing
+foldHsConPatDetails (InfixCon arg1 arg2) = do
+ _ <- foldLPat arg1
+ _ <- foldLPat arg2
+ return Nothing
+
+foldHsRecFieldsPat
+ :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
+foldHsRecFieldsPat HsRecFields {..} = do
+ let onlyUserWritten = case rec_dotdot of
+ Just i -> take $ unLoc i
+ Nothing -> id
+ mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
+ return Nothing
+foldLHsRecFieldPat
+ :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
+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'
+foldLHsRecFieldPat (L _ (HsRecField _ (L _idSpan (XFieldOcc _)) _arg _pun)) =
+ return Nothing
+
--
cgit v1.2.3