aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer/AST/TypecheckedSource.hs')
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1419
1 files changed, 640 insertions, 779 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-19 00:01:50 +0000