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
"."]
              }

-- | 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 = 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

-- | 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 -> 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 = 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

-- | 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 = 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"

-- | 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 = 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" -- clear the old path
                        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)