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
#if defined(NEED_PHANTOM_DIRECTORY)
import Data.Maybe (maybe)
#endif
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 :: [String] -> m ()
setGhcOptions opts :: [String]
opts =
    do DynFlags
old_flags <- RunGhc m DynFlags
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
       (new_flags :: DynFlags
new_flags,not_parsed :: [String]
not_parsed) <- RunGhc2 m DynFlags [String] (DynFlags, [String])
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
DynFlags -> [String] -> GhcT n (DynFlags, [String])
forall (m :: * -> *).
GhcMonad m =>
DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags DynFlags
old_flags [String]
opts
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
not_parsed) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> m ()) -> InterpreterError -> m ()
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError
                            (String -> InterpreterError) -> String -> InterpreterError
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["flags: ", [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
quote [String]
not_parsed,
                                               "not recognized"]
       [InstalledUnitId]
_ <- RunGhc1 m DynFlags [InstalledUnitId]
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
DynFlags -> GhcT n [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
new_flags
       () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

setGhcOption :: MonadInterpreter m => String -> m ()
setGhcOption :: String -> m ()
setGhcOption opt :: String
opt = [String] -> m ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions [String
opt]

defaultConf :: InterpreterConfiguration
defaultConf :: InterpreterConfiguration
defaultConf = Conf :: [String] -> [Extension] -> Bool -> InterpreterConfiguration
Conf {
                languageExts :: [Extension]
languageExts   = [],
                allModsInScope :: Bool
allModsInScope = Bool
False,
                searchFilePath :: [String]
searchFilePath = ["."]
              }

-- | Available options are:
--
--    * 'languageExtensions'
--
--    * 'installedModulesInScope'
--
--    * 'searchPath'
data Option m a = Option{
                    Option m a -> MonadInterpreter m => a -> m ()
_set :: MonadInterpreter m => a -> m (),
                    Option m a -> MonadInterpreter m => m a
_get :: MonadInterpreter m => m a
                  }

data OptionVal m = forall a . (Option m a) := a

-- | Use this function to set or modify the value of any option. It is
--   invoked like this:
--
--   @set [opt1 := val1, opt2 := val2,... optk := valk]@
set :: MonadInterpreter m => [OptionVal m] -> m ()
set :: [OptionVal m] -> m ()
set = (OptionVal m -> m ()) -> [OptionVal m] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((OptionVal m -> m ()) -> [OptionVal m] -> m ())
-> (OptionVal m -> m ()) -> [OptionVal m] -> m ()
forall a b. (a -> b) -> a -> b
$ \(opt :: Option m a
opt := val :: a
val) -> Option m a -> a -> m ()
forall (m :: * -> *) a.
Option m a -> MonadInterpreter m => a -> m ()
_set Option m a
opt a
val

-- | Retrieves the value of an option.
get :: MonadInterpreter m => Option m a -> m a
get :: Option m a -> m a
get = Option m a -> m a
forall (m :: * -> *) a. Option m a -> MonadInterpreter m => m a
_get

-- | Language extensions in use by the interpreter.
--
-- Default is: @[]@ (i.e. none, pure Haskell 98)
languageExtensions :: MonadInterpreter m => Option m [Extension]
languageExtensions :: Option m [Extension]
languageExtensions = (MonadInterpreter m => [Extension] -> m ())
-> (MonadInterpreter m => m [Extension]) -> Option m [Extension]
forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option [Extension] -> m ()
MonadInterpreter m => [Extension] -> m ()
setter m [Extension]
MonadInterpreter m => m [Extension]
getter
    where setter :: [Extension] -> m ()
setter es :: [Extension]
es = do m ()
resetExtensions
                         [String] -> m ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Extension -> String
extFlag Bool
True) [Extension]
es
                         (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf ((InterpreterConfiguration -> InterpreterConfiguration) -> m ())
-> (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall a b. (a -> b) -> a -> b
$ \c :: InterpreterConfiguration
c -> InterpreterConfiguration
c{languageExts :: [Extension]
languageExts = [Extension]
es}
          --
          getter :: m [Extension]
getter = (InterpreterConfiguration -> [Extension]) -> m [Extension]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> [Extension]
languageExts
          --
          resetExtensions :: m ()
resetExtensions = do [(Extension, Bool)]
es <- (InterpreterState -> [(Extension, Bool)]) -> m [(Extension, Bool)]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [(Extension, Bool)]
defaultExts
                               [String] -> m ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setGhcOptions ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ ((Extension, Bool) -> String) -> [(Extension, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Extension -> Bool -> String) -> (Extension, Bool) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Extension -> Bool -> String) -> (Extension, Bool) -> String)
-> (Extension -> Bool -> String) -> (Extension, Bool) -> String
forall a b. (a -> b) -> a -> b
$ (Bool -> Extension -> String) -> Extension -> Bool -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Extension -> String
extFlag) [(Extension, Bool)]
es

extFlag :: Bool -> Extension -> String
extFlag :: Bool -> Extension -> String
extFlag = Bool -> Extension -> String
mkFlag
  where mkFlag :: Bool -> Extension -> String
mkFlag b :: Bool
b (UnknownExtension o :: String
o)   = Bool -> String -> String
strToFlag Bool
b String
o
        mkFlag b :: Bool
b o :: Extension
o                      = Bool -> String -> String
strToFlag Bool
b (Extension -> String
forall a. Show a => a -> String
show Extension
o)
        --
        strToFlag :: Bool -> String -> String
strToFlag b :: Bool
b o :: String
o@('N':'o':(c :: Char
c:_))
                             | Char -> Bool
isUpper Char
c = "-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (if Bool
b then 0 else 2) String
o
        strToFlag b :: Bool
b o :: String
o                    = "-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["No"|Bool -> Bool
not Bool
b] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o

-- | When set to @True@, every module in every available package is implicitly
--   imported qualified. This is very convenient for interactive
--   evaluation, but can be a problem in sandboxed environments
--   (e.g. 'System.Unsafe.unsafePerformIO' is in scope).
--
--   Default value is @True@.
--
--   Observe that due to limitations in the GHC-API, when set to @False@, the
--   private symbols in interpreted modules will not be in scope.
installedModulesInScope :: MonadInterpreter m => Option m Bool
installedModulesInScope :: Option m Bool
installedModulesInScope = (MonadInterpreter m => Bool -> m ())
-> (MonadInterpreter m => m Bool) -> Option m Bool
forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option MonadInterpreter m => Bool -> m ()
forall (m :: * -> *). MonadInterpreter m => Bool -> m ()
setter m Bool
MonadInterpreter m => m Bool
getter
    where getter :: m Bool
getter = (InterpreterConfiguration -> Bool) -> m Bool
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> Bool
allModsInScope
          setter :: Bool -> m ()
setter b :: Bool
b = do (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf ((InterpreterConfiguration -> InterpreterConfiguration) -> m ())
-> (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall a b. (a -> b) -> a -> b
$ \c :: InterpreterConfiguration
c -> InterpreterConfiguration
c{allModsInScope :: Bool
allModsInScope = Bool
b}
                        String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "-f"                   String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["no-" | Bool -> Bool
not Bool
b] String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       "implicit-import-qualified"

-- | The search path for source files. Observe that every time it is set,
--   it overrides the previous search path. The default is @[\".\"]@.
--
--   Keep in mind that by a limitation in ghc, @\".\"@ is always in scope.
searchPath :: MonadInterpreter m => Option m [FilePath]
searchPath :: Option m [String]
searchPath = (MonadInterpreter m => [String] -> m ())
-> (MonadInterpreter m => m [String]) -> Option m [String]
forall (m :: * -> *) a.
(MonadInterpreter m => a -> m ())
-> (MonadInterpreter m => m a) -> Option m a
Option MonadInterpreter m => [String] -> m ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setter m [String]
MonadInterpreter m => m [String]
getter
    where getter :: m [String]
getter = (InterpreterConfiguration -> [String]) -> m [String]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterConfiguration -> a) -> m a
fromConf InterpreterConfiguration -> [String]
searchFilePath
          setter :: [String] -> m ()
setter p :: [String]
p = do (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf ((InterpreterConfiguration -> InterpreterConfiguration) -> m ())
-> (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
forall a b. (a -> b) -> a -> b
$ \c :: InterpreterConfiguration
c -> InterpreterConfiguration
c{searchFilePath :: [String]
searchFilePath = [String]
p}
                        String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption "-i" -- clear the old path
                        String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ":" [String]
p
#if defined(NEED_PHANTOM_DIRECTORY)
                        Maybe String
mfp <- (InterpreterState -> Maybe String) -> m (Maybe String)
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe String
phantomDirectory
                        m () -> (String -> m ()) -> Maybe String -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                              (\fp :: String
fp -> String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp) Maybe String
mfp
#endif

fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a
fromConf :: (InterpreterConfiguration -> a) -> m a
fromConf f :: InterpreterConfiguration -> a
f = (InterpreterState -> a) -> m a
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (InterpreterConfiguration -> a
f (InterpreterConfiguration -> a)
-> (InterpreterState -> InterpreterConfiguration)
-> InterpreterState
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> InterpreterConfiguration
configuration)

onConf :: MonadInterpreter m
       => (InterpreterConfiguration -> InterpreterConfiguration)
       -> m ()
onConf :: (InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf f :: InterpreterConfiguration -> InterpreterConfiguration
f = (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState ((InterpreterState -> InterpreterState) -> m ())
-> (InterpreterState -> InterpreterState) -> m ()
forall a b. (a -> b) -> a -> b
$ \st :: InterpreterState
st -> InterpreterState
st{configuration :: InterpreterConfiguration
configuration = InterpreterConfiguration -> InterpreterConfiguration
f (InterpreterState -> InterpreterConfiguration
configuration InterpreterState
st)}

configureDynFlags :: GHC.DynFlags -> GHC.DynFlags
configureDynFlags :: DynFlags -> DynFlags
configureDynFlags dflags :: DynFlags
dflags =
    (if Bool
GHC.dynamicGhc then Way -> DynFlags -> DynFlags
GHC.addWay' Way
GHC.WayDyn else DynFlags -> DynFlags
forall a. a -> a
id)
                           DynFlags
dflags{ghcMode :: GhcMode
GHC.ghcMode    = GhcMode
GHC.CompManager,
                                  hscTarget :: HscTarget
GHC.hscTarget  = HscTarget
GHC.HscInterpreted,
                                  ghcLink :: GhcLink
GHC.ghcLink    = GhcLink
GHC.LinkInMemory,
                                  verbosity :: Int
GHC.verbosity  = 0}

parseDynamicFlags :: GHC.GhcMonad m
                  => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])
parseDynamicFlags :: DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags d :: DynFlags
d = ((DynFlags, [Located String], [Warn]) -> (DynFlags, [String]))
-> m (DynFlags, [Located String], [Warn]) -> m (DynFlags, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, [Located String], [Warn]) -> (DynFlags, [String])
forall a a c. HasSrcSpan a => (a, [a], c) -> (a, [SrcSpanLess a])
firstTwo (m (DynFlags, [Located String], [Warn]) -> m (DynFlags, [String]))
-> ([String] -> m (DynFlags, [Located String], [Warn]))
-> [String]
-> m (DynFlags, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags DynFlags
d ([Located String] -> m (DynFlags, [Located String], [Warn]))
-> ([String] -> [Located String])
-> [String]
-> m (DynFlags, [Located String], [Warn])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc
    where firstTwo :: (a, [a], c) -> (a, [SrcSpanLess a])
firstTwo (a :: a
a,b :: [a]
b,_) = (a
a, (a -> SrcSpanLess a) -> [a] -> [SrcSpanLess a]
forall a b. (a -> b) -> [a] -> [b]
map a -> SrcSpanLess a
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc [a]
b)