aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/AST
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer/AST')
-rw-r--r--src/HaskellCodeExplorer/AST/RenamedSource.hs498
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1231
2 files changed, 1729 insertions, 0 deletions
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs
new file mode 100644
index 0000000..c1bf463
--- /dev/null
+++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs
@@ -0,0 +1,498 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module HaskellCodeExplorer.AST.RenamedSource
+ ( NameOccurrence(..)
+ , namesFromRenamedSource
+ ) where
+
+import BasicTypes (TupleSort(..))
+import BooleanFormula (BooleanFormula(..))
+import Data.Generics (Data, everything, extQ, mkQ)
+import Data.Maybe (Maybe(..), mapMaybe)
+import qualified Data.Text as T (Text)
+import GHC
+ ( AmbiguousFieldOcc(..)
+ , ConDecl(..)
+ , ConDeclField(..)
+ , DataFamInstDecl(..)
+ , FamilyDecl(..)
+ , FieldOcc(..)
+ , FixitySig(..)
+ , ForeignDecl(..)
+ , GenLocated(..)
+ , HsBindLR(..)
+ , HsExpr(..)
+ , HsPatSynDetails(..)
+ , HsRecField'(..)
+ , HsTupleSort(..)
+ , HsTyLit(..)
+ , HsTyPats
+ , HsTyVarBndr(..)
+ , HsType(..)
+ , IE(..)
+ , LHsBindLR
+ , LHsExpr
+ , LHsQTyVars(..)
+ , LHsType
+ , LPat
+ , LSig
+ , LTyClDecl
+ , Located
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , HsMatchContext(..)
+ , Match(..)
+#else
+ , m_fixity
+ , MatchFixity(..)
+#endif
+ , MatchGroup(..)
+ , Name
+ , Pat(..)
+ , PatSynBind(..)
+ , Sig(..)
+ , TyClDecl(..)
+ , TyFamEqn(..)
+ , Type
+ , unLoc
+ )
+import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames)
+import Prelude hiding (span)
+import TysWiredIn
+ ( nilDataConName
+ , tupleTyConName
+ , typeNatKind
+ , typeSymbolKind
+ )
+data NameOccurrence
+ = NameOccurrence { locatedName :: Located (Maybe Name)
+ , description :: T.Text
+ , isBinder :: Bool }
+ | TyLitOccurrence { locatedName :: Located (Maybe Name)
+ , description :: T.Text
+ , kind :: Type }
+
+-- | Here we are only interested in a small subset of all AST nodes, so it is
+-- convenient to use generic functions
+namesFromRenamedSource :: (Data a) => a -> [NameOccurrence]
+namesFromRenamedSource =
+ everything
+ (++)
+ ([] `mkQ` hsExprNames `extQ` matchGroupNames `extQ` bindNames `extQ`
+ patNames `extQ`
+ sigNames `extQ`
+ hsTypeNames `extQ`
+ tyClDeclNames `extQ`
+ familyDeclNames `extQ`
+ tyFamilyEqNames `extQ`
+ tyFamilyDefEqNames `extQ`
+ dataFamInstDeclNames `extQ`
+ conDeclNames `extQ`
+ importNames `extQ`
+ hsTyVarBndrNames `extQ`
+ hsPatSynDetailsNames `extQ`
+ conDeclFieldNames `extQ`
+ hsRecFieldExprNames `extQ`
+ hsRecAmbFieldExprNames `extQ`
+ hsRecFieldPatNames `extQ`
+ foreignDeclNames)
+
+fieldOccName :: Bool -> FieldOcc Name -> NameOccurrence
+fieldOccName isBinder (FieldOcc (L span _) name) =
+ NameOccurrence
+ { locatedName = L span (Just name)
+ , description = "FieldOcc"
+ , isBinder = isBinder
+ }
+
+conDeclFieldNames :: ConDeclField Name -> [NameOccurrence]
+conDeclFieldNames ConDeclField {..} =
+ map (fieldOccName True . unLoc) cd_fld_names
+
+hsRecFieldExprNames ::
+ HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence]
+hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
+
+hsRecAmbFieldExprNames ::
+ HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [NameOccurrence]
+hsRecAmbFieldExprNames HsRecField {..} =
+ let (L span recField) = hsRecFieldLbl
+ mbName =
+ case recField of
+ Ambiguous _ _ -> Nothing
+ Unambiguous _ name -> Just name
+ in [ NameOccurrence
+ { locatedName = L span mbName
+ , description = "AmbiguousFieldOcc"
+ , isBinder = False
+ }
+ ]
+
+hsRecFieldPatNames ::
+ HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence]
+hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
+
+hsExprNames :: LHsExpr Name -> [NameOccurrence]
+hsExprNames (L _span (HsVar name)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsVar"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L span (ExplicitList _ _ exprs))
+ | null exprs =
+ [ NameOccurrence
+ { locatedName = L span $ Just nilDataConName
+ , description = "ExplicitList"
+ , isBinder = False
+ }
+ ]
+ | otherwise = []
+hsExprNames (L _span (RecordCon name _conLike _instFun _binds)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "RecordCon"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L _span (HsRecFld (Unambiguous (L span _) name))) =
+ [ NameOccurrence
+ { locatedName = L span (Just name)
+ , description = "HsRecFld"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L _span (HsRecFld (Ambiguous (L span _) _name))) =
+ [ NameOccurrence
+ { locatedName = L span Nothing
+ , description = "HsRecFld"
+ , isBinder = False
+ }
+ ]
+hsExprNames _ = []
+
+matchGroupNames :: MatchGroup Name (LHsExpr Name) -> [NameOccurrence]
+matchGroupNames =
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) .
+#else
+ mapMaybe (fmap toNameOcc . matchFixityName . m_fixity . unLoc) .
+#endif
+ unLoc . mg_alts
+ where
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ matchContextName :: HsMatchContext Name -> Maybe (Located Name)
+ matchContextName (FunRhs name _ _bool) = Just name
+ matchContextName _ = Nothing
+#else
+ matchFixityName :: MatchFixity Name -> Maybe (Located Name)
+ matchFixityName NonFunBindMatch = Nothing
+ matchFixityName (FunBindMatch name _bool) = Just name
+#endif
+ toNameOcc :: Located Name -> NameOccurrence
+ toNameOcc n =
+ NameOccurrence
+ {locatedName = Just <$> n, description = "Match", isBinder = True}
+
+bindNames :: LHsBindLR Name Name -> [NameOccurrence]
+bindNames (L _span (PatSynBind PSB {..})) =
+ [ NameOccurrence
+ { locatedName = Just <$> psb_id
+ , description = "PatSynBind"
+ , isBinder = True
+ }
+ ]
+bindNames _ = []
+
+hsPatSynDetailsNames :: HsPatSynDetails (Located Name) -> [NameOccurrence]
+hsPatSynDetailsNames =
+ map
+ (\name ->
+ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsPatSynDetails"
+ , isBinder = True
+ }) .
+ hsPatSynDetails
+
+importNames :: IE Name -> [NameOccurrence]
+importNames =
+ map
+ (\name ->
+ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "IE"
+ , isBinder = False
+ }) .
+ ieLocNames
+
+patNames :: LPat Name -> [NameOccurrence]
+patNames (L _span (VarPat name)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "VarPat"
+ , isBinder = True
+ }
+ ]
+patNames (L _span (ConPatIn name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "ConPatIn"
+ , isBinder = False
+ }
+ ]
+patNames (L _span (AsPat name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "AsPat"
+ , isBinder = True
+ }
+ ]
+patNames (L _span (NPlusKPat name _ _ _ _ _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "NPlusKPat"
+ , isBinder = True
+ }
+ ]
+patNames _ = []
+
+sigNames :: LSig Name -> [NameOccurrence]
+sigNames (L _span (TypeSig names _)) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "TypeSig"
+ , isBinder = False
+ })
+ names
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+sigNames (L _span (PatSynSig names _)) =
+ map (\name -> NameOccurrence (Just <$> name) "PatSynSig" False) names
+#else
+sigNames (L _span (PatSynSig name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "PatSynSig"
+ , isBinder = False
+ }
+ ]
+#endif
+sigNames (L _span (ClassOpSig _ names _)) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "ClassOpSig"
+ , isBinder = True
+ })
+ names
+sigNames (L _span (FixSig (FixitySig names _))) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "FixitySig"
+ , isBinder = False
+ })
+ names
+sigNames (L _span (InlineSig name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "InlineSig"
+ , isBinder = False
+ }
+ ]
+sigNames (L _span (SpecSig name _ _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "SpecSig"
+ , isBinder = False
+ }
+ ]
+sigNames (L _span (MinimalSig _ (L _ boolFormula))) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "MinimalSig"
+ , isBinder = False
+ }) .
+ boolFormulaNames $
+ boolFormula
+ where
+ boolFormulaNames :: BooleanFormula name -> [name]
+ boolFormulaNames (Var a) = [a]
+ boolFormulaNames (And fs) = concatMap (boolFormulaNames . unLoc) fs
+ boolFormulaNames (Or fs) = concatMap (boolFormulaNames . unLoc) fs
+ boolFormulaNames (Parens (L _ f)) = boolFormulaNames f
+sigNames (L _ _) = []
+
+hsTypeNames :: LHsType Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+hsTypeNames (L _span (HsTyVar _promoted name)) =
+#else
+hsTypeNames (L _span (HsTyVar name)) =
+#endif
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsTyVar"
+ , isBinder = False
+ }
+ ]
+hsTypeNames (L span (HsTyLit lit)) =
+ let kind =
+ case lit of
+ HsNumTy _ _ -> typeNatKind
+ HsStrTy _ _ -> typeSymbolKind
+ in [ TyLitOccurrence
+ { locatedName = L span Nothing
+ , description = "HsTyLit"
+ , kind = kind
+ }
+ ]
+hsTypeNames (L _span (HsOpTy _ name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsOpTy"
+ , isBinder = False
+ }
+ ]
+hsTypeNames (L span (HsTupleTy tupleSort types))
+ | null types =
+ let sort =
+ case tupleSort of
+ HsUnboxedTuple -> UnboxedTuple
+ HsBoxedTuple -> BoxedTuple
+ HsConstraintTuple -> ConstraintTuple
+ HsBoxedOrConstraintTuple -> BoxedTuple
+ in [ NameOccurrence
+ { locatedName = L span (Just $ tupleTyConName sort 0)
+ , description = "HsTupleTy"
+ , isBinder = False
+ }
+ ]
+ | otherwise = []
+--https://ghc.haskell.org/trac/ghc/ticket/13737
+--hsTypeNames (L span (HsExplicitListTy _kind types)) = ...
+--hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ...
+hsTypeNames _ = []
+
+hsTyVarBndrNames :: HsTyVarBndr Name -> [NameOccurrence]
+hsTyVarBndrNames (UserTyVar n) =
+ [ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "UserTyVar"
+ , isBinder = True
+ }
+ ]
+hsTyVarBndrNames (KindedTyVar n _) =
+ [ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "KindedTyVar"
+ , isBinder = True
+ }
+ ]
+
+tyClDeclNames :: LTyClDecl Name -> [NameOccurrence]
+tyClDeclNames (L _span DataDecl {..}) =
+ [ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "DataDecl"
+ , isBinder = True
+ }
+ ]
+tyClDeclNames (L _span SynDecl {..}) =
+ [ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "SynDecl"
+ , isBinder = True
+ }
+ ]
+tyClDeclNames (L _span ClassDecl {..}) =
+ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "ClassDecl"
+ , isBinder = True
+ } :
+ concatMap
+ ((\(names1, names2) -> map toNameOcc names1 ++ map toNameOcc names2) . unLoc)
+ tcdFDs
+ where
+ toNameOcc :: Located Name -> NameOccurrence
+ toNameOcc n =
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "FunDep"
+ , isBinder = False
+ }
+tyClDeclNames _ = []
+
+familyDeclNames :: FamilyDecl Name -> [NameOccurrence]
+familyDeclNames FamilyDecl {..} =
+ [ NameOccurrence
+ { locatedName = Just <$> fdLName
+ , description = "FamilyDecl"
+ , isBinder = True
+ }
+ ]
+
+tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence]
+tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "TyFamEqn"
+ , isBinder = False
+ }
+ ]
+
+tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence]
+tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "TyFamEqn"
+ , isBinder = False
+ }
+ ]
+
+dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence]
+dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "DataFamInstDecl"
+ , isBinder = False
+ }
+ ]
+
+conDeclNames :: ConDecl Name -> [NameOccurrence]
+conDeclNames con =
+ case con of
+ ConDeclGADT {con_names = names} ->
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "ConDeclGADT"
+ , isBinder = True
+ })
+ names
+ ConDeclH98 {con_name = name} ->
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "ConDeclH98"
+ , isBinder = True
+ }
+ ]
+
+foreignDeclNames :: ForeignDecl Name -> [NameOccurrence]
+foreignDeclNames decl =
+ [ NameOccurrence
+ { locatedName = Just <$> fd_name decl
+ , description = "ForeignDecl"
+ , isBinder = True
+ }
+ ]
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
new file mode 100644
index 0000000..f97c33b
--- /dev/null
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -0,0 +1,1231 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module HaskellCodeExplorer.AST.TypecheckedSource
+ ( ASTState(..)
+ , Environment(..)
+ , TypeError(..)
+ , foldTypecheckedSource
+ , mkIdentifierInfo
+ , mkIdentifierOccurrence
+ , mkType
+ , removeOverlappingInterval
+ ) where
+
+import Bag (bagToList)
+import BasicTypes (Origin(..))
+import Class (Class, classTyVars)
+import ConLike (ConLike(..),conLikeWrapId_maybe)
+import Control.Monad (return, unless, void)
+import Control.Monad.State.Strict (State, get, modify')
+import qualified Data.HashMap.Strict as HM
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntervalMap.Strict as IVM
+import qualified Data.Map.Strict as M
+import Data.Maybe (Maybe, fromMaybe, mapMaybe)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import DataCon (dataConWorkId)
+import DynFlags (DynFlags)
+import FastString (mkFastString)
+import HaskellCodeExplorer.GhcUtils
+import qualified HaskellCodeExplorer.Types as HCE
+import HsBinds (HsPatSynDetails(..), RecordPatSynField(..))
+import HsSyn
+ ( ABExport(..)
+ , ApplicativeArg(..)
+ , ArithSeqInfo(..)
+ , FieldOcc(..)
+ , GRHS(..)
+ , GRHSs(..)
+ , HsBindLR(..)
+ , HsCmd(..)
+ , HsCmdTop(..)
+ , HsConDetails(..)
+ , HsConPatDetails
+ , HsExpr(..)
+ , HsLocalBindsLR(..)
+ , HsOverLit(..)
+ , HsRecField'(..)
+ , HsRecFields(..)
+ , HsTupArg(..)
+ , HsValBindsLR(..)
+ , HsValBindsLR(..)
+ , LGRHS
+ , LHsBindLR
+ , LHsBinds
+ , LHsCmd
+ , LHsCmd
+ , LHsCmdTop
+ , LHsExpr
+ , LHsRecField
+ , LHsRecUpdField
+ , LHsTupArg
+ , LMatch
+ , LPat
+ , LStmtLR
+ , Match(..)
+ , Match(..)
+ , MatchGroup(..)
+ , ParStmtBlock(..)
+ , Pat(..)
+ , PatSynBind(..)
+ , StmtLR(..)
+ , selectorAmbiguousFieldOcc
+ )
+import HscTypes (TypeEnv, lookupTypeEnv)
+import Id (idType)
+import IdInfo (IdDetails(..))
+import InstEnv
+ ( ClsInst(..)
+ , InstEnvs
+ , instanceSig
+ , is_dfun
+ , lookupUniqueInstEnv
+ )
+import Name (Name, nameOccName, nameUnique)
+import Prelude hiding (span)
+import SrcLoc (GenLocated(..), SrcSpan(..), isGoodSrcSpan, isOneLineSpan, unLoc)
+import TcEvidence (HsWrapper(..))
+import TcHsSyn (conLikeResTy, hsLitType)
+import Type
+ ( TyThing(..)
+ , Type
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , nonDetCmpTypes
+#else
+ , cmpTypes
+#endif
+ , eqTypes
+ , eqType
+ , getClassPredTys_maybe
+ , mkFunTy
+ , mkFunTys
+ , splitForAllTys
+ , splitFunTy_maybe
+ , splitFunTys
+ , substTys
+ , tidyOpenType
+ , zipTvSubst
+ )
+import TysWiredIn (mkListTy, mkTupleTy)
+import Unique (getKey)
+import Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
+import VarEnv (TidyEnv)
+
+data ASTState = ASTState
+ { astStateExprInfoMap :: !HCE.ExpressionInfoMap
+ -- ^ Type of each expression
+ , 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'
+ -- and 'IdentifierInfoMap'.
+ -- '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
+ -- ^ 'TidyEnv' is used to prevent name clashes of free type variables.
+ -- ('TidyEnv' contains all free type variables in scope)
+ , astStateHsWrapper :: !(Maybe HsWrapper)
+ -- ^ HsWrapper comes from 'HsWrap' constructor of 'HsExpr' datatype.
+ , astStateEnv :: !Environment
+ -- ^ 'Environment' doesn't change
+ , 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
+ , typeErrorASTNodeName :: T.Text
+ } deriving (Show, Eq)
+
+data Environment = Environment
+ { envDynFlags :: DynFlags
+ , 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)
+ , envExportedNames :: S.Set Name
+ , envComponentId :: HCE.ComponentId
+ }
+
+-- | Indicates whether an expression consists of more than one token.
+-- Simple expression : wildcard, literal
+-- Composite expressin : applcation, lambda abstraction,...
+data ExprSort
+ = Simple
+ | Composite
+ deriving (Show, Eq)
+
+exprSort :: HsExpr a -> ExprSort
+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 _ = Composite
+
+patSort :: Pat a -> ExprSort
+patSort (WildPat _typ) = Simple
+patSort (LitPat _lit) = 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
+
+-- | 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 astNode typ = do
+ tys <- splitFunTySafe srcSpan astNode typ
+ case tys of
+ Just (arg1, ty1) -> do
+ res <- splitFunTySafe srcSpan astNode ty1
+ case res of
+ Just (arg2, ty2) -> return $ Just (arg1, arg2, ty2)
+ Nothing -> return Nothing
+ Nothing -> return Nothing
+
+-- | Returns result type of a function, adds 'TypeError' to
+-- 'ASTState' in case of a failure.
+funResultTySafe :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe Type)
+funResultTySafe srcSpan astNode typ =
+ fmap snd <$> splitFunTySafe srcSpan astNode typ
+
+-- | Returns result type of a function of two arguments,
+-- adds 'TypeError' to 'ASTState' in case of a failure.
+funResultTy2Safe :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe Type)
+funResultTy2Safe srcSpan astNode typ = do
+ mbResTy1 <- funResultTySafe srcSpan astNode typ
+ case mbResTy1 of
+ Just resTy1 -> funResultTySafe srcSpan astNode resTy1
+ Nothing -> return Nothing
+
+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
+-- on 'ExprSort'.
+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
+ mbHsWrapper <- astStateHsWrapper <$> get
+ modify' $ \astState@ASTState {astStateExprInfoMap = exprInfoMap} ->
+ case sort of
+ Composite ->
+ 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'}
+ 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}
+ 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 _ intervals = intervals
+
+newtype InstTypes = InstTypes [Type]
+
+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
+ -> 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
+ 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
+ flags
+ (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
+ currentPackageId = envPackageId environment
+ compId = envComponentId environment
+ transformation = envTransformation environment
+ fileMap = envFileMap environment
+ defSiteMap = envDefSiteMap environment
+ locationInfo =
+ nameLocationInfo
+ flags
+ 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
+ }
+
+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
+ ClassOpId cls -> Just cls
+ _ -> 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)
+
+restoreTidyEnv :: (State ASTState) a -> (State ASTState) a
+restoreTidyEnv action = do
+ tidyEnv <- astStateTidyEnv <$> get
+ res <- action
+ modify' $ \s -> s {astStateTidyEnv = tidyEnv}
+ return res
+
+restoreHsWrapper :: (State ASTState) a -> (State ASTState) a
+restoreHsWrapper action = do
+ wrapper <- astStateHsWrapper <$> get
+ res <- action
+ modify' $ \s -> s {astStateHsWrapper = wrapper}
+ return res
+
+tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type]))
+tidyIdentifier identifier = do
+ 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})
+ 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'})
+ return typ'
+
+foldTypecheckedSource :: LHsBinds Id -> State ASTState ()
+foldTypecheckedSource = foldLHsBindsLR
+
+foldLHsExpr :: LHsExpr Var -> State ASTState (Maybe Type)
+foldLHsExpr (L span (HsVar (L _ identifier))) =
+ restoreTidyEnv $ do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap span identifier' mbTypes
+ return . Just . varType $ identifier'
+foldLHsExpr (L _ (HsUnboundVar _)) = return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _ (HsConLikeOut conLike)) =
+ restoreTidyEnv $ do
+ let mbType = varType <$> conLikeWrapId_maybe conLike
+ mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
+ return mbType'
+#endif
+foldLHsExpr (L _ (HsRecFld _)) = return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _ (HsOverLabel _ _)) = return Nothing
+#else
+foldLHsExpr (L _ (HsOverLabel _)) = return Nothing
+#endif
+foldLHsExpr (L span expr@(HsIPVar _)) = do
+ addExprInfo span Nothing "HsIPVar" (exprSort expr)
+ return Nothing
+foldLHsExpr (L span (HsOverLit OverLit {ol_type})) =
+ restoreTidyEnv $ do
+ typ <- tidyType ol_type
+ addExprInfo
+ span
+ (Just typ)
+ "HsOverLit"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ
+foldLHsExpr (L span (HsLit lit)) =
+ restoreTidyEnv $ do
+ typ <- tidyType $ hsLitType lit
+ addExprInfo
+ span
+ (Just typ)
+ "HsLit"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ
+foldLHsExpr (L span expr@(HsLam MG {..})) =
+ restoreTidyEnv $ do
+ typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty
+ addExprInfo span (Just typ) "HsLam" (exprSort expr)
+ mapM_ foldLMatch $ unLoc mg_alts
+ return $ Just typ
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L span expr@(HsLamCase MG {..})) =
+#else
+foldLHsExpr (L span expr@(HsLamCase _typ MG {..})) =
+#endif
+ restoreTidyEnv $ do
+ typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty
+ addExprInfo span (Just typ) "HsLamCase" (exprSort expr)
+ mapM_ foldLMatch $ unLoc mg_alts
+ return $ Just typ
+foldLHsExpr (L span expr@(HsApp fun arg)) = do
+ funTy <- foldLHsExpr fun
+ _argTy <- foldLHsExpr arg
+ typ <- fromMaybe (return Nothing) (funResultTySafe span "HsApp" <$> funTy)
+ addExprInfo span typ "HsApp" (exprSort expr)
+ return typ
+foldLHsExpr (L _ (HsAppType _ _)) = return Nothing
+foldLHsExpr (L span ex@(HsAppTypeOut expr _)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsAppTypeOut" (exprSort ex)
+ return typ
+foldLHsExpr (L span expr@(OpApp left op _fixity right)) = do
+ opTyp <- foldLHsExpr op
+ typ <- fromMaybe (return Nothing) (funResultTy2Safe span "HsApp" <$> opTyp)
+ _ <- foldLHsExpr left
+ _ <- foldLHsExpr right
+ addExprInfo span typ "OpApp" (exprSort expr)
+ return typ
+foldLHsExpr (L span e@(NegApp expr _syntaxExp)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "NegApp" (exprSort e)
+ return typ
+foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr
+foldLHsExpr (L span expr@(SectionL operand operator)) = do
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <-
+ fromMaybe (return Nothing) (splitFunTy2Safe span "SectionL" <$> opType)
+ let typ =
+ case mbTypes of
+ Just (_arg1, arg2, res) -> Just $ mkFunTy arg2 res
+ Nothing -> Nothing
+ addExprInfo span typ "SectionL" (exprSort expr)
+ return typ
+foldLHsExpr (L span e@(SectionR operator operand)) = do
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <-
+ fromMaybe (return Nothing) (splitFunTy2Safe span "SectionR" <$> opType)
+ let typ =
+ case mbTypes of
+ Just (arg1, _arg2, res) -> Just $ mkFunTy arg1 res
+ Nothing -> Nothing
+ addExprInfo span typ "SectionR" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(ExplicitTuple tupArgs boxity)) = do
+ tupleArgs <- mapM foldLHsTupArg tupArgs
+ let tupleSectionArgTys =
+ mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs
+ tupleArgTys = mapM fst tupleArgs
+ resultType =
+ mkFunTys <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys)
+ tidyEnv <- astStateTidyEnv <$> get
+ addExprInfo
+ span
+ ((snd . tidyOpenType tidyEnv) <$> resultType)
+ "ExplicitTuple"
+ (exprSort e)
+ return resultType
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do
+ -- TODO
+ _ <- foldLHsExpr expr
+ return Nothing
+#endif
+foldLHsExpr (L span e@(HsCase expr MG {..})) =
+ restoreTidyEnv $ do
+ typ <- tidyType mg_res_ty
+ _ <- foldLHsExpr expr
+ mapM_ foldLMatch (unLoc mg_alts)
+ addExprInfo span (Just typ) "HsCase" (exprSort e)
+ return $ Just typ
+foldLHsExpr (L span e@(HsIf _mbSynExpr condExpr thenExpr elseExpr)) = do
+ _ <- foldLHsExpr condExpr
+ typ <- foldLHsExpr thenExpr
+ _ <- foldLHsExpr elseExpr
+ addExprInfo span typ "HsIf" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsMultiIf typ grhss)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "HsMultiIf" (exprSort e)
+ mapM_ foldLGRHS grhss
+ return $ Just typ'
+foldLHsExpr (L span e@(HsLet (L _ binds) expr)) = do
+ _ <- foldHsLocalBindsLR binds
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsLet" (exprSort e)
+ return typ
+foldLHsExpr (L span expr@(HsDo _context (L _ stmts) typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "HsDo" (exprSort expr)
+ mapM_ foldLStmtLR stmts
+ return $ Just typ'
+foldLHsExpr (L span (ExplicitList typ _syntaxExpr exprs)) =
+ restoreTidyEnv $ do
+ typ' <- mkListTy <$> tidyType typ
+ unless (null exprs) $ addExprInfo span (Just typ') "ExplicitList" Composite
+ mapM_ foldLHsExpr exprs
+ return $ Just typ'
+foldLHsExpr (L span e@(ExplicitPArr typ exprs)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ExplicitPArr" (exprSort e)
+ mapM_ foldLHsExpr exprs
+ return $ Just typ'
+foldLHsExpr (L span e@(RecordCon (L _ _) _conLike conExpr binds)) = do
+ mbConType <-
+ fmap (snd . splitFunTys) <$>
+ foldLHsExpr (L (UnhelpfulSpan $ mkFastString "RecordCon") conExpr)
+ addExprInfo span mbConType "RecordCon" (exprSort e)
+ _ <- foldHsRecFields binds
+ return mbConType
+foldLHsExpr (L span e@(RecordUpd expr binds cons _inputTys outTys _wrapper)) =
+ restoreTidyEnv $ do
+ -- cons is a non-empty list of DataCons that have all the upd'd fields
+ let typ = conLikeResTy (head cons) outTys
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "RecordUpd" (exprSort e)
+ _ <- foldLHsExpr expr
+ mapM_ foldLHsRecUpdField binds
+ return $ Just typ'
+foldLHsExpr (L _span (ExprWithTySig _expr _type)) = return Nothing
+foldLHsExpr (L span e@(ExprWithTySigOut expr _type)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "ExprWithTySigOut" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do
+ typ <-
+ fmap (snd . splitFunTys . snd . splitForAllTys) <$>
+ foldLHsExpr (L (UnhelpfulSpan $ 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 span typ "ArithSeq" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(PArrSeq postTcExpr _seqInfo)) = do
+ typ <- foldLHsExpr (L (UnhelpfulSpan $ mkFastString "PArrSeq") postTcExpr)
+ addExprInfo span typ "ArithSeq" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsSCC _sourceText _fastString expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsSCC" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsCoreAnn _sourceText _fastString expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsCoreAnn" (exprSort e)
+ return typ
+foldLHsExpr (L _span (HsBracket _bracket)) = return Nothing
+foldLHsExpr (L _span (HsRnBracketOut _ _)) = return Nothing
+foldLHsExpr (L _span (HsTcBracketOut _bracket _splice)) = return Nothing
+foldLHsExpr (L _span (HsSpliceE _)) = return Nothing
+foldLHsExpr (L span expr@(HsProc pat cmd)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsCmdTop cmd
+ addExprInfo span Nothing "HsProc" (exprSort expr)
+ return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L span e@(HsStatic _ expr)) = do
+#else
+foldLHsExpr (L span e@(HsStatic expr)) = do
+#endif
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsStatic" (exprSort e)
+ return typ
+foldLHsExpr (L _ HsArrForm {}) = return Nothing
+foldLHsExpr (L _ HsArrApp {}) = return Nothing
+foldLHsExpr (L span e@(HsTick _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsTick" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsBinTick _ _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsBinTick" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsTickPragma" (exprSort e)
+ return typ
+foldLHsExpr (L _span EWildPat) = return Nothing
+foldLHsExpr (L _span (EAsPat _ _)) = return Nothing
+foldLHsExpr (L _span (EViewPat _ _)) = return Nothing
+foldLHsExpr (L _span (ELazyPat _)) = return Nothing
+foldLHsExpr (L span (HsWrap wrapper expr)) =
+ restoreHsWrapper $ do
+ case exprSort expr of
+ Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper})
+ Composite -> return () -- Not sure if it is possible
+ typ <- foldLHsExpr (L span expr)
+ return $ applyWrapper wrapper <$> typ
+
+foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldHsRecFields HsRecFields {..} = do
+ let userWritten =
+ case rec_dotdot of
+ Just i -> take i
+ Nothing -> id
+ mapM_ foldLHsRecField $ userWritten rec_flds
+ return Nothing
+
+foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) =
+ restoreTidyEnv $ do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ addExprInfo span (Just . varType $ identifier') "HsRecField" Composite
+ unless pun $ void (foldLHsExpr arg)
+ return . Just . varType $ identifier'
+
+foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type)
+foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) =
+ restoreTidyEnv $ do
+ let selectorId = selectorAmbiguousFieldOcc recField
+ (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
+ let identifier'' = setVarName identifier' originalName
+ addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes
+ addExprInfo span (Just . varType $ identifier'') "HsRecUpdField" Composite
+ unless pun $ void (foldLHsExpr arg)
+ return . Just . varType $ identifier'
+
+data TupArg
+ = TupArgPresent
+ | TupArgMissing
+ deriving (Show, Eq)
+
+foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg)
+foldLHsTupArg (L _span (Present expr)) =
+ restoreTidyEnv $ do
+ typ <- foldLHsExpr expr
+ typ' <-
+ case typ of
+ Just t -> Just <$> tidyType t
+ Nothing -> return Nothing
+ return (typ', TupArgPresent)
+foldLHsTupArg (L _ (Missing typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ return (Just typ', TupArgMissing)
+
+foldLMatch :: LMatch Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldLMatch (L _span Match {..}) = do
+ mapM_ foldLPat m_pats
+ _ <- foldGRHSs m_grhss
+ return Nothing
+
+foldLMatchCmd :: LMatch Id (LHsCmd Var) -> State ASTState (Maybe Type)
+foldLMatchCmd (L _span Match {..}) = do
+ mapM_ foldLPat m_pats
+ _ <- foldGRHSsCmd m_grhss
+ return Nothing
+
+foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type)
+foldGRHSsCmd GRHSs {..} = do
+ mapM_ foldLGRHSCmd grhssGRHSs
+ _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
+ return Nothing
+
+foldGRHSs :: GRHSs Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldGRHSs GRHSs {..} = do
+ mapM_ foldLGRHS grhssGRHSs
+ _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
+ return Nothing
+
+foldLStmtLR :: LStmtLR Id Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldLStmtLR (L span (LastStmt body _ _)) =
+ do typ <- foldLHsExpr body
+ addExprInfo span typ "LastStmt" Composite
+ return typ
+foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsExpr body
+ return Nothing
+foldLStmtLR (L span (BodyStmt body _ _ _)) = do
+ mbTyp <- foldLHsExpr body
+ addExprInfo span mbTyp "BodyStmt" Composite
+ return mbTyp
+foldLStmtLR (L _ (LetStmt (L _ binds))) = do
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do
+ mapM_ foldParStmtBlock blocks
+ return Nothing
+foldLStmtLR (L _ TransStmt {..}) = do
+ mapM_ foldLStmtLR trS_stmts
+ _ <- maybe (return Nothing) foldLHsExpr trS_by
+ _ <- foldLHsExpr trS_using
+ return Nothing
+foldLStmtLR (L _span RecStmt {..}) = do
+ mapM_ foldLStmtLR recS_stmts
+ return Nothing
+foldLStmtLR (L span (ApplicativeStmt args _ typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo span (Just typ') "ApplicativeStmt" Composite
+ return Nothing
+
+foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type)
+foldApplicativeArg appArg =
+ case appArg of
+ ApplicativeArgOne pat expr -> do
+ _ <- foldLPat pat
+ _ <- foldLHsExpr expr
+ return Nothing
+ ApplicativeArgMany exprStmts _ pat -> do
+ _ <- mapM_ foldLStmtLR exprStmts
+ _ <- foldLPat pat
+ return Nothing
+
+foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Var)
+ -> State ASTState (Maybe Type)
+foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do
+ typ <- foldLHsCmd body
+ addExprInfo span typ "LastStmt Cmd" Composite
+ return typ
+foldLStmtLRCmd (L _ (BindStmt pat body _ _ _)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsCmd body
+ return Nothing
+foldLStmtLRCmd (L span (BodyStmt body _ _ _)) = do
+ typ <- foldLHsCmd body
+ addExprInfo span typ "BodyStmt Cmd" Composite
+ return typ
+foldLStmtLRCmd (L _ (LetStmt (L _ binds))) = do
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do
+ mapM_ foldParStmtBlock blocks
+ return Nothing
+foldLStmtLRCmd (L _ TransStmt {..}) = do
+ mapM_ foldLStmtLR trS_stmts
+ _ <- foldLHsExpr trS_using
+ _ <- maybe (return Nothing) foldLHsExpr trS_by
+ return Nothing
+foldLStmtLRCmd (L _ RecStmt {..}) = do
+ mapM_ foldLStmtLRCmd recS_stmts
+ return Nothing
+foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo span (Just typ') "ApplicativeStmt Cmd" Composite
+ return Nothing
+
+foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldLGRHS (L _span (GRHS guards body)) = do
+ typ <- foldLHsExpr body
+ mapM_ foldLStmtLR guards
+ return typ
+
+foldLGRHSCmd :: LGRHS Id (LHsCmd Var) -> State ASTState (Maybe Type)
+foldLGRHSCmd (L _span (GRHS guards body)) = do
+ typ <- foldLHsCmd body
+ mapM_ foldLStmtLR guards
+ return typ
+
+foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type)
+foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do
+ mapM_ foldLStmtLR exprStmts
+ return Nothing
+
+foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type)
+foldHsLocalBindsLR (HsValBinds binds) = do
+ _ <- foldHsValBindsLR binds
+ return Nothing
+foldHsLocalBindsLR (HsIPBinds _binds) = return Nothing
+foldHsLocalBindsLR EmptyLocalBinds = return Nothing
+
+foldHsValBindsLR :: HsValBindsLR Id Var -> State ASTState (Maybe Type)
+foldHsValBindsLR (ValBindsIn _ _) = return Nothing
+foldHsValBindsLR (ValBindsOut binds _) = do
+ _ <- mapM_ (foldLHsBindsLR . snd) binds
+ return Nothing
+
+foldLHsBindsLR :: LHsBinds Id -> State ASTState ()
+foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList
+
+foldLHsBindLR :: LHsBindLR Id Var
+ -> Maybe Id -- ^ Polymorphic id
+ -> State ASTState (Maybe Type)
+foldLHsBindLR (L _span FunBind {..}) mbPolyId
+ | mg_origin fun_matches == FromSource =
+ restoreTidyEnv $ do
+ let (L idSpan 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 idSpan 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 _ AbsBinds {..}) _ = do
+ _ <-
+ mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $
+ zip (bagToList abs_binds) (map abe_poly abs_exports)
+ return Nothing
+foldLHsBindLR (L _ AbsBindsSig {..}) _ = do
+ _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export)
+ return Nothing
+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
+ InfixPatSyn id1 id2 -> addId id1 >> addId id2
+ PrefixPatSyn ids -> mapM_ addId ids
+ RecordPatSyn recs ->
+ mapM_
+ (\(RecordPatSynField selId patVar) ->
+ addId selId >> addId patVar)
+ recs
+ return Nothing
+
+foldLPat :: LPat Id -> State ASTState (Maybe Type)
+foldLPat (L span (VarPat (L _ identifier))) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap span identifier' Nothing
+ return . Just . varType $ identifier'
+foldLPat (L span pat@(WildPat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "WildPat" (patSort pat)
+ return $ Just typ'
+foldLPat (L span p@(LazyPat pat)) = do
+ mbType <- foldLPat pat
+ addExprInfo span mbType "LazyPat" (patSort p)
+ return mbType
+foldLPat (L span p@(AsPat (L idSpan identifier) pat)) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' Nothing
+ addExprInfo span (Just . varType $ identifier') "AsPat" (patSort p)
+ _ <- foldLPat pat
+ return . Just . varType $ identifier'
+foldLPat (L _span (ParPat pat)) = foldLPat pat
+foldLPat (L span p@(BangPat pat)) = do
+ typ <- foldLPat pat
+ addExprInfo span typ "BangPat" (patSort p)
+ return typ
+foldLPat (L span p@(ListPat pats typ _)) = do
+ typ' <- tidyType typ
+ let listType = mkListTy typ'
+ addExprInfo span (Just listType) "ListPat" (patSort p)
+ _ <- mapM_ foldLPat pats
+ return $ Just listType
+foldLPat (L span pat@(TuplePat pats boxity types)) = do
+ typ' <- tidyType $ mkTupleTy boxity types
+ addExprInfo span (Just typ') "TuplePat" (patSort pat)
+ _ <- mapM_ foldLPat pats
+ return $ Just typ'
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLPat (L _span (SumPat pat _ _ _types)) = do
+ -- TODO
+ _ <- foldLPat pat
+ return Nothing
+#endif
+foldLPat (L span pat@(PArrPat pats typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "PArrPat" (patSort pat)
+ _ <- mapM_ foldLPat pats
+ return $ Just typ'
+foldLPat (L _span (ConPatIn _ _)) = return Nothing
+foldLPat (L span pat@ConPatOut {..}) = do
+ let (L idSpan conLike) = pat_con
+ conId =
+ case conLike of
+ RealDataCon dc -> dataConWorkId dc
+ PatSynCon ps -> patSynId ps
+ typ = conLikeResTy (unLoc pat_con) pat_arg_tys
+ (identifier', mbTypes) <- tidyIdentifier conId
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ConPatOut" (patSort pat)
+ _ <- foldHsConPatDetails pat_args
+ return . Just . varType $ identifier'
+foldLPat (L span p@(ViewPat expr pat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ViewPat" (patSort p)
+ _ <- foldLPat pat
+ _ <- foldLHsExpr expr
+ return $ Just typ'
+foldLPat (L _ (SplicePat _)) = return Nothing
+foldLPat (L span (LitPat hsLit)) = do
+ typ' <- tidyType $ hsLitType hsLit
+ addExprInfo
+ span
+ (Just typ')
+ "LitPat"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ'
+foldLPat (L span pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do
+ typ' <- tidyType ol_type
+ addExprInfo span (Just typ') "NPat" (patSort pat)
+ return $ Just ol_type
+foldLPat (L span pat@(NPlusKPat (L idSpan identifier) (L litSpan OverLit {ol_type}) _ _ _ typ)) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' Nothing
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "NPlusKPat" (patSort pat)
+ olType' <- tidyType ol_type
+ addExprInfo
+ litSpan
+ (Just olType')
+ "NPlusKPat"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ'
+foldLPat (L _span (SigPatIn _ _)) = return Nothing
+foldLPat (L _span (SigPatOut pat typ)) = do
+ typ' <- tidyType typ
+ _ <- foldLPat pat
+ return $ Just typ'
+foldLPat (L span p@(CoPat _ pat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "CoPat" (patSort p)
+ _ <- foldLPat (L span pat)
+ return Nothing
+
+foldHsConPatDetails
+ :: HsConPatDetails Id
+ -> State ASTState (Maybe Type)
+foldHsConPatDetails (PrefixCon args) = do
+ _ <- mapM_ foldLPat args
+ return Nothing
+foldHsConPatDetails (RecCon rec) = do
+ _ <- foldHsRecFieldsPat rec
+ return Nothing
+foldHsConPatDetails (InfixCon arg1 arg2) = do
+ _ <- foldLPat arg1
+ _ <- foldLPat arg2
+ return Nothing
+
+foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type)
+foldHsRecFieldsPat HsRecFields {..} = do
+ let onlyUserWritten =
+ case rec_dotdot of
+ Just i -> take i
+ Nothing -> id
+ _ <- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
+ return Nothing
+
+foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type)
+foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ unless pun $ void $ foldLPat arg
+ return . Just . varType $ identifier'
+
+foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type)
+foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do
+ mbTyp <- foldLHsCmd cmd
+ addExprInfo span mbTyp "HsCmdTop" Composite
+ return mbTyp
+
+foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type)
+foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do
+ _ <- foldLHsExpr expr1
+ _ <- foldLHsExpr expr2
+ return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsCmd (L _ (HsCmdArrForm expr _ _ topCmds)) = do
+#else
+foldLHsCmd (L _ (HsCmdArrForm expr _ topCmds)) = do
+#endif
+ _ <- foldLHsExpr expr
+ _ <- mapM_ foldLHsCmdTop topCmds
+ return Nothing
+foldLHsCmd (L _ (HsCmdApp cmd expr)) = do
+ _ <- foldLHsCmd cmd
+ _ <- foldLHsExpr expr
+ return Nothing
+foldLHsCmd (L _ (HsCmdLam MG {..})) = do
+ mapM_ foldLMatchCmd $ unLoc mg_alts
+ return Nothing
+foldLHsCmd (L _ (HsCmdCase expr MG {..})) = do
+ _ <- foldLHsExpr expr
+ mapM_ foldLMatchCmd $ unLoc mg_alts
+ return Nothing
+foldLHsCmd (L _ (HsCmdPar cmd)) = do
+ _ <- foldLHsCmd cmd
+ return Nothing
+foldLHsCmd (L _ (HsCmdIf _ expr cmd1 cmd2)) = do
+ _ <- foldLHsCmd cmd1
+ _ <- foldLHsCmd cmd2
+ _ <- foldLHsExpr expr
+ return Nothing
+foldLHsCmd (L _ (HsCmdLet (L _ binds) cmd)) = do
+ _ <- foldLHsCmd cmd
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLHsCmd (L _ (HsCmdDo stmts _)) = do
+ mapM_ foldLStmtLRCmd $ unLoc stmts
+ return Nothing
+foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
+ _ <- foldLHsCmd (L span cmd)
+ return Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 17:02:42 +0000