Adapt Haddock to LinearTypes

See ghc/ghc!852.

5 files changed, 32 insertions, 26 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
        ]