From b84a142afdbca026003a6e5a9f872fabaaa71e57 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Fri, 10 Jun 2022 19:03:10 +1000
Subject: clean up typecheckedsource
- fill in holes by returning nothing
- commenting out some debugging imports
---
src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 54 ++++++++----------------
1 file changed, 17 insertions(+), 37 deletions(-)
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index 2a9079d..232d54d 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -84,7 +84,7 @@ import GHC.Data.FastString ( FastString
, mkFastString
, unpackFS
)
-import GHC.Driver.Ppr ( pprTrace )
+-- import GHC.Driver.Ppr ( pprTrace )
import GHC.Hs ( ABExport(..)
, ApplicativeArg(..)
, ArithSeqInfo(..)
@@ -96,7 +96,7 @@ import GHC.Hs ( ABExport(..)
, HsCmd(..)
, HsCmdTop(..)
, HsConDetails(..)
- , HsConPatDetails(..)
+ , HsConPatDetails
, HsExpr(..)
, HsLocalBindsLR(..)
, HsOverLit(..)
@@ -130,10 +130,10 @@ import GHC.Hs ( ABExport(..)
, selectorAmbiguousFieldOcc
)
import GHC.Hs.Binds ( RecordPatSynField(..) )
-import GHC.Hs.Dump ( BlankEpAnnotations(..)
- , BlankSrcSpan(..)
- , showAstData
- )
+-- import GHC.Hs.Dump ( BlankEpAnnotations(..)
+-- , BlankSrcSpan(..)
+-- , showAstData
+-- )
import GHC.Hs.Expr ( HsExpansion(..)
, HsWrap(..)
, XXExprGhcTc(..)
@@ -173,7 +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 GHC.Utils.Outputable ( showPprUnsafe )
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
import Prelude hiding ( span )
@@ -599,22 +599,13 @@ tidyType typ = do
foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState ()
foldTypecheckedSource = foldLHsBindsLR
--- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:606:1: warning: [-Wincomplete-patterns]
--- Pattern match(es) are non-exhaustive
--- In an equation for ‘foldLHsExpr’:
--- Patterns of type ‘LHsExpr GhcTc’ not matched:
--- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsGetField _ _ _)
--- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsProjection _ _)
foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
-- 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
+foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
return . Just . varType $ identifier'
@@ -631,11 +622,6 @@ 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
@@ -644,11 +630,6 @@ 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)
@@ -785,6 +766,8 @@ foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) e
_ <- foldLHsExpr expr
when (isLeft binds) (mapM_ foldLHsRecUpdField (fromLeft [] binds))
return $ Just typ'
+foldLHsExpr ( L _ ( HsGetField _ _ _ )) = return Nothing
+foldLHsExpr ( L _ ( HsProjection _ _ )) = return Nothing
foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "ExprWithTySig" (exprSort e)
@@ -827,6 +810,9 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e)
return typ
+foldLHsExpr (L span (XExpr (ExpansionExpr (HsExpanded _ r)))) =
+ foldLHsExpr (L span r)
+foldLHsExpr (L span (XExpr (WrapExpr wrap))) = foldLHsWrap (L span wrap)
foldHsRecFields
:: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
@@ -1114,10 +1100,8 @@ foldLPat (L _span (SumPat _ pat _ _)) = do
_ <- foldLPat pat
return Nothing
-- no more conpatin / conpatout, just conpat (in the wildcard pattern _)
--- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
--- TODO: FIXME
-
-- original
+-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- foldLPat (ghcDL -> L span pat@ConPatOut {..}) = do
-- let (L idSpan conLike) = pat_con
-- conId =
@@ -1132,7 +1116,7 @@ foldLPat (L _span (SumPat _ pat _ _)) = do
-- _ <- foldHsConPatDetails pat_args
-- return . Just . varType $ identifier'
-foldLPat lp@(L span pat@(ConPat ConPatTc {..} (L _ conLike) args)) = do
+foldLPat lp@(L _ 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)
@@ -1180,11 +1164,6 @@ foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
addExprInfo span mbTyp "HsCmdTop" Composite
return mbTyp
--- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:1379:1: warning: [-Wincomplete-patterns]
--- Pattern match(es) are non-exhaustive
--- In an equation for ‘foldLHsCmd’:
--- Patterns of type ‘LHsCmd GhcTc’ not matched:
--- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsCmdLamCase _ _)
foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type)
foldLHsCmd (L _ (XCmd _ )) = return Nothing
foldLHsCmd (L _ (HsCmdArrApp _ expr1 expr2 _ _)) = do
@@ -1206,7 +1185,8 @@ foldLHsCmd (L _ (HsCmdCase _ expr MG {..})) = do
_ <- foldLHsExpr expr
mapM_ foldLMatchCmd $ unLoc mg_alts
return Nothing
-foldLHsCmd (L _ (HsCmdPar _ cmd)) = do
+foldLHsCmd (L _ (HsCmdLamCase _ _ )) = return Nothing
+foldLHsCmd (L _ (HsCmdPar _ cmd)) = do
_ <- foldLHsCmd cmd
return Nothing
foldLHsCmd (L _ (HsCmdIf _ _ expr cmd1 cmd2)) = do
--
cgit v1.2.3