Update Haddock to new pattern synonym type signature syntax

5 files changed, 85 insertions, 84 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 06a24b4f..d3074438 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -293,8 +293,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
 -- Family instances happen via FamInst now
   TyClD d@(ClassDecl {})         -> ppClassDecl instances loc doc subdocs d unicode
   SigD (TypeSig lnames (L _ t))  -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
-  SigD (PatSynSig lname args ty prov req) ->
-      ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode
+  SigD (PatSynSig lname qtvs prov req ty) ->
+      ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
   ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode
   InstD _                        -> empty
   _                              -> error "declaration not supported by ppDecl"
@@ -350,32 +350,28 @@ ppFunSig loc doc docnames typ unicode =
    names = map getName docnames
 
 ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
-          -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+          -> (HsExplicitFlag, LHsTyVarBndrs DocName)
           -> LHsContext DocName -> LHsContext DocName
+          -> LHsType DocName
           -> Bool -> LaTeX
-ppLPatSig loc doc docname args typ prov req unicode =
-    ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode
-
-ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName
-          -> HsPatSynDetails (HsType DocName) -> HsType DocName
-          -> HsContext DocName -> HsContext DocName
-          -> Bool -> LaTeX
-ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)
+ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode
+  = declWithDoc pref1 (documentationToLaTeX doc)
   where
     pref1 = hsep [ keyword "pattern"
-                 , pp_ctx prov
-                 , pp_head
+                 , ppDocBinder name
                  , dcolon unicode
-                 , pp_ctx req
-                 , ppType unicode typ
+                 , ppLTyVarBndrs expl qtvs unicode
+                 , ctx
+                 , ppType unicode ty
                  ]
 
-    pp_head = case args of
-        PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs
-        InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]
+    ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of
+        (Nothing,   Nothing)  -> empty
+        (Nothing,   Just req) -> parens empty <+> darr <+> req <+> darr
+        (Just prov, Nothing)  -> prov <+> darr
+        (Just prov, Just req) -> prov <+> darr <+> req <+> darr
 
-    pp_type = ppParendType unicode
-    pp_ctx ctx = ppContext ctx unicode
+    darr = darrow unicode
 
 ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
                -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
@@ -786,15 +782,21 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
 ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
+ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX
+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
+
+ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX
+ppContextNoLocsMaybe [] _ = Nothing
+ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
 
 ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
-ppContextNoArrow []  _ = empty
-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+ppContextNoArrow cxt unicode = fromMaybe empty $
+                               ppContextNoLocsMaybe (map unLoc cxt) unicode
 
 
 ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
-ppContextNoLocs []  _ = empty
-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $
+                              ppContextNoLocsMaybe cxt unicode
 
 
 ppContext :: HsContext DocName -> Bool -> LaTeX
@@ -869,14 +871,16 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
 
 ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
          -> Located (HsContext DocName) -> Bool -> LaTeX
-ppForAll expl tvs cxt unicode
-  | show_forall = forall_part <+> ppLContext cxt unicode
-  | otherwise   = ppLContext cxt unicode
+ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode
+
+ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
+              -> Bool -> LaTeX
+ppLTyVarBndrs expl tvs unicode
+  | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+  | otherwise   = empty
   where
     show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
     is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
-    forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
-
 
 ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
 ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
@@ -954,11 +958,6 @@ ppBinder n
   | isInfixName n = parens $ ppOccName n
   | otherwise     = ppOccName n
 
-ppBinderInfix :: OccName -> LaTeX
-ppBinderInfix n
-  | isInfixName n = ppOccName n
-  | otherwise     = quotes $ ppOccName n
-
 isInfixName :: OccName -> Bool
 isInfixName n = isVarSym n || isConSym n
 
@@ -997,9 +996,6 @@ ppLDocName (L _ d) = ppDocName d
 ppDocBinder :: DocName -> LaTeX
 ppDocBinder = ppBinder . nameOccName . getName
 
-ppDocBinderInfix :: DocName -> LaTeX
-ppDocBinderInfix = ppBinderInfix . nameOccName . getName
-
 
 ppName :: Name -> LaTeX
 ppName = ppOccName . nameOccName
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index d4869abd..97f3fb09 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,7 +32,6 @@ import           Control.Applicative
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
-import           Data.Monoid           ( mempty )
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
@@ -49,8 +48,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl
   TyClD d@(SynDecl {})      -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
   TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
   SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
-  SigD (PatSynSig lname args ty prov req) ->
-      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+  SigD (PatSynSig lname qtvs prov req ty) ->
+      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
   ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
   InstD _                        -> noHtml
   _                              -> error "declaration not supported by ppDecl"
@@ -74,39 +73,32 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
 
 ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              Located DocName ->
-             HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
-             LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
+             (HsExplicitFlag, LHsTyVarBndrs DocName) ->
+             LHsContext DocName -> LHsContext DocName ->
+             LHsType DocName ->
+             [(DocName, Fixity)] ->
              Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
-    ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
-             (unLoc prov) (unLoc req) fixities splice unicode qual
-
-ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-            DocName ->
-            HsPatSynDetails (HsType DocName) -> HsType DocName ->
-            HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
-            Splice -> Unicode -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
-         splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual
   | summary = pref1
-  | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
+  | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
                 +++ docSection Nothing qual doc
   where
     pref1 = hsep [ toHtml "pattern"
-                 , pp_cxt prov
-                 , pp_head
+                 , ppBinder summary occname
                  , dcolon unicode
-                 , pp_cxt req
-                 , ppType unicode qual typ
+                 , ppLTyVarBndrs expl qtvs unicode qual
+                 , cxt
+                 , ppLType unicode qual typ
                  ]
-    pp_head = case args of
-        PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
-        InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
 
-    pp_cxt cxt = ppContext cxt unicode qual
-    pp_type = ppParendType unicode qual
+    cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of
+        (Nothing,   Nothing)  -> noHtml
+        (Nothing,   Just req) -> parens noHtml <+> darr <+> req <+> darr
+        (Just prov, Nothing)  -> prov <+> darr
+        (Just prov, Just req) -> prov <+> darr <+> req <+> darr
 
-    occname = nameOccName . getName $ docname
+    darr = darrow unicode
+    occname = nameOccName . getName $ name
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
              [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
@@ -357,17 +349,23 @@ ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
 
+ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html
+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
+
 ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContextNoArrow []  _       _     = noHtml
-ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
+ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
+                                    ppContextNoLocsMaybe (map unLoc cxt) unicode qual
 
 
 ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
-ppContextNoLocs []  _       _     = noHtml
-ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
-    <+> darrow unicode
+ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $
+                                   ppContextNoLocsMaybe cxt unicode qual
 
 
+ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html
+ppContextNoLocsMaybe []  _       _    = Nothing
+ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual
+
 ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
 ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
 
@@ -811,12 +809,19 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
          -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
 ppForAll expl tvs cxt unicode qual
-  | show_forall = forall_part <+> ppLContext cxt unicode qual
-  | otherwise   = ppLContext cxt unicode qual
+  = forall_part <+> ppLContext cxt unicode qual
+  where
+    forall_part = ppLTyVarBndrs expl tvs unicode qual
+
+ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
+              -> Unicode -> Qualification
+              -> Html
+ppLTyVarBndrs expl tvs unicode _qual
+  | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+  | otherwise   = noHtml
   where
     show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
     is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
-    forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
 
 
 ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 48306392..08892cd3 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,7 +20,7 @@ module Haddock.Convert where
 import HsSyn
 import TcType ( tcSplitSigmaTy )
 import TypeRep
-import Type(isStrLitTy)
+import Type ( isStrLitTy, mkFunTys )
 import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
 import Var
@@ -94,12 +94,14 @@ tyThingToLHsDecl t = noLoc $ case t of
     (synifyType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-      let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
+      let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
+          qtvs = univ_tvs ++ ex_tvs
+          ty = mkFunTys arg_tys res_ty
       in SigD $ PatSynSig (synifyName ps)
-                          (fmap (synifyType WithinType) (patSynTyDetails ps))
-                          (synifyType WithinType res_ty)
+                          (Implicit, synifyTyVars qtvs)
                           (synifyCtx req_theta)
                           (synifyCtx prov_theta)
+                          (synifyType WithinType ty)
 
 synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
 synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index ad6a1e98..551e6e7e 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -340,8 +340,8 @@ typeDocs d =
   let docs = go 0 in
   case d of
     SigD (TypeSig _ ty) -> docs (unLoc ty)
-    SigD (PatSynSig _ arg_tys ty req prov) ->
-        let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
+    SigD (PatSynSig _ _ req prov ty) ->
+        let allTys = ty : concat [ unLoc req, unLoc prov ]
         in F.foldMap (docs . unLoc) allTys
     ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
     TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index dca93cc0..aa1a170f 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -402,15 +402,13 @@ renameSig sig = case sig of
     lnames' <- mapM renameL lnames
     ltype' <- renameLType ltype
     return (TypeSig lnames' ltype')
-  PatSynSig lname args ltype lreq lprov -> do
+  PatSynSig lname (flag, qtvs) lreq lprov lty -> do
     lname' <- renameL lname
-    args' <- case args of
-        PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs
-        InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright
-    ltype' <- renameLType ltype
+    qtvs' <- renameLTyVarBndrs qtvs
     lreq' <- renameLContext lreq
     lprov' <- renameLContext lprov
-    return $ PatSynSig lname' args' ltype' lreq' lprov'
+    lty' <- renameLType lty
+    return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
   FixSig (FixitySig lname fixity) -> do
     lname' <- renameL lname
     return $ FixSig (FixitySig lname' fixity)