{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StrictData #-}
module HaskellCodeExplorer.AST.TypecheckedSource
( ASTState(..)
, Environment(..)
, TypeError(..)
, foldTypecheckedSource
, mkIdentifierInfo
, mkIdentifierOccurrence
, mkType
, removeOverlappingInterval
) where
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(..)
, SrcSpanAnnA
, 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.Driver.Ppr ( pprTrace )
import GHC.Hs ( ABExport(..)
, ApplicativeArg(..)
, ArithSeqInfo(..)
, ConPatTc(..)
, FieldOcc(..)
, GRHS(..)
, GRHSs(..)
, HsBindLR(..)
, HsCmd(..)
, HsCmdTop(..)
, HsConDetails(..)
, HsConPatDetails(..)
, 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.Dump ( BlankEpAnnotations(..)
, BlankSrcSpan(..)
, showAstData
)
import GHC.Hs.Expr ( HsExpansion(..)
, HsWrap(..)
, XXExprGhcTc(..)
)
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 GHC.Utils.Outputable ( showPprUnsafe )
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
import Prelude hiding ( span )
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
, 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)
, envExportedNames :: S.Set Name
, envComponentId :: HCE.ComponentId
}
-- | Indicates whether an expression consists of more than one token.
-- Simple expression : wildcard, literal
-- Composite expression : application, 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{} = 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
-- | 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
instance Ord FastString where
a `compare` b = unpackFS a `compare` unpackFS b
deriving instance () => Ord SrcLoc
instance Ord SrcSpan where
a `compare` b =
(srcSpanStart a `compare` srcSpanStart b)
`thenCmp` (srcSpanEnd a `compare` srcSpanEnd b)
addIdentifierToIdSrcSpanMap
:: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState ()
addIdentifierToIdSrcSpanMap span identifier mbTypes | 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
compare (InstTypes ts1) (InstTypes ts2) = nonDetCmpTypes ts1 ts2
-- | 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
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
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
, 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
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 GhcTc -> State ASTState ()
foldTypecheckedSource = foldLHsBindsLR
-- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:606:1: warning: [-Wincomplete-patterns]
-- Pattern match(es) are non-exhaustive
-- In an equation for ‘foldLHsExpr’:
-- Patterns of type ‘LHsExpr GhcTc’ not matched:
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsGetField _ _ _)
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsProjection _ _)
foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
-- foldLHsExpr lhe
-- | pprTrace "foldLHsExpr"
-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
-- False
-- = undefined
foldLHsExpr (L span (XExpr (ExpansionExpr (HsExpanded _ r)))) =
foldLHsExpr (L span r)
foldLHsExpr ( L span (XExpr (WrapExpr wrap) )) = foldLHsWrap (L span wrap)
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
addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr)
return Nothing
-- foldLHsExpr lhe@(L _ (HsOverLit _ _))
-- | pprTrace "foldLHsExpr with hsoverlit"
-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
-- False
-- = undefined
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 _ _))
-- | pprTrace "foldLHsExpr with hslit"
-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
-- False
-- = undefined
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
addExprInfo (getLocA lhe) (Just typ) "HsLam" (exprSort expr)
mapM_ foldLMatch $ unLoc mg_alts
return $ Just typ
foldLHsExpr lhe@(L _ expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) =
restoreTidyEnv $ do
typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty
addExprInfo (getLocA lhe) (Just typ) "HsLamCase" (exprSort expr)
mapM_ foldLMatch $ unLoc mg_alts
return $ Just typ
foldLHsExpr lhe@(L _ expr@(HsApp _ fun arg)) = do
funTy <- foldLHsExpr fun
_argTy <- foldLHsExpr arg
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
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
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
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)
tidyEnv <- astStateTidyEnv <$> get
addExprInfo (getLocA lhe)
(snd . tidyOpenType tidyEnv <$> resultType)
"ExplicitTuple"
(exprSort e)
return resultType
foldLHsExpr (L _span (ExplicitSum _ _ _ expr)) = do
-- TODO
_ <- foldLHsExpr expr
return Nothing
foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) =
restoreTidyEnv $ do
typ <- tidyType mg_res_ty
_ <- foldLHsExpr expr
mapM_ foldLMatch (unLoc mg_alts)
addExprInfo (getLocA lhe) (Just typ) "HsCase" (exprSort e)
return $ Just typ
foldLHsExpr lhe@(L _ e@(HsIf _ condExpr thenExpr elseExpr)) = do
_ <- foldLHsExpr condExpr
typ <- foldLHsExpr thenExpr
_ <- 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@(HsLet _ binds expr)) = do
_ <- foldHsLocalBindsLR binds
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsLet" (exprSort e)
return typ
foldLHsExpr lhe@(L _ expr@(HsDo typ _context (L _ stmts))) =
restoreTidyEnv $ do
typ' <- tidyType typ
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 _ 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
-- 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 (getLocA lhe) (Just typ') "RecordUpd" (exprSort e)
_ <- foldLHsExpr expr
when (isLeft binds) (mapM_ foldLHsRecUpdField (fromLeft [] binds))
return $ Just typ'
foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do
typ <- foldLHsExpr expr
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
(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
addExprInfo (getLocA lhe) typ "ArithSeq" (exprSort e)
return typ
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
_ <- foldLPat pat
_ <- foldLHsCmdTop cmd
addExprInfo (getLocA lhe) Nothing "HsProc" (exprSort expr)
return Nothing
foldLHsExpr lhe@(L _ e@(HsStatic _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsStatic" (exprSort e)
return typ
foldLHsExpr lhe@(L _ e@(HsTick _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsTick" (exprSort e)
return typ
foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e)
return typ
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
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
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
addExprInfo (getLocA lhr)
(Just . varType $ identifier')
"HsRecField"
Composite
unless pun $ void (foldLHsExpr arg)
return . Just . varType $ identifier'
foldLHsRecUpdField :: LHsRecUpdField GhcTc -> State ASTState (Maybe Type)
foldLHsRecUpdField lhr@(L _ (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 (getLocA lhr)
(Just . varType $ identifier'')
"HsRecUpdField"
Composite
unless pun $ void (foldLHsExpr arg)
return . Just . varType $ identifier'
data TupArg
= TupArgPresent
| TupArgMissing
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)
foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
foldLMatch (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSs m_grhss
return Nothing
foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
foldLMatchCmd (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSsCmd m_grhss
return Nothing
foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
foldGRHSsCmd GRHSs {..} = do
mapM_ foldLGRHSCmd grhssGRHSs
_ <- foldHsLocalBindsLR grhssLocalBinds
return Nothing
foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
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
foldLStmtLR (L _span (BindStmt _ pat body)) = do
_ <- foldLPat pat
_ <- foldLHsExpr body
return Nothing
foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do
mbTyp <- foldLHsExpr body
addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite
return mbTyp
foldLStmtLR (L _ (LetStmt _ 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 (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
foldApplicativeArg :: ApplicativeArg GhcTc -> State ASTState (Maybe Type)
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
return typ
foldLStmtLRCmd (L _ (BindStmt _ pat body)) = do
_ <- foldLPat pat
_ <- foldLHsCmd body
return Nothing
foldLStmtLRCmd ls@(L _ (BodyStmt _ body _ _)) = do
typ <- foldLHsCmd body
addExprInfo (getLocA ls) typ "BodyStmt Cmd" Composite
return typ
foldLStmtLRCmd (L _ (LetStmt _ 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 (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
foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
foldLGRHS (L _span (GRHS _ guards body)) = do
typ <- foldLHsExpr body
mapM_ foldLStmtLR guards
return typ
foldLGRHSCmd :: LGRHS GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
foldLGRHSCmd (L _span (GRHS _ guards body)) = do
typ <- foldLHsCmd body
mapM_ foldLStmtLR guards
return typ
foldParStmtBlock :: ParStmtBlock GhcTc GhcTc -> State ASTState (Maybe Type)
foldParStmtBlock (ParStmtBlock _ exprStmts _ids _syntaxExpr) = do
mapM_ foldLStmtLR exprStmts
return Nothing
foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
foldHsLocalBindsLR (HsValBinds _ binds) = do
_ <- foldHsValBindsLR binds
return Nothing
foldHsLocalBindsLR HsIPBinds{} = return Nothing
foldHsLocalBindsLR EmptyLocalBinds{} = return Nothing
foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
foldHsValBindsLR (ValBinds _ _binds _) = do
return Nothing
foldHsValBindsLR (XValBindsLR (NValBinds binds _)) = do
_ <- mapM_ (foldLHsBindsLR . snd) binds
return Nothing
foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState ()
foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList
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
| 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 _ (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 lp
-- | pprTrace "foldLPat"
-- (showAstData NoBlankSrcSpan NoBlankEpAnnotations lp)
-- False
-- = undefined
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'
foldLPat lp@(L _ pat@(WildPat typ)) = do
typ' <- tidyType typ
addExprInfo (getLocA lp) (Just typ') "WildPat" (patSort pat)
return $ Just typ'
foldLPat lp@(L _ p@(LazyPat _ pat)) = do
mbType <- foldLPat pat
addExprInfo (getLocA lp) mbType "LazyPat" (patSort p)
return mbType
foldLPat lp@(L _ p@(AsPat _ ide@(L _ identifier) pat)) = do
(identifier', _) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing
addExprInfo (getLocA lp) (Just . varType $ identifier') "AsPat" (patSort p)
_ <- foldLPat pat
return . Just . varType $ identifier'
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
foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do
typ' <- tidyType typ
let listType = mkListTy typ'
addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p)
mapM_ foldLPat pats
return $ Just listType
foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do
typ' <- tidyType $ mkTupleTy boxity types
addExprInfo (getLocA lp) (Just typ') "TuplePat" (patSort pat)
mapM_ foldLPat pats
return $ Just typ'
foldLPat (L _span (SumPat _ pat _ _)) = do
-- TODO
_ <- foldLPat pat
return Nothing
-- no more conpatin / conpatout, just conpat (in the wildcard pattern _)
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- TODO: FIXME
-- original
-- foldLPat (ghcDL -> 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 lp@(L span pat@(ConPat ConPatTc {..} (L _ conLike) args)) = do
let typ = conLikeResTy conLike cpt_arg_tys
typ' <- tidyType typ
addExprInfo (getLocA lp) (Just typ') "ConPat" (patSort pat)
_ <- foldHsConPatDetails args
return Nothing
foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do
typ' <- tidyType typ
addExprInfo (getLocA lp) (Just typ') "ViewPat" (patSort p)
_ <- foldLPat pat
_ <- foldLHsExpr expr
return $ Just typ'
foldLPat ( L _ SplicePat{} ) = return Nothing
foldLPat lp@(L _ (LitPat _ hsLit)) = do
typ' <- tidyType $ hsLitType hsLit
addExprInfo (getLocA lp)
(Just typ')
"LitPat"
(if isOneLineSpan (getLocA lp) then Simple else Composite)
return $ Just typ'
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
return $ Just typ'
foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
mbTyp <- foldLHsCmd cmd
addExprInfo span mbTyp "HsCmdTop" Composite
return mbTyp
-- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:1379:1: warning: [-Wincomplete-patterns]
-- Pattern match(es) are non-exhaustive
-- In an equation for ‘foldLHsCmd’:
-- 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 _ (HsCmdArrApp _ expr1 expr2 _ _)) = do
_ <- foldLHsExpr expr1
_ <- foldLHsExpr expr2
return Nothing
foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do
_ <- 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 _ binds cmd)) = do
_ <- foldLHsCmd cmd
_ <- foldHsLocalBindsLR binds
return Nothing
foldLHsCmd (L _ (HsCmdDo _ stmts)) = do
mapM_ foldLStmtLRCmd $ unLoc stmts
return Nothing
foldLHsWrap
:: GenLocated SrcSpanAnnA (HsWrap HsExpr) -> State ASTState (Maybe Type)
foldLHsWrap (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
restoreHsWrapper :: (State ASTState) a -> (State ASTState) a
restoreHsWrapper action = do
wrapper <- astStateHsWrapper <$> get
res <- action
modify' $ \s -> s { astStateHsWrapper = wrapper }
return res
foldHsConPatDetails :: HsConPatDetails GhcTc -> State ASTState (Maybe Type)
foldHsConPatDetails (PrefixCon _ args) = do
mapM_ foldLPat args
return Nothing
foldHsConPatDetails (RecCon rec) = do
_ <- foldHsRecFieldsPat rec
return Nothing
foldHsConPatDetails (InfixCon arg1 arg2) = do
_ <- foldLPat arg1
_ <- foldLPat arg2
return Nothing
foldHsRecFieldsPat
:: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
foldHsRecFieldsPat HsRecFields {..} = do
let onlyUserWritten = case rec_dotdot of
Just i -> take $ unLoc i
Nothing -> id
mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
return Nothing
foldLHsRecFieldPat
:: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
foldLHsRecFieldPat (L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun))
= do
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
unless pun $ void $ foldLPat arg
return . Just . varType $ identifier'