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