blob: b416a3232f3ba16603abde2f256770f13b35a0a3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Parse
( parseModule
) where
--------------------------------------------------------------------------------
import Data.Function ((&))
import Data.Maybe (fromMaybe, listToMaybe)
import System.IO.Unsafe (unsafePerformIO)
--------------------------------------------------------------------------------
import Bag (bagToList)
import qualified DynFlags as GHC
import qualified ErrUtils as GHC
import FastString (mkFastString)
import qualified GHC.Hs as GHC
import qualified GHC.LanguageExtensions as GHC
import qualified HeaderInfo as GHC
import qualified HscTypes as GHC
import Lexer (ParseResult (..))
import Lexer (mkPState, unP)
import qualified Lexer as GHC
import qualified Panic as GHC
import qualified Parser as GHC
import SrcLoc (mkRealSrcLoc)
import qualified SrcLoc as GHC
import StringBuffer (stringToStringBuffer)
import qualified StringBuffer as GHC
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.GHC (baseDynFlags)
import Language.Haskell.Stylish.Module
type Extensions = [String]
--------------------------------------------------------------------------------
-- | Filter out lines which use CPP macros
unCpp :: String -> String
unCpp = unlines . go False . lines
where
go _ [] = []
go isMultiline (x : xs) =
let isCpp = isMultiline || listToMaybe x == Just '#'
nextMultiline = isCpp && not (null x) && last x == '\\'
in (if isCpp then "" else x) : go nextMultiline xs
--------------------------------------------------------------------------------
-- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it
-- because haskell-src-exts can't handle it.
dropBom :: String -> String
dropBom ('\xfeff' : str) = str
dropBom str = str
--------------------------------------------------------------------------------
-- | Abstraction over GHC lib's parsing
parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module
parseModule exts fp string =
parsePragmasIntoDynFlags baseDynFlags userExtensions filePath string >>= \dynFlags ->
dropBom string
& removeCpp dynFlags
& runParser dynFlags
& toModule dynFlags
where
toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module
toModule dynFlags res = case res of
POk ps m ->
Right (makeModule ps m)
PFailed failureState ->
let
withFileName x = maybe "" (<> ": ") fp <> x
in
Left . withFileName . unlines . getParserStateErrors dynFlags $ failureState
removeCpp dynFlags s =
if GHC.xopt GHC.Cpp dynFlags then unCpp s
else s
userExtensions =
fmap toLocatedExtensionFlag ("Haskell2010" : exts) -- FIXME: do we need `Haskell2010` here?
toLocatedExtensionFlag flag
= "-X" <> flag
& GHC.L GHC.noSrcSpan
getParserStateErrors dynFlags state
= GHC.getErrorMessages state dynFlags
& bagToList
& fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg)
filePath =
fromMaybe "<interactive>" fp
runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs))
runParser flags str =
let
filename = mkFastString filePath
parseState = mkPState flags (stringToStringBuffer str) (mkRealSrcLoc filename 1 1)
in
unP GHC.parseModule parseState
-- | Parse 'DynFlags' from the extra options
--
-- /Note:/ this function would be IO, but we're not using any of the internal
-- features that constitute side effectful computation. So I think it's fine
-- if we run this to avoid changing the interface too much.
parsePragmasIntoDynFlags ::
GHC.DynFlags
-> [GHC.Located String]
-> FilePath
-> String
-> Either String GHC.DynFlags
{-# NOINLINE parsePragmasIntoDynFlags #-}
parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO $ catchErrors $ do
let opts = GHC.getOptions originalFlags (GHC.stringToStringBuffer str) filepath
(parsedFlags, _invalidFlags, _warnings) <- GHC.parseDynamicFilePragma originalFlags (opts <> extraOpts)
-- FIXME: have a look at 'leftovers' since it should be empty
return $ Right $ parsedFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
where
catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act)
reportErr e = return $ Left (show e)
|
