44b1166 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Merge pull request #31 from CodiePP/lhs-unlit-preprocessing

44b1166Moritz Kiefer7 years ago

extension/package.json+3−1

compare with master

unifiedsplit

@@ -23,7 +23,9 @@

23 "id": "haskell",

24 "extensions": [

25 "hs",

26− "hs-boot"

26+ "hs-boot",

27+ "lhs-boot",

28+ "lhs"

27 ]

29 ]

28 }],

30 }],

29 "configuration": {

31 "configuration": {

src/Development/IDE/Core/Compile.hs+42−4

@@ -57,6 +57,9 @@ import System.FilePath

57import System.IO.Extra

58import Data.Char

60+import SysTools (Option (..), runUnlit)

61+

62+

60-- | Given a string buffer, return a pre-processed @ParsedModule@.

63-- | Given a string buffer, return a pre-processed @ParsedModule@.

61parseModule

64parseModule

62 :: IdeOptions

65 :: IdeOptions

@@ -267,6 +270,33 @@ getModSummaryFromBuffer fp contents dflags parsed = do

267 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

270 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

268 else (HsSrcFile , \newExt -> stem <.> newExt)

271 else (HsSrcFile , \newExt -> stem <.> newExt)

269

272

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+

270-- | Run CPP on a file

300-- | Run CPP on a file

271runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

301runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

272runCpp dflags filename contents = withTempDir $ \dir -> do

302runCpp dflags filename contents = withTempDir $ \dir -> do

@@ -304,7 +334,6 @@ runCpp dflags filename contents = withTempDir $ \dir -> do

304 | otherwise = x

334 | otherwise = x

305 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out

335 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out

306

336

307−

308-- | Given a buffer, flags, file path and module summary, produce a

337-- | Given a buffer, flags, file path and module summary, produce a

309-- parsed module (or errors) and any parse warnings.

338-- parsed module (or errors) and any parse warnings.

310parseFileContents

339parseFileContents

@@ -314,15 +343,24 @@ parseFileContents

314 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

343 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

315 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

344 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

316parseFileContents preprocessor filename mbContents = do

345parseFileContents preprocessor filename mbContents = do

317− contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents

318 let loc = mkRealSrcLoc (mkFastString filename) 1 1

346 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

320

349

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

321 (contents, dflags) <-

359 (contents, dflags) <-

322 if not $ xopt LangExt.Cpp dflags then

360 if not $ xopt LangExt.Cpp dflags then

323 return (contents, dflags)

361 return (contents, dflags)

324 else do

362 else do

325− contents <- liftIO $ runCpp dflags filename mbContents

363+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents

326 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

364 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

327 return (contents, dflags)

365 return (contents, dflags)

328

366

src/Development/IDE/Types/Options.hs+1−1

@@ -56,7 +56,7 @@ defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

56defaultIdeOptions session = IdeOptions

57 {optPreprocessor = (,) []

58 ,optGhcSession = session

59− ,optExtensions = ["hs"]

59+ ,optExtensions = ["hs", "lhs"]

60 ,optPkgLocationOpts = defaultIdePkgLocationOptions

61 ,optThreads = 0

62 ,optShakeProfiling = Nothing

test/manual/lhs/Bird.lhsnew file+19

@@ -0,0 +1,19 @@

2+-- SPDX-License-Identifier: Apache-2.0

5+\subsection{Bird-style LHS}

7+> module Bird

8+> (

9+> fly

10+> ) where

11+

12+

13+

14+what birds are able to do:

15+

16+> fly :: IO ()

17+> fly = putStrLn "birds fly."

18+

19+

test/manual/lhs/Main.hsnew file+12

@@ -0,0 +1,12 @@

2+-- SPDX-License-Identifier: Apache-2.0

4+module Main

5+ (

6+ main

7+ ) where

9+import Test (main)

10+

11+

12+

test/manual/lhs/Test.lhsnew file+36

@@ -0,0 +1,36 @@

2+-- SPDX-License-Identifier: Apache-2.0

5+\subsection{Testing LHS}

7+\begin{code}

8+{-# LANGUAGE CPP #-}

10+module Test

11+ (

12+ main

13+ ) where

14+

15+

16+import Bird

17+

18+\end{code}

19+

20+for this file, \emph{hlint} should be turned off.

21+\begin{code}

22+{-# ANN module ("HLint: ignore" :: String) #-}

23+\end{code}

24+

25+our main procedure

26+

27+\begin{code}

28+

29+main :: IO ()

30+main = do

31+ putStrLn "hello world."

32+ fly

33+

34+\end{code}

35+

36+