From 9e81f6efcdb3b034e15de394b138118d9c62b499 Mon Sep 17 00:00:00 2001
From: Isaac Dupree <id@isaac.cedarswampstudios.org>
Date: Tue, 18 Aug 2009 02:11:05 +0000
Subject: switch AttachInstances to use synify code It changed an instance from
 showing ((,) a b) to (a, b) because my synify code is more sophisticated; I
 hope the latter is a good thing rather than a bad thing aesthetically, here.

But this definitely reduces code duplication!
---
 src/Haddock/Interface/AttachInstances.hs | 43 +++++---------------------------
 1 file changed, 6 insertions(+), 37 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 1f45be01..9da78108 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -14,6 +14,7 @@ module Haddock.Interface.AttachInstances (attachInstances) where
 
 
 import Haddock.Types
+import Haddock.Convert
 
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -121,41 +122,9 @@ funTyConName = mkWiredInName gHC_PRIM
 
 
 toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) 
+toHsInstHead (_, preds, cls, ts) =
+        ( map (unLoc . synifyPred) preds
+        , getName cls
+        , map (unLoc . synifyType WithinType) ts
+        )
 
-
---------------------------------------------------------------------------------
--- Type -> HsType conversion
---------------------------------------------------------------------------------
-
-
-toHsPred :: PredType -> HsPred Name
-toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
-toHsPred (IParam n t) = HsIParam n (toLHsType t)
-toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2)
-
-
-toLHsType :: Type -> Located (HsType Name)
-toLHsType = noLoc . toHsType
-
- 
-toHsType :: Type -> HsType Name
-toHsType t = case t of 
-  TyVarTy v -> HsTyVar (tyVarName v) 
-  AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
-
-  TyConApp tc ts -> case ts of 
-    t1:t2:rest
-      | isSymOcc . nameOccName . tyConName $ tc ->
-          app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest
-    _ -> app (tycon tc) ts
-
-  FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
-  ForAllTy v ty -> cvForAll [v] ty 
-  PredTy p -> HsPredTy (toHsPred p) 
-  where
-    tycon = HsTyVar . tyConName
-    app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType
-    cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty
-    cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty)
-    tyvarbinders = map (noLoc . UserTyVar . tyVarName)
-- 
cgit v1.2.3