Fixing some typechecked "holes"

two "holes"
- Expanded
- ConPat

also added some pprTrace for debugging

1 files 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
+