aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
authorTim Baumann <tim@timbaumann.info>2017-08-06 11:33:38 +0200
committerAlexander Biehl <alexbiehl@gmail.com>2017-08-06 11:33:38 +0200
commit3fddb62913c72f29843335aa796c2e444ded1608 (patch)
treea3cccdacd8e546e527488009ebd5d9c815be46d3 /haddock-api/src/Haddock/Interface
parent4d765e3cd0a735f9a7e8d13fb6633f9ee534fbfb (diff)
Fix: Generate pattern signatures for constructors exported as patterns (#663)
* Fix pretty-printing of pattern signatures Pattern synonyms can have up to two contexts, both having a different semantic meaning: The first holds the constraints required to perform the matching, the second contains the constraints provided by a successful pattern match. When the first context is empty but the second is not it is necessary to render the first, empty context. * Generate pattern synonym signatures for ctors exported as patterns This fixes #653. * Simplify extractPatternSyn It is not necessary to generate the simplest type signature since it will be simplified when pretty-printed. * Add changelog entries for PR #663 * Fix extractPatternSyn error message
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs34
1 files changed, 33 insertions, 1 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b9179d11..89f7f71b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -985,7 +985,9 @@ extractDecl name decl
O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ in if isDataConName name
+ then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
, dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
@@ -1003,6 +1005,36 @@ extractDecl name decl
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
+extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name
+extractPatternSyn nm t tvs cons =
+ case filter matches cons of
+ [] -> error "extractPatternSyn: constructor pattern not found"
+ con:_ -> extract <$> con
+ where
+ matches :: LConDecl Name -> Bool
+ matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
+ extract :: ConDecl Name -> Sig Name
+ extract con =
+ let args =
+ case getConDetails con of
+ PrefixCon args' -> args'
+ RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+ InfixCon arg1 arg2 -> [arg1, arg2]
+ typ = longArrow args (data_ty con)
+ typ' =
+ case con of
+ ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+ _ -> typ
+ typ'' = noLoc (HsQualTy (noLoc []) typ')
+ in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+
+ longArrow :: [LHsType name] -> LHsType name -> LHsType name
+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+
+ data_ty con
+ | ConDeclGADT{} <- con = hsib_body $ con_type con
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+
extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"