From 88f61724d49a2b3c8979dec48433604f591de7f3 Mon Sep 17 00:00:00 2001
From: Nikolay Yakimov <root@livid.pp.ru>
Date: Mon, 18 Jan 2016 03:51:03 +0300
Subject: [PATCH] [Type-constraints] Proof-of-concept

---
 Language/Haskell/GhcMod/Gap.hs      |  2 ++
 Language/Haskell/GhcMod/Info.hs     | 26 +++++++++++++++++++++++---
 Language/Haskell/GhcMod/SrcUtils.hs |  8 ++++++++
 3 files changed, 33 insertions(+), 3 deletions(-)

diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs
index 48337e0..be770b6 100644
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/Language/Haskell/GhcMod/Gap.hs
@@ -316,11 +316,13 @@ setWarnTypedHoles = id
 ----------------------------------------------------------------
 
 class HasType a where
+    getId   :: GhcMonad m => TypecheckedModule -> a -> m ([Id])
     getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
 
 
 instance HasType (LHsBind Id) where
 #if __GLASGOW_HASKELL__ >= 708
+    getId _ b = return $ collectHsBindBinders (unLoc b)
     getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)
       where in_tys = mg_arg_tys m
             out_typ = mg_res_ty m
diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs
index 31a8eab..442c5de 100644
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -11,6 +11,7 @@ import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
 import Prelude
 import qualified GHC as G
+import qualified Var as G (varType)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 
 import Language.Haskell.GhcMod.Convert
@@ -23,6 +24,7 @@ import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
+import Control.Applicative
 
 ----------------------------------------------------------------
 
@@ -79,7 +81,25 @@ getSrcSpanType modSum lineNo colNo = do
   let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
       es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
       ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
-  bts <- mapM (getType tcm) bs
-  ets <- mapM (getType tcm) es
-  pts <- mapM (getType tcm) ps
+      as = concatMap abtoex $ listifyAbsBinds tcs
+      abtoex (G.L _spn G.AbsBinds{abs_exports = es'})
+        = liftA2 (,) G.abe_mono (G.varType . G.abe_poly) `map` es'
+      abtoex _ = []
+      getType' b = getType tcm b >>= tryGetConstrainedType b
+      tryGetConstrainedType _ Nothing = return Nothing
+      tryGetConstrainedType b (Just gt) =
+        do
+          ids <- getId tcm b
+          return $ ct ids <|> Just gt
+        where
+          ct [pid] = (,) (fst gt) <$> lookup pid as
+          -- TODO: A case of multiple ids should probably
+          -- collect all constraints and then apply
+          -- them to calculated type. No idea how
+          -- to do that at the moment.
+          ct _     = Nothing
+
+  ets <- mapM getType' es
+  bts <- mapM getType' bs
+  pts <- mapM getType' ps
   return $ catMaybes $ concat [ets, bts, pts]
diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs
index 0938f81..5571c95 100644
--- a/Language/Haskell/GhcMod/SrcUtils.hs
+++ b/Language/Haskell/GhcMod/SrcUtils.hs
@@ -24,12 +24,14 @@ import Prelude
 ----------------------------------------------------------------
 
 instance HasType (LHsExpr Id) where
+    getId _ _e = return []
     getType tcm e = do
         hs_env <- G.getSession
         mbe <- liftIO $ Gap.deSugar tcm e hs_env
         return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
 
 instance HasType (LPat Id) where
+    getId _ = return . G.collectPatBinders
     getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
 
 ----------------------------------------------------------------
@@ -39,6 +41,12 @@ listifySpans tcs lc = listifyStaged TypeChecker p tcs
   where
     p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
 
+listifyAbsBinds :: TypecheckedSource -> [Located (G.HsBind Id)]
+listifyAbsBinds = listifyStaged TypeChecker p
+  where
+    p (L _ G.AbsBinds{}) = True
+    p _                  = False
+
 listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
 listifyParsedSpans pcs lc = listifyStaged Parser p pcs
   where