Support for -XPatternSynonyms

Signed-off-by: Austin Seipp <austin@well-typed.com>

4 files changed, 118 insertions, 22 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 4a30a168..94adc558 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -249,6 +249,7 @@ declNames :: LHsDecl DocName -> [DocName]
 declNames (L _ decl) = case decl of
   TyClD d  -> [tcdName d]
   SigD (TypeSig lnames _) -> map unLoc lnames
+  SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
   ForD (ForeignImport (L _ n) _ _ _) -> [n]
   ForD (ForeignExport (L _ n) _ _ _) -> [n]
   _ -> error "declaration not supported by declNames"
@@ -291,6 +292,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = 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
   ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode
   InstD _                        -> empty
   _                              -> error "declaration not supported by ppDecl"
@@ -345,6 +348,33 @@ ppFunSig loc doc docnames typ unicode =
  where
    names = map getName docnames
 
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+          -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+          -> LHsContext DocName -> LHsContext 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)
+  where
+    pref1 = hsep [ keyword "pattern"
+                 , pp_ctx prov
+                 , pp_head
+                 , dcolon unicode
+                 , pp_ctx req
+                 , ppType unicode typ
+                 ]
+
+    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]
+
+    pp_type = ppParendType unicode
+    pp_ctx ctx = ppContext ctx unicode
 
 ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
                -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
@@ -914,9 +944,16 @@ ppr_fun_ty ctxt_prec ty1 ty2 unicode
 
 ppBinder :: OccName -> LaTeX
 ppBinder n
-  | isVarSym n = parens $ ppOccName n
-  | otherwise  = ppOccName 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
 
 ppSymName :: Name -> LaTeX
 ppSymName name
@@ -953,6 +990,9 @@ 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.hs b/src/Haddock/Backends/Xhtml.hs
index d61478a8..567abced 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -598,7 +598,7 @@ ppNameMini :: Module -> OccName -> Html
 ppNameMini mdl nm =
     anchor ! [ href (moduleNameUrl mdl nm)
              , target mainFrameName ]
-      << ppBinder' nm
+      << ppBinder' False nm
 
 
 ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 91e6871d..04f94c49 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -30,6 +30,7 @@ import Haddock.Doc (combineDocumentation)
 import           Data.List             ( intersperse )
 import qualified Data.Map as Map
 import           Data.Maybe
+import           Data.Monoid           ( mempty )
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
@@ -40,21 +41,69 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
           DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
           Bool -> Qualification -> Html
 ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
-  TyClD (FamDecl d)              -> ppTyFam summ False links loc mbDoc d unicode qual
-  TyClD d@(DataDecl {})          -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
-  TyClD d@(SynDecl {})           -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
-  TyClD d@(ClassDecl {})         -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
-  SigD (TypeSig lnames (L _ t))  -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
+  TyClD (FamDecl d)         -> ppTyFam summ False links loc mbDoc d unicode qual
+  TyClD d@(DataDecl {})     -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+  TyClD d@(SynDecl {})      -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+  TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
+  SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual
+  SigD (PatSynSig lname args ty prov req) ->
+      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual
   ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
   InstD _                        -> noHtml
   _                              -> error "declaration not supported by ppDecl"
 
 
+ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+             [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty unicode qual =
+  ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual
+
 ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             [DocName] -> HsType DocName -> Bool -> Qualification -> Html
 ppFunSig summary links loc doc docnames typ unicode qual =
+  ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual
+  where
+    pp_typ = ppType unicode qual typ
+
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+             Located DocName ->
+             HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
+             LHsContext DocName -> LHsContext DocName ->
+             Bool -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req unicode qual =
+    ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual
+
+ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+            DocName ->
+            HsPatSynDetails (HsType DocName) -> HsType DocName ->
+            HsContext DocName -> HsContext DocName ->
+            Bool -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual
+  | summary = pref1
+  | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc
+  where
+    -- pref1 = leader <+> ppTypeSig summary occnames pp_typ unicode
+    pref1 = hsep [ toHtml "pattern"
+                 , pp_cxt prov
+                 , pp_head
+                 , dcolon unicode
+                 , pp_cxt req
+                 , ppType 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
+
+    occname = nameOccName . getName $ docname
+
+ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
+            [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual =
   ppTypeOrFunSig summary links loc docnames typ doc
-    ( ppTypeSig summary occnames typ unicode qual
+    ( leader <+> ppTypeSig summary occnames pp_typ unicode
     , concatHtml . punctuate comma $ map (ppBinder False) occnames
     , dcolon unicode
     )
@@ -127,9 +176,9 @@ ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvar
 ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
 
 
-ppTypeSig :: Bool -> [OccName] -> HsType DocName  -> Bool -> Qualification -> Html
-ppTypeSig summary nms ty unicode qual =
-  concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty
+ppTypeSig :: Bool -> [OccName] -> Html  -> Bool -> Html
+ppTypeSig summary nms pp_ty unicode =
+  concatHtml htmlNames <+> dcolon unicode <+> pp_ty
   where
     htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
 
@@ -465,7 +514,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
        char '}')
     InfixCon arg1 arg2 ->
       (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
-            ppBinder summary occ, ppLParendType unicode qual arg2],
+            ppBinderInfix summary occ, ppLParendType unicode qual arg2],
        noHtml, noHtml)
 
   ResTyGADT resTy -> case con_details con of
@@ -526,7 +575,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
 
         InfixCon arg1 arg2 ->
           hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
-            ppBinder False occ,
+            ppBinderInfix False occ,
             ppLParendType unicode qual arg2]
 
       ResTyGADT resTy -> case con_details con of
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 2f2b82ed..280a888c 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -12,7 +12,7 @@
 -----------------------------------------------------------------------------
 module Haddock.Backends.Xhtml.Names (
   ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
-  ppBinder, ppBinder',
+  ppBinder, ppBinderInfix, ppBinder',
   ppModule, ppModuleRef,
   ppIPName,
   linkId
@@ -105,16 +105,23 @@ ppName name = toHtml (getOccString name)
 ppBinder :: Bool -> OccName -> Html
 -- The Bool indicates whether we are generating the summary, in which case
 -- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' False n
 ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
-                        << ppBinder' n
+                        << ppBinder' False n
 
+ppBinderInfix :: Bool -> OccName -> Html
+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n
+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+                             << ppBinder' True n
 
-ppBinder' :: OccName -> Html
-ppBinder' n
-  | isVarSym n = parens $ ppOccName n
-  | otherwise  = ppOccName n
-
+ppBinder' :: Bool -> OccName -> Html
+-- The Bool indicates if it is to be rendered in infix notation
+ppBinder' is_infix n = wrap $ ppOccName n
+  where
+    wrap | is_infix && not is_sym = quote
+         | not is_infix && is_sym = parens
+         | otherwise = id
+    is_sym = isVarSym n || isConSym n
 
 linkId :: Module -> Maybe Name -> Html -> Html
 linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)