diff options
Diffstat (limited to 'src/HaskellCodeExplorer')
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 104 |
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 + |