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 <- 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
       (DynFlags
new_flags,[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 [String
"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,
                                               String
"not recognized"]
       ()
_ <- RunGhc1 m DynFlags ()
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall {n :: * -> *}.
(MonadIO n, MonadMask n) =>
DynFlags -> GhcT n ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
new_flags
       () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

setGhcOption :: MonadInterpreter m => String -> m ()
setGhcOption :: forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption 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 = [String
"."]
              }

-- | Available options are:
--
--    * 'languageExtensions'
--
--    * 'installedModulesInScope'
--
--    * 'searchPath'
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

-- | 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 :: forall (m :: * -> *). MonadInterpreter m => [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
$ \(Option m a
opt := a
val) -> Option m a -> MonadInterpreter m => 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 :: forall (m :: * -> *) a. MonadInterpreter m => Option m a -> m a
get = \Option m a
o -> Option m a -> MonadInterpreter m => m a
forall (m :: * -> *) a. Option m a -> MonadInterpreter m => m a
_get Option m a
o

-- | Language extensions in use by the interpreter.
--
-- Default is: @[]@ (i.e. none, pure Haskell 98)
languageExtensions :: MonadInterpreter m => Option m [Extension]
languageExtensions :: forall (m :: * -> *). MonadInterpreter m => 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 [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
$ \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 c. (a -> b -> c) -> (a, b) -> c
uncurry ((Bool -> Extension -> String) -> Extension -> Bool -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Extension -> String
extFlag) ((Extension, Bool) -> String) -> [(Extension, Bool)] -> [String]
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 (Extension -> String
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (if Bool
b then Int
0 else Int
2) String
o
        strToFlag Bool
b String
o                    = String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"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 :: forall (m :: * -> *). MonadInterpreter m => 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 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
$ \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
$ String
"-f"                   String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"no-" | Bool -> Bool
not Bool
b] String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       String
"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 :: forall (m :: * -> *). MonadInterpreter m => 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 [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
$ \InterpreterConfiguration
c -> InterpreterConfiguration
c{searchFilePath :: [String]
searchFilePath = [String]
p}
                        String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption String
"-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
$ String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":" [String]
p

                        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 ())
                              (\String
fp -> String -> m ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
setGhcOption (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"-i" String -> String -> String
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 = (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 :: forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterConfiguration -> InterpreterConfiguration) -> m ()
onConf 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
$ \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 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  = Int
0}

parseDynamicFlags :: GHC.GhcMonad m
                  => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])
parseDynamicFlags :: forall (m :: * -> *).
GhcMonad m =>
DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags DynFlags
d = ((DynFlags, [GenLocated SrcSpan String], [Warn])
 -> (DynFlags, [String]))
-> m (DynFlags, [GenLocated SrcSpan String], [Warn])
-> m (DynFlags, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, [GenLocated SrcSpan String], [Warn])
-> (DynFlags, [String])
forall {a} {l} {b} {c}. (a, [GenLocated l b], c) -> (a, [b])
firstTwo (m (DynFlags, [GenLocated SrcSpan String], [Warn])
 -> m (DynFlags, [String]))
-> ([String] -> m (DynFlags, [GenLocated SrcSpan String], [Warn]))
-> [String]
-> m (DynFlags, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> [GenLocated SrcSpan String]
-> m (DynFlags, [GenLocated SrcSpan String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [GenLocated SrcSpan String]
-> m (DynFlags, [GenLocated SrcSpan String], [Warn])
GHC.parseDynamicFlags DynFlags
d ([GenLocated SrcSpan String]
 -> m (DynFlags, [GenLocated SrcSpan String], [Warn]))
-> ([String] -> [GenLocated SrcSpan String])
-> [String]
-> m (DynFlags, [GenLocated SrcSpan String], [Warn])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> GenLocated SrcSpan String)
-> [String] -> [GenLocated SrcSpan String]
forall a b. (a -> b) -> [a] -> [b]
map String -> GenLocated SrcSpan String
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, (GenLocated l b -> b) -> [GenLocated l b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated l b -> b
forall l e. GenLocated l e -> e
GHC.unLoc [GenLocated l b]
b)