From 966c694dbf9133064c5fc3996eefc51afc3585f7 Mon Sep 17 00:00:00 2001
From: Nikolay Yakimov <root@livid.pp.ru>
Date: Mon, 18 Jan 2016 07:03:05 +0300
Subject: [PATCH] [Type-constraints] Initial attempt at compounds

I try to compute constraints for "compound" types.
While constraint-building itself is simple, types
do not match due to different representation
between 'internal' and 'exported' signatures.
---
 Language/Haskell/GhcMod/Info.hs | 23 ++++++++++++++++++++---
 1 file changed, 20 insertions(+), 3 deletions(-)

diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs
index 442c5de..befc8e5 100644
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -5,10 +5,10 @@ module Language.Haskell.GhcMod.Info (
 
 import Data.Function (on)
 import Data.List (sortBy)
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, mapMaybe)
 import System.FilePath
 import Exception (ghandle, SomeException(..))
-import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
+import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan)
 import Prelude
 import qualified GHC as G
 import qualified Var as G (varType)
@@ -25,6 +25,8 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
 import Control.Applicative
+import Type
+import Control.Arrow
 
 ----------------------------------------------------------------
 
@@ -93,11 +95,26 @@ getSrcSpanType modSum lineNo colNo = do
           return $ ct ids <|> Just gt
         where
           ct [pid] = (,) (fst gt) <$> lookup pid as
+          ct []    = Nothing
           -- 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
+          -- NB: The following does not work, since
+          -- "inner" types have different IDs from
+          -- exported types. So we need some sort of
+          -- type substitution.
+          ct pids  =
+            let
+              ctys  = mapMaybe (`lookup` as) pids
+              preds = concatMap (fst . getPreds) ctys
+              --typs  = map (snd . getPreds) ctys
+              ty    = mkFunTys preds $ snd gt
+            in Just (fst gt, ty)
+          getPreds x | isForAllTy x = getPreds $ dropForAlls x
+                     | Just (c, t) <- splitFunTy_maybe x
+                     , isPredTy c = first (c:) $ getPreds t
+                     | otherwise = ([], x)
 
   ets <- mapM getType' es
   bts <- mapM getType' bs