path: root/src/HaskellCodeExplorer/AST/TypecheckedSource.hs

{-# LANGUAGE CPP #-}
{-# 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 GHC.Data.Bag (bagToList)
import GHC.Types.Basic (Origin(..))
import GHC.Core.Class (Class, classTyVars)
import Control.Monad (unless, void, when)
import Control.Monad.State.Strict (State, get, modify')
import Data.Either (isLeft, fromLeft)
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap.Strict as IM
import qualified Data.IntervalMap.Strict as IVM
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as S
import qualified Data.Text as T
import GHC.Core.Multiplicity (scaledThing)
import GHC
  ( DynFlags
  , TyThing(..)
  , getLocA
  , reLocA
  , reLocN
  )
import GHC.Data.FastString (mkFastString)
import GHC.Unit.State (UnitState)
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
import GHC.Hs.Binds (RecordPatSynField(..)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#else
  , HsPatSynDetails (..)
#endif
  )
import GHC.Hs
  ( ABExport(..)
  , ApplicativeArg(..)
  , ArithSeqInfo(..)
  , FieldOcc(..)
  , GRHS(..)
  , GRHSs(..)
  , HsBindLR(..)
  , HsCmd(..)
  , HsCmdTop(..)
  , HsConDetails(..)
  , 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
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--  , RecordConTc (..)
  , RecordUpdTc (..)
  , ListPatTc (..)
  , OverLitTc (..)
  , MatchGroupTc (..)
  , NHsValBindsLR (..)
#endif
  )
import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
import GHC.Hs.Extension (GhcTc)
#endif
import GHC.Types.Id (idType)
import GHC.Types.Id.Info (IdDetails(..))
import GHC.Core.InstEnv
  ( ClsInst(..)
  , InstEnvs
  , instanceSig
  , is_dfun
  , lookupUniqueInstEnv
  )
import GHC.Types.Name (Name, nameOccName, nameUnique)
import Prelude hiding (span)
import GHC.Types.SrcLoc
   ( GenLocated(..)
   , SrcSpan(..)
   , isGoodSrcSpan
   , UnhelpfulSpanReason(..)
   , isOneLineSpan
   , unLoc
-- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
--    , cL 
-- #endif    
   )
import GHC.Tc.Types.Evidence (HsWrapper(..))
import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType)
import GHC.Core.Predicate (getClassPredTys_maybe)
import GHC.Core.Type
  ( Type
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
  , nonDetCmpTypes
#else
  , cmpTypes
#endif
  , eqTypes
  , eqType
  , mkVisFunTys
  , mkVisFunTyMany
  , mkVisFunTysMany
  , splitForAllTyCoVars
  , splitFunTy_maybe
  , splitFunTys
  , substTys
  , tidyOpenType
  , zipTvSubst
  )
import GHC.Builtin.Types (mkListTy, mkTupleTy)
import GHC.Types.Unique (getKey)
import GHC.Types.Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
import GHC.Types.Var.Env (TidyEnv)

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

#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
exprSort (ExplicitTuple _ args _)
#else
exprSort (ExplicitTuple args _)
#endif
  | 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
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
patSort (ListPat _ pats)
#else
patSort (ListPat pats _ _)
#endif
  | null pats = Simple
  | otherwise = Composite
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
patSort (TuplePat  _ pats _)
#else
patSort (TuplePat pats _ _)
#endif
  | 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
    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

-- not used any more
-- 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'

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState ()
#else
foldTypecheckedSource :: LHsBinds Id -> State ASTState ()
#endif
foldTypecheckedSource = foldLHsBindsLR

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
#else
foldLHsExpr :: LHsExpr Id -> State ASTState (Maybe Type)
#endif
foldLHsExpr (L _span (XExpr _)) = return Nothing
foldLHsExpr (L _ (HsOverLit _ (XOverLit _))) = return Nothing
foldLHsExpr (L _ (HsLam _ (XMatchGroup _))) = return Nothing
foldLHsExpr (L _ (HsLamCase _ (XMatchGroup _))) = return Nothing
foldLHsExpr (L _ (HsCase _ _ (XMatchGroup _))) = return Nothing
foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) =
  restoreTidyEnv $ do
    (identifier', mbTypes) <- tidyIdentifier identifier
    addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
    return . Just . varType $ identifier'
foldLHsExpr (L _ HsUnboundVar {}) = return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsExpr (L _ (HsConLikeOut _ conLike)) =
#else
foldLHsExpr (L _ (HsConLikeOut conLike)) =
#endif
  -- restoreTidyEnv $ do
  --   let mbType = varType <$> conLikeWrapId_maybe conLike
  --   mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
  --   return mbType'
  restoreTidyEnv $ return Nothing
#endif
foldLHsExpr (L _ HsRecFld {}) = return Nothing
foldLHsExpr (L _ HsOverLabel {}) = return Nothing
foldLHsExpr lhe@(L _ expr@HsIPVar {}) = do
  addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr)
  return Nothing
foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) =
  restoreTidyEnv $ do
    typ <- tidyType ol_type
    addExprInfo
      (getLocA lhe)
      (Just typ)
      "HsOverLit"
      (if isOneLineSpan (getLocA lhe)
         then Simple
         else Composite)
    return $ Just typ
foldLHsExpr lhe@(L _ (HsLit _ lit)) =
  restoreTidyEnv $ do
    typ <- tidyType $ hsLitType lit
    addExprInfo
      (getLocA lhe)
      (Just typ)
      "HsLit"
      (if isOneLineSpan (getLocA lhe)
         then Simple
         else Composite)
    return $ Just typ
foldLHsExpr lhe@(L span 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
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsExpr (L _span (HsPar _ expr)) = foldLHsExpr expr
#else
foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr
#endif
foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do
  opType <- foldLHsExpr operator
  _ <- foldLHsExpr operand
  mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionL") opType
  let typ =
        case mbTypes of
          Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res
          Nothing -> Nothing
  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
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsExpr (L _span (ExplicitSum _ _ _ expr)) = do
#else
foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do
#endif
  -- TODO
  _ <- foldLHsExpr expr
  return Nothing
#endif
foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) =
  restoreTidyEnv $ do
    typ <- tidyType mg_res_ty
    _ <- foldLHsExpr expr
    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
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- foldLHsExpr lhe@(L _ e@(HsSCC _ _sourceText _fastString expr)) = do
-- #else
-- foldLHsExpr lhe@(L _ e@(HsSCC _sourceText _fastString expr)) = do
-- #endif
--   typ <- foldLHsExpr expr
--   addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e)
--   return typ
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- foldLHsExpr lhe@(L _ e@(HsCoreAnn _ _sourceText _fastString expr)) = do
-- #else
-- foldLHsExpr lhe@(L _ e@(HsCoreAnn _sourceText _fastString expr)) = do
-- #endif
--   typ <- foldLHsExpr expr
--   addExprInfo (getLocA lhe) typ "HsCoreAnn" (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 (L _ HsArrForm {}) = return Nothing
-- foldLHsExpr (L _ HsArrApp {}) = return Nothing
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
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do
-- #else
-- foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
-- #endif
--   typ <- foldLHsExpr expr
--   addExprInfo span typ "HsTickPragma" (exprSort e)
--   return typ

-- A few similarly named symbols are in GHC.Hs.Pat
-- foldLHsExpr (L _span EWildPat {}) = return Nothing
-- foldLHsExpr (L _span EAsPat {}) = return Nothing
-- foldLHsExpr (L _span EViewPat {}) = return Nothing
-- foldLHsExpr (L _span ELazyPat {}) = return Nothing

-- there's an hswrap but it is not in hsexpr
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- foldLHsExpr (L span (HsWrap _ wrapper expr)) =
-- #else
-- foldLHsExpr (L span (HsWrap wrapper expr)) =
-- #endif
--   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 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

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
#else
foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type)
#endif
foldLHsRecField (L _span (HsRecField _ (L _idSpan (XFieldOcc _)) _ _)) = return Nothing
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 (XTupArg _) = return (Nothing, TupArgMissing)
foldHsTupArg (Present _ expr) =
  restoreTidyEnv $ do
    typ <- foldLHsExpr expr
    typ' <-
      case typ of
        Just t -> Just <$> tidyType t
        Nothing -> return Nothing
    return (typ', TupArgPresent)
foldHsTupArg (Missing typ) =
  restoreTidyEnv $ do
    typ' <- tidyType $ scaledThing typ
    return (Just typ', TupArgMissing)

-- TODO: use foldHsTupArg
foldLHsTupArg :: LHsTupArg GhcTc -> State ASTState (Maybe Type, TupArg)
foldLHsTupArg (L _span (XTupArg _)) = return (Nothing, TupArgMissing)
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 $ scaledThing typ
    return (Just typ', TupArgMissing)

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
#else
foldLMatch :: LMatch Id (LHsExpr Id) -> State ASTState (Maybe Type)
#endif
foldLMatch (L _span Match {..}) = do
  mapM_ foldLPat m_pats
  _ <- foldGRHSs m_grhss
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLMatch (L _span _) = return Nothing
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
#else
foldLMatchCmd :: LMatch Id (LHsCmd Id) -> State ASTState (Maybe Type)
#endif
foldLMatchCmd (L _span Match {..}) = do
  mapM_ foldLPat m_pats
  _ <- foldGRHSsCmd m_grhss
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLMatchCmd (L _span _) = return Nothing
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
#else
foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type)
#endif
foldGRHSsCmd GRHSs {..} = do
  mapM_ foldLGRHSCmd grhssGRHSs
  _ <- foldHsLocalBindsLR grhssLocalBinds
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldGRHSsCmd (_) = return Nothing
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
#else
foldGRHSs :: GRHSs Id (LHsExpr Id) -> State ASTState (Maybe Type)
#endif
foldGRHSs GRHSs {..} = do
  mapM_ foldLGRHS grhssGRHSs
  _ <- foldHsLocalBindsLR grhssLocalBinds
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldGRHSs (_) = return Nothing
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
#else
foldLStmtLR :: LStmtLR Id Id (LHsExpr Id) -> State ASTState (Maybe Type)
#endif
foldLStmtLR (L _span (XStmtLR _)) = return Nothing
foldLStmtLR lst@(L _ (LastStmt _ body _ _)) =
  do typ <- foldLHsExpr body
     addExprInfo (getLocA lst) typ "LastStmt" Composite
     return typ
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLR (L _span (BindStmt _ pat body)) = do
#else
foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do
#endif
  _ <- foldLPat pat
  _ <- foldLHsExpr body
  return Nothing
foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do
  mbTyp <- foldLHsExpr body
  addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite
  return mbTyp
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLR (L _ (LetStmt _ binds)) = do
#else
foldLStmtLR (L _ (LetStmt (L _ binds))) = do
#endif
  _ <- foldHsLocalBindsLR binds
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLR (L _ (ParStmt _ blocks _ _)) = do
#else
foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do
#endif
  mapM_ foldParStmtBlock blocks
  return Nothing
foldLStmtLR (L _ TransStmt {..}) = do
  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

#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldApplicativeArg :: ApplicativeArg GhcTc -> State ASTState (Maybe Type)
#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type)
#else
foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type)
#endif
foldApplicativeArg appArg =
  case appArg of
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
    XApplicativeArg _ -> return Nothing
    ApplicativeArgOne _ pat expr _bool -> do
#else
    ApplicativeArgOne pat expr _bool -> do
#endif
#else
    ApplicativeArgOne pat expr -> do
#endif
      _ <- foldLPat pat
      _ <- foldLHsExpr expr
      return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
    ApplicativeArgMany _ exprStmts _ pat _ -> do
#else
    ApplicativeArgMany exprStmts _ pat -> do
#endif
      mapM_ foldLStmtLR exprStmts
      _ <- foldLPat pat
      return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLStmtLRCmd ::
     LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
#else
foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type)
#endif
foldLStmtLRCmd (L _ (XStmtLR _)) = return Nothing
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
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLRCmd (L _ (ParStmt _ blocks _ _)) = do
#else
foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do
#endif
  mapM_ foldParStmtBlock blocks
  return Nothing
foldLStmtLRCmd (L _ TransStmt {..}) = do
  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

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
#else
foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLGRHS (L _span (XGRHS _)) = return Nothing
foldLGRHS (L _span (GRHS _ guards body)) = do
#else
foldLGRHS (L _span (GRHS guards body)) = do
#endif
  typ <- foldLHsExpr body
  mapM_ foldLStmtLR guards
  return typ

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLGRHSCmd :: LGRHS GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
#else
foldLGRHSCmd :: LGRHS Id (LHsCmd Id) -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLGRHSCmd (L _span (XGRHS _)) = return Nothing
foldLGRHSCmd (L _span (GRHS _ guards body)) = do
#else
foldLGRHSCmd (L _span (GRHS guards body)) = do
#endif
  typ <- foldLHsCmd body
  mapM_ foldLStmtLR guards
  return typ

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldParStmtBlock :: ParStmtBlock GhcTc GhcTc -> State ASTState (Maybe Type)
#else
foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldParStmtBlock (XParStmtBlock _) = return Nothing
foldParStmtBlock (ParStmtBlock _ exprStmts _ids _syntaxExpr) = do
#else
foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do
#endif
  mapM_ foldLStmtLR exprStmts
  return Nothing

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
#else
foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldHsLocalBindsLR (XHsLocalBindsLR _) = return Nothing
foldHsLocalBindsLR (HsValBinds _ binds) = do
#else
foldHsLocalBindsLR (HsValBinds binds) = do
#endif
  _ <- foldHsValBindsLR binds
  return Nothing
foldHsLocalBindsLR HsIPBinds {} = return Nothing
foldHsLocalBindsLR EmptyLocalBinds {} = return Nothing

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
#else
foldHsValBindsLR :: HsValBindsLR Id Id -> State ASTState (Maybe Type)
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldHsValBindsLR (ValBinds _ _binds _) = do
  return Nothing
foldHsValBindsLR (XValBindsLR (NValBinds binds _)) = do
  _ <- mapM_ (foldLHsBindsLR . snd) binds
  return Nothing
#else
foldHsValBindsLR (ValBindsIn _ _) = return Nothing
foldHsValBindsLR (ValBindsOut binds _) = do
  mapM_ (foldLHsBindsLR . snd) binds
  return Nothing
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState ()
#else
foldLHsBindsLR :: LHsBinds Id -> State ASTState ()
#endif
foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList

foldLHsBindLR :: LHsBindLR GhcTc GhcTc
              -> Maybe Id -- ^ Polymorphic id
              -> State ASTState (Maybe Type)
foldLHsBindLR (L _span (XHsBindsLR _)) _ = return Nothing
foldLHsBindLR (L _span (PatSynBind _ (XPatSynBind _))) _ = return Nothing
-- TODO: FIXME
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
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#else
foldLHsBindLR (L _ AbsBindsSig {..}) _ = do
  _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export)
  return Nothing
#endif
foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ =
  restoreTidyEnv $ do
    _ <- foldLPat psb_def
    _ <-
      let addId :: GenLocated SrcSpan Id -> State ASTState ()
          addId (L span i) = do
            (i', _) <- tidyIdentifier i
            addIdentifierToIdSrcSpanMap span i' Nothing
       in case psb_args of
            InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2)
            PrefixCon _ ids -> mapM_ (addId . reLocN) ids
            RecCon recs ->
              mapM_
                (\(RecordPatSynField field patVar) ->
                   addId
                   (L ((getLocA . rdrNameFieldOcc) field)
                     (extFieldOcc field))
                  >> addId (reLocN patVar))
                recs
    return Nothing

foldLPat :: LPat GhcTc -> State ASTState (Maybe Type)
foldLPat (L _span (XPat _)) = return Nothing
foldLPat (L _ (NPat _ (L _ (XOverLit _)) _ _)) = return Nothing
foldLPat (L _ (NPlusKPat _ (L _ _) (L _ (XOverLit _)) _ _ _)) = 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 _ id@(L _ identifier) pat)) = do
  (identifier', _) <- tidyIdentifier identifier
  addIdentifierToIdSrcSpanMap (getLocA id) identifier' Nothing
  addExprInfo (getLocA lp) (Just . varType $ identifier') "AsPat" (patSort p)
  _ <- foldLPat pat
  return . Just . varType $ identifier'
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat (L _span (ParPat _ pat)) = foldLPat pat
#else
foldLPat (L _span (ParPat pat)) = foldLPat pat
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ p@(BangPat _ pat)) = do
#else
foldLPat lp@(L _ p@(BangPat pat)) = do
#endif
  typ <- foldLPat pat
  addExprInfo (getLocA lp) typ "BangPat" (patSort p)
  return typ
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do
#else
foldLPat lp@(L _ p@(ListPat pats typ _)) = do
#endif
  typ' <- tidyType typ
  let listType = mkListTy typ'
  addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p)
  mapM_ foldLPat pats
  return $ Just listType
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do
#else
foldLPat lp@(L _ pat@(TuplePat pats boxity types)) = do
#endif
  typ' <- tidyType $ mkTupleTy boxity types
  addExprInfo (getLocA lp) (Just typ') "TuplePat" (patSort pat)
  mapM_ foldLPat pats
  return $ Just typ'
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat (L _span (SumPat _ pat _ _)) = do
#else
foldLPat (L _span (SumPat pat _ _ _types)) = do
#endif
  -- TODO
  _ <- foldLPat pat
  return Nothing
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
#else
foldLPat lp@(L _ pat@(PArrPat pats typ)) = do
  typ' <- tidyType typ
  addExprInfo (getLocA lp) (Just typ') "PArrPat" (patSort pat)
  mapM_ foldLPat pats
  return $ Just typ'
#endif
-- no more conpatin / conpatout, just conpat
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- TODO: FIXME
-- foldLPat (ghcDL -> cp@lp@(L _ pat@ConPat {..})) = do
--   let pc@(L _ 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 (getLocA pc) identifier' mbTypes
--   typ' <- tidyType typ
--   addExprInfo (getLocA cp) (Just typ') "ConPat" (patSort pat)
--   _ <- foldHsConPatDetails pat_args
--   return . Just . varType $ identifier'
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
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ (LitPat _ hsLit)) = do
#else
foldLPat lp@(L _ (LitPat hsLit)) = do
#endif
  typ' <- tidyType $ hsLitType hsLit
  addExprInfo
    (getLocA lp)
    (Just typ')
    "LitPat"
    (if isOneLineSpan (getLocA lp)
       then Simple
       else Composite)
  return $ Just typ'
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do
#else
foldLPat lp@(L _ pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do
#endif
  typ' <- tidyType ol_type
  addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat)
  return $ Just ol_type
foldLPat lp@(L _ pat@(NPlusKPat typ id@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do
  (identifier', _) <- tidyIdentifier identifier
  addIdentifierToIdSrcSpanMap (getLocA id) identifier' Nothing
  typ' <- tidyType typ
  addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat)
  olType' <- tidyType ol_type
  addExprInfo
    litSpan
    (Just olType')
    "NPlusKPat"
    (if isOneLineSpan (getLocA lp)
       then Simple
       else Composite)
  return $ Just typ'
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
foldLPat (L _span (SigPat typ pat _)) = do 
  typ' <- tidyType typ
  _ <- foldLPat pat
  return $ Just typ'
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat (L _span (SigPat typ pat)) = do
  typ' <- tidyType typ
  _ <- foldLPat pat
  return $ Just typ'
#else
foldLPat (L _span (SigPatIn _ _)) = return Nothing
foldLPat (L _span (SigPatOut pat typ)) = do
  typ' <- tidyType typ
  _ <- foldLPat pat
  return $ Just typ'
#endif
-- no copat in lpat in 9.2.2
-- foldLPat lp@(L span p@(CoPat _ pat typ)) = do
--   typ' <- tidyType typ
--   addExprInfo (getLocA lp) (Just typ') "CoPat" (patSort p)
--   -- cL is similar to dL and not used any more
--   -- _ <- foldLPat (cL (getLocA lp) pat)
--   _ <- foldLPat (L span pat)
--   return Nothing
foldLPat _ = return Nothing

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsConPatDetails
  :: HsConPatDetails GhcTc
  -> State ASTState (Maybe Type)
#else
foldHsConPatDetails
  :: HsConPatDetails Id
  -> State ASTState (Maybe Type)
#endif
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

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
#else
foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type)
#endif
foldHsRecFieldsPat HsRecFields {..} = do
  let onlyUserWritten =
        case rec_dotdot of
          Just i -> take $ unLoc i
          Nothing -> id
  mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
  return Nothing

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
#else
foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type)
#endif
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

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
#else
foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmdTop (L _span (XCmdTop _)) = return Nothing
foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
#else
foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do
#endif
  mbTyp <- foldLHsCmd cmd
  addExprInfo span mbTyp "HsCmdTop" Composite
  return mbTyp

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type)
#else
foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (XCmd _)) = return Nothing
foldLHsCmd (L _ (HsCmdLam _ (XMatchGroup _))) = return Nothing
foldLHsCmd (L _ (HsCmdCase _ _ (XMatchGroup _))) = return Nothing
foldLHsCmd (L _ (HsCmdArrApp _ expr1 expr2 _ _)) = do
#else
foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do
#endif
  _ <- foldLHsExpr expr1
  _ <- foldLHsExpr expr2
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdArrForm _ expr _  _ topCmds)) = do
#else
foldLHsCmd (L _ (HsCmdArrForm expr _  _ topCmds)) = do
#endif
#else
foldLHsCmd (L _ (HsCmdArrForm expr _ topCmds)) = do
#endif
  _ <- foldLHsExpr expr
  mapM_ foldLHsCmdTop topCmds
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdApp _ cmd expr)) = do
#else
foldLHsCmd (L _ (HsCmdApp cmd expr)) = do
#endif
  _ <- foldLHsCmd cmd
  _ <- foldLHsExpr expr
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdLam _ MG {..})) = do
#else
foldLHsCmd (L _ (HsCmdLam MG {..})) = do
#endif
  mapM_ foldLMatchCmd $ unLoc mg_alts
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdCase _ expr MG {..})) = do
#else
foldLHsCmd (L _ (HsCmdCase expr MG {..})) = do
#endif
  _ <- foldLHsExpr expr
  mapM_ foldLMatchCmd $ unLoc mg_alts
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdPar _ cmd)) = do
#else
foldLHsCmd (L _ (HsCmdPar cmd)) = do
#endif
  _ <- foldLHsCmd cmd
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdIf _ _ expr cmd1 cmd2)) = do
#else
foldLHsCmd (L _ (HsCmdIf _ expr cmd1 cmd2)) = do
#endif
  _ <- foldLHsCmd cmd1
  _ <- foldLHsCmd cmd2
  _ <- foldLHsExpr expr
  return Nothing
foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do
  _ <- foldLHsCmd cmd
  _ <- foldHsLocalBindsLR binds
  return Nothing
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsCmd (L _ (HsCmdDo _ stmts)) = do
#else
foldLHsCmd (L _ (HsCmdDo stmts _)) = do
#endif
  mapM_ foldLStmtLRCmd $ unLoc stmts
  return Nothing
-- no more hscmdwrap
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do
-- #else
-- foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
-- #endif
--   _ <- foldLHsCmd (L span cmd)
--   return Nothing