module Hint.Base (
    MonadInterpreter(..), RunGhc,

    GhcError(..), InterpreterError(..), mayFail, catchIE,

    InterpreterSession, SessionData(..),
    InterpreterState(..), fromState, onState,
    InterpreterConfiguration(..),
    ImportList(..), ModuleQualification(..), ModuleImport(..),

    ModuleName, PhantomModule(..),
    findModule, moduleIsLoaded,
    withDynFlags,

    ghcVersion,

    debug, showGHC
) where

import Control.Monad.IO.Class
import Control.Monad.Catch as MC

import Data.IORef
import Data.Dynamic
import qualified Data.List

import qualified Hint.GHC as GHC

import Hint.Extension

-- | Version of the underlying ghc api. Values are:
--
-- * @804@ for GHC 8.4.x
--
-- * @806@ for GHC 8.6.x
--
-- * etc...
ghcVersion :: Int
ghcVersion :: Int
ghcVersion = __GLASGOW_HASKELL__

class (MonadIO m, MonadMask m) => MonadInterpreter m where
    fromSession      :: FromSession m a
    modifySessionRef :: ModifySessionRef m a
    runGhc           :: RunGhc m a

-- this is for hiding the actual types in haddock
type FromSession      m a = (InterpreterSession -> a) -> m a
type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a

data InterpreterError = UnknownError String
                      | WontCompile [GhcError]
                      | NotAllowed  String
                      -- | GhcExceptions from the underlying GHC API are caught
                      -- and rethrown as this.
                      | GhcException String
                      deriving (Int -> InterpreterError -> ShowS
[InterpreterError] -> ShowS
InterpreterError -> String
(Int -> InterpreterError -> ShowS)
-> (InterpreterError -> String)
-> ([InterpreterError] -> ShowS)
-> Show InterpreterError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InterpreterError] -> ShowS
$cshowList :: [InterpreterError] -> ShowS
show :: InterpreterError -> String
$cshow :: InterpreterError -> String
showsPrec :: Int -> InterpreterError -> ShowS
$cshowsPrec :: Int -> InterpreterError -> ShowS
Show, Typeable)

data InterpreterState = St {
                           InterpreterState -> [PhantomModule]
activePhantoms    :: [PhantomModule],
                           InterpreterState -> [PhantomModule]
zombiePhantoms    :: [PhantomModule],
                           InterpreterState -> Maybe String
phantomDirectory  :: Maybe FilePath,
                           InterpreterState -> PhantomModule
hintSupportModule :: PhantomModule,
                           InterpreterState -> Maybe PhantomModule
importQualHackMod :: Maybe PhantomModule,
                           InterpreterState -> [ModuleImport]
qualImports       :: [ModuleImport],
                           InterpreterState -> [(Extension, Bool)]
defaultExts       :: [(Extension, Bool)], -- R/O
                           InterpreterState -> InterpreterConfiguration
configuration     :: InterpreterConfiguration
                        }

data ImportList = NoImportList | ImportList [String] | HidingList [String]
  deriving (ImportList -> ImportList -> Bool
(ImportList -> ImportList -> Bool)
-> (ImportList -> ImportList -> Bool) -> Eq ImportList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportList -> ImportList -> Bool
$c/= :: ImportList -> ImportList -> Bool
== :: ImportList -> ImportList -> Bool
$c== :: ImportList -> ImportList -> Bool
Eq, Int -> ImportList -> ShowS
[ImportList] -> ShowS
ImportList -> String
(Int -> ImportList -> ShowS)
-> (ImportList -> String)
-> ([ImportList] -> ShowS)
-> Show ImportList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportList] -> ShowS
$cshowList :: [ImportList] -> ShowS
show :: ImportList -> String
$cshow :: ImportList -> String
showsPrec :: Int -> ImportList -> ShowS
$cshowsPrec :: Int -> ImportList -> ShowS
Show)
data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String)
  deriving (ModuleQualification -> ModuleQualification -> Bool
(ModuleQualification -> ModuleQualification -> Bool)
-> (ModuleQualification -> ModuleQualification -> Bool)
-> Eq ModuleQualification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleQualification -> ModuleQualification -> Bool
$c/= :: ModuleQualification -> ModuleQualification -> Bool
== :: ModuleQualification -> ModuleQualification -> Bool
$c== :: ModuleQualification -> ModuleQualification -> Bool
Eq, Int -> ModuleQualification -> ShowS
[ModuleQualification] -> ShowS
ModuleQualification -> String
(Int -> ModuleQualification -> ShowS)
-> (ModuleQualification -> String)
-> ([ModuleQualification] -> ShowS)
-> Show ModuleQualification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleQualification] -> ShowS
$cshowList :: [ModuleQualification] -> ShowS
show :: ModuleQualification -> String
$cshow :: ModuleQualification -> String
showsPrec :: Int -> ModuleQualification -> ShowS
$cshowsPrec :: Int -> ModuleQualification -> ShowS
Show)

-- | Represent module import statement.
--   See 'setImportsF'
data ModuleImport = ModuleImport { ModuleImport -> String
modName :: String
                                 , ModuleImport -> ModuleQualification
modQual :: ModuleQualification
                                 , ModuleImport -> ImportList
modImp  :: ImportList
                                 } deriving (Int -> ModuleImport -> ShowS
[ModuleImport] -> ShowS
ModuleImport -> String
(Int -> ModuleImport -> ShowS)
-> (ModuleImport -> String)
-> ([ModuleImport] -> ShowS)
-> Show ModuleImport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleImport] -> ShowS
$cshowList :: [ModuleImport] -> ShowS
show :: ModuleImport -> String
$cshow :: ModuleImport -> String
showsPrec :: Int -> ModuleImport -> ShowS
$cshowsPrec :: Int -> ModuleImport -> ShowS
Show)

data InterpreterConfiguration = Conf {
                                  InterpreterConfiguration -> [String]
searchFilePath :: [FilePath],
                                  InterpreterConfiguration -> [Extension]
languageExts   :: [Extension],
                                  InterpreterConfiguration -> Bool
allModsInScope :: Bool
                                }

type InterpreterSession = SessionData ()

instance Exception InterpreterError
  where
    displayException :: InterpreterError -> String
displayException (UnknownError String
err) = String
"UnknownError: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
    displayException (WontCompile  [GhcError]
es)  = [String] -> String
unlines ([String] -> String)
-> ([GhcError] -> [String]) -> [GhcError] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
Data.List.nub ([String] -> [String])
-> ([GhcError] -> [String]) -> [GhcError] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcError -> String) -> [GhcError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GhcError -> String
errMsg ([GhcError] -> String) -> [GhcError] -> String
forall a b. (a -> b) -> a -> b
$ [GhcError]
es
    displayException (NotAllowed   String
err) = String
"NotAllowed: "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
    displayException (GhcException String
err) = String
"GhcException: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err

type RunGhc  m a =
    (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)
 -> m a

data SessionData a = SessionData {
                       SessionData a -> IORef InterpreterState
internalState   :: IORef InterpreterState,
                       SessionData a -> a
versionSpecific :: a,
                       SessionData a -> IORef [GhcError]
ghcErrListRef   :: IORef [GhcError],
                       SessionData a -> Logger
ghcLogger       :: GHC.Logger
                     }

-- When intercepting errors reported by GHC, we only get a ErrUtils.Message
-- and a SrcLoc.SrcSpan. The latter holds the file name and the location
-- of the error. However, SrcSpan is abstract and it doesn't provide
-- functions to retrieve the line and column of the error... we can only
-- generate a string with this information. Maybe I can parse this string
-- later.... (sigh)
newtype GhcError = GhcError{GhcError -> String
errMsg :: String} deriving Int -> GhcError -> ShowS
[GhcError] -> ShowS
GhcError -> String
(Int -> GhcError -> ShowS)
-> (GhcError -> String) -> ([GhcError] -> ShowS) -> Show GhcError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhcError] -> ShowS
$cshowList :: [GhcError] -> ShowS
show :: GhcError -> String
$cshow :: GhcError -> String
showsPrec :: Int -> GhcError -> ShowS
$cshowsPrec :: Int -> GhcError -> ShowS
Show

mapGhcExceptions :: MonadInterpreter m
                 => (String -> InterpreterError)
                 -> m a
                 -> m a
mapGhcExceptions :: (String -> InterpreterError) -> m a -> m a
mapGhcExceptions String -> InterpreterError
buildEx m a
action =
    m a
action
      m a -> (InterpreterError -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch` (\InterpreterError
err -> case InterpreterError
err of
                            GhcException String
s -> InterpreterError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> InterpreterError
buildEx String
s)
                            InterpreterError
_              -> InterpreterError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err)

catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a
catchIE :: m a -> (InterpreterError -> m a) -> m a
catchIE = m a -> (InterpreterError -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MC.catch

-- | Module names are _not_ filepaths.
type ModuleName = String

-- ================ Handling the interpreter state =================

fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a
fromState :: (InterpreterState -> a) -> m a
fromState InterpreterState -> a
f = do
  IORef InterpreterState
ref_st <- FromSession m (IORef InterpreterState)
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession SessionData () -> IORef InterpreterState
forall a. SessionData a -> IORef InterpreterState
internalState
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ InterpreterState -> a
f (InterpreterState -> a) -> IO InterpreterState -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef InterpreterState -> IO InterpreterState
forall a. IORef a -> IO a
readIORef IORef InterpreterState
ref_st

onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()
onState :: (InterpreterState -> InterpreterState) -> m ()
onState InterpreterState -> InterpreterState
f = () () -> m InterpreterState -> m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ModifySessionRef m InterpreterState
forall (m :: * -> *) a. MonadInterpreter m => ModifySessionRef m a
modifySessionRef SessionData () -> IORef InterpreterState
forall a. SessionData a -> IORef InterpreterState
internalState InterpreterState -> InterpreterState
f

-- =============== Error handling ==============================

mayFail :: MonadInterpreter m => m (Maybe a) -> m a
mayFail :: m (Maybe a) -> m a
mayFail m (Maybe a)
action =
    do
        Maybe a
maybe_res <- m (Maybe a)
action
        --
        [GhcError]
es <- ModifySessionRef m [GhcError]
forall (m :: * -> *) a. MonadInterpreter m => ModifySessionRef m a
modifySessionRef SessionData () -> IORef [GhcError]
forall a. SessionData a -> IORef [GhcError]
ghcErrListRef ([GhcError] -> [GhcError] -> [GhcError]
forall a b. a -> b -> a
const [])
        --
        case (Maybe a
maybe_res, [GhcError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcError]
es) of
            (Maybe a
Nothing, Bool
True)  -> InterpreterError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> m a) -> InterpreterError -> m a
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError String
"Got no error message"
            (Maybe a
Nothing, Bool
False) -> InterpreterError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> m a) -> InterpreterError -> m a
forall a b. (a -> b) -> a -> b
$ [GhcError] -> InterpreterError
WontCompile ([GhcError] -> [GhcError]
forall a. [a] -> [a]
reverse [GhcError]
es)
            (Just a
a, Bool
_)      -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- ================= Debugging stuff ===============

debug :: MonadInterpreter m => String -> m ()
debug :: String -> m ()
debug = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"!! " String -> ShowS
forall a. [a] -> [a] -> [a]
++)

showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String
showGHC :: a -> m String
showGHC a
a
 = do PrintUnqualified
unqual <- RunGhc m PrintUnqualified
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n PrintUnqualified
forall (m :: * -> *). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual
      (DynFlags -> m String) -> m String
forall (m :: * -> *) a.
MonadInterpreter m =>
(DynFlags -> m a) -> m a
withDynFlags ((DynFlags -> m String) -> m String)
-> (DynFlags -> m String) -> m String
forall a b. (a -> b) -> a -> b
$ \DynFlags
df ->
        -- TODO: get unit state from somewhere?
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ DynFlags -> () -> PrintUnqualified -> SDoc -> String
GHC.showSDocForUser DynFlags
df ()
GHC.emptyUnitState PrintUnqualified
unqual (a -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr a
a)

-- ================ Misc ===================================

-- this type ought to go in Hint.Context, but ghc dislikes cyclic imports...
data PhantomModule = PhantomModule{PhantomModule -> String
pmName :: ModuleName, PhantomModule -> String
pmFile :: FilePath}
                   deriving (PhantomModule -> PhantomModule -> Bool
(PhantomModule -> PhantomModule -> Bool)
-> (PhantomModule -> PhantomModule -> Bool) -> Eq PhantomModule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PhantomModule -> PhantomModule -> Bool
$c/= :: PhantomModule -> PhantomModule -> Bool
== :: PhantomModule -> PhantomModule -> Bool
$c== :: PhantomModule -> PhantomModule -> Bool
Eq, Int -> PhantomModule -> ShowS
[PhantomModule] -> ShowS
PhantomModule -> String
(Int -> PhantomModule -> ShowS)
-> (PhantomModule -> String)
-> ([PhantomModule] -> ShowS)
-> Show PhantomModule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PhantomModule] -> ShowS
$cshowList :: [PhantomModule] -> ShowS
show :: PhantomModule -> String
$cshow :: PhantomModule -> String
showsPrec :: Int -> PhantomModule -> ShowS
$cshowsPrec :: Int -> PhantomModule -> ShowS
Show)

findModule :: MonadInterpreter m => ModuleName -> m GHC.Module
findModule :: String -> m Module
findModule String
mn = (String -> InterpreterError) -> m Module -> m Module
forall (m :: * -> *) a.
MonadInterpreter m =>
(String -> InterpreterError) -> m a -> m a
mapGhcExceptions String -> InterpreterError
NotAllowed (m Module -> m Module) -> m Module -> m Module
forall a b. (a -> b) -> a -> b
$
                    RunGhc m Module
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m Module -> RunGhc m Module
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe FastString -> GhcT n Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
mod_name Maybe FastString
forall a. Maybe a
Nothing
    where mod_name :: ModuleName
mod_name = String -> ModuleName
GHC.mkModuleName String
mn

moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool
moduleIsLoaded :: String -> m Bool
moduleIsLoaded String
mn = (Bool
True Bool -> m Module -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m Module
forall (m :: * -> *). MonadInterpreter m => String -> m Module
findModule String
mn)
                   m Bool -> (InterpreterError -> m Bool) -> m Bool
forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\InterpreterError
e -> case InterpreterError
e of
                                      NotAllowed{}  -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                      WontCompile{} -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                      InterpreterError
_             -> InterpreterError -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
e)

withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a
withDynFlags :: (DynFlags -> m a) -> m a
withDynFlags DynFlags -> m a
action = do
  DynFlags
df <- 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 -> m a
action DynFlags
df