diff options
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 54 |
1 files 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 |