aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-22 14:04:41 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-30 22:37:49 +0200
commit4190a05c4abc710d253212017fb4a654ebde1862 (patch)
treeff8c314093a4742bbde05b723fb4d82860b5948b /haddock-api
parent3eb96a6bbc1f61b81c20df882e243c4d9f4a9404 (diff)
Implement source tokenization during interface creation process.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs30
1 files changed, 29 insertions, 1 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 63d44366..59f7076f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,8 @@ import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
+import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
import qualified Data.Map as M
import Data.Map (Map)
@@ -122,6 +124,8 @@ createInterface tm flags modMap instIfaceMap = do
mkAliasMap dflags $ tm_renamed_source tm
modWarn = moduleWarning dflags gre warnings
+ tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+
return $! Interface {
ifaceMod = mdl
, ifaceOrigFilename = msHsFilePath ms
@@ -145,7 +149,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceFamInstances = fam_instances
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
- , ifaceTokenizedSrc = Nothing
+ , ifaceTokenizedSrc = tokenizedSrc
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -862,6 +866,30 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
+mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+ -> ErrMsgGhc (Maybe [RichToken])
+mkMaybeTokenizedSrc flags tm
+ | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
+ Just src -> do
+ tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+ return $ Just tokens
+ Nothing -> do
+ liftErrMsg . tell . pure $ concat
+ [ "Warning: Cannot hyperlink module \""
+ , moduleNameString . ms_mod_name $ summary
+ , "\" because renamed source is not available"
+ ]
+ return Nothing
+ | otherwise = return Nothing
+ where
+ summary = pm_mod_summary . tm_parsed_module $ tm
+
+mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
+mkTokenizedSrc ms src =
+ Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc
+ where
+ rawSrc = readFile $ msHsFilePath ms
+
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search