module Hint.Configuration (
setGhcOption, setGhcOptions,
defaultConf,
get, set, Option, OptionVal(..),
languageExtensions, availableExtensions, Extension(..),
installedModulesInScope,
searchPath,
configureDynFlags, parseDynamicFlags,
) where
import Control.Monad
import Control.Monad.Catch
import Data.Char
import Data.Maybe (maybe)
import Data.List (intercalate)
import qualified Hint.GHC as GHC
import Hint.Base
import Hint.Util (quote)
import Hint.Extension
setGhcOptions :: MonadInterpreter m => [String] -> m ()
setGhcOptions :: forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions [String]
opts =
do DynFlags
old_flags <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
Logger
logger <- forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession forall a. SessionData a -> Logger
ghcLogger
(DynFlags
new_flags,[String]
not_parsed) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
Logger -> DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags Logger
logger DynFlags
old_flags [String]
opts
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
not_parsed) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"flags: ", [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
quote [String]
not_parsed,
String
"not recognized"]
()
_ <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
new_flags
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setGhcOption :: MonadInterpreter m => String -> m ()
setGhcOption :: forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption String
opt = forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions [String
opt]
defaultConf :: InterpreterConfiguration
defaultConf :: InterpreterConfiguration
defaultConf = Conf {
languageExts :: [Extension]
languageExts = [],
allModsInScope :: Bool
allModsInScope = Bool
False,
searchFilePath :: [String]
searchFilePath = [String
"."]
}
data Option m a = Option{
forall (m :: * -> *) a.
Option m a -> MonadInterpreter m => a -> m ()
_set :: MonadInterpreter m => a -> m (),
forall (m :: * -> *) a. Option m a -> MonadInterpreter m => m a
_get :: MonadInterpreter m => m a
}
data OptionVal m = forall a . (Option m a) := a
set :: MonadInterpreter m => [OptionVal m] -> m ()
set :: forall (m :: * -> *). MonadInterpreter m => [OptionVal m] -> m ()
set = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ \(Option m a
opt := a
val) -> forall (m :: * -> *) a.
Option m a -> MonadInterpreter m => a -> m ()
_set Option m a
opt a
val
get :: MonadInterpreter m => Option m a -> m a
get :: forall (m :: * -> *) a. MonadInterpreter m => Option m a -> m a
get = \Option m a
o -> forall (m :: * -> *) a. Option m a -> MonadInterpreter m => m a
_get Option m a
o
languageExtensions :: MonadInterpreter m => Option m [Extension]
languageExtensions :: forall (m :: * -> *). MonadInterpreter m => Option m [Extension]
languageExtensions = forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option [Extension] -> m ()
setter m [Extension]
getter
where setter :: [Extension] -> m ()
setter [Extension]
es = do m ()
resetExtensions
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Extension -> String
extFlag Bool
True) [Extension]
es
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf forall a b. (a -> b) -> a -> b
$ \InterpreterConfiguration
c -> InterpreterConfiguration
c{languageExts :: [Extension]
languageExts = [Extension]
es}
getter :: m [Extension]
getter = forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> [Extension]
languageExts
resetExtensions :: m ()
resetExtensions = do [(Extension, Bool)]
es <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [(Extension, Bool)]
defaultExts
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Extension -> String
extFlag) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Extension, Bool)]
es
extFlag :: Bool -> Extension -> String
extFlag :: Bool -> Extension -> String
extFlag = Bool -> Extension -> String
mkFlag
where mkFlag :: Bool -> Extension -> String
mkFlag Bool
b (UnknownExtension String
o) = Bool -> String -> String
strToFlag Bool
b String
o
mkFlag Bool
b Extension
o = Bool -> String -> String
strToFlag Bool
b (forall a. Show a => a -> String
show Extension
o)
strToFlag :: Bool -> String -> String
strToFlag Bool
b o :: String
o@(Char
'N':Char
'o':(Char
c:String
_))
| Char -> Bool
isUpper Char
c = String
"-X" forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (if Bool
b then Int
0 else Int
2) String
o
strToFlag Bool
b String
o = String
"-X" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"No"|Bool -> Bool
not Bool
b] forall a. [a] -> [a] -> [a]
++ String
o
installedModulesInScope :: MonadInterpreter m => Option m Bool
installedModulesInScope :: forall (m :: * -> *). MonadInterpreter m => Option m Bool
installedModulesInScope = forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option forall {m :: * -> *}. MonadInterpreter m => Bool -> m ()
setter m Bool
getter
where getter :: m Bool
getter = forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> Bool
allModsInScope
setter :: Bool -> m ()
setter Bool
b = do forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf forall a b. (a -> b) -> a -> b
$ \InterpreterConfiguration
c -> InterpreterConfiguration
c{allModsInScope :: Bool
allModsInScope = Bool
b}
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption forall a b. (a -> b) -> a -> b
$ String
"-f" forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"no-" | Bool -> Bool
not Bool
b] forall a. [a] -> [a] -> [a]
++
String
"implicit-import-qualified"
searchPath :: MonadInterpreter m => Option m [FilePath]
searchPath :: forall (m :: * -> *). MonadInterpreter m => Option m [String]
searchPath = forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setter m [String]
getter
where getter :: m [String]
getter = forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> [String]
searchFilePath
setter :: [String] -> m ()
setter [String]
p = do forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf forall a b. (a -> b) -> a -> b
$ \InterpreterConfiguration
c -> InterpreterConfiguration
c{searchFilePath :: [String]
searchFilePath = [String]
p}
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption String
"-i"
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption forall a b. (a -> b) -> a -> b
$ String
"-i" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
":" [String]
p
Maybe String
mfp <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe String
phantomDirectory
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\String
fp -> forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption forall a b. (a -> b) -> a -> b
$ String
"-i" forall a. [a] -> [a] -> [a]
++ String
fp) Maybe String
mfp
fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a
fromConf :: forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> a
f = forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (InterpreterConfiguration -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> InterpreterConfiguration
configuration)
onConf :: MonadInterpreter m
=> (InterpreterConfiguration -> InterpreterConfiguration)
-> m ()
onConf :: forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf InterpreterConfiguration -> InterpreterConfiguration
f = forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState forall a b. (a -> b) -> a -> b
$ \InterpreterState
st -> InterpreterState
st{configuration :: InterpreterConfiguration
configuration = InterpreterConfiguration -> InterpreterConfiguration
f (InterpreterState -> InterpreterConfiguration
configuration InterpreterState
st)}
configureDynFlags :: GHC.DynFlags -> GHC.DynFlags
configureDynFlags :: DynFlags -> DynFlags
configureDynFlags DynFlags
dflags =
(if Bool
GHC.dynamicGhc then Way -> DynFlags -> DynFlags
GHC.addWay Way
GHC.WayDyn else forall a. a -> a
id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
GHC.setBackendToInterpreter
forall a b. (a -> b) -> a -> b
$
DynFlags
dflags{ghcMode :: GhcMode
GHC.ghcMode = GhcMode
GHC.CompManager,
ghcLink :: GhcLink
GHC.ghcLink = GhcLink
GHC.LinkInMemory,
verbosity :: Int
GHC.verbosity = Int
0}
parseDynamicFlags :: GHC.GhcMonad m
=> GHC.Logger -> GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])
parseDynamicFlags :: forall (m :: * -> *).
GhcMonad m =>
Logger -> DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags Logger
l DynFlags
d = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {l} {b} {c}. (a, [GenLocated l b], c) -> (a, [b])
firstTwo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [GenLocated SrcSpan String]
-> m (DynFlags, [GenLocated SrcSpan String], [Warn])
GHC.parseDynamicFlags Logger
l DynFlags
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
GHC.noLoc
where firstTwo :: (a, [GenLocated l b], c) -> (a, [b])
firstTwo (a
a,[GenLocated l b]
b,c
_) = (a
a, forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
GHC.unLoc [GenLocated l b]
b)