added unlit stage for literate Haskell source files

Signed-off-by: Alexander Diemand <codieplusplus@apax.net>

extension/package.json

@@ -23,7 +23,9 @@
 			"id": "haskell",
 			"extensions": [
 				"hs",
-				"hs-boot"
+				"hs-boot",
+				"lhs-boot",
+				"lhs"
 			]
 		}],
 		"configuration": {

src/Development/IDE/Core/Compile.hs

@@ -57,6 +57,9 @@ import           System.FilePath
 import System.IO.Extra
 import Data.Char
 
+import SysTools (Option (..), runUnlit)
+
+
 -- | Given a string buffer, return a pre-processed @ParsedModule@.
 parseModule
     :: IdeOptions
@@ -267,6 +270,33 @@ getModSummaryFromBuffer fp contents dflags parsed = do
           then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
           else (HsSrcFile , \newExt -> stem <.> newExt)
 
+-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
+runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
+runLhs dflags filename contents = withTempDir $ \dir -> do
+    let fout = dir </> takeFileName filename <.> "unlit"
+    filesrc <- case contents of
+        Nothing   -> return filename
+        Just cnts -> do
+            let fsrc = dir </> takeFileName filename <.> "literate"
+            withBinaryFile fsrc WriteMode $ \h ->
+                hPutStringBuffer h cnts
+            return fsrc
+    unlit filesrc fout
+    SB.hGetStringBuffer fout
+  where
+    unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
+    args filein fileout = [
+                      SysTools.Option     "-h"
+                    , SysTools.Option     (escape filename) -- name this file
+                    , SysTools.FileOption "" filein       -- input file
+                    , SysTools.FileOption "" fileout ]    -- output file
+    -- taken from ghc's DriverPipeline.hs
+    escape ('\\':cs) = '\\':'\\': escape cs
+    escape ('\"':cs) = '\\':'\"': escape cs
+    escape ('\'':cs) = '\\':'\'': escape cs
+    escape (c:cs)    = c : escape cs
+    escape []        = []
+
 -- | Run CPP on a file
 runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
 runCpp dflags filename contents = withTempDir $ \dir -> do
@@ -304,7 +334,6 @@ runCpp dflags filename contents = withTempDir $ \dir -> do
                     | otherwise = x
             stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
 
-
 -- | Given a buffer, flags, file path and module summary, produce a
 -- parsed module (or errors) and any parse warnings.
 parseFileContents
@@ -314,15 +343,24 @@ parseFileContents
        -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
 parseFileContents preprocessor filename mbContents = do
-   contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
-   dflags  <- ExceptT $ parsePragmasIntoDynFlags filename contents
+   contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
+   let isOnDisk = isNothing mbContents
 
+   -- unlit content if literate Haskell ending
+   (isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename
+      then do
+        dflags <- getDynFlags
+        newcontent <- liftIO $ runLhs dflags filename mbContents
+        return (False, newcontent)
+      else return (isOnDisk, contents)
+
+   dflags  <- ExceptT $ parsePragmasIntoDynFlags filename contents
    (contents, dflags) <-
       if not $ xopt LangExt.Cpp dflags then
           return (contents, dflags)
       else do
-          contents <- liftIO $ runCpp dflags filename mbContents
+          contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
           dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
           return (contents, dflags)
 

src/Development/IDE/Types/Options.hs

@@ -43,7 +43,7 @@ defaultIdeOptions :: Action HscEnv -> IdeOptions
 defaultIdeOptions session = IdeOptions
     {optPreprocessor = (,) []
     ,optGhcSession = session
-    ,optExtensions = ["hs"]
+    ,optExtensions = ["hs", "lhs"]
     ,optPkgLocationOpts = defaultIdePkgLocationOptions
     ,optThreads = 0
     ,optShakeProfiling = Nothing

test/manual/lhs/Bird.lhs

@@ -0,0 +1,19 @@
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+
+\subsection{Bird-style LHS}
+
+> module Bird
+>     (
+>       fly
+>     ) where
+
+
+
+what birds are able to do:
+
+> fly :: IO ()
+> fly = putStrLn "birds fly."
+
+

test/manual/lhs/Main.hs

@@ -0,0 +1,12 @@
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Main
+  (
+    main
+  ) where
+
+import Test (main)
+
+
+

test/manual/lhs/Test.lhs

@@ -0,0 +1,36 @@
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+
+\subsection{Testing LHS}
+
+\begin{code}
+{-# LANGUAGE CPP #-}
+
+module Test
+    (
+      main
+    ) where
+
+
+import Bird
+
+\end{code}
+
+for this file, \emph{hlint} should be turned off.
+\begin{code}
+{-# ANN module ("HLint: ignore" :: String) #-}
+\end{code}
+
+our main procedure
+
+\begin{code}
+
+main :: IO ()
+main = do
+  putStrLn "hello world."
+  fly
+
+\end{code}
+
+