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

{-# 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

foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
-- foldLHsExpr lhe
--   | pprTrace "foldLHsExpr"
--              (showAstData NoBlankSrcSpan NoBlankEpAnnotations lhe)
--              False
--   = undefined
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 _ (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 _ 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 (    L _ (  HsGetField _ _ _      )) = return Nothing
foldLHsExpr (    L _ (  HsProjection _ _      )) = return Nothing
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
foldLHsExpr (L span (XExpr (ExpansionExpr (HsExpanded _ r)))) =
  foldLHsExpr (L span r)
foldLHsExpr (L span (XExpr (WrapExpr wrap))) = foldLHsWrap (L span wrap)

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 _)
-- original
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- 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 _ pat@(ConPat ConPatTc {..} (L _ conLike) args)) = do
  let typ = conLikeResTy conLike cpt_arg_tys
  typ' <- tidyType typ
  addExprInfo (getLocA lp) (Just typ') "ConPat" (patSort pat)
  _ <- foldHsConPatDetails args
  return Nothing
foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do
  typ' <- tidyType typ
  addExprInfo (getLocA lp) (Just typ') "ViewPat" (patSort p)
  _ <- foldLPat pat
  _ <- foldLHsExpr expr
  return $ Just typ'
foldLPat (   L _ SplicePat{}     ) = return Nothing
foldLPat lp@(L _ (LitPat _ hsLit)) = do
  typ' <- tidyType $ hsLitType hsLit
  addExprInfo (getLocA lp)
              (Just typ')
              "LitPat"
              (if isOneLineSpan (getLocA lp) then Simple else Composite)
  return $ Just typ'
foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _))
  = do
    typ' <- tidyType ol_type
    addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat)
    return $ Just ol_type
foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _))
  = do
    (identifier', _) <- tidyIdentifier identifier
    addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing
    typ' <- tidyType typ
    addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat)
    olType' <- tidyType ol_type
    addExprInfo litSpan
                (Just olType')
                "NPlusKPat"
                (if isOneLineSpan (getLocA lp) then Simple else Composite)
    return $ Just typ'
foldLPat (L _span (SigPat typ pat _)) = do
  typ' <- tidyType typ
  _    <- foldLPat pat
  return $ Just typ'

foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
  mbTyp <- foldLHsCmd cmd
  addExprInfo span mbTyp "HsCmdTop" Composite
  return mbTyp

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 _ (HsCmdLamCase _ _  )) = 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'