Add kind equalities to GHC.

This implements the ideas originally put forward in
"System FC with Explicit Kind Equality" (ICFP'13).

There are several noteworthy changes with this patch:
 * We now have casts in types. These change the kind
   of a type. See new constructor `CastTy`.

 * All types and all constructors can be promoted.
   This includes GADT constructors. GADT pattern matches
   take place in type family equations. In Core,
   types can now be applied to coercions via the
   `CoercionTy` constructor.

 * Coercions can now be heterogeneous, relating types
   of different kinds. A coercion proving `t1 :: k1 ~ t2 :: k2`
   proves both that `t1` and `t2` are the same and also that
   `k1` and `k2` are the same.

 * The `Coercion` type has been significantly enhanced.
   The documentation in `docs/core-spec/core-spec.pdf` reflects
   the new reality.

 * The type of `*` is now `*`. No more `BOX`.

 * Users can write explicit kind variables in their code,
   anywhere they can write type variables. For backward compatibility,
   automatic inference of kind-variable binding is still permitted.

 * The new extension `TypeInType` turns on the new user-facing
   features.

 * Type families and synonyms are now promoted to kinds. This causes
   trouble with parsing `*`, leading to the somewhat awkward new
   `HsAppsTy` constructor for `HsType`. This is dispatched with in
   the renamer, where the kind `*` can be told apart from a
   type-level multiplication operator. Without `-XTypeInType` the
   old behavior persists. With `-XTypeInType`, you need to import
   `Data.Kind` to get `*`, also known as `Type`.

 * The kind-checking algorithms in TcHsType have been significantly
   rewritten to allow for enhanced kinds.

 * The new features are still quite experimental and may be in flux.

 * TODO: Several open tickets: #11195, #11196, #11197, #11198, #11203.

 * TODO: Update user manual.

Tickets addressed: #9017, #9173, #7961, #10524, #8566, #11142.
Updates Haddock submodule.

6 files changed, 254 insertions, 223 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 4decbe12bb..342bc35679 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -446,9 +446,9 @@ cvtConstr (ForallC tvs ctxt con)
         ; let qvars = case (tvs,con_qvars con') of
                 ([],Nothing) -> Nothing
                 _  ->
-                  Just $ mkHsQTvs (hsQTvBndrs tvs' ++
-                                   hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder [])
-                                              (con_qvars con')))
+                  Just $ mkHsQTvs (hsQTvExplicit tvs' ++
+                                   hsQTvExplicit (fromMaybe (HsQTvs PlaceHolder [])
+                                                            (con_qvars con')))
         ; returnL $ con' { con_qvars = qvars
                          , con_cxt = Just $
                                      L loc (ctxt' ++
@@ -482,9 +482,9 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
                          ; return (mkLHsSigType ty) }
 
 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
-                               ; ys' <- mapM tName ys
-                               ; returnL (map noLoc xs', map noLoc ys') }
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
+                               ; ys' <- mapM tNameL ys
+                               ; returnL (xs', ys') }
 
 
 ------------------------------------------
@@ -785,7 +785,7 @@ the trees to reflect the fixities of the underlying operators:
 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
 right-biased for types and left-biased for everything else. So we left-bias the
-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
+trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
 
 Sample input:
 
@@ -1004,12 +1004,12 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm)
-  = do { nm' <- tName nm
-       ; returnL $ UserTyVar (noLoc nm') }
+  = do { nm' <- tNameL nm
+       ; returnL $ UserTyVar nm' }
 cvt_tv (TH.KindedTV nm ki)
-  = do { nm' <- tName nm
+  = do { nm' <- tNameL nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar (noLoc nm') ki' }
+       ; returnL $ KindedTyVar nm' ki' }
 
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
@@ -1054,8 +1054,8 @@ cvtTypeKind ty_str ty
              | [x']    <- tys' -> returnL (HsListTy x')
              | otherwise
                         -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys'
-           VarT nm -> do { nm' <- tName nm
-                         ; mk_apps (HsTyVar (noLoc nm')) tys' }
+           VarT nm -> do { nm' <- tNameL nm
+                         ; mk_apps (HsTyVar nm') tys' }
            ConT nm -> do { nm' <- tconName nm
                          ; mk_apps (HsTyVar (noLoc nm')) tys' }
 
@@ -1066,7 +1066,7 @@ cvtTypeKind ty_str ty
                    ; ty'  <- cvtType ty
                    ; loc <- getL
                    ; let hs_ty | null tvs  = rho_ty
-                               | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs'
+                               | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
                                                                , hst_body  = rho_ty })
                          rho_ty | null cxt  = ty'
                                 | otherwise = L loc (HsQualTy { hst_ctxt = cxt'
@@ -1087,8 +1087,8 @@ cvtTypeKind ty_str ty
              -> mk_apps mkAnonWildCardTy tys'
 
            WildCardT (Just nm)
-             -> do { nm' <- tName nm
-                   ; mk_apps (mkNamedWildCardTy (noLoc nm')) tys' }
+             -> do { nm' <- tNameL nm
+                   ; mk_apps (mkNamedWildCardTy nm') tys' }
 
            InfixT t1 s t2
              -> do { s'  <- tconName s
@@ -1098,8 +1098,10 @@ cvtTypeKind ty_str ty
                    }
 
            UInfixT t1 s t2
-             -> do { t2' <- cvtType t2
-                   ; cvtOpAppT t1 s t2'
+             -> do { t1' <- cvtType t1
+                   ; t2' <- cvtType t2
+                   ; s'  <- tconName s
+                   ; return $ cvtOpAppT t1' s' t2'
                    } -- Note [Converting UInfix]
 
            ParensT t
@@ -1157,23 +1159,26 @@ split_ty_app ty = go ty []
     go f as           = return (f,as)
 
 cvtTyLit :: TH.TyLit -> HsTyLit
-cvtTyLit (NumTyLit i) = HsNumTy (show i) i
-cvtTyLit (StrTyLit s) = HsStrTy s        (fsLit s)
-
-{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
-application @x `op` y@. The produced tree of infix types will be right-biased,
-provided @y@ is.
+cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i
+cvtTyLit (TH.StrTyLit s) = HsStrTy s        (fsLit s)
 
-See the @cvtOpApp@ documentation for how this function works.
+{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
+   structure in them.
 -}
-cvtOpAppT :: TH.Type -> TH.Name -> LHsType RdrName -> CvtM (LHsType RdrName)
-cvtOpAppT (UInfixT x op2 y) op1 z
-  = do { l <- cvtOpAppT y op1 z
-       ; cvtOpAppT x op2 l }
-cvtOpAppT x op y
-  = do { op' <- tconNameL op
-       ; x' <- cvtType x
-       ; returnL (mkHsOpTy x' op' y) }
+cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
+cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
+  = L (combineSrcSpans loc1 loc2) $
+    HsAppsTy (t1' ++ [HsAppInfix (noLoc op)] ++ t2')
+  where
+    t1' | L _ (HsAppsTy t1s) <- t1
+        = t1s
+        | otherwise
+        = [HsAppPrefix t1]
+
+    t2' | L _ (HsAppsTy t2s) <- t2
+        = t2s
+        | otherwise
+        = [HsAppPrefix t2]
 
 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
 cvtKind = cvtTypeKind "kind"
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 48348cc2e1..3f49f42a0e 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -46,7 +46,7 @@ module HsDecls (
   -- ** @RULE@ declarations
   LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
-  flattenRuleDecls,
+  flattenRuleDecls, pprFullRuleName,
   -- ** @VECTORISE@ declarations
   VectDecl(..), LVectDecl,
   lvectDeclName, lvectInstDecl,
@@ -638,7 +638,7 @@ countTyClDecls decls
 
 -- | Does this declaration have a complete, user-supplied kind signature?
 -- See Note [Complete user-supplied kind signatures]
-hsDeclHasCusk :: TyClDecl name -> Bool
+hsDeclHasCusk :: TyClDecl Name -> Bool
 hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl
 hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
   = hsTvbAllKinded tyvars && rhs_annotated rhs
@@ -1060,14 +1060,19 @@ getConNames :: ConDecl name -> [Located name]
 getConNames ConDeclH98  {con_name  = name}  = [name]
 getConNames ConDeclGADT {con_names = names} = names
 
+-- don't call with RdrNames, because it can't deal with HsAppsTy
 getConDetails :: ConDecl name -> HsConDeclDetails name
 getConDetails ConDeclH98  {con_details  = details} = details
 getConDetails ConDeclGADT {con_type     = ty     } = details
   where
     (details,_,_,_) = gadtDeclDetails ty
 
+-- don't call with RdrNames, because it can't deal with HsAppsTy
 gadtDeclDetails :: LHsSigType name
-     -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name])
+                -> ( HsConDeclDetails name
+                   , LHsType name
+                   , LHsContext name
+                   , [LHsTyVarBndr name] )
 gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
   where
     (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
@@ -1635,12 +1640,15 @@ deriving instance (DataId name) => Data (RuleBndr name)
 collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
+pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
+pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n
+
 instance OutputableBndr name => Outputable (RuleDecls name) where
   ppr (HsRules _ rules) = ppr rules
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
-        = sep [text "{-# RULES" <+> doubleQuotes (ftext $ snd $ unLoc name)
+        = sep [text "{-# RULES" <+> pprFullRuleName name
                                 <+> ppr act,
                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index c5afa7410f..6e02df7438 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -594,7 +594,6 @@ in the ParsedSource.
 There are unfortunately enough differences between the ParsedSource and the
 RenamedSource that the API Annotations cannot be used directly with
 RenamedSource, so this allows a simple mapping to be used based on the location.
->>>>>>> origin/master
 -}
 
 instance OutputableBndr id => Outputable (HsExpr id) where
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 91e5973ece..0f65e4b297 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -153,10 +153,11 @@ data Pat id
                                         --   Use (conLikeResTy pat_con pat_arg_tys) to get
                                         --   the type of the pattern
 
-        pat_tvs   :: [TyVar],           -- Existentially bound type variables (tyvars only)
+        pat_tvs   :: [TyVar],           -- Existentially bound type variables
         pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                         -- One reason for putting coercion variable here, I think,
                                         --      is to ensure their kinds are zonked
+
         pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
         pat_args  :: HsConPatDetails id,
         pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
@@ -236,6 +237,12 @@ hsConPatArgs (PrefixCon ps)   = ps
 hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
 
+instance (Outputable arg, Outputable rec)
+         => Outputable (HsConDetails arg rec) where
+  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
+
 {-
 However HsRecFields is used only for patterns and expressions
 (not data type declarations)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 8bcdc6aac1..df2f0f36f3 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -18,7 +18,6 @@ HsTypes: Abstract syntax: user-defined types
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
-        HsTyOp,LHsTyOp,
         HsTyVarBndr(..), LHsTyVarBndr,
         LHsQTyVars(..),
         HsImplicitBndrs(..),
@@ -26,9 +25,9 @@ module HsTypes (
         LHsSigType, LHsSigWcType, LHsWcType,
         HsTupleSort(..),
         HsContext, LHsContext,
-        HsTyWrapper(..),
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
+        HsAppType(..),
 
         LBangType, BangType,
         HsSrcBang(..), HsImplBang(..),
@@ -48,18 +47,17 @@ module HsTypes (
 
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
-        mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
+        mkHsQTvs, hsQTvExplicit, isHsKindedTyVar, hsTvbAllKinded,
         hsScopedTvs, hsWcScopedTvs, dropWildCards,
-        hsTyVarName, hsLKiTyVarNames,
-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName,
-        splitLHsInstDeclTy, getLHsInstDeclClass_maybe,
+        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
+        hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
+        splitLHsInstDeclTy,
         splitLHsPatSynTy,
         splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
-        splitLHsClassTy_maybe,
-        splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe,
-        mkHsAppTys, mkHsOpTy,
+        splitHsFunType, splitHsAppTys,
+        mkHsOpTy,
         ignoreParens, hsSigType, hsSigWcType,
-        hsLTyVarBndrsToTypes,
+        hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
         -- Printing
         pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
@@ -70,9 +68,9 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
 import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
-import Id( Id )
+import Id ( Id )
 import Name( Name )
-import RdrName( RdrName )
+import RdrName ( RdrName )
 import DataCon( HsSrcBang(..), HsImplBang(..),
                 SrcStrictness(..), SrcUnpackedness(..) )
 import TysPrim( funTyConName )
@@ -87,10 +85,6 @@ import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
-#if __GLASGOW_HASKELL__ < 709
--- SPJ temp
--- import Data.Monoid hiding((<>))
-#endif
 #if __GLASGOW_HASKELL > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
@@ -208,8 +202,8 @@ type LHsTyVarBndr name = Located (HsTyVarBndr name)
                          -- See Note [HsType binders]
 
 data LHsQTyVars name   -- See Note [HsType binders]
-  = HsQTvs { hsq_kvs :: PostRn name [Name]      -- Kind variables
-           , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
+  = HsQTvs { hsq_implicit :: PostRn name [Name]      -- implicit (dependent) variables
+           , hsq_explicit :: [LHsTyVarBndr name]     -- explicit variables
              -- See Note [HsForAllTy tyvar binders]
     }
   deriving( Typeable )
@@ -217,23 +211,10 @@ data LHsQTyVars name   -- See Note [HsType binders]
 deriving instance (DataId name) => Data (LHsQTyVars name)
 
 mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName
-mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs }
-
-hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name]
-hsQTvBndrs = hsq_tvs
-
-{-
-#if __GLASGOW_HASKELL__ > 710
-instance Semigroup (LHsTyVarBndrs name) where
-  HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2
-    = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
-#endif
+mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs }
 
-instance Monoid (LHsQTyVars name) where
-  mempty = mkHsQTvs []
-  mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
-    = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
--}
+hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name]
+hsQTvExplicit = hsq_explicit
 
 ------------------------------------------------
 --            HsImplicitBndrs
@@ -245,8 +226,7 @@ instance Monoid (LHsQTyVars name) where
 -- In the last of these, wildcards can happen, so we must accommodate them
 
 data HsImplicitBndrs name thing   -- See Note [HsType binders]
-  = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars
-         , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars
+  = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars
          , hsib_body :: thing              -- Main payload (type or list of types)
     }
   deriving (Typeable)
@@ -305,8 +285,7 @@ A HsSigType is just a HsImplicitBndrs wrapping a LHsType.
 E.g. For a signature like
    f :: forall (a::k). blah
 we get
-   HsIB { hsib_kvs = [k]
-        , hsib_tvs = []
+   HsIB { hsib_vars = [k]
         , hsib_body = HsForAllTy { hst_bndrs = [(a::*)]
                                  , hst_body = blah }
 The implicit kind variable 'k' is bound by the HsIB;
@@ -315,8 +294,7 @@ the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy
 
 mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing
 mkHsImplicitBndrs x = HsIB { hsib_body = x
-                           , hsib_kvs = PlaceHolder
-                           , hsib_tvs = PlaceHolder }
+                           , hsib_vars = PlaceHolder }
 
 mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing
 mkHsWildCardBndrs x = HsWC { hswc_body = x
@@ -327,8 +305,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x
 -- the wrapped thing had free type variables?
 mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing
 mkEmptyImplicitBndrs x = HsIB { hsib_body = x
-                              , hsib_kvs = []
-                              , hsib_tvs = [] }
+                              , hsib_vars = [] }
 
 mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing
 mkEmptyWildCardBndrs x = HsWC { hswc_body = x
@@ -374,9 +351,9 @@ isHsKindedTyVar :: HsTyVarBndr name -> Bool
 isHsKindedTyVar (UserTyVar {})   = False
 isHsKindedTyVar (KindedTyVar {}) = True
 
--- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations?
+-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
 hsTvbAllKinded :: LHsQTyVars name -> Bool
-hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
+hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
 
 data HsType name
   = HsForAllTy   -- See Note [HsType binders]
@@ -399,6 +376,10 @@ data HsType name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
+  | HsAppsTy            [HsAppType name]  -- Used only before renaming,
+                                          -- Note [HsAppsTy]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
   | HsAppTy             (LHsType name)
                         (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
@@ -430,7 +411,7 @@ data HsType name
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
+  | HsOpTy              (LHsType name) (Located name) (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
@@ -524,11 +505,6 @@ data HsType name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-
-      -- For details on above see note [Api annotations] in ApiAnnotation
-
   | HsWildCardTy (HsWildCardInfo name)  -- A type wildcard
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
@@ -543,15 +519,8 @@ data HsTyLit
   | HsStrTy SourceText FastString
     deriving (Data, Typeable)
 
-data HsTyWrapper
-  = WpKiApps [Kind]  -- kind instantiation: [] k1 k2 .. kn
-  deriving (Data, Typeable)
-
-type LHsTyOp name = HsTyOp (Located name)
-type HsTyOp name = (HsTyWrapper, name)
-
 mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
-mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
+mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
 
 data HsWildCardInfo name
     = AnonWildCard (PostRn name (Located Name))
@@ -562,6 +531,15 @@ data HsWildCardInfo name
     deriving (Typeable)
 deriving instance (DataId name) => Data (HsWildCardInfo name)
 
+data HsAppType name
+  = HsAppInfix (Located name)       -- either a symbol or an id in backticks
+  | HsAppPrefix (LHsType name)      -- anything else, including things like (+)
+  deriving (Typeable)
+deriving instance (DataId name) => Data (HsAppType name)
+
+instance OutputableBndr name => Outputable (HsAppType name) where
+  ppr = ppr_app_ty TopPrec
+
 {-
 Note [HsForAllTy tyvar binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -580,7 +558,7 @@ Note [Context quantification] in RnTypes, and Trac #4426.
 In GHC 7.12, Qualified will no longer bind variables
 and this will become an error.
 
-The kind variables bound in the hsq_kvs field come both
+The kind variables bound in the hsq_implicit field come both
   a) from the kind signatures on the kind vars (eg k1)
   b) from the scope of the forall (eg k2)
 Example:   f :: forall (a::k1) b. T a (b::k2)
@@ -614,6 +592,16 @@ HsTyVar: A name in a type or kind.
       Tv: kind variable
       TcCls: kind constructor or promoted type constructor
 
+Note [HsAppsTy]
+~~~~~~~~~~~~~~~
+How to parse
+
+  Foo * Int
+
+? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming.
+So we just take type expressions like this and put each component in a list, so be
+sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means
+that the parser should never produce HsAppTy or HsOpTy.
 
 Note [Promoted lists and tuples]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -777,17 +765,23 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name]
 --  - the named wildcars; see Note [Scoping of named wildcards]
 -- because they scope in the same way
 hsWcScopedTvs sig_ty
-  | HsIB { hsib_kvs = kvs,  hsib_body = sig_ty1 } <- sig_ty
+  | HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty
   , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1
-  , (tvs, _) <- splitLHsForAllTy sig_ty2
-  = kvs ++ nwcs ++ map hsLTyVarName tvs
+  = case sig_ty2 of
+      L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
+                                              map hsLTyVarName tvs
+               -- include kind variables only if the type is headed by forall
+               -- (this is consistent with GHC 7 behaviour)
+      _                                    -> nwcs
 
 hsScopedTvs :: LHsSigType Name -> [Name]
 -- Same as hsWcScopedTvs, but for a LHsSigType
 hsScopedTvs sig_ty
-  | HsIB { hsib_kvs = kvs,  hsib_body = sig_ty2 } <- sig_ty
-  , (tvs, _) <- splitLHsForAllTy sig_ty2
-  = kvs ++ map hsLTyVarName tvs
+  | HsIB { hsib_vars = vars,  hsib_body = sig_ty2 } <- sig_ty
+  , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
+  = vars ++ map hsLTyVarName tvs
+  | otherwise
+  = []
 
 {- Note [Scoping of named wildcards]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -810,31 +804,32 @@ hsTyVarName (KindedTyVar (L _ n) _) = n
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
-hsLTyVarNames :: LHsQTyVars name -> [name]
--- Type variables only
-hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
+hsExplicitLTyVarNames :: LHsQTyVars name -> [name]
+-- Explicit variables only
+hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
 
-hsLKiTyVarNames :: LHsQTyVars Name -> [Name]
--- Kind and type variables
-hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
+hsAllLTyVarNames :: LHsQTyVars Name -> [Name]
+-- All variables
+hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
   = kvs ++ map hsLTyVarName tvs
 
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
--- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell
--- quoting for type family equations.
+hsLTyVarLocNames :: LHsQTyVars name -> [Located name]
+hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
+
+-- | Convert a LHsTyVarBndr to an equivalent LHsType.
 hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
 hsLTyVarBndrToType = fmap cvt
   where cvt (UserTyVar n)                     = HsTyVar n
         cvt (KindedTyVar (L name_loc n) kind)
                    = HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind
 
--- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell
--- quoting for type family equations. Works on *type* variable only, no kind
--- vars.
+-- | Convert a LHsTyVarBndrs to a list of types.
+-- Works on *type* variable only, no kind vars.
 hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name]
-hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs
+hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
 
 ---------------------
 mkAnonWildCardTy :: HsType RdrName
@@ -871,34 +866,12 @@ sameNamedWildCard (L _  (NamedWildCard (L _ n1)))
                   (L _  (NamedWildCard (L _ n2))) = n1 == n2
 sameNamedWildCard _ _ = False
 
-splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
+splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name])
+  -- no need to worry about HsAppsTy here
 splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
 splitHsAppTys (L _ (HsParTy f))   as = splitHsAppTys f as
 splitHsAppTys f                   as = (f,as)
 
--- retrieve the name of the "head" of a nested type application
--- somewhat like splitHsAppTys, but a little more thorough
--- used to examine the result of a GADT-like datacon, so it doesn't handle
--- *all* cases (like lists, tuples, (~), etc.)
-hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n])
-hsTyGetAppHead_maybe = go []
-  where
-    go tys (L _ (HsTyVar (L _ n)))       = Just (n, tys)
-    go tys (L _ (HsAppTy l r))           = go (r : tys) l
-    go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys)
-    go tys (L _ (HsParTy t))             = go tys t
-    go tys (L _ (HsKindSig t _))         = go tys t
-    go _   _                             = Nothing
-
-mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
-mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
-mkHsAppTys fun_ty (arg_ty:arg_tys)
-  = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
-  where
-    mk_app fun arg = HsAppTy (noLoc fun) arg
-       -- Add noLocs for inner nodes of the application;
-       -- they are never used
-
 splitLHsPatSynTy :: LHsType name
                  -> ( [LHsTyVarBndr name]
                     , LHsContext name        -- Required
@@ -935,39 +908,14 @@ splitLHsInstDeclTy
     :: LHsSigType Name
     -> ([Name], LHsContext Name, LHsType Name)
         -- Split up an instance decl type, returning the pieces
-splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs
+splitLHsInstDeclTy (HsIB { hsib_vars = itkvs
                          , hsib_body = inst_ty })
-  = (ikvs ++ itvs, cxt, body_ty)
+  = (itkvs, cxt, body_ty)
          -- Return implicitly bound type and kind vars
          -- For an instance decl, all of them are in scope
   where
     (cxt, body_ty) = splitLHsQualTy inst_ty
 
-getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name)
--- Works on (HsSigType RdrName)
-getLHsInstDeclClass_maybe inst_ty
-  = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty)
-       ; (cls, _) <- splitLHsClassTy_maybe tau
-       ; return cls }
-
-splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
--- Watch out.. in ...deriving( Show )... we use this on
--- the list of partially applied predicates in the deriving,
--- so there can be zero args.
---
--- In TcDeriv we also use this to figure out what data type is being
--- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo").
-splitLHsClassTy_maybe ty
-  = checkl ty []
-  where
-    checkl (L _ ty) args = case ty of
-        HsTyVar (L lt t)       -> Just (L lt t, args)
-        HsAppTy l r            -> checkl l (r:args)
-        HsOpTy l (_,L lt tc) r -> checkl (L lt (HsTyVar (L lt tc))) (l:r:args)
-        HsParTy t              -> checkl t args
-        HsKindSig ty _         -> checkl ty args
-        _                      -> Nothing
-
 -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
 -- Breaks up any parens in the result type:
 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
@@ -994,10 +942,10 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
 
 splitHsFunType other = ([], other)
 
-
 ignoreParens :: LHsType name -> LHsType name
-ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
-ignoreParens ty                 = ty
+ignoreParens (L _ (HsParTy ty))                = ignoreParens ty
+ignoreParens (L _ (HsAppsTy [HsAppPrefix ty])) = ignoreParens ty
+ignoreParens ty                                = ty
 
 {-
 ************************************************************************
@@ -1013,9 +961,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (OutputableBndr name)
-      => Outputable (LHsQTyVars name) where
-    ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs
+instance (OutputableBndr name) => Outputable (LHsQTyVars name) where
+    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar n)     = ppr n
@@ -1103,16 +1050,14 @@ seems like the Right Thing anyway.)
 
 pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
 
-pprHsType ty       = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty)
+pprHsType ty       = ppr_mono_ty TopPrec (prepare ty)
 pprParendHsType ty = ppr_mono_ty TyConPrec ty
 
--- Before printing a type
--- (a) Remove outermost HsParTy parens
--- (b) Drop top-level for-all type variables in user style
---     since they are implicit in Haskell
-prepare :: PprStyle -> HsType name -> HsType name
-prepare sty (HsParTy ty)          = prepare sty (unLoc ty)
-prepare _   ty                    = ty
+-- Before printing a type, remove outermost HsParTy parens
+prepare :: HsType name -> HsType name
+prepare (HsParTy ty)                      = prepare (unLoc ty)
+prepare (HsAppsTy [HsAppPrefix (L _ ty)]) = prepare ty
+prepare ty                                = ty
 
 ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
@@ -1146,34 +1091,22 @@ ppr_mono_ty _    (HsTyLit t)         = ppr_tylit t
 ppr_mono_ty _    (HsWildCardTy (AnonWildCard _))     = char '_'
 ppr_mono_ty _    (HsWildCardTy (NamedWildCard name)) = ppr name
 
-ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
-  = ppr_mono_ty ctxt_prec ty
--- We are not printing kind applications. If we wanted to do so, we should do
--- something like this:
-{-
-  = go ctxt_prec kis ty
-  where
-    go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
-    go ctxt_prec (ki:kis) ty
-      = maybeParen ctxt_prec TyConPrec $
-        hsep [ go FunPrec kis ty
-             , ptext (sLit "@") <> pprParendKind ki ]
--}
-
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
   = maybeParen ctxt_prec TyOpPrec $
     ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
 
+ppr_mono_ty ctxt_prec (HsAppsTy tys)
+  = maybeParen ctxt_prec TyConPrec $
+    hsep (map (ppr_app_ty TopPrec) tys)
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec TyConPrec $
     hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2)
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2)
   = maybeParen ctxt_prec TyOpPrec $
     sep [ ppr_mono_lty TyOpPrec ty1
         , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]
-    -- Don't print the wrapper (= kind applications)
-    -- c.f. HsWrapTy
 
 ppr_mono_ty _         (HsParTy ty)
   = parens (ppr_mono_lty TopPrec ty)
@@ -1197,6 +1130,12 @@ ppr_fun_ty ctxt_prec ty1 ty2
     sep [p1, ptext (sLit "->") <+> p2]
 
 --------------------------
+ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc
+ppr_app_ty _    (HsAppInfix (L _ n))                  = pprInfixOcc n
+ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n
+ppr_app_ty ctxt (HsAppPrefix ty)                      = ppr_mono_lty ctxt ty
+
+--------------------------
 ppr_tylit :: HsTyLit -> SDoc
 ppr_tylit (HsNumTy _ i) = integer i
 ppr_tylit (HsStrTy _ s) = text (show s)
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ca3cae5260..fb969ebff1 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -51,9 +51,11 @@ module HsUtils(
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
   -- Types
-  mkHsAppTy, userHsTyVarBndrs,
+  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
   mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
+  getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppsTy,
+  getLHsInstDeclClass_maybe,
 
   -- Stmts
   mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
@@ -92,13 +94,12 @@ import HsTypes
 import HsLit
 import PlaceHolder
 
-import TcType( tcSplitForAllTys, tcSplitPhiTy )
 import TcEvidence
 import RdrName
 import Var
-import Type( isPredTy )
-import Kind( isKind )
-import TypeRep
+import TyCoRep
+import Type   ( filterOutInvisibleTypes )
+import TcType
 import DataCon
 import Name
 import NameSet
@@ -171,6 +172,9 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 
+mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name
+mkHsAppTys = foldl mkHsAppTy
+
 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
@@ -335,10 +339,15 @@ mkHsStringPrimLit fs
   = HsStringPrim (unpackFS fs) (fastStringToByteString fs)
 
 -------------
-userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
+userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name]
+-- Caller sets location
+userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
+
+userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]
 -- Caller sets location
 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
 
+
 {-
 ************************************************************************
 *                                                                      *
@@ -548,24 +557,27 @@ toLHsSigWcType ty
   = mkLHsSigWcType (go ty)
   where
     go :: Type -> LHsType RdrName
-    go ty@(ForAllTy {})
-      | (tvs, tau) <- tcSplitForAllTys ty
-      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
-                          , hst_body = go tau })
-    go ty@(FunTy arg _)
+    go ty@(ForAllTy (Anon arg) _)
       | isPredTy arg
       , (theta, tau) <- tcSplitPhiTy ty
       = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                         , hst_body = go tau })
-    go (FunTy arg res)      = nlHsFunTy (go arg) (go res)
+    go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res)
+    go ty@(ForAllTy {})
+      | (tvs, tau) <- tcSplitForAllTys ty
+      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+                          , hst_body = go tau })
     go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
     go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
     go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
     go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
     go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
        where
-         args' = filterOut isKind args
-         -- Source-language types have _implicit_ kind arguments,
+         args' = filterOutInvisibleTypes tc args
+    go (CastTy ty _)        = go ty
+    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)
+
+         -- Source-language types have _invisible_ kind arguments,
          -- so we must remove them here (Trac #8563)
 
     go_tv :: TyVar -> LHsTyVarBndr RdrName
@@ -956,20 +968,23 @@ hsConDeclsBinders cons = go id cons
              L loc (ConDeclGADT { con_names = names
                                 , con_type = HsIB { hsib_body = res_ty}}) ->
                case tau of
+                 L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _res_ty)
+                         -> record_gadt flds
                  L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-                         -> (map (L loc . unLoc) names ++ ns, r' ++ fs)
-                            where r' = remSeen (concatMap (cd_fld_names . unLoc)
-                                                          flds)
-                                  remSeen'
-                                    = foldr (.) remSeen
-                                        [deleteBy ((==) `on`
-                                                  rdrNameFieldOcc . unLoc) v
-                                        | v <- r']
-                                  (ns, fs) = go remSeen' rs
+                         -> record_gadt flds
+
                  _other  -> (map (L loc . unLoc) names ++ ns, fs)
                             where (ns, fs) = go remSeen rs
-                 where
-                   (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
+               where
+                 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
+                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
+                   where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
+                         remSeen' = foldr (.) remSeen
+                                        [deleteBy ((==) `on`
+                                                   rdrNameFieldOcc . unLoc) v
+                                        | v <- r']
+                         (ns, fs) = go remSeen' rs
+
              L loc (ConDeclH98 { con_name = name
                                , con_details = RecCon flds }) ->
                ([L loc (unLoc name)] ++ ns, r' ++ fs)
@@ -1080,3 +1095,61 @@ lPatImplicits = hs_lpat
                                                                      (unLoc fld)
                                                           pat_explicit = maybe True (i<) (rec_dotdot fs)]
     details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
+
+{-
+************************************************************************
+*                                                                      *
+   Dealing with HsAppsTy
+*                                                                      *
+************************************************************************
+-}
+
+-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
+-- without consulting fixities.
+getAppsTyHead_maybe :: [HsAppType name] -> Maybe (LHsType name, [LHsType name])
+getAppsTyHead_maybe tys = case splitHsAppsTy tys of
+  ([app1:apps], []) ->  -- no symbols, some normal types
+    Just (mkHsAppTys app1 apps, [])
+  ([app1l:appsl, app1r:appsr], [L loc op]) ->  -- one operator
+    Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr])
+  _ -> -- can't figure it out
+    Nothing
+
+-- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix
+-- types (normal types) and infix operators.
+-- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first
+-- element of @non_syms@ followed by the first element of @syms@ followed by
+-- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
+-- has one more element than the syms list.
+splitHsAppsTy :: [HsAppType name] -> ([[LHsType name]], [Located name])
+splitHsAppsTy = go [] [] []
+  where
+    go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
+    go acc acc_non acc_sym (HsAppPrefix ty : rest)
+      = go (ty : acc) acc_non acc_sym rest
+    go acc acc_non acc_sym (HsAppInfix op : rest)
+      = go [] (reverse acc : acc_non) (op : acc_sym) rest
+
+-- retrieve the name of the "head" of a nested type application
+-- somewhat like splitHsAppTys, but a little more thorough
+-- used to examine the result of a GADT-like datacon, so it doesn't handle
+-- *all* cases (like lists, tuples, (~), etc.)
+hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
+hsTyGetAppHead_maybe = go []
+  where
+    go tys (L _ (HsTyVar ln))           = Just (ln, tys)
+    go tys (L _ (HsAppsTy apps))
+      | Just (head, args) <- getAppsTyHead_maybe apps
+                                         = go (args ++ tys) head
+    go tys (L _ (HsAppTy l r))           = go (r : tys) l
+    go tys (L _ (HsOpTy l (L loc n) r))  = Just (L loc n, l : r : tys)
+    go tys (L _ (HsParTy t))             = go tys t
+    go tys (L _ (HsKindSig t _))         = go tys t
+    go _   _                             = Nothing
+
+getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name)
+-- Works on (HsSigType RdrName)
+getLHsInstDeclClass_maybe inst_ty
+  = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty)
+       ; (cls, _) <- hsTyGetAppHead_maybe tau
+       ; return cls }