diff options
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 652 |
1 files changed, 224 insertions, 428 deletions
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index 7cf5157..cb7d323 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -21,23 +21,23 @@ 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(..) --- , conLikeWrapId_maybe - ) -import Control.Monad (return, unless, void) +import Control.Monad (unless, void, when) import Control.Monad.State.Strict (State, get, modify') +import Data.Either (isLeft, fromLeft) import qualified Data.HashMap.Strict as HM import qualified Data.IntMap.Strict as IM import qualified Data.IntervalMap.Strict as IVM import qualified Data.Map.Strict as M -import Data.Maybe (Maybe, fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as S import qualified Data.Text as T -import GHC.Core.DataCon (dataConWorkId) +import GHC.Core.Multiplicity (scaledThing) import GHC ( DynFlags , TyThing(..) - , CoPat(..) + , getLocA + , reLocA + , reLocN ) import GHC.Data.FastString (mkFastString) import GHC.Unit.State (UnitState) @@ -118,6 +118,7 @@ import GHC.Types.SrcLoc ( GenLocated(..) , SrcSpan(..) , isGoodSrcSpan + , UnhelpfulSpanReason(..) , isOneLineSpan , unLoc -- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) @@ -136,9 +137,10 @@ import GHC.Core.Type #endif , eqTypes , eqType - , mkFunTy --- , mkFunTys --- , splitForAllTys + , mkVisFunTys + , mkVisFunTyMany + , mkVisFunTysMany + , splitForAllTyCoVars , splitFunTy_maybe , splitFunTys , substTys @@ -248,7 +250,7 @@ splitFunTySafe :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type)) splitFunTySafe srcSpan astNode typ = case splitFunTy_maybe typ of - Just (ty1, ty2) -> return $ Just (ty1, ty2) + Just (_, ty1, ty2) -> return $ Just (ty1, ty2) Nothing -> do flags <- envDynFlags . astStateEnv <$> get let typeError = @@ -402,6 +404,7 @@ traceInstanceResolution :: traceInstanceResolution environment c ts = go c ts S.empty where flags = envDynFlags environment + unitState = envUnitState environment go :: Class -> [Type] -> S.Set (Name, InstTypes) -> HCE.InstanceResolution go cls types seenInstances = let clsTyVarCount = length $ classTyVars cls @@ -425,7 +428,7 @@ traceInstanceResolution environment c ts = go c ts S.empty (mkType flags . idType $ is_dfun inst) (map (mkType flags) instTypes) (nameLocationInfo - flags + unitState (envPackageId environment) (envComponentId environment) (envTransformation environment) @@ -555,12 +558,13 @@ restoreTidyEnv action = do modify' $ \s -> s {astStateTidyEnv = tidyEnv} return res -restoreHsWrapper :: (State ASTState) a -> (State ASTState) a -restoreHsWrapper action = do - wrapper <- astStateHsWrapper <$> get - res <- action - modify' $ \s -> s {astStateHsWrapper = wrapper} - 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 @@ -601,19 +605,15 @@ foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type) #else foldLHsExpr :: LHsExpr Id -> State ASTState (Maybe Type) #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsExpr (L _span (XExpr _)) = return Nothing foldLHsExpr (L _ (HsOverLit _ (XOverLit _))) = return Nothing foldLHsExpr (L _ (HsLam _ (XMatchGroup _))) = return Nothing foldLHsExpr (L _ (HsLamCase _ (XMatchGroup _))) = return Nothing foldLHsExpr (L _ (HsCase _ _ (XMatchGroup _))) = return Nothing -foldLHsExpr (L span (HsVar _ (L _ identifier))) = -#else -foldLHsExpr (L span (HsVar (L _ identifier))) = -#endif +foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap span identifier' mbTypes + addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes return . Just . varType $ identifier' foldLHsExpr (L _ HsUnboundVar {}) = return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) @@ -630,151 +630,100 @@ foldLHsExpr (L _ (HsConLikeOut conLike)) = #endif foldLHsExpr (L _ HsRecFld {}) = return Nothing foldLHsExpr (L _ HsOverLabel {}) = return Nothing -foldLHsExpr (L span expr@HsIPVar {}) = do - addExprInfo span Nothing "HsIPVar" (exprSort expr) +foldLHsExpr lhe@(L _ expr@HsIPVar {}) = do + addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr) return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) = -#else -foldLHsExpr (L span (HsOverLit OverLit {ol_type})) = -#endif +foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) = restoreTidyEnv $ do typ <- tidyType ol_type addExprInfo - span + (getLocA lhe) (Just typ) "HsOverLit" - (if isOneLineSpan span + (if isOneLineSpan (getLocA lhe) then Simple else Composite) return $ Just typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span (HsLit _ lit)) = -#else -foldLHsExpr (L span (HsLit lit)) = -#endif +foldLHsExpr lhe@(L _ (HsLit _ lit)) = restoreTidyEnv $ do typ <- tidyType $ hsLitType lit addExprInfo - span + (getLocA lhe) (Just typ) "HsLit" - (if isOneLineSpan span + (if isOneLineSpan (getLocA lhe) then Simple else Composite) return $ Just typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(HsLam _ (MG (MatchGroupTc {..}) mg_alts _))) = -#else -foldLHsExpr (L span expr@(HsLam MG {..})) = -#endif +foldLHsExpr lhe@(L span expr@(HsLam _ (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do - typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty - addExprInfo span (Just typ) "HsLam" (exprSort expr) + typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty + addExprInfo (getLocA lhe) (Just typ) "HsLam" (exprSort expr) mapM_ foldLMatch $ unLoc mg_alts return $ Just typ -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) = -#else -foldLHsExpr (L span expr@(HsLamCase MG {..})) = -#endif -#else -foldLHsExpr (L span expr@(HsLamCase _typ MG {..})) = -#endif +foldLHsExpr lhe@(L _ expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do - typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty - addExprInfo span (Just typ) "HsLamCase" (exprSort expr) + typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty + addExprInfo (getLocA lhe) (Just typ) "HsLamCase" (exprSort expr) mapM_ foldLMatch $ unLoc mg_alts return $ Just typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(HsApp _ fun arg)) = do -#else -foldLHsExpr (L span expr@(HsApp fun arg)) = do -#endif +foldLHsExpr lhe@(L _ expr@(HsApp _ fun arg)) = do funTy <- foldLHsExpr fun _argTy <- foldLHsExpr arg - typ <- maybe (return Nothing) (funResultTySafe span "HsApp") funTy - addExprInfo span typ "HsApp" (exprSort expr) + typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy + addExprInfo (getLocA lhe) typ "HsApp" (exprSort expr) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -foldLHsExpr (L span ex@(HsAppType _ expr _)) = do -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span ex@(HsAppType _ expr)) = do -#else -foldLHsExpr (L _ (HsAppType _ _)) = return Nothing -foldLHsExpr (L span ex@(HsAppTypeOut expr _)) = do -#endif +foldLHsExpr lhe@(L _ ex@(HsAppType _ expr _)) = do typ <- foldLHsExpr expr - addExprInfo span typ "HsAppType" (exprSort ex) + addExprInfo (getLocA lhe) typ "HsAppType" (exprSort ex) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(OpApp _ left op right)) = do -#else -foldLHsExpr (L span expr@(OpApp left op _fixity right)) = do -#endif +foldLHsExpr lhe@(L _ expr@(OpApp _ left op right)) = do opTyp <- foldLHsExpr op - typ <- maybe (return Nothing) (funResultTy2Safe span "HsApp") opTyp + typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp _ <- foldLHsExpr left _ <- foldLHsExpr right - addExprInfo span typ "OpApp" (exprSort expr) + addExprInfo (getLocA lhe) typ "OpApp" (exprSort expr) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(NegApp _ expr _syntaxExp)) = do -#else -foldLHsExpr (L span e@(NegApp expr _syntaxExp)) = do -#endif +foldLHsExpr lhe@(L _ e@(NegApp _ expr _syntaxExp)) = do typ <- foldLHsExpr expr - addExprInfo span typ "NegApp" (exprSort e) + addExprInfo (getLocA lhe) typ "NegApp" (exprSort e) return typ #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsExpr (L _span (HsPar _ expr)) = foldLHsExpr expr #else foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(SectionL _ operand operator)) = do -#else -foldLHsExpr (L span expr@(SectionL operand operator)) = do -#endif +foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do opType <- foldLHsExpr operator _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe span "SectionL") opType + mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionL") opType let typ = case mbTypes of - Just (_arg1, arg2, res) -> Just $ mkFunTy arg2 res + Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res Nothing -> Nothing - addExprInfo span typ "SectionL" (exprSort expr) + addExprInfo (getLocA lhe) typ "SectionL" (exprSort expr) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(SectionR _ operator operand)) = do -#else -foldLHsExpr (L span e@(SectionR operator operand)) = do -#endif +foldLHsExpr lhe@(L _ e@(SectionR _ operator operand)) = do opType <- foldLHsExpr operator _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe span "SectionR") opType + mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionR") opType let typ = case mbTypes of - Just (arg1, _arg2, res) -> Just $ mkFunTy arg1 res + Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res Nothing -> Nothing - addExprInfo span typ "SectionR" (exprSort e) + addExprInfo (getLocA lhe) typ "SectionR" (exprSort e) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(ExplicitTuple _ tupArgs boxity)) = do -#else -foldLHsExpr (L span e@(ExplicitTuple tupArgs boxity)) = do -#endif - tupleArgs <- mapM foldLHsTupArg tupArgs +foldLHsExpr lhe@(L _ e@(ExplicitTuple _ tupArgs boxity)) = do + tupleArgs <- mapM foldHsTupArg tupArgs let tupleSectionArgTys = mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs tupleArgTys = mapM fst tupleArgs resultType = - mkFunTys <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys) + mkVisFunTysMany <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys) tidyEnv <- astStateTidyEnv <$> get addExprInfo - span + (getLocA lhe) (snd . tidyOpenType tidyEnv <$> resultType) "ExplicitTuple" (exprSort e) @@ -789,106 +738,70 @@ foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do _ <- foldLHsExpr expr return Nothing #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) = -#else -foldLHsExpr (L span e@(HsCase expr MG {..})) = -#endif +foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do typ <- tidyType mg_res_ty _ <- foldLHsExpr expr mapM_ foldLMatch (unLoc mg_alts) - addExprInfo span (Just typ) "HsCase" (exprSort e) + addExprInfo (getLocA lhe) (Just typ) "HsCase" (exprSort e) return $ Just typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(HsIf _ _mbSynExpr condExpr thenExpr elseExpr)) = do -#else -foldLHsExpr (L span e@(HsIf _mbSynExpr condExpr thenExpr elseExpr)) = do -#endif +foldLHsExpr lhe@(L _ e@(HsIf _ condExpr thenExpr elseExpr)) = do _ <- foldLHsExpr condExpr typ <- foldLHsExpr thenExpr _ <- foldLHsExpr elseExpr - addExprInfo span typ "HsIf" (exprSort e) + addExprInfo (getLocA lhe) typ "HsIf" (exprSort e) return typ -foldLHsExpr (L span e@(HsMultiIf typ grhss)) = +foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = restoreTidyEnv $ do typ' <- tidyType typ - addExprInfo span (Just typ') "HsMultiIf" (exprSort e) + addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e) mapM_ foldLGRHS grhss return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(HsLet _ (L _ binds) expr)) = do -#else -foldLHsExpr (L span e@(HsLet (L _ binds) expr)) = do -#endif +foldLHsExpr lhe@(L _ e@(HsLet _ binds expr)) = do _ <- foldHsLocalBindsLR binds typ <- foldLHsExpr expr - addExprInfo span typ "HsLet" (exprSort e) + addExprInfo (getLocA lhe) typ "HsLet" (exprSort e) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(HsDo typ _context (L _ stmts))) = -#else -foldLHsExpr (L span expr@(HsDo _context (L _ stmts) typ)) = -#endif +foldLHsExpr lhe@(L _ expr@(HsDo typ _context (L _ stmts))) = restoreTidyEnv $ do typ' <- tidyType typ - addExprInfo span (Just typ') "HsDo" (exprSort expr) + addExprInfo (getLocA lhe) (Just typ') "HsDo" (exprSort expr) mapM_ foldLStmtLR stmts return $ Just typ' -foldLHsExpr (L span (ExplicitList typ _syntaxExpr exprs)) = +foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = restoreTidyEnv $ do typ' <- mkListTy <$> tidyType typ - unless (null exprs) $ addExprInfo span (Just typ') "ExplicitList" Composite - mapM_ foldLHsExpr exprs - return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -#else -foldLHsExpr (L span e@(ExplicitPArr typ exprs)) = - restoreTidyEnv $ do - typ' <- tidyType typ - addExprInfo span (Just typ') "ExplicitPArr" (exprSort e) + unless (null exprs) $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite mapM_ foldLHsExpr exprs return $ Just typ' -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(RecordCon conExpr _ binds)) = do -#else -foldLHsExpr (L span e@(RecordCon (L _ _) _conLike conExpr binds)) = do -#endif +foldLHsExpr lhe@(L _ e@(RecordCon conExpr _ binds)) = do mbConType <- fmap (snd . splitFunTys) <$> - foldLHsExpr (L (UnhelpfulSpan $ mkFastString "RecordCon") conExpr) - addExprInfo span mbConType "RecordCon" (exprSort e) + foldLHsExpr + (reLocA + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr)) + addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e) _ <- foldHsRecFields binds return mbConType -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) = -#else -foldLHsExpr (L span e@(RecordUpd expr binds cons _inputTys outTys _wrapper)) = -#endif +foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) = restoreTidyEnv $ do -- cons is a non-empty list of DataCons that have all the upd'd fields let typ = conLikeResTy (head cons) outTys typ' <- tidyType typ - addExprInfo span (Just typ') "RecordUpd" (exprSort e) + addExprInfo (getLocA lhe) (Just typ') "RecordUpd" (exprSort e) _ <- foldLHsExpr expr - mapM_ foldLHsRecUpdField binds + when (isLeft binds) (mapM_ foldLHsRecUpdField (fromLeft [] binds)) return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -foldLHsExpr (L span e@(ExprWithTySig _ expr _)) = do -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(ExprWithTySig _ expr)) = do -#else -foldLHsExpr (L _span (ExprWithTySig _expr _type)) = return Nothing -foldLHsExpr (L span e@(ExprWithTySigOut expr _type)) = do -#endif +foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do typ <- foldLHsExpr expr - addExprInfo span typ "ExprWithTySig" (exprSort e) + addExprInfo (getLocA lhe) typ "ExprWithTySig" (exprSort e) return typ -foldLHsExpr (L span e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do +foldLHsExpr lhe@(L _ e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do typ <- - fmap (snd . splitFunTys . snd . splitForAllTys) <$> - foldLHsExpr (L (UnhelpfulSpan $ mkFastString "ArithSeq") postTcExpr) + fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> + foldLHsExpr + (reLocA + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr)) _ <- case seqInfo of From expr -> foldLHsExpr expr @@ -896,69 +809,46 @@ foldLHsExpr (L span e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 FromThenTo expr1 expr2 expr3 -> foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3 - addExprInfo span typ "ArithSeq" (exprSort e) - return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -#else -foldLHsExpr (L span e@(PArrSeq postTcExpr _seqInfo)) = do - typ <- foldLHsExpr (L (UnhelpfulSpan $ mkFastString "PArrSeq") postTcExpr) - addExprInfo span typ "ArithSeq" (exprSort e) + addExprInfo (getLocA lhe) typ "ArithSeq" (exprSort e) return typ -#endif -- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span e@(HsSCC _ _sourceText _fastString expr)) = do +-- foldLHsExpr lhe@(L _ e@(HsSCC _ _sourceText _fastString expr)) = do -- #else --- foldLHsExpr (L span e@(HsSCC _sourceText _fastString expr)) = do +-- foldLHsExpr lhe@(L _ e@(HsSCC _sourceText _fastString expr)) = do -- #endif -- typ <- foldLHsExpr expr --- addExprInfo span typ "HsSCC" (exprSort e) +-- addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e) -- return typ -- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span e@(HsCoreAnn _ _sourceText _fastString expr)) = do +-- foldLHsExpr lhe@(L _ e@(HsCoreAnn _ _sourceText _fastString expr)) = do -- #else --- foldLHsExpr (L span e@(HsCoreAnn _sourceText _fastString expr)) = do +-- foldLHsExpr lhe@(L _ e@(HsCoreAnn _sourceText _fastString expr)) = do -- #endif -- typ <- foldLHsExpr expr --- addExprInfo span typ "HsCoreAnn" (exprSort e) +-- 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 foldLHsExpr (L _span HsSpliceE {}) = return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span expr@(HsProc _ pat cmd)) = do -#else -foldLHsExpr (L span expr@(HsProc pat cmd)) = do -#endif +foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do _ <- foldLPat pat _ <- foldLHsCmdTop cmd - addExprInfo span Nothing "HsProc" (exprSort expr) + addExprInfo (getLocA lhe) Nothing "HsProc" (exprSort expr) return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -foldLHsExpr (L span e@(HsStatic _ expr)) = do -#else -foldLHsExpr (L span e@(HsStatic expr)) = do -#endif +foldLHsExpr lhe@(L _ e@(HsStatic _ expr)) = do typ <- foldLHsExpr expr - addExprInfo span typ "HsStatic" (exprSort e) + addExprInfo (getLocA lhe) typ "HsStatic" (exprSort e) return typ -- foldLHsExpr (L _ HsArrForm {}) = return Nothing -- foldLHsExpr (L _ HsArrApp {}) = return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(HsTick _ _ expr)) = do -#else -foldLHsExpr (L span e@(HsTick _ expr)) = do -#endif +foldLHsExpr lhe@(L _ e@(HsTick _ _ expr)) = do typ <- foldLHsExpr expr - addExprInfo span typ "HsTick" (exprSort e) + addExprInfo (getLocA lhe) typ "HsTick" (exprSort e) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L span e@(HsBinTick _ _ _ expr)) = do -#else -foldLHsExpr (L span e@(HsBinTick _ _ expr)) = do -#endif +foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do typ <- foldLHsExpr expr - addExprInfo span typ "HsBinTick" (exprSort e) + 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 @@ -988,15 +878,11 @@ foldLHsExpr (L span e@(HsBinTick _ _ expr)) = do -- typ <- foldLHsExpr (L span expr) -- return $ applyWrapper wrapper <$> typ -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -#else -foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type) -#endif foldHsRecFields HsRecFields {..} = do let userWritten = case rec_dotdot of - Just i -> take i + Just i -> take $ unLoc i Nothing -> id mapM_ foldLHsRecField $ userWritten rec_flds return Nothing @@ -1006,25 +892,17 @@ foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Ty #else foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsRecField (L _span (HsRecField (L _idSpan (XFieldOcc _)) _ _)) = return Nothing -foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc identifier _)) arg pun)) = -#else -foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = -#endif +foldLHsRecField (L _span (HsRecField _ (L _idSpan (XFieldOcc _)) _ _)) = return Nothing +foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes - addExprInfo span (Just . varType $ identifier') "HsRecField" Composite + addExprInfo (getLocA lhr) (Just . varType $ identifier') "HsRecField" Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsRecUpdField :: LHsRecUpdField GhcTc -> State ASTState (Maybe Type) -#else -foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type) -#endif -foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) = +foldLHsRecUpdField lhr@(L _ (HsRecField _ (L idSpan recField) arg pun)) = restoreTidyEnv $ do let selectorId = selectorAmbiguousFieldOcc recField (identifier', mbTypes) <- tidyIdentifier selectorId @@ -1038,7 +916,7 @@ foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) = _ -> selName let identifier'' = setVarName identifier' originalName addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes - addExprInfo span (Just . varType $ identifier'') "HsRecUpdField" Composite + addExprInfo (getLocA lhr) (Just . varType $ identifier'') "HsRecUpdField" Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' @@ -1047,17 +925,25 @@ data TupArg | TupArgMissing deriving (Show, Eq) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldHsTupArg :: HsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) +foldHsTupArg (XTupArg _) = return (Nothing, TupArgMissing) +foldHsTupArg (Present _ expr) = + restoreTidyEnv $ do + typ <- foldLHsExpr expr + typ' <- + case typ of + Just t -> Just <$> tidyType t + Nothing -> return Nothing + return (typ', TupArgPresent) +foldHsTupArg (Missing typ) = + restoreTidyEnv $ do + typ' <- tidyType $ scaledThing typ + return (Just typ', TupArgMissing) + +-- TODO: use foldHsTupArg foldLHsTupArg :: LHsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) -#else -foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg) -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsTupArg (L _span (XTupArg _)) = return (Nothing, TupArgMissing) foldLHsTupArg (L _span (Present _ expr)) = -#else -foldLHsTupArg (L _span (Present expr)) = -#endif restoreTidyEnv $ do typ <- foldLHsExpr expr typ' <- @@ -1067,7 +953,7 @@ foldLHsTupArg (L _span (Present expr)) = return (typ', TupArgPresent) foldLHsTupArg (L _ (Missing typ)) = restoreTidyEnv $ do - typ' <- tidyType typ + typ' <- tidyType $ scaledThing typ return (Just typ', TupArgMissing) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) @@ -1103,7 +989,7 @@ foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif foldGRHSsCmd GRHSs {..} = do mapM_ foldLGRHSCmd grhssGRHSs - _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds) + _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldGRHSsCmd (_) = return Nothing @@ -1116,7 +1002,7 @@ foldGRHSs :: GRHSs Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldGRHSs GRHSs {..} = do mapM_ foldLGRHS grhssGRHSs - _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds) + _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldGRHSs (_) = return Nothing @@ -1127,33 +1013,25 @@ foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type #else foldLStmtLR :: LStmtLR Id Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLR (L _span (XStmtLR _)) = return Nothing -foldLStmtLR (L span (LastStmt _ body _ _)) = -#else -foldLStmtLR (L span (LastStmt body _ _)) = -#endif +foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = do typ <- foldLHsExpr body - addExprInfo span typ "LastStmt" Composite + addExprInfo (getLocA lst) typ "LastStmt" Composite return typ #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLR (L _span (BindStmt _ pat body _ _)) = do +foldLStmtLR (L _span (BindStmt _ pat body)) = do #else foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do #endif _ <- foldLPat pat _ <- foldLHsExpr body return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLR (L span (BodyStmt _ body _ _)) = do -#else -foldLStmtLR (L span (BodyStmt body _ _ _)) = do -#endif +foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do mbTyp <- foldLHsExpr body - addExprInfo span mbTyp "BodyStmt" Composite + addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite return mbTyp #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLR (L _ (LetStmt _ (L _ binds))) = do +foldLStmtLR (L _ (LetStmt _ binds)) = do #else foldLStmtLR (L _ (LetStmt (L _ binds))) = do #endif @@ -1172,17 +1050,13 @@ foldLStmtLR (L _ TransStmt {..}) = do _ <- foldLHsExpr trS_using return Nothing foldLStmtLR (L _span RecStmt {..}) = do - mapM_ foldLStmtLR recS_stmts + mapM_ foldLStmtLR (unLoc recS_stmts) return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLR (L span (ApplicativeStmt typ args _)) = -#else -foldLStmtLR (L span (ApplicativeStmt args _ typ)) = -#endif +foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do typ' <- tidyType typ mapM_ (foldApplicativeArg . snd) args - addExprInfo span (Just typ') "ApplicativeStmt" Composite + addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) @@ -1208,7 +1082,7 @@ foldApplicativeArg appArg = _ <- foldLHsExpr expr return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - ApplicativeArgMany _ exprStmts _ pat -> do + ApplicativeArgMany _ exprStmts _ pat _ -> do #else ApplicativeArgMany exprStmts _ pat -> do #endif @@ -1221,36 +1095,20 @@ foldLStmtLRCmd :: #else foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLRCmd (L _ (XStmtLR _)) = return Nothing -foldLStmtLRCmd (L span (LastStmt _ body _syntaxExpr _)) = do -#else -foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do -#endif +foldLStmtLRCmd ls@(L _ (LastStmt _ body _syntaxExpr _)) = do typ <- foldLHsCmd body - addExprInfo span typ "LastStmt Cmd" Composite + addExprInfo (getLocA ls) typ "LastStmt Cmd" Composite return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLRCmd (L _ (BindStmt _ pat body _ _)) = do -#else -foldLStmtLRCmd (L _ (BindStmt pat body _ _ _)) = do -#endif +foldLStmtLRCmd (L _ (BindStmt _ pat body)) = do _ <- foldLPat pat _ <- foldLHsCmd body return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLRCmd (L span (BodyStmt _ body _ _)) = do -#else -foldLStmtLRCmd (L span (BodyStmt body _ _ _)) = do -#endif +foldLStmtLRCmd ls@(L _ (BodyStmt _ body _ _)) = do typ <- foldLHsCmd body - addExprInfo span typ "BodyStmt Cmd" Composite + addExprInfo (getLocA ls) typ "BodyStmt Cmd" Composite return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLRCmd (L _ (LetStmt _ (L _ binds))) = do -#else -foldLStmtLRCmd (L _ (LetStmt (L _ binds))) = do -#endif +foldLStmtLRCmd (L _ (LetStmt _ binds)) = do _ <- foldHsLocalBindsLR binds return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) @@ -1266,17 +1124,13 @@ foldLStmtLRCmd (L _ TransStmt {..}) = do _ <- maybe (return Nothing) foldLHsExpr trS_by return Nothing foldLStmtLRCmd (L _ RecStmt {..}) = do - mapM_ foldLStmtLRCmd recS_stmts + mapM_ foldLStmtLRCmd (unLoc recS_stmts) return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLStmtLRCmd (L span (ApplicativeStmt typ args _)) = -#else -foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) = -#endif +foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do typ' <- tidyType typ mapM_ (foldApplicativeArg . snd) args - addExprInfo span (Just typ') "ApplicativeStmt Cmd" Composite + addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) @@ -1365,23 +1219,16 @@ foldLHsBindsLR :: LHsBinds Id -> State ASTState () #endif foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsBindLR :: LHsBindLR GhcTc GhcTc -> Maybe Id -- ^ Polymorphic id -> State ASTState (Maybe Type) -#else -foldLHsBindLR :: LHsBindLR Id Id - -> Maybe Id -- ^ Polymorphic id - -> State ASTState (Maybe Type) -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsBindLR (L _span (XHsBindsLR _)) _ = return Nothing foldLHsBindLR (L _span (PatSynBind _ (XPatSynBind _))) _ = return Nothing -#endif +-- TODO: FIXME foldLHsBindLR (L _span FunBind {..}) mbPolyId | mg_origin fun_matches == FromSource = restoreTidyEnv $ do - let (L idSpan identifier) = fun_id -- monotype + let fi@(L _ identifier) = fun_id -- monotype typ = case mbPolyId of Just polyId -> varType polyId @@ -1389,7 +1236,7 @@ foldLHsBindLR (L _span FunBind {..}) mbPolyId name = maybe (varName identifier) varName mbPolyId identifier' = setVarType (setVarName identifier name) typ (identifier'', _) <- tidyIdentifier identifier' - addIdentifierToIdSrcSpanMap idSpan identifier'' Nothing + addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing mapM_ foldLMatch (unLoc (mg_alts fun_matches)) return Nothing | otherwise = return Nothing @@ -1408,11 +1255,7 @@ foldLHsBindLR (L _ AbsBindsSig {..}) _ = do _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export) return Nothing #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = -#else -foldLHsBindLR (L _ (PatSynBind PSB {..})) _ = -#endif restoreTidyEnv $ do _ <- foldLPat psb_def _ <- @@ -1421,98 +1264,75 @@ foldLHsBindLR (L _ (PatSynBind PSB {..})) _ = (i', _) <- tidyIdentifier i addIdentifierToIdSrcSpanMap span i' Nothing in case psb_args of -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - InfixCon id1 id2 -> addId id1 >> addId id2 - PrefixCon ids -> mapM_ addId ids + InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2) + PrefixCon _ ids -> mapM_ (addId . reLocN) ids RecCon recs -> mapM_ - (\(RecordPatSynField selId patVar) -> - addId selId >> addId patVar) - recs -#else - InfixPatSyn id1 id2 -> addId id1 >> addId id2 - PrefixPatSyn ids -> mapM_ addId ids - RecordPatSyn recs -> - mapM_ - (\(RecordPatSynField selId patVar) -> - addId selId >> addId patVar) + (\(RecordPatSynField field patVar) -> + addId + (L ((getLocA . rdrNameFieldOcc) field) + (extFieldOcc field)) + >> addId (reLocN patVar)) recs -#endif return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLPat :: LPat GhcTc -> State ASTState (Maybe Type) -#else -foldLPat :: LPat Id -> State ASTState (Maybe Type) -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L _span (XPat _)) = return Nothing -foldLPat (ghcDL -> L _ (NPat _ (L _ (XOverLit _)) _ _)) = return Nothing -foldLPat (ghcDL -> L _ (NPlusKPat _ (L _ _) (L _ (XOverLit _)) _ _ _)) = return Nothing -foldLPat (ghcDL -> L span (VarPat _ (L _ identifier))) = do -#else -foldLPat (ghcDL -> L span (VarPat (L _ identifier))) = do -#endif +foldLPat (L _span (XPat _)) = return Nothing +foldLPat (L _ (NPat _ (L _ (XOverLit _)) _ _)) = return Nothing +foldLPat (L _ (NPlusKPat _ (L _ _) (L _ (XOverLit _)) _ _ _)) = return Nothing +foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do (identifier', _) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap span identifier' Nothing + addIdentifierToIdSrcSpanMap (getLocA lp) identifier' Nothing return . Just . varType $ identifier' -foldLPat (ghcDL -> L span pat@(WildPat typ)) = do +foldLPat lp@(L _ pat@(WildPat typ)) = do typ' <- tidyType typ - addExprInfo span (Just typ') "WildPat" (patSort pat) + addExprInfo (getLocA lp) (Just typ') "WildPat" (patSort pat) return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(LazyPat _ pat)) = do -#else -foldLPat (L span p@(LazyPat pat)) = do -#endif +foldLPat lp@(L _ p@(LazyPat _ pat)) = do mbType <- foldLPat pat - addExprInfo span mbType "LazyPat" (patSort p) + addExprInfo (getLocA lp) mbType "LazyPat" (patSort p) return mbType -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(AsPat _ (L idSpan identifier) pat)) = do -#else -foldLPat (L span p@(AsPat (L idSpan identifier) pat)) = do -#endif +foldLPat lp@(L _ p@(AsPat _ id@(L _ identifier) pat)) = do (identifier', _) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap idSpan identifier' Nothing - addExprInfo span (Just . varType $ identifier') "AsPat" (patSort p) + addIdentifierToIdSrcSpanMap (getLocA id) identifier' Nothing + addExprInfo (getLocA lp) (Just . varType $ identifier') "AsPat" (patSort p) _ <- foldLPat pat return . Just . varType $ identifier' #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L _span (ParPat _ pat)) = foldLPat pat +foldLPat (L _span (ParPat _ pat)) = foldLPat pat #else -foldLPat (ghcDL -> L _span (ParPat pat)) = foldLPat pat +foldLPat (L _span (ParPat pat)) = foldLPat pat #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(BangPat _ pat)) = do +foldLPat lp@(L _ p@(BangPat _ pat)) = do #else -foldLPat (L span p@(BangPat pat)) = do +foldLPat lp@(L _ p@(BangPat pat)) = do #endif typ <- foldLPat pat - addExprInfo span typ "BangPat" (patSort p) + addExprInfo (getLocA lp) typ "BangPat" (patSort p) return typ #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(ListPat (ListPatTc typ _) pats)) = do +foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do #else -foldLPat (L span p@(ListPat pats typ _)) = do +foldLPat lp@(L _ p@(ListPat pats typ _)) = do #endif typ' <- tidyType typ let listType = mkListTy typ' - addExprInfo span (Just listType) "ListPat" (patSort p) + addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p) mapM_ foldLPat pats return $ Just listType #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span pat@(TuplePat types pats boxity)) = do +foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do #else -foldLPat (L span pat@(TuplePat pats boxity types)) = do +foldLPat lp@(L _ pat@(TuplePat pats boxity types)) = do #endif typ' <- tidyType $ mkTupleTy boxity types - addExprInfo span (Just typ') "TuplePat" (patSort pat) + addExprInfo (getLocA lp) (Just typ') "TuplePat" (patSort pat) mapM_ foldLPat pats return $ Just typ' #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L _span (SumPat _ pat _ _)) = do +foldLPat (L _span (SumPat _ pat _ _)) = do #else foldLPat (L _span (SumPat pat _ _ _types)) = do #endif @@ -1522,80 +1342,73 @@ foldLPat (L _span (SumPat pat _ _ _types)) = do #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) #else -foldLPat (L span pat@(PArrPat pats typ)) = do +foldLPat lp@(L _ pat@(PArrPat pats typ)) = do typ' <- tidyType typ - addExprInfo span (Just typ') "PArrPat" (patSort pat) + addExprInfo (getLocA lp) (Just typ') "PArrPat" (patSort pat) mapM_ foldLPat pats return $ Just typ' #endif -- no more conpatin / conpatout, just conpat -- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing -foldLPat (ghcDL -> L span pat@ConPat {..}) = 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 idSpan identifier' mbTypes - typ' <- tidyType typ - addExprInfo span (Just typ') "ConPat" (patSort pat) - _ <- foldHsConPatDetails pat_args - return . Just . varType $ identifier' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(ViewPat typ expr pat)) = do -#else -foldLPat (ghcDL -> L span p@(ViewPat expr pat typ)) = do -#endif +-- TODO: FIXME +-- foldLPat (ghcDL -> cp@lp@(L _ pat@ConPat {..})) = do +-- let pc@(L _ 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 +-- typ' <- tidyType typ +-- addExprInfo (getLocA cp) (Just typ') "ConPat" (patSort pat) +-- _ <- foldHsConPatDetails pat_args +-- return . Just . varType $ identifier' +foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do typ' <- tidyType typ - addExprInfo span (Just typ') "ViewPat" (patSort p) + addExprInfo (getLocA lp) (Just typ') "ViewPat" (patSort p) _ <- foldLPat pat _ <- foldLHsExpr expr return $ Just typ' -foldLPat (ghcDL -> L _ SplicePat {}) = return Nothing +foldLPat (L _ SplicePat {}) = return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span (LitPat _ hsLit)) = do +foldLPat lp@(L _ (LitPat _ hsLit)) = do #else -foldLPat (L span (LitPat hsLit)) = do +foldLPat lp@(L _ (LitPat hsLit)) = do #endif typ' <- tidyType $ hsLitType hsLit addExprInfo - span + (getLocA lp) (Just typ') "LitPat" - (if isOneLineSpan span + (if isOneLineSpan (getLocA lp) then Simple else Composite) return $ Just typ' #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do +foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do #else -foldLPat (L span pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do +foldLPat lp@(L _ pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do #endif typ' <- tidyType ol_type - addExprInfo span (Just typ') "NPat" (patSort pat) + addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat) return $ Just ol_type -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span pat@(NPlusKPat typ (L idSpan identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do -#else -foldLPat (L span pat@(NPlusKPat (L idSpan identifier) (L litSpan OverLit {ol_type}) _ _ _ typ)) = do -#endif +foldLPat lp@(L _ pat@(NPlusKPat typ id@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do (identifier', _) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap idSpan identifier' Nothing + addIdentifierToIdSrcSpanMap (getLocA id) identifier' Nothing typ' <- tidyType typ - addExprInfo span (Just typ') "NPlusKPat" (patSort pat) + addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat) olType' <- tidyType ol_type addExprInfo litSpan (Just olType') "NPlusKPat" - (if isOneLineSpan span + (if isOneLineSpan (getLocA lp) then Simple else Composite) return $ Just typ' #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -foldLPat (ghcDL -> L _span (SigPat typ pat _)) = do +foldLPat (L _span (SigPat typ pat _)) = do typ' <- tidyType typ _ <- foldLPat pat return $ Just typ' @@ -1611,22 +1424,15 @@ foldLPat (L _span (SigPatOut pat typ)) = do _ <- foldLPat pat return $ Just typ' #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (ghcDL -> L span p@(CoPat _ _ pat typ)) = do -#else -foldLPat (L span p@(CoPat _ pat typ)) = do -#endif - typ' <- tidyType typ - addExprInfo span (Just typ') "CoPat" (patSort p) -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) - _ <- foldLPat (cL span pat) -#else - _ <- foldLPat (L span pat) -#endif - return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) +-- 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 -#endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsConPatDetails @@ -1637,7 +1443,7 @@ foldHsConPatDetails :: HsConPatDetails Id -> State ASTState (Maybe Type) #endif -foldHsConPatDetails (PrefixCon args) = do +foldHsConPatDetails (PrefixCon _ args) = do mapM_ foldLPat args return Nothing foldHsConPatDetails (RecCon rec) = do @@ -1656,7 +1462,7 @@ foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type) foldHsRecFieldsPat HsRecFields {..} = do let onlyUserWritten = case rec_dotdot of - Just i -> take i + Just i -> take $ unLoc i Nothing -> id mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds return Nothing @@ -1666,18 +1472,12 @@ foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Ty #else foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type) #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc identifier _)) arg pun)) = do -#else -foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = do -#endif +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' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsRecFieldPat (L _ (HsRecField (L _idSpan (XFieldOcc _)) _arg _pun)) = return Nothing -#endif +foldLHsRecFieldPat (L _ (HsRecField _ (L _idSpan (XFieldOcc _)) _arg _pun)) = return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) @@ -1761,11 +1561,7 @@ foldLHsCmd (L _ (HsCmdIf _ expr cmd1 cmd2)) = do _ <- foldLHsCmd cmd2 _ <- foldLHsExpr expr return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsCmd (L _ (HsCmdLet _ (L _ binds) cmd)) = do -#else -foldLHsCmd (L _ (HsCmdLet (L _ binds) cmd)) = do -#endif +foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do _ <- foldLHsCmd cmd _ <- foldHsLocalBindsLR binds return Nothing |