Adapt Haddock to LinearTypes

See ghc/ghc!852.

13 files changed, 118 insertions, 76 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 27a7d804..75a49036 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -36,6 +36,8 @@ import Data.Version
 import System.Directory
 import System.FilePath
 
+import GHC.Core.Multiplicity
+
 prefix :: [String]
 prefix = ["-- Hoogle documentation, generated by Haddock"
          ,"-- See Hoogle, http://www.haskell.org/hoogle/"
@@ -76,7 +78,7 @@ dropHsDocTy = f
         f (HsBangTy x a b) = HsBangTy x a (g b)
         f (HsAppTy x a b) = HsAppTy x (g a) (g b)
         f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
-        f (HsFunTy x a b) = HsFunTy x (g a) (g b)
+        f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
         f (HsListTy x a) = HsListTy x (g a)
         f (HsTupleTy x a b) = HsTupleTy x a (map g b)
         f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
@@ -236,14 +238,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
   -- AZ:TODO get rid of the concatMap
    = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
     where
-        f (PrefixCon args) = [typeSig name $ args ++ [resType]]
+        f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
-        f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+        f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
                           [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
-        funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)
+        funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y)
         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
 
         typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 19c72335..6ced4924 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -265,6 +265,7 @@ classify tok =
     ITvbar                 -> TkGlyph
     ITlarrow            {} -> TkGlyph
     ITrarrow            {} -> TkGlyph
+    ITlolly             {} -> TkGlyph
     ITat                   -> TkGlyph
     ITtilde                -> TkGlyph
     ITdarrow            {} -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 17ba00f0..ce5ff11c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -129,8 +129,8 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
     go (HLitTy l) = IfaceLitTy l
     go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)
                                   in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
-    go (HFunTy a b) = IfaceFunTy VisArg a b
-    go (HQualTy con b) = IfaceFunTy InvisArg con b
+    go (HFunTy w a b) = IfaceFunTy VisArg w a b
+    go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b
     go (HCastTy a) = a
     go HCoercionTy = IfaceTyVar "<coercion type>"
     go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 0c323ae5..badb1914 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -41,6 +41,7 @@ import Control.Monad
 import Data.Maybe
 import Data.List
 import Prelude hiding ((<>))
+import GHC.Core.Multiplicity
 
 import Haddock.Doc (combineDocumentation)
 
@@ -483,13 +484,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
       = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
         : do_largs n (darrow unicode) ltype
 
-    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+    do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
       = [ (decltt ldr, latex <+> nl)
         | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
         , let latex = ppSideBySideField subdocs unicode field
         ]
         ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
-    do_args n leader (HsFunTy _ lt r)
+    do_args n leader (HsFunTy _ _w lt r)
       = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
         : do_largs (n+1) (arrow unicode) r
     do_args n leader t
@@ -773,7 +774,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
           | hasArgDocs -> header_ <+> ppOcc
           | otherwise -> hsep [ header_
                               , ppOcc
-                              , hsep (map (ppLParendType unicode) args)
+                              , hsep (map ((ppLParendType unicode) . hsScaledThing) args)
                               ]
 
         -- Record constructor, e.g. 'Identity { runIdentity :: a }'
@@ -783,9 +784,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
         InfixCon arg1 arg2
           | hasArgDocs -> header_ <+> ppOcc
           | otherwise -> hsep [ header_
-                              , ppLParendType unicode arg1
+                              , ppLParendType unicode (hsScaledThing arg1)
                               , ppOccInfix
-                              , ppLParendType unicode arg2
+                              , ppLParendType unicode (hsScaledThing arg2)
                               ]
 
       ConDeclGADT{}
@@ -804,10 +805,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
         (_, RecCon (L _ fields))             -> doRecordFields fields
 
         -- Any GADT or a regular H98 prefix data constructor
-        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs args
+        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
 
         -- An infix H98 data constructor
-        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2]
+        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
 
         _ -> empty
 
@@ -1047,7 +1048,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode
   = sep [ ppLContext ctxt unicode
         , ppr_mono_lty ty unicode ]
-ppr_mono_ty (HsFunTy _ ty1 ty2)   u
+ppr_mono_ty (HsFunTy _ _ ty1 ty2)   u
   = sep [ ppr_mono_lty ty1 u
         , arrow u <+> ppr_mono_lty ty2 u ]
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5163fb6b..6e210b61 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,6 +41,7 @@ import GHC.Exts
 import GHC.Types.Name
 import GHC.Data.BooleanFormula
 import GHC.Types.Name.Reader ( rdrNameOcc )
+import GHC.Core.Multiplicity
 
 -- | Pretty print a declaration
 ppDecl :: Bool                                     -- ^ print summary info only
@@ -163,14 +164,14 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
         : do_largs n (darrow unicode) ltype
 
-    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+    do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
       = [ (ldr <+> html, mdoc, subs)
         | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
         , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
         ]
         ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
 
-    do_args n leader (HsFunTy _ lt r)
+    do_args n leader (HsFunTy _ _w lt r)
       = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
 
@@ -836,7 +837,8 @@ ppShortConstrParts summary dataInst con unicode qual
 
         -- Prefix constructor, e.g. 'Just a'
         PrefixCon args ->
-          ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
+          ( header_ +++
+              hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
           , noHtml
           , noHtml
           )
@@ -852,9 +854,9 @@ ppShortConstrParts summary dataInst con unicode qual
 
         -- Infix constructor, e.g. 'a :| [a]'
         InfixCon arg1 arg2 ->
-          ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1
+          ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
                              , ppOccInfix
-                             , ppLParendType unicode qual HideEmptyContexts arg2
+                             , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
                              ]
           , noHtml
           , noHtml
@@ -910,7 +912,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
         PrefixCon args
           | hasArgDocs -> header_ +++ ppOcc <+> fixity
           | otherwise -> hsep [ header_ +++ ppOcc
-                              , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
+                              , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
                               , fixity
                               ]
 
@@ -920,9 +922,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
         -- Infix constructor, e.g. 'a :| [a]'
         InfixCon arg1 arg2
           | hasArgDocs -> header_ +++ ppOcc <+> fixity
-          | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+          | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
                               , ppOccInfix
-                              , ppLParendType unicode qual HideEmptyContexts arg2
+                              , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
                               , fixity
                               ]
 
@@ -957,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
     doConstrArgsWithDocs args = subFields pkg qual $ case con of
       ConDeclH98{} ->
         [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
-        | (i, arg) <- zip [0..] args
+        | (i, arg) <- zip [0..] (map hsScaledThing args)
         , let mdoc = Map.lookup i argDocs
         ]
       ConDeclGADT{} ->
@@ -1150,14 +1152,14 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmp
       case unLoc t of
         HsForAllTy _ _ s -> hasNonEmptyContext s
         HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
-        HsFunTy _ _ s    -> hasNonEmptyContext s
+        HsFunTy _ _ _ s    -> hasNonEmptyContext s
         _ -> False
     isFirstContextEmpty :: LHsType name -> Bool
     isFirstContextEmpty t =
       case unLoc t of
         HsForAllTy _ _ s -> isFirstContextEmpty s
         HsQualTy _ cxt _ -> null (unLoc cxt)
-        HsFunTy _ _ s    -> isFirstContextEmpty s
+        HsFunTy _ _ _ s    -> isFirstContextEmpty s
         _ -> False
 
 
@@ -1197,7 +1199,7 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
   | otherwise = ppDocName q Prefix True name
 ppr_mono_ty (HsStarTy _ isUni) u _ _ =
   toHtml (if u || isUni then "★" else "*")
-ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =
+ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e =
   hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
        , arrow u <+> ppr_mono_lty ty2 u q e
        ]
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b45b6eab..3b73dcd1 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -57,6 +57,8 @@ import Haddock.Types
 import Haddock.Interface.Specialize
 import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )
 
+import GHC.Core.Multiplicity
+
 import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )
 
 
@@ -151,7 +153,7 @@ tyThingToLHsDecl prr t = case t of
 
   -- a data-constructor alone just gets rendered as a function:
   AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc]
-    (synifySigWcType ImplicitizeForAll [] (dataConUserType dc)))
+    (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc)))
 
   AConLike (PatSynCon ps) ->
     allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps)
@@ -205,7 +207,7 @@ synifyTyCon prr _coax tc
     DataDecl { tcdLName = synifyName tc
              , tcdTyVars = HsQTvs  { hsq_ext = []   -- No kind polymorphism
                                    , hsq_explicit = zipWith mk_hs_tv
-                                                            tyVarKinds
+                                                            (map scaledThing tyVarKinds)
                                                             alphaTyVars --a, b, c... which are unfortunately all kind *
                                    }
 
@@ -374,7 +376,7 @@ synifyDataCon use_gadt_syntax dc =
 
   linear_tys =
     zipWith (\ty bang ->
-               let tySyn = synifyType WithinType [] ty
+               let tySyn = synifyType WithinType [] (scaledThing ty)
                in case bang of
                     (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
                     bang' -> noLoc $ HsBangTy noExtField bang' tySyn)
@@ -387,9 +389,9 @@ synifyDataCon use_gadt_syntax dc =
   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
           (True,True) -> Left "synifyDataCon: contradiction!"
           (True,False) -> return $ RecCon (noLoc field_tys)
-          (False,False) -> return $ PrefixCon linear_tys
+          (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
           (False,True) -> case linear_tys of
-                           [a,b] -> return $ InfixCon a b
+                           [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
                            _ -> Left "synifyDataCon: infix with non-2 args?"
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
@@ -628,11 +630,12 @@ synifyType _ vs (AppTy t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
   in noLoc $ HsAppTy noExtField s1 s2
-synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty
-synifyType _ vs       (FunTy VisArg t1 t2) = let
+synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty
+synifyType _ vs       (FunTy VisArg w t1 t2) = let
   s1 = synifyType WithinType vs t1
   s2 = synifyType WithinType vs t2
-  in noLoc $ HsFunTy noExtField s1 s2
+  w' = synifyMult vs w
+  in noLoc $ HsFunTy noExtField w' s1 s2
 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
   case argf of
     Required    -> synifyVisForAllType vs forallty
@@ -749,7 +752,7 @@ noKindTyVars ts ty
   = let args = map (noKindTyVars ts) xs
         func = case f of
                  TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
-                             , xsKinds `eqTypes` map typeKind xs
+                             , map scaledThing xsKinds `eqTypes` map typeKind xs
                              , isLiftedTypeKind outKind
                              -> unitVarSet var
                  TyConApp t ks | t `elem` ts
@@ -758,10 +761,20 @@ noKindTyVars ts ty
                  _ -> noKindTyVars ts f
     in unionVarSets (func : args)
 noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
-noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2
+noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet`
+                                    noKindTyVars ts t1 `unionVarSet`
+                                    noKindTyVars ts t2
 noKindTyVars ts (CastTy t _) = noKindTyVars ts t
 noKindTyVars _ _ = emptyVarSet
 
+synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
+synifyMult vs t = case t of
+                    One  -> HsLinearArrow
+                    Many -> HsUnrestrictedArrow
+                    ty -> HsExplicitMult (synifyType WithinType vs ty)
+
+
+
 synifyPatSynType :: PatSyn -> LHsType GhcRn
 synifyPatSynType ps =
   let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
@@ -923,5 +936,5 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 []
 
 -- | See Note [Invariant: Never expand type synonyms]
 tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)
-tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res)
+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res)
 tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 73a2bac6..e4d7c2b6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -33,6 +33,7 @@ import GHC.Driver.Types
 import GHC
 import GHC.Core.Class
 import GHC.Driver.Session
+import GHC.Core.Multiplicity
 import GHC.Types.SrcLoc  ( advanceSrcLoc )
 import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder
                          , tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -205,12 +206,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
             | otherwise
             = tau_ty
 
+--   tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty)
-              PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
-              InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
+              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
 
-   mkFunTy a b = noLoc (HsFunTy noExtField a b)
+   mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b)
 
 getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
   -- Should only be called on ConDeclGADT
@@ -259,12 +261,14 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
             | otherwise
             = tau_ty
 
+--   tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty)
-              PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
-              InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
+              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
 
-   mkFunTy a b = noLoc (HsFunTy noExtField a b)
+   -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
+   mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b)
 
 getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
   -- Should only be called on ConDeclGADT
@@ -316,8 +320,8 @@ reparenTypePrec = go
     = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)
   go p (HsQualTy x ctxt ty)
     = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
-  go p (HsFunTy x ty1 ty2)
-    = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)
+  go p (HsFunTy x w ty1 ty2)
+    = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
   go p (HsAppTy x fun_ty arg_ty)
     = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
   go p (HsAppKindTy x fun_ty arg_ki)
@@ -642,7 +646,9 @@ tyCoFVsOfType' (TyVarTy v)        a b c = (FV.unitFV v `unionFV` tyCoFVsOfType'
 tyCoFVsOfType' (TyConApp _ tys)   a b c = tyCoFVsOfTypes' tys a b c
 tyCoFVsOfType' (LitTy {})         a b c = emptyFV a b c
 tyCoFVsOfType' (AppTy fun arg)    a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
-tyCoFVsOfType' (FunTy _ arg res)  a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c
+tyCoFVsOfType' (FunTy _ w arg res)  a b c = (tyCoFVsOfType' w `unionFV`
+                                           tyCoFVsOfType' res `unionFV`
+                                           tyCoFVsOfType' arg) a b c
 tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty)  a b c
 tyCoFVsOfType' (CastTy ty _)      a b c = (tyCoFVsOfType' ty) a b c
 tyCoFVsOfType' (CoercionTy _ )    a b c = emptyFV a b c
@@ -688,8 +694,8 @@ defaultRuntimeRepVars = go emptyVarEnv
     go subs (TyConApp tc tc_args)
       = TyConApp tc (map (go subs) tc_args)
 
-    go subs (FunTy af arg res)
-      = FunTy af (go subs arg) (go subs res)
+    go subs (FunTy af w arg res)
+      = FunTy af (go subs w) (go subs arg) (go subs res)
 
     go subs (AppTy t u)
       = AppTy (go subs t) (go subs u)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index ec61fb37..7deb67f9 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -194,13 +194,13 @@ instHead (_, _, cls, args)
 argCount :: Type -> Int
 argCount (AppTy t _)     = argCount t + 1
 argCount (TyConApp _ ts) = length ts
-argCount (FunTy _ _ _)   = 2
+argCount (FunTy _ _ _ _) = 2
 argCount (ForAllTy _ t)  = argCount t
 argCount (CastTy t _)    = argCount t
 argCount _ = 0
 
 simplify :: Type -> SimpleType
-simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (FunTy _ _ t1 t2)  = SimpleType funTyConName [simplify t1, simplify t2]
 simplify (ForAllTy _ t) = simplify t
 simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
   where (SimpleType s ts) = simplify t1
@@ -255,7 +255,7 @@ isTypeHidden expInfo = typeHidden
       case t of
         TyVarTy {} -> False
         AppTy t1 t2 -> typeHidden t1 || typeHidden t2
-        FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2
+        FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2
         TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
         ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty
         LitTy _ -> False
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 108e9f66..eb3354a4 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -56,6 +56,8 @@ import GHC.Data.FastString ( unpackFS, bytesFS )
 import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
 
+import GHC.Core.Multiplicity
+
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
@@ -486,8 +488,9 @@ subordinates instMap decl = case decl of
 -- | Extract constructor argument docs from inside constructor decls.
 conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
 conArgDocs con = case getConArgs con of
-                   PrefixCon args -> go 0 (map unLoc args ++ ret)
-                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
+                                                unLoc (hsScaledThing arg2)] ++ ret)
                    RecCon _ -> go 1 ret
   where
     go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
@@ -514,8 +517,8 @@ typeDocs = go 0
   where
     go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
     go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
-    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
-    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+    go n (HsFunTy _ _w (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
+    go n (HsFunTy _ _ _ ty) = go (n+1) (unLoc ty)
     go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
     go _ _ = M.empty
 
@@ -1126,9 +1129,9 @@ extractPatternSyn nm t tvs cons =
   extract con =
     let args =
           case getConArgs con of
-            PrefixCon args' -> args'
+            PrefixCon args' -> (map hsScaledThing args')
             RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
-            InfixCon arg1 arg2 -> [arg1, arg2]
+            InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
         typ = longArrow args (data_ty con)
         typ' =
           case con of
@@ -1137,8 +1140,8 @@ extractPatternSyn nm t tvs cons =
         typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
     in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
 
-  longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
-  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs
+  longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name
+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs
 
   data_ty con
     | ConDeclGADT{} <- con = con_res_ty con
@@ -1155,7 +1158,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
 extractRecSel nm t tvs (L _ con : rest) =
   case getConArgs con of
     RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
-      L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))
+      L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty)))))
     _ -> extractRecSel nm t tvs rest
  where
   matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index a0c118f8..80b84e87 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -221,6 +221,11 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
                           -> RnM (Maybe (LInjectivityAnn DocNameI))
 renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
+renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
+renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow
+renameArrow HsLinearArrow = return HsLinearArrow
+renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p
+
 renameType :: HsType GhcRn -> RnM (HsType DocNameI)
 renameType t = case t of
   HsForAllTy { hst_tele = tele, hst_body = ltype } -> do
@@ -249,10 +254,11 @@ renameType t = case t of
     b' <- renameLKind b
     return (HsAppKindTy noExtField a' b')
 
-  HsFunTy _ a b -> do
+  HsFunTy _ w a b -> do
     a' <- renameLType a
     b' <- renameLType b
-    return (HsFunTy noExtField a' b')
+    w' <- renameArrow w
+    return (HsFunTy noExtField w' a' b')
 
   HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty
   HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty)
@@ -491,14 +497,20 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
                    , con_mb_cxt = lcontext', con_args = details'
                    , con_res_ty = res_ty', con_doc = mbldoc' })
 
+renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
+               -> RnM (HsScaled DocNameI (LHsType DocNameI))
+renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
+
 renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
 renameDetails (RecCon (L l fields)) = do
   fields' <- mapM renameConDeclFieldField fields
   return (RecCon (L l fields'))
-renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+                               -- This causes an assertion failure
+--renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps
+renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
 renameDetails (InfixCon a b) = do
-  a' <- renameLType a
-  b' <- renameLType b
+  a' <- renameHsScaled a
+  b' <- renameHsScaled b
   return (InfixCon a' b')
 
 renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index e137c258..5c933f25 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -16,7 +16,7 @@ import GHC
 import GHC.Types.Name
 import GHC.Data.FastString
 import GHC.Builtin.Types.Prim ( funTyConName )
-import GHC.Builtin.Types ( listTyConName )
+import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
 
 import Control.Monad
 import Control.Monad.Trans.State
@@ -136,7 +136,7 @@ sugarTuples typ =
 sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
 sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
-    | funTyConName == name' = HsFunTy noExtField la lb
+    | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb
   where
     name' = getName name
 sugarOperators typ = typ
@@ -260,7 +260,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
 renameType t@(HsStarTy _ _) = pure t
 renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
 renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
-renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
+renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr
 renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
 renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
 renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
@@ -281,6 +281,10 @@ renameType (HsExplicitTupleTy x ltys) =
 renameType t@(HsTyLit _ _) = pure t
 renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 
+renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
+renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p
+renameHsArrow mult = pure mult
+
 
 renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
 renameLType = located renameType
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index d72b9004..8346a477 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -90,6 +90,8 @@ import qualified System.Posix.Internals
 
 import GHC.Utils.Monad ( MonadIO(..) )
 
+import GHC.Core.Multiplicity
+
 
 --------------------------------------------------------------------------------
 -- * Logging
@@ -200,7 +202,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
         field_avail :: LConDeclField GhcRn -> Bool
         field_avail (L _ (ConDeclField _ fs _ _))
             = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
-        field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
+        field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ]
 
     keep _ = Nothing
 
diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html
index 83092456..403fb18c 100644
--- a/html-test/ref/Instances.html
+++ b/html-test/ref/Instances.html
@@ -594,11 +594,7 @@
 		      ></span
 		      > <a href="#" title="Instances"
 		      >Foo</a
-		      > ((-&gt;) a :: <a href="#" title="Data.Kind"
-		      >Type</a
-		      > -&gt; <a href="#" title="Data.Kind"
-		      >Type</a
-		      >)</span
+		      > ((-&gt;) a)</span
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td