From 069ae2042ed716211fba513b8243fb7950a19bbf Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Wed, 8 Jun 2022 23:29:46 +1000 Subject: removed all CPP macros, and formatted code with brittany --- src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 1419 ++++++++++------------ 1 file changed, 640 insertions(+), 779 deletions(-) (limited to 'src/HaskellCodeExplorer/AST/TypecheckedSource.hs') diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index d31634c..22911df 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -19,142 +18,157 @@ module HaskellCodeExplorer.AST.TypecheckedSource , removeOverlappingInterval ) where -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) -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 (fromMaybe, mapMaybe) -import qualified Data.Set as S -import qualified Data.Text as T -import GHC.Core.Multiplicity (scaledThing) -import GHC - ( DynFlags - , TyThing(..) - , getLocA - , reLocA - , reLocN - , SrcLoc(..) - , srcSpanStart - , srcSpanEnd - ) -import GHC.Data.FastString - ( mkFastString - , FastString - , unpackFS - ) -import GHC.Unit.State (UnitState) -import GHC.Utils.Misc (thenCmp) -import HaskellCodeExplorer.GhcUtils -import qualified HaskellCodeExplorer.Types as HCE -import GHC.Hs.Binds (RecordPatSynField(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else - , HsPatSynDetails (..) -#endif - ) -import GHC.Hs - ( ABExport(..) - , ApplicativeArg(..) - , ArithSeqInfo(..) - , FieldOcc(..) - , GRHS(..) - , GRHSs(..) - , HsBindLR(..) - , HsCmd(..) - , HsCmdTop(..) - , HsConDetails(..) - , HsExpr(..) - , HsLocalBindsLR(..) - , HsOverLit(..) - , HsPragE(..) - , HsRecField'(..) - , HsRecFields(..) - , HsTupArg(..) - , HsValBindsLR(..) - , HsValBindsLR(..) - , LGRHS - , LHsBindLR - , LHsBinds - , LHsCmd - , LHsCmd - , LHsCmdTop - , LHsExpr - , LHsRecField - , LHsRecUpdField - , LMatch - , LPat - , LStmtLR - , Match(..) - , Match(..) - , MatchGroup(..) - , ParStmtBlock(..) - , Pat(..) - , PatSynBind(..) - , StmtLR(..) - , selectorAmbiguousFieldOcc - , RecordUpdTc (..) - , ListPatTc (..) - , OverLitTc (..) - , MatchGroupTc (..) - , NHsValBindsLR (..) - ) -import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -import GHC.Hs.Extension (GhcTc) -import GHC.Types.Id (idType) -import GHC.Types.Id.Info (IdDetails(..)) -import GHC.Core.InstEnv - ( ClsInst(..) - , InstEnvs - , instanceSig - , is_dfun - , lookupUniqueInstEnv - ) -import GHC.Types.Name (Name, nameOccName, nameUnique) -import Prelude hiding (span) -import GHC.Types.SrcLoc - ( GenLocated(..) - , SrcSpan(..) - , isGoodSrcSpan - , UnhelpfulSpanReason(..) - , isOneLineSpan - , unLoc - ) -import GHC.Tc.Types.Evidence (HsWrapper(..)) -import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType) -import GHC.Core.Predicate (getClassPredTys_maybe) -import GHC.Core.Type - ( Type - , nonDetCmpTypes - , eqTypes - , eqType - , mkVisFunTys - , mkVisFunTyMany - , mkVisFunTysMany - , splitForAllTyCoVars - , splitFunTy_maybe - , splitFunTys - , substTys - , tidyOpenType - , zipTvSubst - ) -import GHC.Builtin.Types (mkListTy, mkTupleTy) -import GHC.Types.Unique (getKey) -import GHC.Types.Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType) -import GHC.Types.Var.Env (TidyEnv) +import Control.Monad ( unless + , void + , when + ) +import Control.Monad.State.Strict ( State + , get + , modify' + ) +import Data.Either ( fromLeft + , isLeft + ) +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 ( fromMaybe + , mapMaybe + ) +import qualified Data.Set as S +import qualified Data.Text as T +import GHC ( DynFlags + , SrcLoc(..) + , TyThing(..) + , getLocA + , reLocA + , reLocN + , srcSpanEnd + , srcSpanStart + ) +import GHC.Builtin.Types ( mkListTy + , mkTupleTy + ) +import GHC.Core.Class ( Class + , classTyVars + ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.DataCon ( dataConRepType ) +import GHC.Core.InstEnv ( ClsInst(..) + , InstEnvs + , instanceSig + , is_dfun + , lookupUniqueInstEnv + ) +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.PatSyn ( patSynBuilder ) +import GHC.Core.Predicate ( getClassPredTys_maybe ) +import GHC.Core.Type ( Type + , eqType + , eqTypes + , mkVisFunTyMany + , mkVisFunTys + , mkVisFunTysMany + , nonDetCmpTypes + , splitForAllTyCoVars + , splitFunTy_maybe + , splitFunTys + , substTys + , tidyOpenType + , zipTvSubst + ) +import GHC.Data.Bag ( bagToList ) +import GHC.Data.FastString ( FastString + , mkFastString + , unpackFS + ) +import GHC.Hs ( ABExport(..) + , ApplicativeArg(..) + , ArithSeqInfo(..) + , FieldOcc(..) + , GRHS(..) + , GRHSs(..) + , HsBindLR(..) + , HsCmd(..) + , HsCmdTop(..) + , HsConDetails(..) + , HsExpr(..) + , HsLocalBindsLR(..) + , HsOverLit(..) + , HsPragE(..) + , HsRecField'(..) + , HsRecFields(..) + , HsTupArg(..) + , HsValBindsLR(..) + , LGRHS + , LHsBindLR + , LHsBinds + , LHsCmd + , LHsCmdTop + , LHsExpr + , LHsRecField + , LHsRecUpdField + , LMatch + , LPat + , LStmtLR + , ListPatTc(..) + , Match(..) + , MatchGroup(..) + , MatchGroupTc(..) + , NHsValBindsLR(..) + , OverLitTc(..) + , ParStmtBlock(..) + , Pat(..) + , PatSynBind(..) + , RecordUpdTc(..) + , StmtLR(..) + , selectorAmbiguousFieldOcc + ) +import GHC.Hs.Binds ( RecordPatSynField(..) ) +import GHC.Hs.Extension ( GhcTc ) +import GHC.Tc.Types.Evidence ( HsWrapper(..) ) +import GHC.Tc.Utils.Zonk ( conLikeResTy + , hsLitType + ) +import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.Id ( idType ) +import GHC.Types.Id.Info ( IdDetails(..) ) +import GHC.Types.Name ( Name + , nameOccName + , nameUnique + ) +import GHC.Types.SrcLoc ( GenLocated(..) + , SrcSpan(..) + , UnhelpfulSpanReason(..) + , isGoodSrcSpan + , isOneLineSpan + , unLoc + ) +import GHC.Types.TypeEnv ( TypeEnv + , lookupTypeEnv + ) +import GHC.Types.Unique ( getKey ) +import GHC.Types.Var ( Id + , Var + , idDetails + , isId + , setVarName + , setVarType + , varName + , varType + ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Unit.State ( UnitState ) +import GHC.Utils.Misc ( thenCmp ) +import HaskellCodeExplorer.GhcUtils +import qualified HaskellCodeExplorer.Types as HCE +import Prelude hiding ( span ) data ASTState = ASTState - { astStateExprInfoMap :: !HCE.ExpressionInfoMap + { astStateExprInfoMap :: !HCE.ExpressionInfoMap -- ^ Type of each expression - , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap + , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap -- ^ Each occurrence of an identifier in a source code , astStateIdSrcSpanMap :: !(M.Map SrcSpan (Var, Maybe (Type, [Type]))) -- ^ Intermediate data structure that is used to populate 'IdentifierOccurrenceMap' @@ -162,38 +176,42 @@ data ASTState = ASTState -- 'SrcSpan' - location of an identifier in a source code -- 'Type' - 'expected' type of an identifier -- '[Type]' - types at which type variables are instantiated - , astStateTidyEnv :: !TidyEnv + , astStateTidyEnv :: !TidyEnv -- ^ 'TidyEnv' is used to prevent name clashes of free type variables. -- ('TidyEnv' contains all free type variables in scope) - , astStateHsWrapper :: !(Maybe HsWrapper) + , astStateHsWrapper :: !(Maybe HsWrapper) -- ^ HsWrapper comes from 'HsWrap' constructor of 'HsExpr' datatype. - , astStateEnv :: !Environment + , astStateEnv :: !Environment -- ^ 'Environment' doesn't change - , astStateTypeErrors :: [TypeError] + , astStateTypeErrors :: [TypeError] -- ^ Non-empty list of TypeError's indicates that most likely there is a bug in -- a fold_something function in this module. } -- | A 'TypeError' means that an assumption about a type of an AST node is incorrect. data TypeError = TypeError - { typeErrorSrcSpan :: SrcSpan - , typeErrorMessage :: T.Text + { typeErrorSrcSpan :: SrcSpan + , typeErrorMessage :: T.Text , typeErrorASTNodeName :: T.Text - } deriving (Show, Eq) + } + deriving (Show, Eq) data Environment = Environment - { envDynFlags :: DynFlags - , envUnitState :: UnitState - , envTypeEnv :: TypeEnv - , envInstEnv :: InstEnvs - , envTransformation :: HCE.SourceCodeTransformation - , envPackageId :: HCE.PackageId + { envDynFlags :: DynFlags + , envUnitState :: UnitState + , envTypeEnv :: TypeEnv + , envInstEnv :: InstEnvs + , envTransformation :: HCE.SourceCodeTransformation + , envPackageId :: HCE.PackageId , envCurrentModuleDefSites :: HCE.DefinitionSiteMap , envFileMap :: HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath , envDefSiteMap :: HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap - , envModuleNameMap :: HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) + , envModuleNameMap + :: HM.HashMap + HCE.HaskellModuleName + (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) , envExportedNames :: S.Set Name - , envComponentId :: HCE.ComponentId + , envComponentId :: HCE.ComponentId } -- | Indicates whether an expression consists of more than one token. @@ -205,55 +223,49 @@ data ExprSort deriving (Show, Eq) exprSort :: HsExpr a -> ExprSort -exprSort HsVar {} = Simple -exprSort HsIPVar {} = Simple -exprSort HsOverLit {} = Simple -exprSort HsLit {} = Simple +exprSort HsVar{} = Simple +exprSort HsIPVar{} = Simple +exprSort HsOverLit{} = Simple +exprSort HsLit{} = Simple -exprSort (ExplicitTuple _ args _) - | null args = Simple - | otherwise = Composite -exprSort (ExplicitList _ args) - | null args = Simple - | otherwise = Composite +exprSort (ExplicitTuple _ args _) | null args = Simple + | otherwise = Composite +exprSort (ExplicitList _ args) | null args = Simple + | otherwise = Composite exprSort _ = Composite patSort :: Pat a -> ExprSort -patSort WildPat {} = Simple -patSort LitPat {} = Simple -patSort NPat {} = Simple -patSort (ListPat _ pats) - | null pats = Simple - | otherwise = Composite -patSort (TuplePat _ pats _) - | null pats = Simple - | otherwise = Composite +patSort WildPat{} = Simple +patSort LitPat{} = Simple +patSort NPat{} = Simple +patSort (ListPat _ pats) | null pats = Simple + | otherwise = Composite +patSort (TuplePat _ pats _) | null pats = Simple + | otherwise = Composite patSort _ = Composite -- | Splits a type of a function, adds 'TypeError' to 'ASTState' -- in case of failure. -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) - Nothing -> do - flags <- envDynFlags . astStateEnv <$> get - let typeError = - TypeError - { typeErrorSrcSpan = srcSpan - , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ - , typeErrorASTNodeName = astNode - } - modify' - (\st -> st {astStateTypeErrors = typeError : astStateTypeErrors st}) - return Nothing +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) + Nothing -> do + flags <- envDynFlags . astStateEnv <$> get + let typeError = TypeError + { typeErrorSrcSpan = srcSpan + , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ + , typeErrorASTNodeName = astNode + } + modify' + (\st -> st { astStateTypeErrors = typeError : astStateTypeErrors st }) + return Nothing -- | Splits a type of a function of two arguments, adds -- 'TypeError' to 'ASTState' in case of a failure. -splitFunTy2Safe :: - SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type)) +splitFunTy2Safe + :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type)) splitFunTy2Safe srcSpan astNode typ = do tys <- splitFunTySafe srcSpan astNode typ case tys of @@ -261,7 +273,7 @@ splitFunTy2Safe srcSpan astNode typ = do res <- splitFunTySafe srcSpan astNode ty1 case res of Just (arg2, ty2) -> return $ Just (arg1, arg2, ty2) - Nothing -> return Nothing + Nothing -> return Nothing Nothing -> return Nothing -- | Returns result type of a function, adds 'TypeError' to @@ -277,7 +289,7 @@ funResultTy2Safe srcSpan astNode typ = do mbResTy1 <- funResultTySafe srcSpan astNode typ case mbResTy1 of Just resTy1 -> funResultTySafe srcSpan astNode resTy1 - Nothing -> return Nothing + Nothing -> return Nothing instance Ord FastString where a `compare` b = unpackFS a `compare` unpackFS b @@ -286,16 +298,15 @@ deriving instance () => Ord SrcLoc instance Ord SrcSpan where a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` - (srcSpanEnd a `compare` srcSpanEnd b) + (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) -addIdentifierToIdSrcSpanMap :: - SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () -addIdentifierToIdSrcSpanMap span identifier mbTypes - | isGoodSrcSpan span = - modify' $ \astState@ASTState {astStateIdSrcSpanMap = ids} -> - let ids' = M.insert span (identifier, mbTypes) ids - in astState {astStateIdSrcSpanMap = ids'} +addIdentifierToIdSrcSpanMap + :: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () +addIdentifierToIdSrcSpanMap span identifier mbTypes | isGoodSrcSpan span = + modify' $ \astState@ASTState { astStateIdSrcSpanMap = ids } -> + let ids' = M.insert span (identifier, mbTypes) ids + in astState { astStateIdSrcSpanMap = ids' } addIdentifierToIdSrcSpanMap _ _ _ = return () -- | Updates 'ExpressionInfoMap' or 'IdentifierOccurrenceMap' depending @@ -304,80 +315,76 @@ addExprInfo :: SrcSpan -> Maybe Type -> T.Text -> ExprSort -> State ASTState () addExprInfo span mbType descr sort = do transformation <- envTransformation . astStateEnv <$> get case srcSpanToLineAndColNumbers transformation span of - Just (_file,(startLine, startCol), (endLine, endCol)) -> do - flags <- envDynFlags . astStateEnv <$> get + Just (_file, (startLine, startCol), (endLine, endCol)) -> do + flags <- envDynFlags . astStateEnv <$> get mbHsWrapper <- astStateHsWrapper <$> get - modify' $ \astState@ASTState {astStateExprInfoMap = exprInfoMap} -> + modify' $ \astState@ASTState { astStateExprInfoMap = exprInfoMap } -> case sort of Composite -> - let exprInfo = - HCE.ExpressionInfo - {exprType = mkType flags <$> mbType, description = descr} + let exprInfo = HCE.ExpressionInfo + { exprType = mkType flags <$> mbType + , description = descr + } interval = IVM.OpenInterval (startLine, startCol) (endLine, endCol) exprInfoMap' = IVM.insert interval exprInfo exprInfoMap - in astState {astStateExprInfoMap = exprInfoMap'} + in astState { astStateExprInfoMap = exprInfoMap' } Simple -> - let idOcc = - HCE.IdentifierOccurrence - { internalId = Nothing - , internalIdFromRenamedSource = Nothing - , isBinder = False - , instanceResolution = Nothing - , idOccType = - case mbHsWrapper of - Just w -> mkType flags <$> (applyWrapper w <$> mbType) - Nothing -> mkType flags <$> mbType - , typeArguments = Nothing - , description = descr - , sort = HCE.ValueId - } - idOccMap = - IM.insertWith - removeOverlappingInterval - startLine - [((startCol, endCol), idOcc)] - (astStateIdOccMap astState) - in astState {astStateIdOccMap = idOccMap} + let + idOcc = HCE.IdentifierOccurrence + { internalId = Nothing + , internalIdFromRenamedSource = Nothing + , isBinder = False + , instanceResolution = Nothing + , idOccType = case mbHsWrapper of + Just w -> + mkType flags <$> (applyWrapper w <$> mbType) + Nothing -> mkType flags <$> mbType + , typeArguments = Nothing + , description = descr + , sort = HCE.ValueId + } + idOccMap = IM.insertWith removeOverlappingInterval + startLine + [((startCol, endCol), idOcc)] + (astStateIdOccMap astState) + in + astState { astStateIdOccMap = idOccMap } Nothing -> return () -- | Finds the first interval that overlaps with a new interval -- and adds the smaller one of the two to the list. If there are no overlapping -- intervals then this function adds a new interval to the list. -removeOverlappingInterval :: - forall a. [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)] -removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals = - go intervals False - where - go :: - [((Int, Int), a)] - -> Bool -- If an overlapping interval is found - -> [((Int, Int), a)] - go (i:is) True = i : go is True - -- Current interval is inside new interval - go (interval@((s, e), _val):is) False - | newStart <= s && newEnd >= e = interval : go is True - -- New interval is inside current interval - go (((s, e), _val):is) False - | newStart >= s && newEnd <= e = newInterval : go is True - -- Intervals partially overlap - go (interval@((s, e), _val):is) False - | newStart >= s && newEnd >= e && newStart < e = - (if e - s >= newEnd - newStart - then newInterval - else interval) : - go is True - -- Intervals partially overlap - go (interval@((s, e), _val):is) False - | newStart <= s && newEnd <= e && newEnd > s = - (if e - s >= newEnd - newStart - then newInterval - else interval) : - go is True - -- Intervals don't overlap - go (interval:is) False = interval : go is False - go [] True = [] - go [] False = [newInterval] +removeOverlappingInterval + :: forall a . [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)] +removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals + = go intervals False + where + go + :: [((Int, Int), a)] + -> Bool -- If an overlapping interval is found + -> [((Int, Int), a)] + go (i : is) True = i : go is True + -- Current interval is inside new interval + go (interval@((s, e), _val) : is) False | newStart <= s && newEnd >= e = + interval : go is True + -- New interval is inside current interval + go (((s, e), _val) : is) False | newStart >= s && newEnd <= e = + newInterval : go is True + -- Intervals partially overlap + go (interval@((s, e), _val) : is) False + | newStart >= s && newEnd >= e && newStart < e + = (if e - s >= newEnd - newStart then newInterval else interval) + : go is True + -- Intervals partially overlap + go (interval@((s, e), _val) : is) False + | newStart <= s && newEnd <= e && newEnd > s + = (if e - s >= newEnd - newStart then newInterval else interval) + : go is True + -- Intervals don't overlap + go (interval : is) False = interval : go is False + go [] True = [] + go [] False = [newInterval] removeOverlappingInterval _ intervals = intervals newtype InstTypes = InstTypes [Type] @@ -386,207 +393,197 @@ instance Eq InstTypes where (==) (InstTypes ts1) (InstTypes ts2) = eqTypes ts1 ts2 instance Ord InstTypes where -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) compare (InstTypes ts1) (InstTypes ts2) = nonDetCmpTypes ts1 ts2 -#else - compare (InstTypes ts1) (InstTypes ts2) = cmpTypes ts1 ts2 -#endif -- | Creates an instance resolution tree -traceInstanceResolution :: - Environment +traceInstanceResolution + :: Environment -> Class -> [Type] -- ^ Types at which type variables of a class are instantated -> HCE.InstanceResolution 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 - in case lookupUniqueInstEnv - (envInstEnv environment) - cls - (take clsTyVarCount types) of - Right (inst, instTypes) -> - -- A successful match is a ClsInst, together with the types at which - -- the dfun_id in the ClsInst should be instantiated - let instWithTypes = (is_dfun_name inst, InstTypes instTypes) - in if not $ S.member instWithTypes seenInstances - then let (typeVars, predTypes, _class, _types) = - instanceSig inst - subst = zipTvSubst typeVars instTypes - constraints = - mapMaybe getClassPredTys_maybe . substTys subst $ - predTypes - in HCE.Instance - (instanceToText flags inst) - (mkType flags . idType $ is_dfun inst) - (map (mkType flags) instTypes) - (nameLocationInfo - unitState - (envPackageId environment) - (envComponentId environment) - (envTransformation environment) - (envFileMap environment) - (envDefSiteMap environment) - (Just . instanceToText flags $ inst) - Nothing - (varName . is_dfun $ inst)) - (map - (\(cl, tys) -> - go - cl - tys - (S.insert instWithTypes seenInstances)) - constraints) - else HCE.Stop - Left _ -> HCE.Stop + 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 + in + case + lookupUniqueInstEnv (envInstEnv environment) + cls + (take clsTyVarCount types) + of + Right (inst, instTypes) -> + -- A successful match is a ClsInst, together with the types at which + -- the dfun_id in the ClsInst should be instantiated + let instWithTypes = (is_dfun_name inst, InstTypes instTypes) + in + if not $ S.member instWithTypes seenInstances + then + let + (typeVars, predTypes, _class, _types) = instanceSig inst + subst = zipTvSubst typeVars instTypes + constraints = + mapMaybe getClassPredTys_maybe . substTys subst $ predTypes + in + HCE.Instance + (instanceToText flags inst) + (mkType flags . idType $ is_dfun inst) + (map (mkType flags) instTypes) + (nameLocationInfo unitState + (envPackageId environment) + (envComponentId environment) + (envTransformation environment) + (envFileMap environment) + (envDefSiteMap environment) + (Just . instanceToText flags $ inst) + Nothing + (varName . is_dfun $ inst) + ) + (map + (\(cl, tys) -> + go cl tys (S.insert instWithTypes seenInstances) + ) + constraints + ) + else HCE.Stop + Left _ -> HCE.Stop mkIdentifierInfo :: Environment -> Id -> Maybe Name -> HCE.IdentifierInfo mkIdentifierInfo environment identifier mbNameFromRenamedSource = - let name = fromMaybe (varName identifier) mbNameFromRenamedSource - sort = nameSort name - nameSpace = occNameNameSpace . nameOccName $ name - flags = envDynFlags environment - unitState = envUnitState environment + let name = fromMaybe (varName identifier) mbNameFromRenamedSource + sort = nameSort name + nameSpace = occNameNameSpace . nameOccName $ name + flags = envDynFlags environment + unitState = envUnitState environment currentPackageId = envPackageId environment - compId = envComponentId environment - transformation = envTransformation environment - fileMap = envFileMap environment - defSiteMap = envDefSiteMap environment - locationInfo = - nameLocationInfo - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap - Nothing - Nothing - name - in HCE.IdentifierInfo - { sort = sort - , occName = HCE.OccName $ nameToText name + compId = envComponentId environment + transformation = envTransformation environment + fileMap = envFileMap environment + defSiteMap = envDefSiteMap environment + locationInfo = nameLocationInfo unitState + currentPackageId + compId + transformation + fileMap + defSiteMap + Nothing + Nothing + name + in HCE.IdentifierInfo + { sort = sort + , occName = HCE.OccName $ nameToText name , demangledOccName = demangleOccName name - , nameSpace = nameSpace - , idType = mkType flags $ varType identifier - , locationInfo = locationInfo - , details = mbIdDetails identifier - , doc = - nameDocumentation - transformation - fileMap - defSiteMap - (envCurrentModuleDefSites environment) - name - , internalId = HCE.InternalId $ identifierKey flags identifier - , externalId = - case sort of - HCE.External -> - case locationInfo of - HCE.ExactLocation {..} -> - Just $ - HCE.ExternalId $ - T.intercalate - "|" - [ HCE.packageIdToText currentPackageId - , HCE.getHaskellModuleName moduleName - , case nameSpace of - HCE.VarName -> T.pack $ show HCE.Val - HCE.DataName -> T.pack $ show HCE.Val - _ -> T.pack $ show HCE.Typ - , nameToText name - ] - HCE.ApproximateLocation {name = n, ..} -> - Just $ - HCE.ExternalId $ - T.intercalate - "|" - [ HCE.packageIdToText packageId - , HCE.getHaskellModuleName moduleName - , T.pack $ show entity - , n - ] - _ -> Nothing - _ -> Nothing - , isExported = S.member name $ envExportedNames environment + , nameSpace = nameSpace + , idType = mkType flags $ varType identifier + , locationInfo = locationInfo + , details = mbIdDetails identifier + , doc = nameDocumentation transformation + fileMap + defSiteMap + (envCurrentModuleDefSites environment) + name + , internalId = HCE.InternalId $ identifierKey flags identifier + , externalId = case sort of + HCE.External -> case locationInfo of + HCE.ExactLocation {..} -> + Just $ HCE.ExternalId $ T.intercalate + "|" + [ HCE.packageIdToText currentPackageId + , HCE.getHaskellModuleName moduleName + , case nameSpace of + HCE.VarName -> T.pack $ show HCE.Val + HCE.DataName -> T.pack $ show HCE.Val + _ -> T.pack $ show HCE.Typ + , nameToText name + ] + HCE.ApproximateLocation { name = n, ..} -> + Just $ HCE.ExternalId $ T.intercalate + "|" + [ HCE.packageIdToText packageId + , HCE.getHaskellModuleName moduleName + , T.pack $ show entity + , n + ] + _ -> Nothing + _ -> Nothing + , isExported = S.member name $ envExportedNames environment } -mkIdentifierOccurrence :: - Environment +mkIdentifierOccurrence + :: Environment -> Id -> Name -> Maybe (Type, [Type]) -> Bool -> T.Text -> HCE.IdentifierOccurrence -mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr = - let flags = envDynFlags environment - mbClass - | isId identifier = - case idDetails identifier of +mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr + = let flags = envDynFlags environment + mbClass + | isId identifier = case idDetails identifier of ClassOpId cls -> Just cls - _ -> Nothing - | otherwise = Nothing - mbInstanceResolution = - case (mbClass, mbInstTypes) of + _ -> Nothing + | otherwise = Nothing + mbInstanceResolution = case (mbClass, mbInstTypes) of (Just cls, Just (_, ts)) -> Just $ traceInstanceResolution environment cls ts _ -> Nothing - in HCE.IdentifierOccurrence - (Just . HCE.InternalId . identifierKey flags $ identifier) - (Just . HCE.InternalId . T.pack . show . getKey . nameUnique $ nameFromRenamedSource) - isBinder - mbInstanceResolution - (mkType flags . fst <$> mbInstTypes) - (map (mkType flags) . snd <$> mbInstTypes) - descr - (if isId identifier - then HCE.ValueId - else HCE.TypeId) + in HCE.IdentifierOccurrence + (Just . HCE.InternalId . identifierKey flags $ identifier) + ( Just + . HCE.InternalId + . T.pack + . show + . getKey + . nameUnique + $ nameFromRenamedSource + ) + isBinder + mbInstanceResolution + (mkType flags . fst <$> mbInstTypes) + (map (mkType flags) . snd <$> mbInstTypes) + descr + (if isId identifier then HCE.ValueId else HCE.TypeId) restoreTidyEnv :: (State ASTState) a -> (State ASTState) a restoreTidyEnv action = do tidyEnv <- astStateTidyEnv <$> get - res <- action - modify' $ \s -> s {astStateTidyEnv = tidyEnv} + res <- action + modify' $ \s -> s { astStateTidyEnv = tidyEnv } return res tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type])) tidyIdentifier identifier = do - tidyEnv <- astStateTidyEnv <$> get + tidyEnv <- astStateTidyEnv <$> get mbHsWrapper <- astStateHsWrapper <$> get - let (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier - identifierType = varType identifier' - (mbTypes, updatedEnv) = - case mbHsWrapper of - Just wrapper -> - let expectedType = applyWrapper wrapper identifierType - (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType - wrapperTys = - map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper) - in if not $ eqType expectedType identifierType - then (Just (expectedType', wrapperTys), tidyEnv'') - else (Nothing, tidyEnv') - Nothing -> (Nothing, tidyEnv') - modify' (\s -> s {astStateTidyEnv = updatedEnv}) + let + (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier + identifierType = varType identifier' + (mbTypes, updatedEnv) = case mbHsWrapper of + Just wrapper -> + let + expectedType = applyWrapper wrapper identifierType + (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType + wrapperTys = + map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper) + in + if not $ eqType expectedType identifierType + then (Just (expectedType', wrapperTys), tidyEnv'') + else (Nothing, tidyEnv') + Nothing -> (Nothing, tidyEnv') + modify' (\s -> s { astStateTidyEnv = updatedEnv }) return (identifier', mbTypes) tidyType :: Type -> State ASTState Type tidyType typ = do tidyEnv <- astStateTidyEnv <$> get let (tidyEnv', typ') = tidyOpenType tidyEnv typ - modify' (\s -> s {astStateTidyEnv = tidyEnv'}) + modify' (\s -> s { astStateTidyEnv = tidyEnv' }) return typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState () -#else -foldTypecheckedSource :: LHsBinds Id -> State ASTState () -#endif foldTypecheckedSource = foldLHsBindsLR -- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:606:1: warning: [-Wincomplete-patterns] @@ -596,48 +593,39 @@ 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 - (identifier', mbTypes) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes - return . Just . varType $ identifier' -foldLHsExpr (L _ HsUnboundVar {}) = return Nothing +foldLHsExpr ( L _span (XExpr _ )) = return Nothing +foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do + (identifier', mbTypes) <- tidyIdentifier identifier + addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes + return . Just . varType $ identifier' +foldLHsExpr (L _ HsUnboundVar{} ) = 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 +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 addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr) return Nothing foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) = restoreTidyEnv $ do typ <- tidyType ol_type - addExprInfo - (getLocA lhe) - (Just typ) - "HsOverLit" - (if isOneLineSpan (getLocA lhe) - then Simple - else Composite) - return $ Just typ -foldLHsExpr lhe@(L _ (HsLit _ lit)) = - restoreTidyEnv $ do - typ <- tidyType $ hsLitType lit - addExprInfo - (getLocA lhe) - (Just typ) - "HsLit" - (if isOneLineSpan (getLocA lhe) - then Simple - else Composite) + addExprInfo (getLocA lhe) + (Just typ) + "HsOverLit" + (if isOneLineSpan (getLocA lhe) then Simple else Composite) return $ Just typ +foldLHsExpr lhe@(L _ (HsLit _ lit)) = restoreTidyEnv $ do + typ <- tidyType $ hsLitType lit + addExprInfo (getLocA lhe) + (Just typ) + "HsLit" + (if isOneLineSpan (getLocA lhe) then Simple else Composite) + return $ Just typ foldLHsExpr lhe@(L _ expr@(HsLam _ (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty @@ -651,97 +639,90 @@ foldLHsExpr lhe@(L _ expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) = mapM_ foldLMatch $ unLoc mg_alts return $ Just typ foldLHsExpr lhe@(L _ expr@(HsApp _ fun arg)) = do - funTy <- foldLHsExpr fun + funTy <- foldLHsExpr fun _argTy <- foldLHsExpr arg - typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy + typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy addExprInfo (getLocA lhe) typ "HsApp" (exprSort expr) return typ - + foldLHsExpr lhe@(L _ ex@(HsAppType _ expr _)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsAppType" (exprSort ex) return typ foldLHsExpr lhe@(L _ expr@(OpApp _ left op right)) = do opTyp <- foldLHsExpr op - typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp - _ <- foldLHsExpr left - _ <- foldLHsExpr right + typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp + _ <- foldLHsExpr left + _ <- foldLHsExpr right addExprInfo (getLocA lhe) typ "OpApp" (exprSort expr) return typ foldLHsExpr lhe@(L _ e@(NegApp _ expr _syntaxExp)) = do typ <- foldLHsExpr expr 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 -foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do - opType <- foldLHsExpr operator - _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionL") opType - let typ = - case mbTypes of - Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res - Nothing -> Nothing +foldLHsExpr ( L _span ( HsPar _ expr )) = foldLHsExpr expr +foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do + opType <- foldLHsExpr operator + _ <- foldLHsExpr operand + mbTypes <- maybe (return Nothing) + (splitFunTy2Safe (getLocA lhe) "SectionL") + opType + let typ = case mbTypes of + Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res + Nothing -> Nothing addExprInfo (getLocA lhe) typ "SectionL" (exprSort expr) return typ foldLHsExpr lhe@(L _ e@(SectionR _ operator operand)) = do - opType <- foldLHsExpr operator - _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionR") opType - let typ = - case mbTypes of - Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res - Nothing -> Nothing + opType <- foldLHsExpr operator + _ <- foldLHsExpr operand + mbTypes <- maybe (return Nothing) + (splitFunTy2Safe (getLocA lhe) "SectionR") + opType + let typ = case mbTypes of + Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res + Nothing -> Nothing addExprInfo (getLocA lhe) typ "SectionR" (exprSort e) return typ 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 = - mkVisFunTysMany <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys) + let + tupleSectionArgTys = + mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs + tupleArgTys = mapM fst tupleArgs + resultType = + mkVisFunTysMany + <$> tupleSectionArgTys + <*> (mkTupleTy boxity <$> tupleArgTys) tidyEnv <- astStateTidyEnv <$> get - addExprInfo - (getLocA lhe) - (snd . tidyOpenType tidyEnv <$> resultType) - "ExplicitTuple" - (exprSort e) + addExprInfo (getLocA lhe) + (snd . tidyOpenType tidyEnv <$> resultType) + "ExplicitTuple" + (exprSort e) return resultType -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsExpr (L _span (ExplicitSum _ _ _ expr)) = do -#else -foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do -#endif -- TODO _ <- foldLHsExpr expr return Nothing -#endif foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do typ <- tidyType mg_res_ty - _ <- foldLHsExpr expr + _ <- foldLHsExpr expr mapM_ foldLMatch (unLoc mg_alts) addExprInfo (getLocA lhe) (Just typ) "HsCase" (exprSort e) return $ Just typ foldLHsExpr lhe@(L _ e@(HsIf _ condExpr thenExpr elseExpr)) = do - _ <- foldLHsExpr condExpr + _ <- foldLHsExpr condExpr typ <- foldLHsExpr thenExpr - _ <- foldLHsExpr elseExpr + _ <- foldLHsExpr elseExpr addExprInfo (getLocA lhe) typ "HsIf" (exprSort e) return typ -foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = - restoreTidyEnv $ do - typ' <- tidyType typ - addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e) - mapM_ foldLGRHS grhss - return $ Just typ' +foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = restoreTidyEnv $ do + typ' <- tidyType typ + addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e) + mapM_ foldLGRHS grhss + return $ Just typ' foldLHsExpr lhe@(L _ e@(HsLet _ binds expr)) = do - _ <- foldHsLocalBindsLR binds + _ <- foldHsLocalBindsLR binds typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsLet" (exprSort e) return typ @@ -751,23 +732,22 @@ foldLHsExpr lhe@(L _ expr@(HsDo typ _context (L _ stmts))) = addExprInfo (getLocA lhe) (Just typ') "HsDo" (exprSort expr) mapM_ foldLStmtLR stmts return $ Just typ' -foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = - restoreTidyEnv $ do - typ' <- mkListTy <$> tidyType typ - unless (null exprs) $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite - mapM_ foldLHsExpr exprs - return $ Just typ' +foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = restoreTidyEnv $ do + typ' <- mkListTy <$> tidyType typ + unless (null exprs) + $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite + mapM_ foldLHsExpr exprs + return $ Just typ' foldLHsExpr lhe@(L _ e@(RecordCon conExpr _ binds)) = do - mbConType <- - fmap (snd . splitFunTys) <$> - foldLHsExpr - (reLocA - (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr)) - addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e) - _ <- foldHsRecFields binds - return mbConType -foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) = - restoreTidyEnv $ do + mbConType <- fmap (snd . splitFunTys) <$> foldLHsExpr + (reLocA + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr) + ) + addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e) + _ <- foldHsRecFields binds + return mbConType +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 @@ -780,29 +760,27 @@ foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do addExprInfo (getLocA lhe) typ "ExprWithTySig" (exprSort e) return typ foldLHsExpr lhe@(L _ e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do - typ <- - fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> - foldLHsExpr + typ <- fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> foldLHsExpr (reLocA - (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr)) - _ <- - case seqInfo of - From expr -> foldLHsExpr expr - FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 - FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 - FromThenTo expr1 expr2 expr3 -> - foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3 + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr) + ) + _ <- case seqInfo of + From expr -> foldLHsExpr expr + FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 + FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 + FromThenTo expr1 expr2 expr3 -> + foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3 addExprInfo (getLocA lhe) typ "ArithSeq" (exprSort e) return typ -foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do +foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC{}) expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsSCC" (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 -foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do +foldLHsExpr ( L _span HsBracket{} ) = return Nothing +foldLHsExpr ( L _span HsRnBracketOut{} ) = return Nothing +foldLHsExpr ( L _span HsTcBracketOut{} ) = return Nothing +foldLHsExpr ( L _span HsSpliceE{} ) = return Nothing +foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do _ <- foldLPat pat _ <- foldLHsCmdTop cmd addExprInfo (getLocA lhe) Nothing "HsProc" (exprSort expr) @@ -820,21 +798,25 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e) return typ -foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldHsRecFields + :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldHsRecFields HsRecFields {..} = do - let userWritten = - case rec_dotdot of - Just i -> take $ unLoc i - Nothing -> id + let userWritten = case rec_dotdot of + Just i -> take $ unLoc i + Nothing -> id mapM_ foldLHsRecField $ userWritten rec_flds return Nothing -foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = - restoreTidyEnv $ do +foldLHsRecField + :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) + = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes - addExprInfo (getLocA lhr) (Just . varType $ identifier') "HsRecField" Composite + addExprInfo (getLocA lhr) + (Just . varType $ identifier') + "HsRecField" + Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' @@ -845,15 +827,17 @@ foldLHsRecUpdField lhr@(L _ (HsRecField _ (L idSpan recField) arg pun)) = (identifier', mbTypes) <- tidyIdentifier selectorId -- Name of the selectorId is not 'correct' (Internal instead of External) : -- https://github.com/ghc/ghc/blob/321b420f4582d103ca7b304867b916a749712e9f/compiler/typecheck/TcExpr.hs#L2424 - typeEnv <- envTypeEnv . astStateEnv <$> get - let selName = varName selectorId - originalName = - case lookupTypeEnv typeEnv selName of - Just (AnId originalSelId) -> varName originalSelId - _ -> selName + typeEnv <- envTypeEnv . astStateEnv <$> get + let selName = varName selectorId + originalName = case lookupTypeEnv typeEnv selName of + Just (AnId originalSelId) -> varName originalSelId + _ -> selName let identifier'' = setVarName identifier' originalName addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes - addExprInfo (getLocA lhr) (Just . varType $ identifier'') "HsRecUpdField" Composite + addExprInfo (getLocA lhr) + (Just . varType $ identifier'') + "HsRecUpdField" + Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' @@ -863,69 +847,47 @@ data TupArg deriving (Show, Eq) foldHsTupArg :: HsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) -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) +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) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -#else -foldLMatch :: LMatch Id (LHsExpr Id) -> State ASTState (Maybe Type) -#endif foldLMatch (L _span Match {..}) = do mapM_ foldLPat m_pats _ <- foldGRHSs m_grhss return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) -#else -foldLMatchCmd :: LMatch Id (LHsCmd Id) -> State ASTState (Maybe Type) -#endif foldLMatchCmd (L _span Match {..}) = do mapM_ foldLPat m_pats _ <- foldGRHSsCmd m_grhss return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) -#else -foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type) -#endif foldGRHSsCmd GRHSs {..} = do mapM_ foldLGRHSCmd grhssGRHSs _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -#else -foldGRHSs :: GRHSs Id (LHsExpr Id) -> State ASTState (Maybe Type) -#endif foldGRHSs GRHSs {..} = do mapM_ foldLGRHS grhssGRHSs _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing -foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = - do typ <- foldLHsExpr body - addExprInfo (getLocA lst) typ "LastStmt" Composite - return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +foldLStmtLR + :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = do + typ <- foldLHsExpr body + addExprInfo (getLocA lst) typ "LastStmt" Composite + return typ foldLStmtLR (L _span (BindStmt _ pat body)) = do -#else -foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do -#endif _ <- foldLPat pat _ <- foldLHsExpr body return Nothing @@ -933,18 +895,10 @@ foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do mbTyp <- foldLHsExpr body addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite return mbTyp -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLR (L _ (LetStmt _ binds)) = do -#else -foldLStmtLR (L _ (LetStmt (L _ binds))) = do -#endif _ <- foldHsLocalBindsLR binds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLR (L _ (ParStmt _ blocks _ _)) = do -#else -foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do -#endif mapM_ foldParStmtBlock blocks return Nothing foldLStmtLR (L _ TransStmt {..}) = do @@ -955,36 +909,24 @@ foldLStmtLR (L _ TransStmt {..}) = do foldLStmtLR (L _span RecStmt {..}) = do mapM_ foldLStmtLR (unLoc recS_stmts) return Nothing -foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = - restoreTidyEnv $ do - typ' <- tidyType typ - mapM_ (foldApplicativeArg . snd) args - addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite - return Nothing +foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do + typ' <- tidyType typ + mapM_ (foldApplicativeArg . snd) args + addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite + return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldApplicativeArg :: ApplicativeArg GhcTc -> State ASTState (Maybe Type) -#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type) -#else -foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type) -#endif -foldApplicativeArg appArg = - case appArg of - ApplicativeArgOne _ pat expr _bool -> do - _ <- foldLPat pat - _ <- foldLHsExpr expr - return Nothing - ApplicativeArgMany _ exprStmts _ pat _ -> do - mapM_ foldLStmtLR exprStmts - _ <- foldLPat pat - return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -foldLStmtLRCmd :: - LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) -#else -foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type) -#endif +foldApplicativeArg appArg = case appArg of + ApplicativeArgOne _ pat expr _bool -> do + _ <- foldLPat pat + _ <- foldLHsExpr expr + return Nothing + ApplicativeArgMany _ exprStmts _ pat _ -> do + mapM_ foldLStmtLR exprStmts + _ <- foldLPat pat + return Nothing +foldLStmtLRCmd + :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) foldLStmtLRCmd ls@(L _ (LastStmt _ body _syntaxExpr _)) = do typ <- foldLHsCmd body addExprInfo (getLocA ls) typ "LastStmt Cmd" Composite @@ -1000,11 +942,7 @@ foldLStmtLRCmd ls@(L _ (BodyStmt _ body _ _)) = do foldLStmtLRCmd (L _ (LetStmt _ binds)) = do _ <- foldHsLocalBindsLR binds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLRCmd (L _ (ParStmt _ blocks _ _)) = do -#else -foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do -#endif mapM_ foldParStmtBlock blocks return Nothing foldLStmtLRCmd (L _ TransStmt {..}) = do @@ -1015,12 +953,11 @@ foldLStmtLRCmd (L _ TransStmt {..}) = do foldLStmtLRCmd (L _ RecStmt {..}) = do mapM_ foldLStmtLRCmd (unLoc recS_stmts) return Nothing -foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = - restoreTidyEnv $ do - typ' <- tidyType typ - mapM_ (foldApplicativeArg . snd) args - addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite - return Nothing +foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do + typ' <- tidyType typ + mapM_ (foldApplicativeArg . snd) args + addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite + return Nothing foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldLGRHS (L _span (GRHS _ guards body)) = do @@ -1043,88 +980,67 @@ foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) foldHsLocalBindsLR (HsValBinds _ binds) = do _ <- foldHsValBindsLR binds return Nothing -foldHsLocalBindsLR HsIPBinds {} = return Nothing -foldHsLocalBindsLR EmptyLocalBinds {} = return Nothing +foldHsLocalBindsLR HsIPBinds{} = return Nothing +foldHsLocalBindsLR EmptyLocalBinds{} = return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) -#else -foldHsValBindsLR :: HsValBindsLR Id Id -> State ASTState (Maybe Type) -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldHsValBindsLR (ValBinds _ _binds _) = do return Nothing foldHsValBindsLR (XValBindsLR (NValBinds binds _)) = do _ <- mapM_ (foldLHsBindsLR . snd) binds return Nothing -#else -foldHsValBindsLR (ValBindsIn _ _) = return Nothing -foldHsValBindsLR (ValBindsOut binds _) = do - mapM_ (foldLHsBindsLR . snd) binds - return Nothing -#endif foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState () foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList -foldLHsBindLR :: LHsBindLR GhcTc GhcTc - -> Maybe Id -- ^ Polymorphic id - -> State ASTState (Maybe Type) +foldLHsBindLR + :: LHsBindLR GhcTc GhcTc + -> Maybe Id -- ^ Polymorphic id + -> State ASTState (Maybe Type) foldLHsBindLR (L _span FunBind {..}) mbPolyId - | mg_origin fun_matches == FromSource = - restoreTidyEnv $ do - let fi@(L _ identifier) = fun_id -- monotype - typ = - case mbPolyId of - Just polyId -> varType polyId - Nothing -> varType identifier - name = maybe (varName identifier) varName mbPolyId - identifier' = setVarType (setVarName identifier name) typ - (identifier'', _) <- tidyIdentifier identifier' - addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing - mapM_ foldLMatch (unLoc (mg_alts fun_matches)) - return Nothing + | mg_origin fun_matches == FromSource = restoreTidyEnv $ do + let fi@(L _ identifier) = fun_id -- monotype + typ = case mbPolyId of + Just polyId -> varType polyId + Nothing -> varType identifier + name = maybe (varName identifier) varName mbPolyId + identifier' = setVarType (setVarName identifier name) typ + (identifier'', _) <- tidyIdentifier identifier' + addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing + mapM_ foldLMatch (unLoc (mg_alts fun_matches)) + return Nothing | otherwise = return Nothing foldLHsBindLR (L _ PatBind {..}) _ = do _ <- foldLPat pat_lhs _ <- foldGRHSs pat_rhs return Nothing -foldLHsBindLR (L _ VarBind {}) _ = return Nothing +foldLHsBindLR (L _ VarBind{} ) _ = return Nothing foldLHsBindLR (L _ AbsBinds {..}) _ = do - mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $ - zip (bagToList abs_binds) (map abe_poly abs_exports) + mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) + $ zip (bagToList abs_binds) (map abe_poly abs_exports) return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else -foldLHsBindLR (L _ AbsBindsSig {..}) _ = do - _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export) +foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = restoreTidyEnv $ do + _ <- foldLPat psb_def + _ <- + let addId :: GenLocated SrcSpan Id -> State ASTState () + addId (L span i) = do + (i', _) <- tidyIdentifier i + addIdentifierToIdSrcSpanMap span i' Nothing + in case psb_args of + InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2) + PrefixCon _ ids -> mapM_ (addId . reLocN) ids + RecCon recs -> mapM_ + (\(RecordPatSynField field patVar) -> + addId (L ((getLocA . rdrNameFieldOcc) field) (extFieldOcc field)) + >> addId (reLocN patVar) + ) + recs return Nothing -#endif -foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = - restoreTidyEnv $ do - _ <- foldLPat psb_def - _ <- - let addId :: GenLocated SrcSpan Id -> State ASTState () - addId (L span i) = do - (i', _) <- tidyIdentifier i - addIdentifierToIdSrcSpanMap span i' Nothing - in case psb_args of - InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2) - PrefixCon _ ids -> mapM_ (addId . reLocN) ids - RecCon recs -> - mapM_ - (\(RecordPatSynField field patVar) -> - addId - (L ((getLocA . rdrNameFieldOcc) field) - (extFieldOcc field)) - >> addId (reLocN patVar)) - recs - return Nothing foldLPat :: LPat GhcTc -> State ASTState (Maybe Type) -foldLPat (L _span (XPat _)) = return Nothing -foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do +foldLPat ( L _span (XPat _ )) = return Nothing +foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do (identifier', _) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap (getLocA lp) identifier' Nothing return . Just . varType $ identifier' @@ -1142,56 +1058,26 @@ foldLPat lp@(L _ p@(AsPat _ ide@(L _ identifier) pat)) = do 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 (L _span (ParPat _ pat)) = foldLPat pat -#else -foldLPat (L _span (ParPat pat)) = foldLPat pat -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat lp@(L _ p@(BangPat _ pat)) = do -#else -foldLPat lp@(L _ p@(BangPat pat)) = do -#endif +foldLPat ( L _span ( ParPat _ pat)) = foldLPat pat +foldLPat lp@(L _ p@(BangPat _ pat)) = do typ <- foldLPat pat addExprInfo (getLocA lp) typ "BangPat" (patSort p) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do -#else -foldLPat lp@(L _ p@(ListPat pats typ _)) = do -#endif typ' <- tidyType typ let listType = mkListTy typ' addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p) mapM_ foldLPat pats return $ Just listType -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do -#else -foldLPat lp@(L _ pat@(TuplePat pats boxity types)) = do -#endif typ' <- tidyType $ mkTupleTy boxity types 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 (L _span (SumPat _ pat _ _)) = do -#else -foldLPat (L _span (SumPat pat _ _ _types)) = do -#endif -- TODO _ <- foldLPat pat return Nothing -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -#else -foldLPat lp@(L _ pat@(PArrPat pats typ)) = do - typ' <- tidyType typ - addExprInfo (getLocA lp) (Just typ') "PArrPat" (patSort pat) - mapM_ foldLPat pats - return $ Just typ' -#endif -- no more conpatin / conpatout, just conpat (in the wildcard pattern _) -- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing -- TODO: FIXME @@ -1214,60 +1100,35 @@ foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do _ <- foldLPat pat _ <- foldLHsExpr expr return $ Just typ' -foldLPat (L _ SplicePat {}) = return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +foldLPat ( L _ SplicePat{} ) = return Nothing foldLPat lp@(L _ (LitPat _ hsLit)) = do -#else -foldLPat lp@(L _ (LitPat hsLit)) = do -#endif typ' <- tidyType $ hsLitType hsLit - addExprInfo - (getLocA lp) - (Just typ') - "LitPat" - (if isOneLineSpan (getLocA lp) - then Simple - else Composite) - return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do -#else -foldLPat lp@(L _ pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do -#endif - typ' <- tidyType ol_type - addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat) - return $ Just ol_type -foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do - (identifier', _) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing - typ' <- tidyType typ - addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat) - olType' <- tidyType ol_type - addExprInfo - litSpan - (Just olType') - "NPlusKPat" - (if isOneLineSpan (getLocA lp) - then Simple - else Composite) - return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -foldLPat (L _span (SigPat typ pat _)) = do - typ' <- tidyType typ - _ <- foldLPat pat - return $ Just typ' -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (L _span (SigPat typ pat)) = do - typ' <- tidyType typ - _ <- foldLPat pat + addExprInfo (getLocA lp) + (Just typ') + "LitPat" + (if isOneLineSpan (getLocA lp) then Simple else Composite) return $ Just typ' -#else -foldLPat (L _span (SigPatIn _ _)) = return Nothing -foldLPat (L _span (SigPatOut pat typ)) = do +foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) + = do + typ' <- tidyType ol_type + addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat) + return $ Just ol_type +foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) + = do + (identifier', _) <- tidyIdentifier identifier + addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing + typ' <- tidyType typ + addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat) + olType' <- tidyType ol_type + addExprInfo litSpan + (Just olType') + "NPlusKPat" + (if isOneLineSpan (getLocA lp) then Simple else Composite) + return $ Just typ' +foldLPat (L _span (SigPat typ pat _)) = do typ' <- tidyType typ - _ <- foldLPat pat + _ <- foldLPat pat return $ Just typ' -#endif foldLPat _ = return Nothing foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) @@ -1282,12 +1143,12 @@ foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do -- 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 _ (XCmd _ )) = return Nothing foldLHsCmd (L _ (HsCmdArrApp _ expr1 expr2 _ _)) = do _ <- foldLHsExpr expr1 _ <- foldLHsExpr expr2 return Nothing -foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do +foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do _ <- foldLHsExpr expr mapM_ foldLHsCmdTop topCmds return Nothing -- cgit v1.2.3