diff options
Diffstat (limited to 'src/HaskellCodeExplorer/AST/TypecheckedSource.hs')
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 161 |
1 files changed, 32 insertions, 129 deletions
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index 0aa4191..d31634c 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,6 +22,9 @@ module HaskellCodeExplorer.AST.TypecheckedSource import GHC.Data.Bag (bagToList) import GHC.Types.Basic (Origin(..)) import GHC.Core.Class (Class, classTyVars) +import GHC.Core.ConLike (ConLike(..)) +import GHC.Core.DataCon (dataConRepType) +import GHC.Core.PatSyn (patSynBuilder) import Control.Monad (unless, void, when) import Control.Monad.State.Strict (State, get, modify') import Data.Either (isLeft, fromLeft) @@ -38,9 +42,17 @@ import GHC , getLocA , reLocA , reLocN + , SrcLoc(..) + , srcSpanStart + , srcSpanEnd + ) +import GHC.Data.FastString + ( mkFastString + , FastString + , unpackFS ) -import GHC.Data.FastString (mkFastString) import GHC.Unit.State (UnitState) +import GHC.Utils.Misc (thenCmp) import HaskellCodeExplorer.GhcUtils import qualified HaskellCodeExplorer.Types as HCE import GHC.Hs.Binds (RecordPatSynField(..) @@ -89,19 +101,14 @@ import GHC.Hs , PatSynBind(..) , StmtLR(..) , selectorAmbiguousFieldOcc -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- , RecordConTc (..) , RecordUpdTc (..) , ListPatTc (..) , OverLitTc (..) , MatchGroupTc (..) , NHsValBindsLR (..) -#endif ) import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) import GHC.Hs.Extension (GhcTc) -#endif import GHC.Types.Id (idType) import GHC.Types.Id.Info (IdDetails(..)) import GHC.Core.InstEnv @@ -120,20 +127,13 @@ import GHC.Types.SrcLoc , UnhelpfulSpanReason(..) , isOneLineSpan , unLoc --- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) --- , cL --- #endif ) import GHC.Tc.Types.Evidence (HsWrapper(..)) import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType) import GHC.Core.Predicate (getClassPredTys_maybe) import GHC.Core.Type ( Type -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , nonDetCmpTypes -#else - , cmpTypes -#endif , eqTypes , eqType , mkVisFunTys @@ -210,11 +210,7 @@ exprSort HsIPVar {} = Simple exprSort HsOverLit {} = Simple exprSort HsLit {} = Simple -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) exprSort (ExplicitTuple _ args _) -#else -exprSort (ExplicitTuple args _) -#endif | null args = Simple | otherwise = Composite exprSort (ExplicitList _ args) @@ -227,18 +223,10 @@ patSort :: Pat a -> ExprSort patSort WildPat {} = Simple patSort LitPat {} = Simple patSort NPat {} = Simple -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) patSort (ListPat _ pats) -#else -patSort (ListPat pats _ _) -#endif | null pats = Simple | otherwise = Composite -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) patSort (TuplePat _ pats _) -#else -patSort (TuplePat pats _ _) -#endif | null pats = Simple | otherwise = Composite patSort _ = Composite @@ -291,6 +279,16 @@ funResultTy2Safe srcSpan astNode typ = do Just resTy1 -> funResultTySafe srcSpan astNode resTy1 Nothing -> return Nothing +instance Ord FastString where + a `compare` b = unpackFS a `compare` unpackFS b + +deriving instance () => Ord SrcLoc + +instance Ord SrcSpan where + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + (srcSpanEnd a `compare` srcSpanEnd b) + addIdentifierToIdSrcSpanMap :: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () addIdentifierToIdSrcSpanMap span identifier mbTypes @@ -557,14 +555,6 @@ restoreTidyEnv action = do modify' $ \s -> s {astStateTidyEnv = tidyEnv} return res --- not used any more --- restoreHsWrapper :: (State ASTState) a -> (State ASTState) a --- restoreHsWrapper action = do --- wrapper <- astStateHsWrapper <$> get --- res <- action --- modify' $ \s -> s {astStateHsWrapper = wrapper} --- return res - tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type])) tidyIdentifier identifier = do tidyEnv <- astStateTidyEnv <$> get @@ -613,12 +603,14 @@ foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes return . Just . varType $ identifier' foldLHsExpr (L _ HsUnboundVar {}) = return Nothing -foldLHsExpr (L _ (HsConLikeOut _ _)) = - -- restoreTidyEnv $ do - -- let mbType = varType <$> conLikeWrapId_maybe conLike - -- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType - -- return mbType' - restoreTidyEnv $ return Nothing +-- The logic does not match exactly with the old logic, i.e. (varType . dataConWrapId) and dataConRepType have seemingly different definitions. +foldLHsExpr (L _ (HsConLikeOut _ conLike)) = + restoreTidyEnv $ do + let mbType = case conLike of + RealDataCon dataCon -> Just $ dataConRepType dataCon + PatSynCon patSyn -> (\(_, typ, _) -> typ) <$> patSynBuilder patSyn + mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType + return mbType' foldLHsExpr (L _ HsRecFld {}) = return Nothing foldLHsExpr (L _ HsOverLabel {}) = return Nothing foldLHsExpr lhe@(L _ expr@HsIPVar {}) = do @@ -806,14 +798,6 @@ foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e) return typ --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr lhe@(L _ e@(HsCoreAnn _ _sourceText _fastString expr)) = do --- #else --- foldLHsExpr lhe@(L _ e@(HsCoreAnn _sourceText _fastString expr)) = do --- #endif --- typ <- foldLHsExpr expr --- addExprInfo (getLocA lhe) typ "HsCoreAnn" (exprSort e) --- return typ foldLHsExpr (L _span HsBracket {}) = return Nothing foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing @@ -827,8 +811,6 @@ foldLHsExpr lhe@(L _ e@(HsStatic _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsStatic" (exprSort e) return typ --- foldLHsExpr (L _ HsArrForm {}) = return Nothing --- foldLHsExpr (L _ HsArrApp {}) = return Nothing foldLHsExpr lhe@(L _ e@(HsTick _ _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsTick" (exprSort e) @@ -837,33 +819,6 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e) return typ --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do --- #else --- foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do --- #endif --- typ <- foldLHsExpr expr --- addExprInfo span typ "HsTickPragma" (exprSort e) --- return typ - --- A few similarly named symbols are in GHC.Hs.Pat --- foldLHsExpr (L _span EWildPat {}) = return Nothing --- foldLHsExpr (L _span EAsPat {}) = return Nothing --- foldLHsExpr (L _span EViewPat {}) = return Nothing --- foldLHsExpr (L _span ELazyPat {}) = return Nothing - --- there's an hswrap but it is not in hsexpr --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span (HsWrap _ wrapper expr)) = --- #else --- foldLHsExpr (L span (HsWrap wrapper expr)) = --- #endif --- 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 foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldHsRecFields HsRecFields {..} = do @@ -874,11 +829,7 @@ foldHsRecFields HsRecFields {..} = do mapM_ foldLHsRecField $ userWritten rec_flds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -#else -foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type) -#endif foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier @@ -1241,7 +1192,7 @@ foldLPat lp@(L _ pat@(PArrPat pats typ)) = do mapM_ foldLPat pats return $ Just typ' #endif --- no more conpatin / conpatout, just conpat +-- 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 @@ -1317,48 +1268,8 @@ foldLPat (L _span (SigPatOut pat typ)) = do _ <- foldLPat pat return $ Just typ' #endif --- no copat in lpat in 9.2.2 --- foldLPat lp@(L span p@(CoPat _ pat typ)) = do --- typ' <- tidyType typ --- addExprInfo (getLocA lp) (Just typ') "CoPat" (patSort p) --- -- cL is similar to dL and not used any more --- -- _ <- foldLPat (cL (getLocA lp) pat) --- _ <- foldLPat (L span pat) --- return Nothing foldLPat _ = return Nothing --- no longer used --- 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 - --- no longer used --- 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 - foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do mbTyp <- foldLHsCmd cmd @@ -1406,11 +1317,3 @@ foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do foldLHsCmd (L _ (HsCmdDo _ stmts)) = do mapM_ foldLStmtLRCmd $ unLoc stmts return Nothing --- no more hscmdwrap --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do --- #else --- foldLHsCmd (L span (HsCmdWrap _ cmd)) = do --- #endif --- _ <- foldLHsCmd (L span cmd) --- return Nothing |