From 9331d3a35c2d370a974dced5515d2e4357ec0d6f Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 11 Aug 2011 12:08:15 +0100 Subject: Hack this to make it work with both Alex 2.x and Alex 3.x. Unicode in documentation strings is (still) mangled. I don't think it's possible to make it so that we get the current behaviour with Alex 2.x but magic Unicode support if you use Alex 3.x. At some point we have to decide that Alex 3.x is a requirement, then we can do Unicode. --- src/Haddock/Lex.x | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index 17267656..e41c9461 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -31,12 +31,11 @@ import DynFlags import FastString import Data.Char +import Data.Word (Word8) import Numeric import System.IO.Unsafe } -%wrapper "posn" - $ws = $white # \n $digit = [0-9] $hexdigit = [0-9a-fA-F] @@ -140,6 +139,37 @@ tokenPos t = let AlexPn _ line col = snd t in (line, col) -- ----------------------------------------------------------------------------- -- Alex support stuff +-- XXX: copied the posn wrapper code from Alex to make this lexer work +-- with both Alex 2.x and Alex 3.x. However, we are not using the +-- Unicode/UTF-8 support in Alex 3.x, and Unicode documentation will +-- probably get mangled. + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (p,c,[]) = Nothing +alexGetByte (p,_,(c:s)) = let p' = alexMove p c + in p' `seq` Just (fromIntegral (ord c), (p', c, s)) + +-- for compat with Alex 2.x: +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar i = case alexGetByte i of + Nothing -> Nothing + Just (b,i') -> Just (chr (fromIntegral b), i') + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + type StartCode = Int type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken] -- cgit v1.2.3 From 0c16f3b04aadd0cc22fedbf123bae6369d1c445e Mon Sep 17 00:00:00 2001 From: David Terei Date: Thu, 18 Aug 2011 14:27:53 -0700 Subject: Add safe haskell indication to haddock output --- src/Haddock/Backends/Xhtml.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 27 ++++++++++++++++----------- src/Haddock/Interface/ParseModuleHeader.hs | 3 ++- src/Haddock/Interface/Rn.hs | 5 +++-- src/Haddock/InterfaceFile.hs | 4 +++- src/Haddock/Types.hs | 2 ++ 6 files changed, 28 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index b639760d..08e2fe07 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -200,7 +200,8 @@ moduleInfo iface = entries = mapMaybe doOneEntry [ ("Portability",hmi_portability), ("Stability",hmi_stability), - ("Maintainer",hmi_maintainer) + ("Maintainer",hmi_maintainer), + ("Safe Haskell",hmi_safety) ] in case entries of diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index a92c9c46..d013ca27 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -25,6 +25,7 @@ import Haddock.Doc import Data.Maybe import FastString import GHC +import Outputable ( showPpr ) import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment @@ -59,14 +60,18 @@ lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment df -- yes, you always get a HaddockModInfo though it might be empty lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader dflags gre mbStr = do - let failure = (emptyHaddockModInfo, Nothing) - case mbStr of - Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] - return failure - Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + (hmod, docn) <- case mbStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + case parseModuleHeader dflags str of + Left mess -> do + tell ["haddock module header parse failed: " ++ mess] + return failure + Right (info, doc) -> + return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + return (hmod { hmi_safety = safety }, docn) + + where + safety = Just $ showPpr $ safeHaskell dflags + failure = (emptyHaddockModInfo, Nothing) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index d0e3e5fb..35533d0d 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -59,7 +59,8 @@ parseModuleHeader dflags str0 = hmi_description = docOpt, hmi_portability = portabilityOpt, hmi_stability = stabilityOpt, - hmi_maintainer = maintainerOpt + hmi_maintainer = maintainerOpt, + hmi_safety = Nothing }, doc) -- | This function is how we read keys. diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs index 6f7af908..d63524b6 100644 --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -9,8 +9,9 @@ import Name ( Name ) import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = - HaddockModInfo (fmap (rnDoc gre) desc) port stab maint +rnHaddockModInfo gre hmod = + let desc = hmi_description hmod + in hmod { hmi_description = fmap (rnDoc gre) desc } ids2string :: [RdrName] -> String ids2string [] = [] diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index d337eefe..33f28d68 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -511,13 +511,15 @@ instance Binary name => Binary (HaddockModInfo name) where put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi) + put_ bh (hmi_safety hmi) get bh = do descr <- get bh porta <- get bh stabi <- get bh maint <- get bh - return (HaddockModInfo descr porta stabi maint) + safet <- get bh + return (HaddockModInfo descr porta stabi maint safet) instance Binary DocName where diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index d82e3efd..c0bf4ad7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -330,6 +330,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_stability :: Maybe String , hmi_maintainer :: Maybe String + , hmi_safety :: Maybe String } @@ -339,6 +340,7 @@ emptyHaddockModInfo = HaddockModInfo , hmi_portability = Nothing , hmi_stability = Nothing , hmi_maintainer = Nothing + , hmi_safety = Nothing } -- cgit v1.2.3 From dca8a6d07073bcb9fb35c8dd39fc5eeccd142e2a Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 22 Oct 2011 11:29:06 +0200 Subject: Bump .haddock file version since the format has changed recently --- src/Haddock/InterfaceFile.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 33f28d68..1c2aa360 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -64,14 +64,10 @@ binaryInterfaceMagic = 0xD0Cface -- because we store GHC datatypes in our interface files, we need to make sure -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 700 -binaryInterfaceVersion = 16 -#elif __GLASGOW_HASKELL__ == 701 -binaryInterfaceVersion = 16 -#elif __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 16 +#if __GLASGOW_HASKELL__ == 702 +binaryInterfaceVersion = 17 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 16 +binaryInterfaceVersion = 17 #else #error Unknown GHC version #endif -- cgit v1.2.3