This repository has been archived by the owner on Apr 25, 2020. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 177
/
GHCApi.hs
153 lines (131 loc) · 5.17 KB
/
GHCApi.hs
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.GhcMod.GHCApi (
withGHC
, withGHCDummyFile
, initializeFlags
, initializeFlagsWithCradle
, setTargetFiles
, getDynamicFlags
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import CoreMonad
import Data.Maybe (isJust,fromJust)
import Distribution.PackageDescription (PackageDescription)
import DynFlags
import Exception
import GHC
import GHC.Paths (libdir)
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.ErrMsg
import Language.Haskell.GhcMod.GHCChoice
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import System.Exit
import System.IO
----------------------------------------------------------------
-- | Converting the 'Ghc' monad to the 'IO' monad.
withGHCDummyFile :: Alternative m => Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities.
-> IO (m a)
withGHCDummyFile = withGHC "Dummy"
-- | Converting the 'Ghc' monad to the 'IO' monad.
withGHC :: Alternative m => FilePath -- ^ A target file displayed in an error message.
-> Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities.
-> IO (m a)
withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags body
where
ignore :: Alternative m => SomeException -> IO (m a)
ignore e = do
hPutStr stderr $ file ++ ":0:0:Error:"
hPrint stderr e
exitSuccess
----------------------------------------------------------------
importDirs :: [IncludeDir]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
data Build = CabalPkg | SingleFile deriving Eq
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> [GHCOption] -> Bool -> m (LogReader, Maybe PackageDescription)
initializeFlagsWithCradle opt cradle ghcopts logging
| cabal = withCabal |||> withoutCabal
| otherwise = withoutCabal
where
mCradleFile = cradleCabalFile cradle
cabal = isJust mCradleFile
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc
logger <- initSession CabalPkg opt compOpts logging
return (logger, Just pkgDesc)
withoutCabal = do
logger <- initSession SingleFile opt compOpts logging
return (logger, Nothing)
where
compOpts = CompilerOptions ghcopts importDirs []
----------------------------------------------------------------
initSession :: GhcMonad m => Build
-> Options
-> CompilerOptions
-> Bool
-> m LogReader
initSession build opt compOpts logging = do
dflags0 <- getSessionDynFlags
(dflags1,readLog) <- setupDynamicFlags dflags0
_ <- setSessionDynFlags dflags1
return readLog
where
cmdOpts = ghcOptions compOpts
idirs = includeDirs compOpts
depPkgs = depPackages compOpts
ls = lineSeparator opt
setupDynamicFlags df0 = do
df1 <- modifyFlagsWithOpts df0 cmdOpts
let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt
liftIO $ setLogger logging df3 ls
----------------------------------------------------------------
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session.
initializeFlags :: GhcMonad m => Options -> m ()
initializeFlags opt = do
dflags0 <- getSessionDynFlags
dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt
void $ setSessionDynFlags dflags1
----------------------------------------------------------------
-- FIXME removing Options
modifyFlags :: DynFlags -> [IncludeDir] -> [Package] -> Bool -> Build -> DynFlags
modifyFlags d0 idirs depPkgs splice build
| splice = setSplice d4
| otherwise = d4
where
d1 = d0 { importPaths = idirs }
d2 = d1 {
ghcLink = LinkInMemory
, hscTarget = HscInterpreted
}
d3 = Gap.addDevPkgs d2 depPkgs
d4 | build == CabalPkg = Gap.setCabalPkg d3
| otherwise = d3
setSplice :: DynFlags -> DynFlags
setSplice dflag = dopt_set dflag Opt_D_dump_splices
----------------------------------------------------------------
modifyFlagsWithOpts :: GhcMonad m => DynFlags -> [GHCOption] -> m DynFlags
modifyFlagsWithOpts dflags cmdOpts =
tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts)
where
tfst (a,_,_) = a
----------------------------------------------------------------
-- | Set the files that GHC will load / compile.
setTargetFiles :: (GhcMonad m) => [FilePath] -> m ()
setTargetFiles [] = error "ghc-mod: setTargetFiles: No target files given"
setTargetFiles files = do
targets <- forM files $ \file -> guessTarget file Nothing
setTargets targets
----------------------------------------------------------------
-- | Return the 'DynFlags' currently in use in the GHC session.
getDynamicFlags :: IO DynFlags
getDynamicFlags = runGhc (Just libdir) getSessionDynFlags