{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}

module Language.Haskell.GhcMod.FillSig (
    sig
  , refine
  , auto
  ) where

import Data.Char (isSymbol)
import Data.Function (on)
import Data.Functor
import Data.List (find, nub, sortBy)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Text.PrettyPrint (($$), text, nest)
import Prelude

import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
            SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import qualified Name as G
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
import qualified Var as Ty
import qualified HsPat as Ty
#if MIN_VERSION_haskell_src_exts(1,18,0)
import qualified Language.Haskell.Exts as HE
#else
import qualified Language.Haskell.Exts.Annotated as HE
#endif
import Djinn.GHC

import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Logging (gmLog)
import Language.Haskell.GhcMod.Pretty (showDoc)
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)

#if __GLASGOW_HASKELL__ >= 710
import GHC (unLoc)
#endif

----------------------------------------------------------------
-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
----------------------------------------------------------------

-- Possible signatures we can find: function or instance
data SigInfo
    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
    | InstanceDecl SrcSpan G.Class
    | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]

-- Signature for fallback operation via haskell-src-exts
data HESigInfo
    = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
    | HEFamSignature
          HE.SrcSpan
          TyFamType
          (HE.Name HE.SrcSpanInfo)
          [HE.Name HE.SrcSpanInfo]

data TyFamType = Closed | Open | Data
initialTyFamString :: TyFamType -> (String, String)
initialTyFamString Closed = ("instance", "")
initialTyFamString Open   = ("function", "type instance ")
initialTyFamString Data   = ("function", "data instance ")

-- | Create a initial body from a signature.
sig :: IOish m
    => FilePath     -- ^ A target file.
    -> Int          -- ^ Line number.
    -> Int          -- ^ Column number.
    -> GhcModT m String
sig file lineNo colNo =
    runGmlT' [Left file] deferErrors $ ghandle fallback $ do
      oopts <- outputOpts
      style <- getStyle
      dflag <- G.getSessionDynFlags
      modSum <- fileModSummaryWithMapping file
      whenFound oopts (getSignature modSum lineNo colNo) $ \s ->
        case s of
          Signature loc names ty ->
              ("function", fourInts loc, map (initialBody dflag style ty) names)

          InstanceDecl loc cls ->
            let body x = initialBody dflag style (G.idType x) x
            in ("instance", fourInts loc, body `map` Ty.classMethods cls)

          TyFamDecl loc name flavour vars ->
            let (rTy, initial) = initialTyFamString flavour
                body = initialFamBody dflag style name vars
            in (rTy, fourInts loc, [initial ++ body])
  where
    fallback (SomeException _) = do
      oopts <- outputOpts
      -- Code cannot be parsed by ghc module
      -- Fallback: try to get information via haskell-src-exts
      whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of
        HESignature loc names ty ->
          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
        HEFamSignature loc flavour name vars ->
          let (rTy, initial) = initialTyFamString flavour
           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])

----------------------------------------------------------------
-- a. Code for getting the information

-- Get signature from ghc parsing and typechecking
getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)
getSignature modSum lineNo colNo = do
    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
    -- Inspect the parse tree to find the signature
    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
#if __GLASGOW_HASKELL__ >= 800
      [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->
#elif __GLASGOW_HASKELL__ >= 710
      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
#else
      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
#endif
        -- We found a type signature
        return $ Just $ Signature loc (map G.unLoc names) ty
      [L _ (G.InstD _)] -> do
        -- We found an instance declaration
        TypecheckedModule{tm_renamed_source = Just tcs
                         ,tm_checked_module_info = minfo} <- G.typecheckModule p
        let lst = listifyRenamedSpans tcs (lineNo, colNo)
        case Gap.getClass lst of
            Just (clsName,loc) -> obtainClassInfo minfo clsName loc
            _                  -> return Nothing
#if __GLASGOW_HASKELL__ >= 800
      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do
#elif __GLASGOW_HASKELL__ >= 708
      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
#elif __GLASGOW_HASKELL__ >= 706
      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do
#else
      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do
#endif
#if __GLASGOW_HASKELL__ >= 708
        let flavour = case info of
                        G.ClosedTypeFamily _ -> Closed
                        G.OpenTypeFamily     -> Open
                        G.DataFamily         -> Data
#else
        let flavour = case info of  -- Closed type families where introduced in GHC 7.8
                        G.TypeFamily -> Open
                        G.DataFamily -> Data
#endif

#if __GLASGOW_HASKELL__ >= 800
            getTyFamVarName x = case x of
                L _ (G.UserTyVar (G.L _ n))     -> n
                L _ (G.KindedTyVar (G.L _ n) _) -> n
#elif __GLASGOW_HASKELL__ >= 710
            getTyFamVarName x = case x of
                L _ (G.UserTyVar n)     -> n
                L _ (G.KindedTyVar (G.L _ n) _) -> n
#elif __GLASGOW_HASKELL__ >= 706
            getTyFamVarName x = case x of
                L _ (G.UserTyVar n)     -> n
                L _ (G.KindedTyVar n _) -> n
#else
            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg
                L _ (G.UserTyVar n _)     -> n
                L _ (G.KindedTyVar n _ _) -> n
#endif
         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
      _ -> return Nothing
  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
        obtainClassInfo minfo clsName loc = do
          tyThing <- G.modInfoLookupName minfo clsName
          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe
                      cls <- G.tyConClass_maybe clsCon
                      return $ InstanceDecl loc cls

-- Get signature from haskell-src-exts
getSignatureFromHE :: (MonadIO m, GhcMonad m) =>
    FilePath -> Int -> Int -> m (Maybe HESigInfo)
getSignatureFromHE file lineNo colNo = do
  presult <- liftIO $ HE.parseFile file
  return $ case presult of
             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
               decl <- find (typeSigInRangeHE lineNo colNo) mdecls
               case decl of
                 HE.TypeSig (HE.SrcSpanInfo s _) names ty ->
                     return $ HESignature s names ty

#if MIN_VERSION_haskell_src_exts(1,18,0)
                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ ->
#else
                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ ->
#endif
                   let (name, tys) = dHeadTyVars declHead in
                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)

                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->
                   let (name, tys) = dHeadTyVars declHead in
                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)
                 _ -> fail ""
             _ -> Nothing
  where cleanTyVarBind (HE.KindedVar _ n _) = n
        cleanTyVarBind (HE.UnkindedVar _ n) = n

#if MIN_VERSION_haskell_src_exts(1,16,0)
        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
        dHeadTyVars (HE.DHead _ name) = (name, [])
        dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)
        dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])
        dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r
#else
        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])
        dHeadTyVars (HE.DHead _ n tys) = (n, tys)
#endif

----------------------------------------------------------------
-- b. Code for generating initial code

-- A list of function arguments, and whether they are functions or normal
-- arguments is built from either a function signature or an instance signature
data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String

initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String
initialBody dflag style ty name =
    initialBody' (getFnName dflag style name) (getFnArgs ty)

initialBody' :: String -> [FnArg] -> String
initialBody' fname args =
    initialHead fname args ++ " = " ++ n ++ "_body"
 where n = if isSymbolName fname then "" else '_':fname

initialFamBody :: FnArgsInfo ty name
               => DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args =
    initialHead fnName fnArgs ++ " = ()"
 where fnName = getFnName dflag style name
       fnArgs = map (FnExplicitName . getFnName dflag style) args

initialHead :: String -> [FnArg] -> String
initialHead fname args =
  case initialBodyArgs args infiniteVars infiniteFns of
    []      -> fname
    arglist -> if isSymbolName fname
               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
               else fname ++ " " ++ unwords arglist

initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
initialBodyArgs [] _ _ = []
initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs
initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs
initialBodyArgs (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs
initialBodyArgs _                  _      _  =
    error "initialBodyArgs: This should never happen" -- Lists are infinite

initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts =
  case initialBodyArgs1 args elts of
    []      -> fname
    arglist
      | isSymbolName fname ->
        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
      | otherwise ->
        fname ++ " " ++ unwords arglist

initialBodyArgs1 :: [FnArg] -> [String] -> [String]
initialBodyArgs1 args elts = take (length args) elts

-- Getting the initial body of function and instances differ
-- This is because for functions we only use the parsed file
-- (so the full file doesn't have to be type correct)
-- but for instances we need to get information about the class

class FnArgsInfo ty name | ty -> name, name -> ty where
  getFnName :: DynFlags -> PprStyle -> name -> String
  getFnArgs :: ty -> [FnArg]

instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
  getFnName dflag style name = showOccName dflag style $ Gap.occName name
#if __GLASGOW_HASKELL__ >= 800
  getFnArgs (G.HsForAllTy _ (L _ iTy))
#elif __GLASGOW_HASKELL__ >= 710
  getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
#else
  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
#endif
    = getFnArgs iTy

  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy
  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
    where fnarg ty = case ty of
#if __GLASGOW_HASKELL__ >= 800
              (G.HsForAllTy _ (L _ iTy)) ->
#elif __GLASGOW_HASKELL__ >= 710
              (G.HsForAllTy _ _ _ _ (L _ iTy)) ->
#else
              (G.HsForAllTy _ _ _ (L _ iTy)) ->
#endif
                fnarg iTy

              (G.HsParTy (L _ iTy))          -> fnarg iTy
              (G.HsFunTy _ _)                -> True
              _                              -> False
  getFnArgs _ = []

instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
  getFnName _ _ (HE.Ident  _ s) = s
  getFnName _ _ (HE.Symbol _ s) = s
  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy
  getFnArgs (HE.TyFun _ lTy rTy)    =
      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
    where fnarg ty = case ty of
              (HE.TyForall _ _ _ iTy) -> fnarg iTy
              (HE.TyParen _ iTy)      -> fnarg iTy
              (HE.TyFun _ _ _)        -> True
              _                       -> False
  getFnArgs _ = []

instance FnArgsInfo Type Id where
  getFnName dflag style method = showOccName dflag style $ G.getOccName method
  getFnArgs = getFnArgs' . Ty.dropForAlls
    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =
            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)
                  (\_ -> FnArgFunction:getFnArgs' rTy)
                  $ Ty.splitFunTy_maybe lTy

          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =
              getFnArgs' iTy

          getFnArgs' _ = []

-- Infinite supply of variable and function variable names
infiniteVars, infiniteFns :: [String]
infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
infiniteFns  = infiniteSupply ["f","g","h"]
infiniteSupply :: [String] -> [String]
infiniteSupply initialSupply =
    initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)
                               ([1 .. ] :: [Integer])

-- Check whether a String is a symbol name
isSymbolName :: String -> Bool
isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c
isSymbolName []    = error "This should never happen"


----------------------------------------------------------------
-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION
----------------------------------------------------------------

refine :: IOish m
       => FilePath     -- ^ A target file.
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
       -> Expression   -- ^ A Haskell expression.
       -> GhcModT m String
refine file lineNo colNo (Expression expr) =
  ghandle handler $
    runGmlT' [Left file] deferErrors $ do
      oopts <- outputOpts
      style <- getStyle
      dflag <- G.getSessionDynFlags
      modSum <- fileModSummaryWithMapping file
      p <- G.parseModule modSum
      tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
      ety <- G.exprType expr
      whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $
        \(loc, name, rty, paren) ->
            let eArgs = getFnArgs ety
                rArgs = getFnArgs rty
                diffArgs' = length eArgs - length rArgs
                diffArgs  = if diffArgs' < 0 then 0 else diffArgs'
                iArgs = take diffArgs eArgs
                txt = initialHead1 expr iArgs (infinitePrefixSupply name)
             in (fourInts loc, doParen paren txt)
  where
   handler (SomeException ex) = do
     gmLog GmException "refining" $
           text "" $$ nest 4 (showDoc ex)
     emptyResult =<< outputOpts

-- Look for the variable in the specified position
findVar
  :: GhcMonad m
  => DynFlags
  -> PprStyle
  -> G.TypecheckedModule
  -> G.TypecheckedSource
  -> Int
  -> Int
  -> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
  case lst of
#if __GLASGOW_HASKELL__ >= 800
    e@(L _ (G.HsVar (L _ i))):others -> do
#else
    e@(L _ (G.HsVar i)):others -> do
#endif
      tyInfo <- Gap.getType tcm e
      case tyInfo of
        Just (s, typ)
          | name == "undefined" || head name == '_' ->
            return $ Just (s, name, typ, b)
          where
            name = getFnName dflag style i
            -- If inside an App, we need parenthesis
            b = case others of
                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
                    isSearchedVar i a1 || isSearchedVar i a2
                  _  -> False
        _ -> return Nothing
    _ -> return Nothing
  where
    lst :: [G.LHsExpr Id]
    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)

infinitePrefixSupply :: String -> [String]
infinitePrefixSupply "undefined" = repeat "undefined"
infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])

doParen :: Bool -> String -> String
doParen False s = s
doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s

isSearchedVar :: Id -> G.HsExpr Id -> Bool
#if __GLASGOW_HASKELL__ >= 800
isSearchedVar i (G.HsVar (L _ i2)) = i == i2
#else
isSearchedVar i (G.HsVar i2) = i == i2
#endif
isSearchedVar _ _ = False


----------------------------------------------------------------
-- REFINE AUTOMATICALLY
----------------------------------------------------------------

auto :: IOish m
     => FilePath     -- ^ A target file.
     -> Int          -- ^ Line number.
     -> Int          -- ^ Column number.
     -> GhcModT m String
auto file lineNo colNo =
  ghandle handler $ runGmlT' [Left file] deferErrors $ do
        oopts <- outputOpts
        style <- getStyle
        dflag <- G.getSessionDynFlags
        modSum <- fileModSummaryWithMapping file
        p <- G.parseModule modSum
        tcm@TypecheckedModule {
                 tm_typechecked_source = tcs
               , tm_checked_module_info = minfo
               } <- G.typecheckModule p
        whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
          topLevel <- getEverythingInTopLevel minfo
          let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
              -- Remove self function to prevent recursion, and id to trim
              -- cases
              filterFn (n,_) = let funName = G.getOccString n
                                   recName = G.getOccString (G.getName f)
                               in funName `notElem` recName:notWantedFuns
              -- Find without using other functions in top-level
              localBnds = M.unions $
                  map (\(L _ pat) -> getBindingsForPat pat) pats
              lbn = filter filterFn (M.toList localBnds)
          djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000
          let -- Find with the entire top-level
              almostEnv = M.toList $ M.union localBnds topLevel
              env = filter filterFn almostEnv
          djinns <- djinn True (Just minfo) env rty (Max 10) 100000
          return ( fourInts loc
                 , map (doParen paren) $ nub (djinnsEmpty ++ djinns))
 where
   handler (SomeException ex) = do
     gmLog GmException "auto-refining" $
           text "" $$ nest 4 (showDoc ex)
     emptyResult =<< outputOpts

-- Functions we do not want in completions
notWantedFuns :: [String]
notWantedFuns = ["id", "asTypeOf", "const"]

-- Get all things defined in top-level
getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)
getEverythingInTopLevel m = do
  let modInfo  = tyThingsToInfo (G.modInfoTyThings m)
      topNames = G.modInfoTopLevelScope m
  case topNames of
    Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'
                         let topThings' = catMaybes topThings
                             topInfo    = tyThingsToInfo topThings'
                         return $ M.union modInfo topInfo
    Nothing -> return modInfo

tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type
tyThingsToInfo [] = M.empty
tyThingsToInfo (G.AnId i : xs) =
    M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)
-- Getting information about constructors is not needed
-- because they will be added by djinn-ghc when traversing types
-- #if __GLASGOW_HASKELL__ >= 708
-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]
-- #else
-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]
-- #endif
tyThingsToInfo (_:xs) = tyThingsToInfo xs

-- Find the Id of the function and the pattern where the hole is located
getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])
getPatsForVariable tcs (lineNo, colNo) =
  let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
   in case bnd of
        G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of
          Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
          _                     -> (error "This should never happen", [])
        G.FunBind { Ty.fun_id = L _ funId } ->
          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
#if __GLASGOW_HASKELL__ >= 708
                    :: [G.LMatch Id (G.LHsExpr Id)]
#else
                    :: [G.LMatch Id]
#endif
#if __GLASGOW_HASKELL__ >= 710
              (L _ (G.Match _ pats _ _):_) = m
#else
              (L _ (G.Match pats _ _):_) = m
#endif
           in (funId, pats)
        _ -> (error "This should never happen", [])

getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
#if __GLASGOW_HASKELL__ >= 800
getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)
#else
getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
#endif
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
    M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
#if __GLASGOW_HASKELL__ >= 708
getBindingsForPat (Ty.ListPat  l _ _) =
    M.unions $ map (\(L _ i) -> getBindingsForPat i) l
#else
getBindingsForPat (Ty.ListPat  l _)   =
    M.unions $ map (\(L _ i) -> getBindingsForPat i) l
#endif
getBindingsForPat (Ty.TuplePat l _ _) =
    M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.PArrPat  l _)   =
    M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.ConPatIn (L _ i) d) =
    M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
getBindingsForPat _ = M.empty

getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
#if __GLASGOW_HASKELL__ >= 800
getBindingsForRecPat (G.PrefixCon args) =
#else
getBindingsForRecPat (Ty.PrefixCon args) =
#endif
    M.unions $ map (\(L _ i) -> getBindingsForPat i) args
#if __GLASGOW_HASKELL__ >= 800
getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =
#else
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
#endif
    M.union (getBindingsForPat a1) (getBindingsForPat a2)
#if __GLASGOW_HASKELL__ >= 800
getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
#else
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
#endif
    getBindingsForRecFields (map unLoc' fields)
 where
#if __GLASGOW_HASKELL__ >= 710
   unLoc' = unLoc
#else
   unLoc' = id
#endif
   getBindingsForRecFields [] = M.empty
   getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
       M.union (getBindingsForPat a) (getBindingsForRecFields fs)