From 4f75be94f45a0e92553eccefe56230c554333ce7 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Sun, 10 Dec 2017 12:22:21 -0800
Subject: Use the GHC lexer for the Hyperlinker backend (#714)

* Start changing to use GHC lexer

* better cpp

* Change SrcSpan to RealSrcSpan

* Remove error

* Try to stop too many open files

* wip

* wip

* Revert "wip"

This reverts commit b605510a195f26315e3d8ca90e6d95a6737553e1.

Conflicts:
	haddock-api/haddock-api.cabal
	haddock-api/src/Haddock/Interface.hs

* Remove pointless 'caching'

* Use dlist rather than lists when finding vars

* Use a map rather than list

* Delete bogus comment

* Rebase followup

Things now run using the GHC lexer. There are still

  - stray debug statements
  - unnecessary changes w.r.t. master

* Cleaned up differences w.r.t. current Haddock HEAD

Things are looking good. quasiquotes in particular look beautiful: the
TH ones (with Haskell source inside) colour/link their contents too!

Haven't yet begun to check for possible performance problems.

* Support CPP and top-level pragmas

The support for these is hackier - but no more hacky than the existing
support.

* Tests pass, CPP is better recognized

The tests were in some cases altered: I consider the new output to be more
correct than the old one....

* Fix shrinking of source without tabs in test

* Replace 'Position'/'Span' with GHC counterparts

Replaces 'Position' -> 'GHC.RealSrcLoc' and 'Span' -> 'GHC.RealSrcSpan'.

* Nits

* Forgot entry in .cabal

* Update changelog
---
 haddock-api/src/Haddock/Interface/Create.hs | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock/Interface/Create.hs')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 2a56e87a..4309163f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -20,7 +20,6 @@
 module Haddock.Interface.Create (createInterface) where
 
 import Documentation.Haddock.Doc (metaDocAppend)
-import Documentation.Haddock.Utf8 as Utf8
 import Haddock.Types
 import Haddock.Options
 import Haddock.GhcUtils
@@ -33,15 +32,14 @@ import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
 import Data.Bifunctor
 import Data.Bitraversable
-import qualified Data.ByteString as BS
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.List
 import Data.Maybe
 import Data.Ord
 import Control.Applicative
-import Control.Exception (evaluate)
 import Control.Monad
+import Control.DeepSeq
 import Data.Traversable
 
 import Avail hiding (avail)
@@ -160,7 +158,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
-  tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+  tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm
 
   return $! Interface {
     ifaceMod               = mdl
@@ -1137,12 +1135,12 @@ seqList :: [a] -> ()
 seqList [] = ()
 seqList (x : xs) = x `seq` seqList xs
 
-mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule
                     -> ErrMsgGhc (Maybe [RichToken])
-mkMaybeTokenizedSrc flags tm
+mkMaybeTokenizedSrc dflags flags tm
     | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
         Just src -> do
-            tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+            tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src))
             return $ Just tokens
         Nothing -> do
             liftErrMsg . tell . pure $ concat
@@ -1155,12 +1153,14 @@ mkMaybeTokenizedSrc flags tm
   where
     summary = pm_mod_summary . tm_parsed_module $ tm
 
-mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc ms src = do
-  -- make sure to read the whole file at once otherwise
+mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken]
+mkTokenizedSrc dflags ms src = do
+  -- make sure to read the whole file at once otherwise 
   -- we run out of file descriptors (see #495)
-  rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
-  return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))
+  file <- force <$> readFile (filepath)
+  return $ Hyperlinker.enrich src (Hyperlinker.parse dflags filepath file)
+  where
+    filepath = msHsFilePath ms
 
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
-- 
cgit v1.2.3