From 006e0c13d7885cc446b6d58aa256a3574d4349e8 Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Mon, 12 Sep 2011 22:28:28 +0100 Subject: Follow changes to BinIface Name serialization --- src/Haddock/InterfaceFile.hs | 55 ++++++++++++++++++++++++++++---------------- 1 file changed, 35 insertions(+), 20 deletions(-) (limited to 'src/Haddock/InterfaceFile.hs') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index d337eefe..57374b1d 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -30,6 +31,7 @@ import Data.Map (Map) import GHC hiding (NoLink) import Binary +import BinIface (getSymtabName, getDictFastString) import Name import UniqSupply import UniqFM @@ -108,10 +110,10 @@ writeInterfaceFile filename iface = do let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, bin_dict_map = dict_map_ref } - ud <- newWriteState (putName bin_symtab) (putFastString bin_dict) -- put the main thing - bh <- return $ setUserData bh0 ud + bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file @@ -170,9 +172,11 @@ freshNameCache = ( create_fresh_nc , \_ -> return () ) -- monad being used. The exact monad is whichever monad the first -- argument, the getter and setter of the name cache, requires. -- -readInterfaceFile :: MonadIO m => - NameCacheAccessor m - -> FilePath -> m (Either String InterfaceFile) +readInterfaceFile :: forall m. + MonadIO m + => NameCacheAccessor m + -> FilePath + -> m (Either String InterfaceFile) readInterfaceFile (get_name_cache, set_name_cache) filename = do bh0 <- liftIO $ readBinMem filename @@ -184,23 +188,38 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do "Magic number mismatch: couldn't load interface file: " ++ filename | version /= binaryInterfaceVersion -> return . Left $ "Interface file is of wrong version: " ++ filename - | otherwise -> do + | otherwise -> with_name_cache $ \update_nc -> do dict <- get_dictionary bh0 - bh1 <- init_handle_user_data bh0 dict - - theNC <- get_name_cache - (nc', symtab) <- get_symbol_table bh1 theNC - set_name_cache nc' - - -- set the symbol table - let ud' = getUserData bh1 - bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab} + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- update_nc (get_symbol_table bh1) + return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) + (getDictFastString dict) -- load the actual data - iface <- liftIO $ get bh2 + iface <- liftIO $ get bh1 return (Right iface) where + with_name_cache :: forall a. + ((forall n b. MonadIO n + => (NameCache -> n (NameCache, b)) + -> n b) + -> m a) + -> m a + with_name_cache act = do + nc_var <- get_name_cache >>= (liftIO . newIORef) + x <- act $ \f -> do + nc <- liftIO $ readIORef nc_var + (nc', x) <- f nc + liftIO $ writeIORef nc_var nc' + return x + liftIO (readIORef nc_var) >>= set_name_cache + return x + get_dictionary bin_handle = liftIO $ do dict_p <- get bin_handle data_p <- tellBin bin_handle @@ -209,10 +228,6 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do seekBin bin_handle data_p return dict - init_handle_user_data bin_handle dict = liftIO $ do - ud <- newReadState dict - return (setUserData bin_handle ud) - get_symbol_table bh1 theNC = liftIO $ do symtab_p <- get bh1 data_p' <- tellBin bh1 -- cgit v1.2.3 From 45bcf701d8e99e86f28a966b31654c16a5ae6b42 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/Haddock/InterfaceFile.hs') 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 57374b1d..8ff91e34 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -526,13 +526,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 fddafc1d..c9b29bd0 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