{-# 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' foldLPat _ = return Nothing 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' foldLHsRecFieldPat (L _ (HsRecField _ (L _idSpan (XFieldOcc _)) _arg _pun)) = return Nothing