-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Interpreter.GHC
-- License     :  BSD-style
--
-- Maintainer  :  jcpetruzza@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (GHC API)
--
-- A Haskell interpreter built on top of the GHC API
-----------------------------------------------------------------------------
module Language.Haskell.Interpreter.GHC(
    -- * Session handling
     InterpreterSession, newSession, newSessionUsing,
    -- * Error handling
     InterpreterError(..), GhcError(..),
    -- * The interpreter type
     Interpreter,
    -- ** Running the interpreter
     withSession,
    -- ** Interpreter options
     setUseLanguageExtensions,
    -- ** Context handling
     ModuleName,
     loadModules, getLoadedModules, setTopLevelModules,
     setImports,
     reset,
    -- ** Module querying
     ModuleElem(..), Id, name, children,
     getModuleExports,
    -- ** Type inference
     typeOf, typeChecks, kindOf,
    -- ** Evaluation
     interpret, as, infer,
     eval)

where

import Prelude hiding ( span )

import qualified GHC
import qualified Outputable as GHC.O
import qualified ErrUtils   as GHC.E
import qualified Name       as GHC.N

import qualified GHC.Exts ( unsafeCoerce# )

import Control.Monad        ( liftM, filterM, guard, when )
import Control.Monad.Trans  ( liftIO )
import Control.Monad.Error  ( MonadError(throwError, catchError) )

import Control.Exception ( Exception(DynException), tryJust )

import Data.Typeable           ( Typeable, TypeRep, mkTyCon,
                                 mkTyConApp, splitTyConApp )
import qualified Data.Typeable ( typeOf )
import Data.Dynamic            ( fromDynamic )

import Data.List  ( (\\) )
import Data.Maybe ( catMaybes )

import Language.Haskell.Interpreter.GHC.Base

import Language.Haskell.Interpreter.GHC.Parsers     ( ParseResult(..),
                                                      parseExpr, parseType )
import Language.Haskell.Interpreter.GHC.Conversions ( FromGhcRep(..) )

import qualified Language.Haskell.Interpreter.GHC.Compat as Compat

-- | Set to true to allow GHC's extensions to Haskell 98.
setUseLanguageExtensions :: Bool -> Interpreter ()
setUseLanguageExtensions val =
    do
        ghc_session <- fromSessionState ghcSession
        --
        let negate_or_not = if val then "" else "no-"
        let flag = concat ["-f", negate_or_not, "glasgow-exts"]
        --
        old_flags               <- liftIO $ GHC.getSessionDynFlags ghc_session
        (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags
                                                                  [flag]
        --
        when (not . null $ not_parsed) $
            throwError $ UnknownError (concat ["flag: '", flag,
                                                           "' not recognized"])
        --
        liftIO $ GHC.setSessionDynFlags ghc_session new_flags
        --
        return ()

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

-- | An Id for a class, a type constructor, a data constructor, a binding, etc
type Id = String

data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id]
  deriving (Read, Show, Eq)

name :: ModuleElem -> Id
name (Fun f)     = f
name (Class c _) = c
name (Data d _)  = d

children :: ModuleElem -> [Id]
children (Fun   _)     = []
children (Class _ ms)  = ms
children (Data  _ dcs) = dcs

-- | Tries to load all the requested modules from their source file.
--   Modules my be indicated by their ModuleName (e.g. \"My.Module\") or
--   by the full path to its source file.
--
-- The interpreter is 'reset' both before loading the modules and in the event
-- of an error.
loadModules :: [String] -> Interpreter ()
loadModules fs =
    do
        ghc_session <- fromSessionState ghcSession
        --
        -- first, unload everything
        reset
        --
        let doLoad = mayFail $ do
            targets <- mapM (\f -> GHC.guessTarget f Nothing) fs
            --
            GHC.setTargets ghc_session targets
            res <- GHC.load ghc_session GHC.LoadAllTargets
            return $ guard (isSucceeded res) >> Just ()
        --
        doLoad `catchError` (\e -> reset >> throwError e)
        --
        return ()

-- | Returns the list of modules loaded with 'loadModules'.
getLoadedModules :: Interpreter [ModuleName]
getLoadedModules = liftM (map modNameFromSummary) getLoadedModSummaries

modNameFromSummary :: GHC.ModSummary -> ModuleName
modNameFromSummary =  modNameFromModule . GHC.ms_mod

modNameFromModule :: GHC.Module -> ModuleName
modNameFromModule = GHC.moduleNameString . GHC.moduleName

getLoadedModSummaries :: Interpreter [GHC.ModSummary]
getLoadedModSummaries =
  do ghc_session  <- fromSessionState ghcSession
     --
     all_mod_summ <- liftIO $ GHC.getModuleGraph ghc_session
     filterM (liftIO . GHC.isLoaded ghc_session . GHC.ms_mod_name) all_mod_summ

-- | Sets the modules whose context is used during evaluation. All bindings
--   of these modules are in scope, not only those exported.
--
--   Modules must be interpreted to use this function.
setTopLevelModules :: [ModuleName] -> Interpreter ()
setTopLevelModules ms =
    do
        ghc_session <- fromSessionState ghcSession
        --
        loaded_mods_ghc <- getLoadedModSummaries
        --
        let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc
        when (not . null $ not_loaded) $
            throwError $ NotAllowed ("These modules have not been loaded:\n" ++
                                     unlines not_loaded)
        --
        ms_mods <- mapM findModule ms
        --
        let mod_is_interpr = GHC.moduleIsInterpreted ghc_session
        not_interpreted <- liftIO $ filterM (liftM not . mod_is_interpr) ms_mods
        when (not . null $ not_interpreted) $
            throwError $ NotAllowed ("These modules are not interpreted:\n" ++
                                     unlines (map modNameFromModule
                                                  not_interpreted))
        --
        liftIO $ do
            (_, old_imports) <- GHC.getContext ghc_session
            GHC.setContext ghc_session ms_mods old_imports

-- | Gets an abstract representation of all the entities exported by the module.
--   It is similar to the @:browse@ command in GHCi.
getModuleExports :: ModuleName -> Interpreter [ModuleElem]
getModuleExports mn =
    do
        ghc_session <- fromSessionState ghcSession
        --
        module_  <- findModule mn
        mod_info <- mayFail $ GHC.getModuleInfo ghc_session module_
        exports  <- liftIO $ mapM (GHC.lookupName ghc_session)
                                  (GHC.modInfoExports mod_info)
        --
        return (asModElemList $ catMaybes exports)

asModElemList :: [GHC.TyThing] -> [ModuleElem]
asModElemList xs = concat [cs',
                           ts',
                           ds \\ (concatMap (map Fun . children) ts'),
                           fs \\ (concatMap (map Fun . children) cs')]
    where (cs,ts,ds,fs) = ([asModElem c | c@GHC.AClass{}   <- xs],
                           [asModElem t | t@GHC.ATyCon{}   <- xs],
                           [asModElem d | d@GHC.ADataCon{} <- xs],
                           [asModElem f | f@GHC.AnId{}     <- xs])
          cs' = [Class n $ filter (alsoIn fs) ms  | Class n ms  <- cs]
          ts' = [Data  t $ filter (alsoIn ds) dcs | Data  t dcs <- ts]
          alsoIn es = (`elem` (map name es))


asModElem :: GHC.TyThing -> ModuleElem
asModElem (GHC.AnId f)      = Fun $ getUnqualName f
asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc
asModElem (GHC.ATyCon tc)   = Data  (getUnqualName tc)
                                    (map getUnqualName $ GHC.tyConDataCons tc)
asModElem (GHC.AClass c)    = Class (getUnqualName c)
                                    (map getUnqualName $ GHC.classMethods c)

getUnqualName :: GHC.NamedThing a => a -> String
getUnqualName = GHC.O.showSDocUnqual . GHC.pprParenSymName

findModule :: ModuleName -> Interpreter GHC.Module
findModule mn =
    do
        ghc_session <- fromSessionState ghcSession
        --
        let mod_name = GHC.mkModuleName mn
        mapGhcExceptions NotAllowed $ GHC.findModule ghc_session
                                                     mod_name
                                                     Nothing

mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a
mapGhcExceptions buildEx action =
    do
        r <- liftIO $ tryJust ghcExceptions action
        either (throwError . buildEx . flip GHC.showGhcException []) return r

ghcExceptions :: Exception -> Maybe GHC.GhcException
ghcExceptions (DynException a) = fromDynamic a
ghcExceptions  _               = Nothing

-- | Sets the modules whose exports must be in context.
setImports :: [ModuleName] -> Interpreter ()
setImports ms =
    do
        ghc_session <- fromSessionState ghcSession
        --
        ms_mods <- mapM findModule ms
        --
        liftIO $ do
            (old_top_level, _) <- GHC.getContext ghc_session
            GHC.setContext ghc_session old_top_level ms_mods

-- | All imported modules are cleared from the context, and
--   loaded modules are unloaded. It is similar to a @:load@ in
--   GHCi, but observe that not even the Prelude will be in
--   context after a reset.
reset :: Interpreter ()
reset =
    do
        ghc_session <- fromSessionState ghcSession
        --
        -- Remove all modules from context
        liftIO $ GHC.setContext ghc_session [] []
        --
        -- Unload all previously loaded modules
        liftIO $ GHC.setTargets ghc_session []
        liftIO $ GHC.load ghc_session GHC.LoadAllTargets
        --
        -- At this point, GHCi would call rts_revertCAFs and
        -- reset the buffering of stdin, stdout and stderr.
        -- Should we do any of these?
        --
        -- liftIO $ rts_revertCAFs
        --
        return ()


-- | Returns a string representation of the type of the expression.
typeOf :: String -> Interpreter String
typeOf expr =
    do
        ghc_session <- fromSessionState ghcSession
        --
        -- First, make sure the expression has no syntax errors,
        -- for this is the only way we have to "intercept" this
        -- kind of errors
        failOnParseError parseExpr expr
        --
        ty <- mayFail $ GHC.exprType ghc_session expr
        --
        fromGhcRep ty


-- | Tests if the expression type checks.
typeChecks :: String -> Interpreter Bool
typeChecks expr = (typeOf expr >> return True)
                  `catchError`
                  onCompilationError (\_ -> return False)

-- | Returns a string representation of the kind of the type expression.
kindOf :: String -> Interpreter String
kindOf type_expr =
    do
        ghc_session <- fromSessionState ghcSession
        --
        -- First, make sure the expression has no syntax errors,
        -- for this is the only way we have to "intercept" this
        -- kind of errors
        failOnParseError parseType type_expr

        kind <- mayFail $ GHC.typeKind ghc_session type_expr
        --
        fromGhcRep (Compat.Kind kind)


-- | Convenience functions to be used with typeCheck to provide witnesses.
--   Example:
--
--   * @interpret \"head [True,False]\" (as :: Bool)@
--
--   * @interpret \"head $ map show [True,False]\" infer >>= flip interpret (as :: Bool)@
as, infer :: Typeable a => a
as    = undefined
infer = undefined

-- | Evaluates an expression, given a witness for its monomorphic type.
interpret :: Typeable a => String -> a -> Interpreter a
interpret expr witness =
    do
        ghc_session <- fromSessionState ghcSession
        --
        -- First, make sure the expression has no syntax errors,
        -- for this is the only way we have to "intercept" this
        -- kind of errors
        failOnParseError parseExpr expr
        --
        let expr_typesig = concat ["(", expr, ") :: ", show $ myTypeOf witness]
        expr_val <- mayFail $ GHC.compileExpr ghc_session expr_typesig
        --
        return (GHC.Exts.unsafeCoerce# expr_val :: a)

-- HACK! Allows evaluations even when the Prelude is not in scope
myTypeOf :: Typeable a => a -> TypeRep
myTypeOf a
    | type_of_a == type_of_string = qual_type_of_string
    | otherwise                   = type_of_a
    where type_of_a           = Data.Typeable.typeOf a
          type_of_string      = Data.Typeable.typeOf (undefined :: [Char])
          (list_ty_con, _)    = splitTyConApp type_of_string
          qual_type_of_string = mkTyConApp list_ty_con
                                        [mkTyConApp (mkTyCon "Prelude.Char") []]

-- | @eval expr@ will evaluate @show expr@.
--  It will succeed only if @expr@ has type t and there is a 'Show'
--  instance for t.
eval :: String -> Interpreter String
eval expr = interpret show_expr (as :: String)
    where show_expr = unwords ["Prelude.show", "(", expr, ") "]

mayFail :: IO (Maybe a) -> Interpreter a
mayFail ghc_action =
    do
        maybe_res <- liftIO ghc_action
        --
        es <- modifySessionState ghcErrListRef (const [])
        --
        case maybe_res of
            Nothing -> if null es
                         then throwError $ UnknownError "Got no error message"
                         else throwError $ WontCompile (reverse es)
            Just a  -> if null es
                         then return a
                         else fail "GHC reported errors and also gave a result!"

failOnParseError :: (GHC.Session -> String -> IO ParseResult)
                 -> String
                 -> Interpreter ()
failOnParseError parser expr =
    do
        ghc_session <- fromSessionState ghcSession
        --
        parsed <- liftIO $ parser ghc_session expr
        --
        -- If there was a parsing error, do the "standard" error reporting
        res <- case parsed of
                   ParseOk             -> return (Just ())
                   --
                   ParseError span err ->
                       do
                           -- parsing failed, so we report it just as all
                           -- other errors get reported....
                           logger <- fromSessionState ghcErrLogger
                           liftIO $ logger GHC.SevError
                                           span
                                           GHC.O.defaultErrStyle
                                           err
                           --
                           -- behave like the rest of the GHC API functions
                           -- do on error...
                           return Nothing
        --
        -- "may Have Already Failed", actually :)
        mayFail (return res)

isSucceeded :: GHC.SuccessFlag -> Bool
isSucceeded GHC.Succeeded = True
isSucceeded GHC.Failed    = False

onCompilationError :: ([GhcError] -> Interpreter a)
                   -> (InterpreterError -> Interpreter a)
onCompilationError recover =
    \interp_error -> case interp_error of
                       WontCompile errs -> recover errs
                       otherErr         -> throwError otherErr

-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?
-- foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()