-- | The recommended interface, because it is safer (guaranteed not to crash as long
--   as modules have not been mis-installed somehow), is 'loadDynamic'.  For
--   versatility's sake, 'unsafeLoad' is provided as well, but caveat codor!
module System.Plugins (unsafeLoad, loadDynamic) where

import Data.Dynamic
import Data.IORef
import Data.List
import Data.Maybe
import Data.Typeable
import Unsafe.Coerce

import qualified BasicTypes
import qualified DynFlags
import qualified Encoding
import qualified Exception
import qualified FastString
import qualified GHC
import qualified GHC.Exts
import qualified GHC.Paths (libdir)
import qualified HscTypes
import qualified IfaceSyn
import qualified IfaceType
import qualified IOEnv
import qualified Linker
import qualified LoadIface
import qualified Maybes
import qualified Module
import MonadUtils (liftIO)
import qualified Name
import qualified ObjLink
import qualified OccName
import qualified Outputable
import qualified PackageConfig
import qualified Packages
import qualified TcRnTypes
import qualified SrcLoc
import qualified UniqSupply
import qualified Unique


-- | Resolves the specified symbol to any given type.  This means linking the package
--   containing it if it is not already linked, extracting the value of that symbol,
--   and returning that value.  Because a call is made to 'unsafeCoerce', the behavior
--   is unpredictable (most likely an immediate crash) if the symbol is not actually of
--   the expected type.  Because 'load' has no a priori way to know the type, you must
--   be certain to provide adequate type information in the caller, ie by giving a
--   type signature.
--   
--   Three error conditions are detected and handled nicely, returning
--   'Nothing':  The package does not exist; the package does not contain the given
--   module; or the module does not contain a symbol by the given name.
--   
--   As a limitation which may be relaxed in a future version, note that re-exports
--   are not chased; thus for example it is not possible to find the symbol
--   @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@.
unsafeLoad
    :: (String, String, String)
    -- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in
    --   a package installed somewhere in ghc's database.
    --   
    --   @packageName@ is a full package name including a version,
    --   ie @\"hello-1.0\"@; you can inspect these package names through
    --   @ghc-pkg@.
    --   
    --   @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or
    --   @\"Data.Dynamic\"@.
    --   
    --   @symbolName@ is an unqualified symbol name, ie @\"hello\"@.
    -> IO (Maybe a)
    -- ^ If the specified symbol is found, 'Just' its
    --   value.  Otherwise, 'Nothing'.
unsafeLoad symbol@(packageName, moduleName, symbolName)
    = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
        GHC.runGhc (Just GHC.Paths.libdir) $ do
          flags <- GHC.getSessionDynFlags
          GHC.setSessionDynFlags flags
          
          (flags, _) <- liftIO $ Packages.initPackages flags
          
          liftIO $ Linker.initDynLinker flags
          let packageId = Module.fsToPackageId (FastString.mkFastString packageName)
          Exception.ghandle
            (\(GHC.CmdLineError _) -> do
               liftIO $ putStrLn $ "Unknown package " ++ packageName ++ "."
               return Nothing)
            (do
              liftIO $ Linker.linkPackages flags [packageId]
              
              Exception.ghandle
                (\(GHC.ProgramError string) -> do
                   if (hasPrefix string "Failed to load interface ")
                     then liftIO $ putStrLn $ "Unknown module " ++ moduleName
                                            ++ " in package " ++ packageName
                                            ++ "."
                     else liftIO $ putStrLn $ "Unknown symbol " ++ symbolName
                                            ++ " in module " ++ moduleName
                                            ++ " in package " ++ packageName
                                            ++ "."
                   return Nothing)
                (do
                  session <- GHC.getSession
                  let name = Name.mkExternalName
                               (Unique.mkBuiltinUnique 0)
                               (Module.mkModule packageId
                                                (Module.mkModuleName moduleName))
                               (OccName.mkVarOcc symbolName)
                               SrcLoc.noSrcSpan
                  result <- liftIO $ Linker.getHValue session name
                  return $ Just $ unsafeCoerce result))


-- | Resolves the specified symbol to a Dynamic.  This means first parsing the installed
--   .hi file for the package containing the symbol to verify that the symbol is in fact
--   a Dynamic, then, if it is, linking the package if it is not already linked,
--   extracting the value of that symbol, and returning that value.  Unlike 'load', this
--   function should be \"perfectly safe\", not crashing even if the symbol is not
--   actually of the expected type.
--   
--   Four error conditions are detected and handled nicely, returning
--   'Nothing':  The package does not exist; the package does not contain the given
--   module; the module does not contain a symbol by the given name; or the symbol's type
--   is not 'Dynamic'.
--   
--   As a limitation which may be relaxed in a future version, note that re-exports are
--   not chased; thus for example it is not possible to find the symbol
--   @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@.
--   (Also because that symbol is not a 'Dynamic'.)
loadDynamic
    :: (String, String, String)
    -- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in
    --   a package installed somewhere in ghc's database.
    --   
    --   @packageName@ is a full package name including a version,
    --   ie @\"hello-1.0\"@; you can inspect these package names through
    --   @ghc-pkg@.
    --   
    --   @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or
    --   @\"Data.Dynamic\"@.
    --   
    --   @symbolName@ is an unqualified symbol name, ie @\"hello\"@.
    -> IO (Maybe Dynamic)
    -- ^ If the specified symbol is found and of an appropriate type, 'Just' its
    --   value.  Otherwise, 'Nothing'.
loadDynamic symbol = do
  maybeInterfaceType <- symbolInterfaceType symbol
  case maybeInterfaceType of
    Nothing -> return Nothing
    Just interfaceType -> do
      let isDynamic = interfaceTypeIsDynamic interfaceType
      case isDynamic of
        False -> return Nothing
        True -> unsafeLoad symbol


symbolInterfaceType :: (String, String, String) -> IO (Maybe IfaceType.IfaceType)
symbolInterfaceType (packageName, moduleName, symbolName)
    = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
        GHC.runGhc (Just GHC.Paths.libdir) $ do
          flags <- GHC.getSessionDynFlags
          GHC.setSessionDynFlags flags
          
          (flags, _) <- liftIO $ Packages.initPackages flags
          
          uniqueSupply <- liftIO $ UniqSupply.mkSplitUniqSupply 'a'
          uniqueSupplyIORef <- liftIO $ newIORef uniqueSupply
          hscEnv <- GHC.getSession
          let packageState = DynFlags.pkgState flags
              packageId = Module.fsToPackageId (FastString.mkFastString packageName)
          case Packages.lookupPackage (Packages.pkgIdMap packageState) packageId of
            Nothing -> do
              liftIO $ putStrLn $ "Unknown package " ++ packageName ++ "."
              return Nothing
            Just packageConfig -> do
              let installedPackageInfo
                    = PackageConfig.packageConfigToInstalledPackageInfo packageConfig
                  module' = Module.mkModule packageId $ Module.mkModuleName moduleName
                  libraryDirs = PackageConfig.libraryDirs installedPackageInfo
                  interfacePathWithinLibraryDir = moduleNameToInterfacePath moduleName
                  visitLibraryDir (libraryDir : moreLibraryDirs) = (do
                    let interfacePath = libraryDir ++ "/" ++ interfacePathWithinLibraryDir
                        environment = TcRnTypes.Env {
                                        TcRnTypes.env_top = hscEnv,
                                        TcRnTypes.env_us = uniqueSupplyIORef,
                                        TcRnTypes.env_gbl = (),
                                        TcRnTypes.env_lcl = ()
                                      }
                    errorOrModuleInterface
                      <- liftIO $ IOEnv.runIOEnv environment
                         $ LoadIface.readIface module' interfacePath False
                    case errorOrModuleInterface of
                      Maybes.Failed message -> visitLibraryDir moreLibraryDirs
                      Maybes.Succeeded moduleInterface -> do
                        let variableName = OccName.mkVarOcc symbolName
                            declarations = HscTypes.mi_decls moduleInterface
                            visitDeclaration ((_, declaration) : moreDeclarations) = (do
                              case declaration of
                                IfaceSyn.IfaceId { } -> do
                                  if IfaceSyn.ifName declaration == variableName
                                    then return $ Just $ IfaceSyn.ifType declaration
                                    else visitDeclaration moreDeclarations
                                _ -> visitDeclaration moreDeclarations)
                            visitDeclaration [] = do
                              liftIO $ putStrLn $ "Unknown symbol " ++ symbolName
                                                  ++ " in module " ++ moduleName
                                                  ++ " in package " ++ packageName
                                                  ++ "."
                              return Nothing
                        visitDeclaration declarations)
                  visitLibraryDir [] = do
                    liftIO $ putStrLn $ "Unknown module " ++ moduleName
                                        ++ " in package " ++ packageName
                                        ++ "."
                    return Nothing
              visitLibraryDir libraryDirs


interfaceTypeToString :: IfaceType.IfaceType -> String
interfaceTypeToString ifaceType
    = Outputable.showSDoc $ IfaceType.pprIfaceType ifaceType


interfaceTypeIsDynamic :: IfaceType.IfaceType -> Bool
interfaceTypeIsDynamic (IfaceType.IfaceTyConApp constructor arguments)
    = let interfaceTypeConstructorIsDynamic (IfaceType.IfaceTc name)
              = let occName = Name.nameOccName name
                    typeName = OccName.occNameString occName
                    module' = Name.nameModule name
                    packageId = Module.modulePackageId module'
                    packageName = Module.packageIdString packageId
                    moduleName = Module.moduleNameString $ Module.moduleName module'
                in (packageName == "base")
                   && (moduleName == "Data.Dynamic")
                   && (typeName == "Dynamic")
          interfaceTypeConstructorIsDynamic _ = False
      in (length arguments == 0) && (interfaceTypeConstructorIsDynamic constructor)
interfaceTypeIsDynamic _ = False


encodeSymbol :: (String, String, String) -> String
encodeSymbol (packageName, moduleName, symbolName)
    = (Encoding.zEncodeString packageName)
      ++ "_"
      ++ (Encoding.zEncodeString moduleName)
      ++ "_"
      ++ (Encoding.zEncodeString symbolName)
      ++ "_closure"


moduleNameToInterfacePath :: String -> String
moduleNameToInterfacePath moduleName = 
    let translateCharacter '.' = '/'
        translateCharacter c = c
    in (map translateCharacter moduleName) ++ ".hi"


hasPrefix :: String -> String -> Bool
hasPrefix string prefix = take (length prefix) string == prefix