@@ -57,6 +57,9 @@ import System.FilePath
5757import System.IO.Extra
5858import Data.Char
5959
60+import SysTools (Option (..), runUnlit)
61+
62+
6063-- | Given a string buffer, return a pre-processed @ParsedModule@.
6164parseModule
6265 :: IdeOptions
@@ -267,6 +270,33 @@ getModSummaryFromBuffer fp contents dflags parsed = do
267270 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
268271 else (HsSrcFile , \newExt -> stem <.> newExt)
269272
273+-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
274+runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
275+runLhs dflags filename contents = withTempDir $ \dir -> do
276+ let fout = dir </> takeFileName filename <.> "unlit"
277+ filesrc <- case contents of
278+ Nothing -> return filename
279+ Just cnts -> do
280+ let fsrc = dir </> takeFileName filename <.> "literate"
281+ withBinaryFile fsrc WriteMode $ \h ->
282+ hPutStringBuffer h cnts
283+ return fsrc
284+ unlit filesrc fout
285+ SB.hGetStringBuffer fout
286+ where
287+ unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
288+ args filein fileout = [
289+ SysTools.Option "-h"
290+ , SysTools.Option (escape filename) -- name this file
291+ , SysTools.FileOption "" filein -- input file
292+ , SysTools.FileOption "" fileout ] -- output file
293+ -- taken from ghc's DriverPipeline.hs
294+ escape ('\\':cs) = '\\':'\\': escape cs
295+ escape ('\"':cs) = '\\':'\"': escape cs
296+ escape ('\'':cs) = '\\':'\'': escape cs
297+ escape (c:cs) = c : escape cs
298+ escape [] = []
299+
270300-- | Run CPP on a file
271301runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
272302runCpp dflags filename contents = withTempDir $ \dir -> do
@@ -304,7 +334,6 @@ runCpp dflags filename contents = withTempDir $ \dir -> do
304334 | otherwise = x
305335 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
306336
307−
308337-- | Given a buffer, flags, file path and module summary, produce a
309338-- parsed module (or errors) and any parse warnings.
310339parseFileContents
@@ -314,15 +343,24 @@ parseFileContents
314343 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
315344 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
316345parseFileContents preprocessor filename mbContents = do
317− contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
318346 let loc = mkRealSrcLoc (mkFastString filename) 1 1
319− dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
347+ contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
348+ let isOnDisk = isNothing mbContents
320349
350+ -- unlit content if literate Haskell ending
351+ (isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename
352+ then do
353+ dflags <- getDynFlags
354+ newcontent <- liftIO $ runLhs dflags filename mbContents
355+ return (False, newcontent)
356+ else return (isOnDisk, contents)
357+
358+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
321359 (contents, dflags) <-
322360 if not $ xopt LangExt.Cpp dflags then
323361 return (contents, dflags)
324362 else do
325− contents <- liftIO $ runCpp dflags filename mbContents
363+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
326364 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
327365 return (contents, dflags)
328366