content: {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
  {-# LANGUAGE FlexibleInstances #-}
  
  module GhcMod.Exe.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 Prelude
  
  import Exception (ghandle, SomeException(..))
  import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
              SrcSpan, Type, GenLocated(L))
  import Pretty (($$), text, nest)
  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
  import qualified Language.Haskell.Exts as HE
  import Djinn.GHC
  
  import qualified GhcMod.Gap as Gap
  import GhcMod.Convert
  import GhcMod.DynFlags
  import GhcMod.Monad
  import GhcMod.SrcUtils
  import GhcMod.Logging (gmLog)
  import GhcMod.Pretty (showToDoc)
  import GhcMod.Doc
  import GhcMod.Types
  import 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__ >= 802
        [L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] ->
  #elif __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__ >= 802
        [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _ _)))] -> do
  #elif __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
  
                   HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ ->
                     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
  #if __GLASGOW_HASKELL__ >= 802
        ety <- G.exprType G.TM_Inst expr
  #else
        ety <- G.exprType expr
  #endif
        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 (showToDoc 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 (showToDoc 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)
  