1module Hint.Configuration ( 2 setGhcOption, setGhcOptions, 3 4 defaultConf, 5 6 get, set, Option, OptionVal(..), 7 8 languageExtensions, availableExtensions, Extension(..), 9 installedModulesInScope, 10 11 searchPath, 12 13 configureDynFlags, parseDynamicFlags, 14 15) where 16 17import Control.Monad 18import Control.Monad.Catch 19import Data.Char 20import Data.Maybe (maybe) 21import Data.List (intercalate) 22 23import qualified Hint.GHC as GHC 24import Hint.Base 25import Hint.Util (quote) 26 27import Hint.Extension 28 29setGhcOptions :: MonadInterpreter m => [String] -> m () 30setGhcOptions opts = 31 do old_flags <- runGhc GHC.getSessionDynFlags 32 (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts 33 unless (null not_parsed) $ 34 throwM $ UnknownError 35 $ concat ["flags: ", unwords $ map quote not_parsed, 36 "not recognized"] 37 _ <- runGhc1 GHC.setSessionDynFlags new_flags 38 return () 39 40setGhcOption :: MonadInterpreter m => String -> m () 41setGhcOption opt = setGhcOptions [opt] 42 43defaultConf :: InterpreterConfiguration 44defaultConf = Conf { 45 languageExts = [], 46 allModsInScope = False, 47 searchFilePath = ["."] 48 } 49 50-- | Available options are: 51-- 52-- * 'languageExtensions' 53-- 54-- * 'installedModulesInScope' 55-- 56-- * 'searchPath' 57data Option m a = Option{ 58 _set :: MonadInterpreter m => a -> m (), 59 _get :: MonadInterpreter m => m a 60 } 61 62data OptionVal m = forall a . (Option m a) := a 63 64-- | Use this function to set or modify the value of any option. It is 65-- invoked like this: 66-- 67-- @set [opt1 := val1, opt2 := val2,... optk := valk]@ 68set :: MonadInterpreter m => [OptionVal m] -> m () 69set = mapM_ $ \(opt := val) -> _set opt val 70 71-- | Retrieves the value of an option. 72get :: MonadInterpreter m => Option m a -> m a 73get = _get 74 75-- | Language extensions in use by the interpreter. 76-- 77-- Default is: @[]@ (i.e. none, pure Haskell 98) 78languageExtensions :: MonadInterpreter m => Option m [Extension] 79languageExtensions = Option setter getter 80 where setter es = do resetExtensions 81 setGhcOptions $ map (extFlag True) es 82 onConf $ \c -> c{languageExts = es} 83 -- 84 getter = fromConf languageExts 85 -- 86 resetExtensions = do es <- fromState defaultExts 87 setGhcOptions $ uncurry (flip extFlag) <$> es 88 89extFlag :: Bool -> Extension -> String 90extFlag = mkFlag 91 where mkFlag b (UnknownExtension o) = strToFlag b o 92 mkFlag b o = strToFlag b (show o) 93 -- 94 strToFlag b o@('N':'o':(c:_)) 95 | isUpper c = "-X" ++ drop (if b then 0 else 2) o 96 strToFlag b o = "-X" ++ concat ["No"|not b] ++ o 97 98-- | When set to @True@, every module in every available package is implicitly 99-- imported qualified. This is very convenient for interactive 100-- evaluation, but can be a problem in sandboxed environments 101-- (e.g. 'System.Unsafe.unsafePerformIO' is in scope). 102-- 103-- Default value is @True@. 104-- 105-- Observe that due to limitations in the GHC-API, when set to @False@, the 106-- private symbols in interpreted modules will not be in scope. 107installedModulesInScope :: MonadInterpreter m => Option m Bool 108installedModulesInScope = Option setter getter 109 where getter = fromConf allModsInScope 110 setter b = do onConf $ \c -> c{allModsInScope = b} 111 setGhcOption $ "-f" ++ 112 concat ["no-" | not b] ++ 113 "implicit-import-qualified" 114 115-- | The search path for source files. Observe that every time it is set, 116-- it overrides the previous search path. The default is @[\".\"]@. 117-- 118-- Keep in mind that by a limitation in ghc, @\".\"@ is always in scope. 119searchPath :: MonadInterpreter m => Option m [FilePath] 120searchPath = Option setter getter 121 where getter = fromConf searchFilePath 122 setter p = do onConf $ \c -> c{searchFilePath = p} 123 setGhcOption "-i" -- clear the old path 124 setGhcOption $ "-i" ++ intercalate ":" p 125 126 mfp <- fromState phantomDirectory 127 maybe (return ()) 128 (\fp -> setGhcOption $ "-i" ++ fp) mfp 129 130fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a 131fromConf f = fromState (f . configuration) 132 133onConf :: MonadInterpreter m 134 => (InterpreterConfiguration -> InterpreterConfiguration) 135 -> m () 136onConf f = onState $ \st -> st{configuration = f (configuration st)} 137 138configureDynFlags :: GHC.DynFlags -> GHC.DynFlags 139configureDynFlags dflags = 140 (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id) 141 dflags{GHC.ghcMode = GHC.CompManager, 142 GHC.hscTarget = GHC.HscInterpreted, 143 GHC.ghcLink = GHC.LinkInMemory, 144 GHC.verbosity = 0} 145 146parseDynamicFlags :: GHC.GhcMonad m 147 => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) 148parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc 149 where firstTwo (a,b,_) = (a, map GHC.unLoc b) 150