From ae5ed291f3c1550b0eda7bb0585ead327b5d967e Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 10 Jun 2011 01:35:31 +0000 Subject: Add git commits since switchover: darcs format (followed by a conflict resolution): commit 6f92cdd12d1354dfbd80f8323ca333bea700896a Merge: f420cc4 28df3a1 Author: Simon Peyton Jones Date: Thu May 19 17:54:34 2011 +0100 Merge remote branch 'origin/master' into ghc-generics commit 28df3a119f770fdfe85c687dd73d5f6712b8e7d0 Author: Max Bolingbroke Date: Sat May 14 22:37:02 2011 +0100 Unicode fix for getExecDir on Windows commit 89813e729be8bce26765b95419a171a7826f6d70 Merge: 6df3a04 797ab27 Author: Simon Peyton Jones Date: Mon May 9 11:55:17 2011 +0100 Merge branch 'ghc-new-co' commit 6df3a040da3dbddee67c6e30a892f87e6b164383 Author: Ian Lynagh Date: Sun May 8 17:05:50 2011 +0100 Follow changes in SDoc commit f420cc48b9259f0b1afd2438b12f9a2bde57053d Author: Jose Pedro Magalhaes Date: Wed May 4 17:31:52 2011 +0200 Adapt haddock to the removal of HsNumTy and TypePat. commit 797ab27bdccf39c73ccad374fea265f124cb52ea Merge: 1d81436 5a91450 Author: Simon Peyton Jones Date: Mon May 2 12:05:03 2011 +0100 Merge remote branch 'origin/master' into ghc-new-co commit 1d8143659a81cf9611668348e33fd0775c7ab1d2 Author: Simon Peyton Jones Date: Mon May 2 12:03:46 2011 +0100 Wibbles for ghc-new-co branch commit 5a91450e2ea5a93c70bd3904b022445c9cc82488 Author: Ian Lynagh Date: Fri Apr 22 00:51:56 2011 +0100 Follow defaultDynFlags change in GHC --- src/Haddock/Backends/LaTeX.hs | 1 - src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++-- src/Haddock/Convert.hs | 40 ++++++++++++++++++++++++-------- src/Haddock/Interface/AttachInstances.hs | 3 ++- src/Haddock/Interface/Rename.hs | 2 -- src/Haddock/Interface/Rn.hs | 4 ++-- src/Main.hs | 27 +++++++++++---------- 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 -- cgit v1.2.3