wip

Author: mpickering

haddock-api/haddock-api.cabal

@@ -53,6 +53,7 @@ library
 
     , ghc-paths
     , haddock-library == 1.2.*
+    , pipes
 
   hs-source-dirs:
       src

haddock-api/src/Haddock.hs

@@ -73,6 +73,7 @@ import Packages
 import Panic (handleGhcException)
 import Module
 import FastString
+import Pipes
 
 --------------------------------------------------------------------------------
 -- * Exception handling
@@ -161,9 +162,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
 
-  ghc flags' $ do
+  ghc flags' $ runEffect $ do
 
-    dflags <- getDynFlags
+    dflags <- lift getDynFlags
 
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -176,14 +177,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           }
 
       -- Render the interfaces.
-      liftIO $ renderStep dflags flags qual packages ifaces
+      lift $ liftIO $ renderStep dflags flags qual packages ifaces
 
     else do
       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
         throwE "No input file(s)."
 
       -- Get packages supplied with --read-interface.
-      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+      readInterfaceFiles freshNameCache (readIfaceArgs flags)
+      let packages = undefined
 
       -- Render even though there are no input files (usually contents/index).
       liftIO $ renderStep dflags flags qual packages []
@@ -208,16 +210,12 @@ withGhc flags action = do
 
 
 readPackagesAndProcessModules :: [Flag] -> [String]
-                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+                              -> Producer' Interface (StateT LinkEnv Ghc) ()
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
-    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
-
-    -- Create the interfaces -- this is the core part of Haddock.
-    let ifaceFiles = map snd packages
-    (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
-
-    return (packages, ifaces, homeLinks)
+    readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+    >-> map snd
+    >-> processModules (verbosity flags) files flags
 
 
 renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
@@ -365,19 +363,18 @@ modulePackageInfo dflags flags modu =
 readInterfaceFiles :: MonadIO m
                    => NameCacheAccessor m
                    -> [(DocPaths, FilePath)]
-                   -> m [(DocPaths, InterfaceFile)]
+                   -> Producer' (DocPaths, InterfaceFile) m ()
 readInterfaceFiles name_cache_accessor pairs = do
-  catMaybes `liftM` mapM tryReadIface pairs
+  mapM_ tryReadIface pairs
   where
     -- try to read an interface, warn if we can't
     tryReadIface (paths, file) =
-      readInterfaceFile name_cache_accessor file >>= \case
+      lift (readInterfaceFile name_cache_accessor file) >>= \case
         Left err -> liftIO $ do
           putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
-          return Nothing
-        Right f -> return $ Just (paths, f)
+        Right f -> yield (paths, f)
 
 
 -------------------------------------------------------------------------------

haddock-api/src/Haddock/Interface.hs

@@ -57,6 +57,8 @@ import GHC hiding (verbosity)
 import HscTypes
 import FastString (unpackFS)
 
+import Pipes
+
 -- | Create 'Interface's and a link environment by typechecking the list of
 -- modules using the GHC API and processing the resulting syntax trees.
 processModules
@@ -65,11 +67,11 @@ processModules
                                 -- module topology
   -> [Flag]                     -- ^ Command-line flags
   -> [InterfaceFile]            -- ^ Interface files of package dependencies
-  -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
+  -> Producer' Interface (StateT LinkEnv Ghc) () -- ^ Resulting list of interfaces and renaming
                                 -- environment
 processModules verbosity modules flags extIfaces = do
 
-  out verbosity verbose "Creating interfaces..."
+  lift $ lift $ out verbosity verbose "Creating interfaces..."
   let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
                                    , iface <- ifInstalledIfaces ext ]
   interfaces <- createIfaces0 verbosity modules flags instIfaceMap

haddock-api/src/Haddock/Interface/Specialize.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
 
 
 module Haddock.Interface.Specialize
@@ -34,7 +36,8 @@ specialize :: (Eq name, Typeable name)
            => Data a
            => name -> HsType name -> a -> a
 specialize name details =
-    everywhere $ mkT step
+    let !a = everywhere $ mkT step
+    in a
   where
     step (HsTyVar (L _ name')) | name == name' = details
     step typ = typ

haddock.cabal

@@ -62,7 +62,8 @@ executable haddock
       ghc-boot,
       ghc >= 7.11 && < 8.1,
       bytestring,
-      transformers
+      transformers,
+      pipes
 
     other-modules:
       ResponseFile,
@@ -121,6 +122,7 @@ executable haddock
       Haddock.Options
       Haddock.GhcUtils
       Haddock.Syb
+      Haddock.Pipes
       Haddock.Convert
   else
     build-depends:  haddock-api == 2.16.*