aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/LaTeX.hs1
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs7
-rw-r--r--src/Haddock/Convert.hs40
-rw-r--r--src/Haddock/Interface/AttachInstances.hs3
-rw-r--r--src/Haddock/Interface/Rename.hs2
-rw-r--r--src/Haddock/Interface/Rn.hs4
-rw-r--r--src/Main.hs27
7 files changed, 52 insertions, 32 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 7f53d926..71773d0d 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -874,7 +874,6 @@ ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)
-ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index ce0dccda..381802b4 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -711,11 +711,14 @@ ppr_mono_ty _ (HsKindSig ty kind) u q =
ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)
-ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
+#if __GLASGOW_HASKELL__ == 612
+ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+#else
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
+#endif
ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
= maybeParen ctxt_prec pREC_CON $
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index dde8c1b6..9892ff47 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -18,7 +18,7 @@ module Haddock.Convert where
import HsSyn
-import TcType ( tcSplitSigmaTy )
+import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
import TypeRep
import Coercion ( splitKindFunTys, synTyConResKind )
import Name
@@ -44,9 +44,15 @@ tyThingToLHsDecl t = noLoc $ case t of
-- into a ForD instead of a SigD if we wanted. Haddock doesn't
-- need to care.
AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
+
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ATyCon tc -> TyClD (synifyTyCon tc)
+
+ -- type-constructors (e.g. Maybe) are complicated, put the definition
+ -- later in the file (also it's used for class associated-types too.)
+ ACoAxiom ax -> TyClD (synifyAxiom ax)
+
-- a data-constructor alone just gets rendered as a function:
ADataCon dc -> SigD (TypeSig (synifyName dc)
(synifyType ImplicitizeForAll (dataConUserType dc)))
@@ -71,6 +77,16 @@ tyThingToLHsDecl t = noLoc $ case t of
synifyClassAT :: TyCon -> LTyClDecl Name
synifyClassAT = noLoc . synifyTyCon
+synifyAxiom :: CoAxiom -> TyClDecl Name
+synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = let name = synifyName tc
+ tyvars = synifyTyVars tvs
+ typats = map (synifyType WithinType) args
+ hs_rhs_ty = synifyType WithinType rhs
+ in TySynonym name tyvars (Just typats) hs_rhs_ty
+ | otherwise
+ = error "synifyAxiom"
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
@@ -162,11 +178,15 @@ synifyDataCon use_gadt_syntax dc = noLoc $
use_named_field_syntax = not (null field_tys)
name = synifyName dc
-- con_qvars means a different thing depending on gadt-syntax
+ (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
+
qvars = if use_gadt_syntax
- then synifyTyVars (dataConAllTyVars dc)
- else synifyTyVars (dataConExTyVars dc)
+ then synifyTyVars (univ_tvs ++ ex_tvs)
+ else synifyTyVars ex_tvs
+
-- skip any EqTheta, use 'orig'inal syntax
- ctx = synifyCtx (dataConDictTheta dc)
+ ctx = synifyCtx theta
+
linear_tys = zipWith (\ty bang ->
let tySyn = synifyType WithinType ty
in case bang of
@@ -175,23 +195,23 @@ synifyDataCon use_gadt_syntax dc = noLoc $
-- HsNoBang never appears, it's implied instead.
_ -> noLoc $ HsBangTy bang tySyn
)
- (dataConOrigArgTys dc) (dataConStrictMarks dc)
+ arg_tys (dataConStrictMarks dc)
field_tys = zipWith (\field synTy -> ConDeclField
(synifyName field) synTy Nothing)
(dataConFieldLabels dc) linear_tys
- tys = case (use_named_field_syntax, use_infix_syntax) of
+ hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> error "synifyDataCon: contradiction!"
(True,False) -> RecCon field_tys
(False,False) -> PrefixCon linear_tys
(False,True) -> case linear_tys of
[a,b] -> InfixCon a b
_ -> error "synifyDataCon: infix with non-2 args?"
- res_ty = if use_gadt_syntax
- then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))
- else ResTyH98
+ hs_res_ty = if use_gadt_syntax
+ then ResTyGADT (synifyType WithinType res_ty)
+ else ResTyH98
-- finally we get synifyDataCon's result!
in ConDecl name Implicit{-we don't know nor care-}
- qvars ctx tys res_ty Nothing
+ qvars ctx hs_arg_tys hs_res_ty Nothing
False --we don't want any "deprecated GADT syntax" warnings!
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index cc2dfa19..e4da3233 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -30,9 +30,10 @@ import GhcMonad (withSession)
#else
import HscTypes (withSession)
#endif
+import TysPrim( funTyCon )
import MonadUtils (liftIO)
import TcRnDriver (tcRnGetInfo)
-import TypeRep hiding (funTyConName)
+import TypeRep
import Var hiding (varName)
import TyCon
import PrelNames
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index e28ff639..b53f579c 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -265,8 +265,6 @@ renameType t = case t of
HsParTy ty -> return . HsParTy =<< renameLType ty
- HsNumTy n -> return (HsNumTy n)
-
HsPredTy p -> return . HsPredTy =<< renamePred p
HsKindSig ty k -> do
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
index 4c040f3e..6f7af908 100644
--- a/src/Haddock/Interface/Rn.hs
+++ b/src/Haddock/Interface/Rn.hs
@@ -6,7 +6,7 @@ import RnEnv ( dataTcOccs )
import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
import Name ( Name )
-import Outputable ( ppr, defaultUserStyle )
+import Outputable ( ppr, showSDoc )
rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =
@@ -14,7 +14,7 @@ rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =
ids2string :: [RdrName] -> String
ids2string [] = []
-ids2string (x:_) = show $ ppr x defaultUserStyle
+ids2string (x:_) = showSDoc $ ppr x
data Id x = Id {unId::x}
instance Monad Id where (Id v)>>=f = f v; return = Id
diff --git a/src/Main.hs b/src/Main.hs
index deb699f7..b49fc6e4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -57,7 +57,7 @@ import Paths_haddock
import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
-import Panic (handleGhcException)
+import Panic (panic, handleGhcException)
import Module
@@ -393,7 +393,7 @@ getPrologue flags =
[] -> return Nothing
[filename] -> do
str <- readFile filename
- case parseParas (tokenise defaultDynFlags str
+ case parseParas (tokenise (defaultDynFlags (panic "No settings")) str
(1,0) {- TODO: real position -}) of
Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename
Just doc -> return (Just doc)
@@ -416,18 +416,17 @@ getInTreeLibDir = do
getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-getExecDir = allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then
- return Nothing
- else do
- s <- peekCString buf
- return (Just (dropFileName s))
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecDir = return Nothing
#endif
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 04:54:42 +0000