# LANGUAGE CPP , 
              GADTs , 
              OverloadedStrings , 
              LambdaCase , 
              TupleSections , 
              ScopedTypeVariables , 
              ViewPatterns , 
              PackageImports 
   #
             GADTs,
             OverloadedStrings,
             LambdaCase,
             TupleSections,
             ScopedTypeVariables,
             ViewPatterns,
             PackageImports
  #-}

module Gen2.TH where


   Template Haskell support through Node.js 

  Template Haskell support through Node.js
-}

import           Compiler.Settings

import qualified Gen2.Generator      as Gen2
import qualified Gen2.Linker         as Gen2
import qualified Gen2.ClosureInfo    as Gen2
import qualified Gen2.Shim           as Gen2
import qualified Gen2.Object         as Gen2
import qualified Gen2.Cache          as Gen2
import qualified Gen2.Rts            as Gen2
import Prelude

import           GHC.Hs.Extension
import           BasicTypes
import           CoreToStg
import           CoreUtils
import           CorePrep
import           Name
import           Id
import           Outputable          hiding ((<>))
import           CoreSyn
import           SrcLoc
import           Module
import           DynFlags
import           TcRnMonad
import           HscTypes
import           Packages
import           Maybes
import           SimplStg
import           GHC.Serialized
import           GHC.ThToHs
import           Bag
import           StaticPtrTable
import           Finder
import           Avail
import           ConLike
import           StgSyn
import           CostCentre
import           NameEnv

import           Control.Concurrent
import qualified Control.Exception              as E
import           Control.Monad

import qualified Data.IntMap                    as IM
import qualified Data.Map                       as M

import           Data.Text                      (Text)
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.ByteString                (ByteString)
import qualified Data.ByteString                as B
import qualified Data.ByteString.Base16         as B16
import qualified Data.ByteString.Lazy           as BL
import qualified Data.List                      as L
import qualified Data.Set                       as S
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import qualified Data.Text.Lazy.Encoding        as TL

import qualified GHCJS.Prim.TH.Types            as TH

-- #if defined(MIN_VERSION_template_haskell_ghcjs)
  import qualified " template - haskell - ghcjs " Language . Haskell . TH             as TH
  import qualified " template - haskell - ghcjs " Language . Haskell . TH.Syntax      as TH
-- #else

import qualified "template-haskell"       Language.Haskell.TH            as TH
import qualified "template-haskell"       Language.Haskell.TH.Syntax     as TH
-- #endif

import           System.Process
  (terminateProcess, waitForProcess)
import           System.Directory
  (doesFileExist)
import           System.FilePath
import           System.IO
import           System.IO.Error
import           System.Timeout

import           ErrUtils
import           GHC.Hs.Expr
import           DsMonad
import           DsExpr
import           GHC.Hs.Pat
import           GHC.Hs.Types
import           GHC.Hs.Decls
import           TcSplice ()
import           UniqDFM

#include "HsVersions.h"

convertE :: SrcSpan -> ByteString -> TcM (LHsExpr GhcPs)
convertE = convertTH (get :: Get TH.Exp)   convertToHsExpr

convertP :: SrcSpan -> ByteString -> TcM (LPat GhcPs)
convertP = convertTH (get :: Get TH.Pat)   convertToPat

convertT :: SrcSpan -> ByteString -> TcM (LHsType GhcPs)
convertT = convertTH (get :: Get TH.Type)  convertToHsType

convertD :: SrcSpan -> ByteString -> TcM [LHsDecl GhcPs]
convertD = convertTH (get :: Get [TH.Dec]) convertToHsDecls

convertTH :: Binary a
          => Get a
          -> (Origin -> SrcSpan -> a -> Either MsgDoc b)
          -> SrcSpan
          -> ByteString
          -> TcM b
convertTH g f s b
  = do
    th_origin <- getThSpliceOrigin
    case f th_origin s (runGet g (BL.fromStrict b)) of
      Left msg -> failWithTc msg
      Right x  -> return x

-- | We only want to produce warnings for TH-splices if the user requests so.
-- See Note [Warnings for TH splices].
getThSpliceOrigin :: TcM Origin
getThSpliceOrigin = do
  warn <- goptM Opt_EnableThSpliceWarnings
  if warn then return FromSource else return Generated

convertAnn :: SrcSpan -> ByteString -> TcM Serialized
convertAnn _ bs = return (toSerialized B.unpack bs)

ghcjsRunMeta :: GhcjsEnv
             -> GhcjsSettings
             -> MetaRequest
             -> LHsExpr GhcTc
             -> TcM MetaResult
ghcjsRunMeta js_env js_settings req expr =
  let m :: (hs_syn -> MetaResult) -> String -> TH.THResultType
        -> Bool -> (hs_syn -> SDoc)
        -> (SrcSpan -> ByteString -> TcM hs_syn)
        -> TcM MetaResult
      m r desc th_type show_code ppr_code convert_res
        = r <$> ghcjsRunMeta' js_env
                              js_settings
                              desc
                              th_type
                              show_code
                              ppr_code
                              convert_res
                              expr
  in case req of
    MetaE  r -> m r "expression"   TH.THExp        True  ppr convertE
    MetaP  r -> m r "pattern"      TH.THPat        True  ppr convertP
    MetaT  r -> m r "type"         TH.THType       True  ppr convertT
    MetaD  r -> m r "declarations" TH.THDec        True  ppr convertD
    MetaAW r -> m r "annotation"   TH.THAnnWrapper False ppr convertAnn

ghcjsRunMeta' :: GhcjsEnv
              -> GhcjsSettings
              -> String
              -> TH.THResultType
              -> Bool
              -> (hs_syn -> SDoc)
              -> (SrcSpan -> ByteString -> TcM hs_syn)
              -> LHsExpr GhcTc
              -> TcM hs_syn
ghcjsRunMeta' js_env js_settings _descr tht _show_code _ppr_code cvt expr = do
  traceTc "About to run" (ppr expr)
  recordThSpliceUse -- seems to be the best place to do this,
                    -- we catch all kinds of splices and annotations.
  failIfErrsM
  ds_expr  <- initDsTc (dsLExpr expr)
  dflags   <- getDynFlags
  hsc_env  <- getTopEnv
  src_span <- getSrcSpanM
  traceTc "About to run (desugared)" (ppr ds_expr)
  (js_code, symb) <-
    compileExpr js_env js_settings hsc_env dflags src_span ds_expr
  gbl_env  <- getGblEnv
  r        <- getThRunner js_env hsc_env dflags (tcg_mod gbl_env)
  base     <- liftIO $ takeMVar (thrBase r)
  let pkgs     = L.nub $
                 (S.toList . imp_dep_pkgs . tcg_imports $ gbl_env) ++
                 concatMap (map fst . dep_pkgs .  mi_deps . hm_iface)
                           (eltsUDFM $ hsc_HPT hsc_env)
      settings = thSettings { gsUseBase = BaseState base }
  lr       <- liftIO $ linkTh js_env
                              settings
                              []
                              dflags
                              pkgs
                              (hsc_HPT hsc_env)
                              (Just js_code)
  ext <- liftIO $ do
    llr      <- mconcat <$> mapM (Gen2.tryReadShimFile dflags)  (Gen2.linkLibRTS lr)
    lla'     <- mconcat <$> mapM (Gen2.tryReadShimFile dflags)  (Gen2.linkLibA lr)
    llaarch' <- mconcat <$> mapM (Gen2.readShimsArchive dflags) (Gen2.linkLibAArch lr)
    return (llr <> lla' <> llaarch')
  let bs = ext <> BL.toStrict (Gen2.linkOut lr)
               <> T.encodeUtf8 ("\nh$TH.loadedSymbol = " <> symb <> ";\n")
  -- fixme exception handling
  hv <- setSrcSpan (getLoc expr) $ do
    loc <- TH.qLocation
    requestRunner r (TH.RunTH tht bs (Just loc)) >>= \case
      TH.RunTH' bsr -> cvt src_span bsr
      _             -> error
        "ghcjsRunMeta': unexpected response, expected RunTH' message"
  liftIO $ putMVar (thrBase r) (Gen2.linkBase lr)
  return hv

compileExpr :: GhcjsEnv -> GhcjsSettings -> HscEnv -> DynFlags
            -> SrcSpan -> CoreExpr -> TcM (ByteString, Text)
compileExpr js_env js_settings hsc_env dflags src_span ds_expr
  = newUnique >>= \u -> liftIO $ do
      -- liftIO (putStrLn $ "compileExpr:\n" ++ Utils.showIndent ds_expr)
      prep_expr     <- corePrepExpr dflags hsc_env ds_expr
      n             <- modifyMVar (thSplice js_env)
                                  (\n -> let n' = n+1 in pure (n',n'))
      let th_mod   = mod n
          th_binds0 = [bind n u prep_expr]
      (spt_entries, th_binds1) <- sptCreateStaticBinds hsc_env th_mod th_binds0
      let (stg_pgm0, cost_centre_info) =
            coreToStg dflags th_mod th_binds1
      stg_pgm1 <- stg2stg hsc_env th_mod stg_pgm0
      return (Gen2.generate js_settings
                            dflags
                            (mod n)
                            stg_pgm1
                            spt_entries
                            NoStubs
                            cost_centre_info
             , symb n)
  where
    symb n     = "h$thrunnerZCThRunner" <> T.pack (show n) <> "zithExpr"
    thExpr n u = mkVanillaGlobal (mkExternalName u
                                                 (mod n)
                                                 (mkVarOcc "thExpr")
                                                 src_span)
                                 (exprType ds_expr)
    bind n u e = NonRec (thExpr n u) e
    mod n      = mkModule thrunnerPackage'
                          (mkModuleName $ "ThRunner" ++ show n)

thrunnerPackage :: InstalledUnitId
thrunnerPackage = stringToInstalledUnitId "thrunner"

thrunnerPackage' :: UnitId
thrunnerPackage' = stringToUnitId "thrunner"

getThRunner :: GhcjsEnv -> HscEnv -> DynFlags -> Module -> TcM THRunner
getThRunner js_env hsc_env dflags m = do
  let m' = moduleNameString (moduleName m)
  (r, fin) <- liftIO $ modifyMVar (thRunners js_env) $ \runners ->
    case M.lookup m' (activeRunners runners) of
      Just r  -> return (runners, (r, return ()))
      Nothing -> do
        (r, runners') <- startTHRunner dflags js_env hsc_env runners
  fixme add cleanup again 
                do 
               th_modfinalizers_var < - fmap tcg_th_modfinalizers 
                                            getGblEnv 
               writeTcRef th_modfinalizers_var 
                          [ TH.qRunIO ( finishTHModule      r ) ]
               do
              th_modfinalizers_var <- fmap tcg_th_modfinalizers
                                           getGblEnv
              writeTcRef th_modfinalizers_var
                         [TH.qRunIO (finishTHModule dflags js_env  m' r)] -}
        return (insertActiveRunner m' r runners', (r, fin))
  fin >> return r

{-
  generate the "virtual" linked object for a hs-boot file
 -}
bootObject :: GhcjsSettings
           -> DynFlags
           -> Module
           -> ModDetails
           -> LinkedObj
bootObject js_settings dflags m details =
  let mn      = moduleName m
      stg_pgm = mapMaybe mk_decl (md_exports details)
      mk_decl (Avail n)
        | Just ty_thing <- lookupNameEnv (md_types details) n
        = mk_decl_ty n ty_thing
      mk_decl _ = Nothing

      mk_decl_ty n (AnId i)                     = mk_decl_id n i
      mk_decl_ty _ (AConLike (RealDataCon _dc)) = Nothing
      mk_decl_ty _ _                            = Nothing
      mk_decl_id _ i = Just
        (StgTopLifted (
         (StgNonRec i (StgRhsClosure noExtFieldSilent
                                     dontCareCCS
                                   -- noBinderInfo
                                   -- []
                                   ReEntrant
                                   []
                                    (StgApp i [])))))
  in ObjLoaded
       (moduleNameString mn ++ " [boot]")
       (Gen2.generate js_settings dflags m stg_pgm [] NoStubs emptyCollectedCCs)

linkTh :: GhcjsEnv
       -> GhcjsSettings        -- settings (contains the base state)
       -> [FilePath]           -- extra js files
       -> DynFlags             -- dynamic flags
       -> [InstalledUnitId]    -- package dependencies
       -> HomePackageTable     -- what to link
       -> Maybe ByteString     -- current module or Nothing to get the initial code + rts
       -> IO Gen2.LinkResult
linkTh env settings js_files dflags pkgs hpt code = do
  (th_deps_pkgs, th_deps)  <- Gen2.thDeps dflags
  let home_mod_infos = eltsUDFM hpt
      pkgs' | isJust code = L.nub $ pkgs ++ th_deps_pkgs
            | otherwise   = th_deps_pkgs
      is_root   = const True
      linkables = concatMap mk_linkable home_mod_infos
      mk_linkable :: HomeModInfo -> [LinkedObj]
      mk_linkable hm = maybe (generate_linkable hm)
                             convert_linkable
                             (hm_linkable hm)

      convert_linkable :: Linkable -> [LinkedObj]
      convert_linkable = map ObjFile . getOfiles

      generate_linkable :: HomeModInfo -> [LinkedObj]
      generate_linkable hm = [bootObject settings
                                         dflags
                                         (mi_module $ hm_iface hm)
                                         (hm_details hm)]

      getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)

      link      = Gen2.link' dflags'
                             env
                             settings
                             "Template Haskell"
                             []
                             pkgs'
                             obj_files
                             js_files
                             is_root
                             th_deps
      dflags'   = dflags { ways        = WayDebug : ways dflags
                         , thisInstalledUnitId = thrunnerPackage -- thisPackage = thrunnerPackage
                         }
      obj_files = maybe []
                        (\b -> ObjLoaded "<Template Haskell>" b : linkables)
                        code
      packageLibPaths :: InstalledUnitId -> [FilePath]
      packageLibPaths pkg = maybe [] libraryDirs (lookupInstalledPackage dflags pkg)
      cache_key = T.pack $
        (show . L.nub . L.sort . map Gen2.funPackage . S.toList $ th_deps) ++
        show (ways dflags') ++
        show (topDir dflags)
  if isJust code
     then link
     else Gen2.getCached dflags' "template-haskell" cache_key >>= \case
            Just c  -> return (runGet get $ BL.fromStrict c)
            Nothing -> do
              lr <- link
              _ <- Gen2.putCached dflags'
                             "template-haskell"
                             cache_key
                             [topDir dflags </> "ghcjs_boot.completed"]
                             (BL.toStrict . runPut . put $ lr)
              return lr

requestRunner :: THRunner -> TH.Message -> TcM TH.Message
requestRunner runner msg = liftIO (sendToRunner runner 0 msg) >> res
  where
    res = liftIO (readFromRunner runner) >>= \case
            (msg, 0) -> return msg
            (req, n) -> do
              liftIO . sendToRunner runner n =<< handleRunnerReq runner req
              res

finishRunner :: Bool -> THRunner -> IO Int
finishRunner stopRunner runner = do
  sendToRunner runner 0 (TH.FinishTH stopRunner)
  memoryUsage <- readFromRunner runner >>= \case
    (TH.FinishTH' memoryUsage, _) -> do
      when stopRunner $ do
        hClose (thrHandleIn runner) `E.catch` \(_::E.SomeException) -> return ()
        hClose (thrHandleErr runner) `E.catch` \(_::E.SomeException) -> return ()
      return memoryUsage
    _                 -> error
       "finishRunner: unexpected response, expected FinishTH' message"
  return memoryUsage

finishRunnerProcess :: THRunner -> IO ()
finishRunnerProcess runner =
  let ph = thrProcess runner
  in  maybe (void $ terminateProcess ph)
            (\_ -> return ())
        =<< timeout 30000000 (waitForProcess ph)

handleRunnerReq :: THRunner -> TH.Message -> TcM TH.Message
handleRunnerReq runner msg =
  case msg of
    TH.QUserException e     -> term                              >>  error e
    TH.QCompilerException n -> term                              >>  throwCompilerException n runner
    TH.QFail e              -> term                              >>  fail e
    TH.StartRecover         -> startRecover runner               >>  pure TH.StartRecover'
    TH.EndRecover b         -> endRecover b runner               >>  pure TH.EndRecover'
    TH.Report isErr msg     -> TH.qReport isErr msg              >>  pure TH.Report'
    _                       -> getEnv >>= \env -> liftIO $
      runIOEnv env (handleOtherReq msg) `E.catch` \e ->
        addException e >>= \n -> return (TH.QCompilerException' n (show e))
  where
    addException :: E.SomeException -> IO Int
    addException e = modifyMVar (thrExceptions runner) $ \m ->
      let s = IM.size m in return (IM.insert s e m, s)
    handleOtherReq :: TH.Message -> TcM TH.Message
    handleOtherReq msg = case msg of
      TH.NewName n                   -> TH.NewName'                       <$> TH.qNewName n
      TH.LookupName b n              -> TH.LookupName'                    <$> TH.qLookupName b n
      TH.Reify n                     -> TH.Reify'                         <$> TH.qReify n
      TH.ReifyInstances n ts         -> TH.ReifyInstances'                <$> TH.qReifyInstances n ts
      TH.ReifyRoles n                -> TH.ReifyRoles'                    <$> TH.qReifyRoles n
      TH.ReifyAnnotations nn         -> TH.ReifyAnnotations' . map B.pack <$> TH.qReifyAnnotations nn
      TH.ReifyModule m               -> TH.ReifyModule'                   <$> TH.qReifyModule m
      TH.ReifyFixity n               -> TH.ReifyFixity'                   <$> TH.qReifyFixity n
      TH.ReifyConStrictness n        -> TH.ReifyConStrictness'            <$> TH.qReifyConStrictness n
      TH.AddForeignFilePath lang src -> TH.qAddForeignFilePath lang src   >>  pure TH.AddForeignFilePath'
      TH.AddTempFile xs              -> TH.AddTempFile'                   <$> TH.qAddTempFile xs
      TH.AddDependentFile f          -> TH.qAddDependentFile f            >>  pure TH.AddDependentFile'
      TH.AddTopDecls decs            -> TH.qAddTopDecls decs              >>  pure TH.AddTopDecls'
      TH.AddCorePlugin plugin        -> do
        hsc_env <- env_top <$> getEnv
        r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
        let err = hang
              (text "addCorePlugin: invalid plugin module "
                 <+> text (show plugin)
              )
              2
              (text "Plugins in the current package can't be specified.")
        case r of
          Found {} -> addErr err
          FoundMultiple {} -> addErr err
          _ -> return ()
        th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
        updTcRef th_coreplugins_var (plugin:)
        pure TH.AddCorePlugin'
      TH.IsExtEnabled ext            -> TH.IsExtEnabled'                  <$> TH.qIsExtEnabled ext
      TH.ExtsEnabled                 -> TH.ExtsEnabled'                   <$> TH.qExtsEnabled
      _                              -> term >> error "handleRunnerReq: unexpected request"
    term :: TcM ()
    term = liftIO $ terminateProcess (thrProcess runner)

throwCompilerException :: Int -> THRunner -> TcM a
throwCompilerException n runner = liftIO $ do
  e <- IM.lookup n <$> readMVar (thrExceptions runner)
  case e of
    Just ex -> liftIO (E.throwIO ex)
    Nothing -> error "throwCompilerException: exception id not found"

startRecover :: THRunner -> TcM ()
startRecover (thrRecover -> r) = do
  v <- getErrsVar
  msgs <- readTcRef v
  writeTcRef v emptyMessages
  liftIO (modifyMVar_ r (pure . (msgs:)))

endRecover :: Bool -> THRunner -> TcM ()
endRecover recoveryTaken (thrRecover -> r) = do
  msgs <- liftIO $ modifyMVar r (\(h:t) -> pure (t,h))
  v <- getErrsVar
  if recoveryTaken
     then writeTcRef v msgs
     else updTcRef v (unionMessages msgs)
  where
    unionMessages (wm1, em1) (wm2, em2) = (unionBags wm1 wm2, unionBags em1 em2)

finishTHModule :: DynFlags -> GhcjsEnv -> String -> THRunner -> IO ThModFinalizers
finishTHModule dflags js_env m runner = do
  mr <- finishTHp js_env False m runner
  ns <- readNodeSettings dflags
  modifyMVar_ ( thRunners js_env ) ( pure . deleteActiveRunner m )
  if (fromIntegral mr > nodeKeepAliveMaxMem ns)
    then void $ finishTHp js_env True m runner
    else modifyMVar_ ( thRunners js_env ) ( pure . consIdleRunner runner )
  pure (ThModFinalizers []) -- fixme is this right?

finishTHp :: GhcjsEnv -> Bool -> String -> THRunner -> IO Int
finishTHp _js_env endProcess _m runner = do
  let ph = thrProcess runner
  _ <- readMVar (thrBase runner)
  mu <- finishRunner endProcess runner
  when endProcess $
    maybe (void $ terminateProcess ph)
      (\_ -> return ()) =<< timeout 30000000 (waitForProcess ph)
  return mu

finishTHAll :: GhcjsEnv -> IO ()
finishTHAll js_env = do
  runners <- takeMVar (thRunners js_env)
  forM_ (idleRunners runners ++ M.elems (activeRunners runners))
        (\r -> void (finishRunner True r)
         `E.catch`
         \(_::E.SomeException) -> return ())

sendToRunner :: THRunner -> Int -> TH.Message -> IO ()
sendToRunner runner responseTo msg =
  sendToRunnerRaw runner responseTo (BL.toStrict . runPut . put $ msg)

sendToRunnerRaw :: THRunner -> Int -> ByteString -> IO ()
sendToRunnerRaw runner responseTo bs = do
  let header = BL.toStrict . runPut $ do
        putWord32be (fromIntegral $ B.length bs)
        putWord32be (fromIntegral responseTo)
  B.hPut (thrHandleIn runner) (B16.encode $ header <> bs)
  hFlush (thrHandleIn runner)

readFromRunner :: THRunner -> IO (TH.Message, Int)
readFromRunner runner = do
  let h = thrHandleErr runner
  (len, tgt) <- runGet ((,) <$> getWord32be <*> getWord32be) <$> BL.hGet h 8
  (,fromIntegral tgt) . runGet get <$> BL.hGet h (fromIntegral len)

thSettings :: GhcjsSettings
thSettings = GhcjsSettings False True False False Nothing
                           Nothing Nothing True True True
                           Nothing NoBase
                           Nothing Nothing [] False

startTHRunner :: DynFlags
              -> GhcjsEnv
              -> HscEnv
              -> THRunnerState
              -> IO (THRunner, THRunnerState)
startTHRunner dflags js_env hsc_env runners =
  maybe ((,runners) <$> startTHRunnerProcess dflags js_env hsc_env)
        pure
        (unconsIdleRunner runners)

startTHRunnerProcess :: DynFlags -> GhcjsEnv -> HscEnv -> IO THRunner
startTHRunnerProcess dflags js_env hsc_env = do
  let thSupport = case objectDir dflags of
                    Just dir -> dir </> "th-support.js"
                    Nothing -> "th-support.js"
  compilationProgressMsg dflags $ "Checking for " ++ thSupport
  thSupportFiles <- filterM doesFileExist [ thSupport ]
  lr <- linkTh js_env thSettings thSupportFiles dflags [] (hsc_HPT hsc_env) Nothing
  fr <- BL.fromChunks <$> mapM (Gen2.tryReadShimFile dflags) (Gen2.linkLibRTS lr)
  fa <- BL.fromChunks <$> mapM (Gen2.tryReadShimFile dflags) (Gen2.linkLibA lr)
  aa <- BL.fromChunks <$> mapM (Gen2.readShimsArchive dflags) (Gen2.linkLibAArch lr)
  let rtsd = TL.encodeUtf8 Gen2.rtsDeclsText
      rts  = TL.encodeUtf8 $ Gen2.rtsText' dflags (Gen2.dfCgSettings dflags)
  (inp,out,err,pid) <- runNodeInteractive dflags Nothing (topDir dflags </> "thrunner.js")
  mv  <- newMVar (Gen2.linkBase lr)
  emv <- newMVar []
  eev <- newMVar IM.empty
  _ <- forkIO $ catchIOError (forever $ hGetChar out >>= putChar) (\_ -> return ())
  let r = THRunner pid inp err mv emv eev
  sendToRunnerRaw r 0 (BL.toStrict $ rtsd <> fr <> rts <> fa <> aa <> Gen2.linkOut lr)
  return r

 #if defined(MIN_VERSION_template_haskell_ghcjs)
 #else
 #endif
 | We only want to produce warnings for TH-splices if the user requests so.
 See Note [Warnings for TH splices].
 seems to be the best place to do this,
 we catch all kinds of splices and annotations.
 fixme exception handling
 liftIO (putStrLn $ "compileExpr:\n" ++ Utils.showIndent ds_expr)

  generate the "virtual" linked object for a hs-boot file
 
 noBinderInfo
 []
 settings (contains the base state)
 extra js files
 dynamic flags
 package dependencies
 what to link
 current module or Nothing to get the initial code + rts
 thisPackage = thrunnerPackage
 fixme is this right?
# LANGUAGE CPP , 
              GADTs , 
              OverloadedStrings , 
              LambdaCase , 
              TupleSections , 
              ScopedTypeVariables , 
              ViewPatterns , 
              PackageImports 
   #
             GADTs,
             OverloadedStrings,
             LambdaCase,
             TupleSections,
             ScopedTypeVariables,
             ViewPatterns,
             PackageImports
  #-}

module Gen2.TH where


   Template Haskell support through Node.js 

  Template Haskell support through Node.js
-}

import           Compiler.Settings

import qualified Gen2.Generator      as Gen2
import qualified Gen2.Linker         as Gen2
import qualified Gen2.ClosureInfo    as Gen2
import qualified Gen2.Shim           as Gen2
import qualified Gen2.Object         as Gen2
import qualified Gen2.Cache          as Gen2
import qualified Gen2.Rts            as Gen2
import Prelude

import           GHC.Hs.Extension
import           BasicTypes
import           CoreToStg
import           CoreUtils
import           CorePrep
import           Name
import           Id
import           Outputable          hiding ((<>))
import           CoreSyn
import           SrcLoc
import           Module
import           DynFlags
import           TcRnMonad
import           HscTypes
import           Packages
import           Maybes
import           SimplStg
import           GHC.Serialized
import           GHC.ThToHs
import           Bag
import           StaticPtrTable
import           Finder
import           Avail
import           ConLike
import           StgSyn
import           CostCentre
import           NameEnv

import           Control.Concurrent
import qualified Control.Exception              as E
import           Control.Monad

import qualified Data.IntMap                    as IM
import qualified Data.Map                       as M

import           Data.Text                      (Text)
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.ByteString                (ByteString)
import qualified Data.ByteString                as B
import qualified Data.ByteString.Base16         as B16
import qualified Data.ByteString.Lazy           as BL
import qualified Data.List                      as L
import qualified Data.Set                       as S
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import qualified Data.Text.Lazy.Encoding        as TL

import qualified GHCJS.Prim.TH.Types            as TH

  import qualified " template - haskell - ghcjs " Language . Haskell . TH             as TH
  import qualified " template - haskell - ghcjs " Language . Haskell . TH.Syntax      as TH

import qualified "template-haskell"       Language.Haskell.TH            as TH
import qualified "template-haskell"       Language.Haskell.TH.Syntax     as TH

import           System.Process
  (terminateProcess, waitForProcess)
import           System.Directory
  (doesFileExist)
import           System.FilePath
import           System.IO
import           System.IO.Error
import           System.Timeout

import           ErrUtils
import           GHC.Hs.Expr
import           DsMonad
import           DsExpr
import           GHC.Hs.Pat
import           GHC.Hs.Types
import           GHC.Hs.Decls
import           TcSplice ()
import           UniqDFM

#include "HsVersions.h"

convertE :: SrcSpan -> ByteString -> TcM (LHsExpr GhcPs)
convertE = convertTH (get :: Get TH.Exp)   convertToHsExpr

convertP :: SrcSpan -> ByteString -> TcM (LPat GhcPs)
convertP = convertTH (get :: Get TH.Pat)   convertToPat

convertT :: SrcSpan -> ByteString -> TcM (LHsType GhcPs)
convertT = convertTH (get :: Get TH.Type)  convertToHsType

convertD :: SrcSpan -> ByteString -> TcM [LHsDecl GhcPs]
convertD = convertTH (get :: Get [TH.Dec]) convertToHsDecls

convertTH :: Binary a
          => Get a
          -> (Origin -> SrcSpan -> a -> Either MsgDoc b)
          -> SrcSpan
          -> ByteString
          -> TcM b
convertTH g f s b
  = do
    th_origin <- getThSpliceOrigin
    case f th_origin s (runGet g (BL.fromStrict b)) of
      Left msg -> failWithTc msg
      Right x  -> return x

getThSpliceOrigin :: TcM Origin
getThSpliceOrigin = do
  warn <- goptM Opt_EnableThSpliceWarnings
  if warn then return FromSource else return Generated

convertAnn :: SrcSpan -> ByteString -> TcM Serialized
convertAnn _ bs = return (toSerialized B.unpack bs)

ghcjsRunMeta :: GhcjsEnv
             -> GhcjsSettings
             -> MetaRequest
             -> LHsExpr GhcTc
             -> TcM MetaResult
ghcjsRunMeta js_env js_settings req expr =
  let m :: (hs_syn -> MetaResult) -> String -> TH.THResultType
        -> Bool -> (hs_syn -> SDoc)
        -> (SrcSpan -> ByteString -> TcM hs_syn)
        -> TcM MetaResult
      m r desc th_type show_code ppr_code convert_res
        = r <$> ghcjsRunMeta' js_env
                              js_settings
                              desc
                              th_type
                              show_code
                              ppr_code
                              convert_res
                              expr
  in case req of
    MetaE  r -> m r "expression"   TH.THExp        True  ppr convertE
    MetaP  r -> m r "pattern"      TH.THPat        True  ppr convertP
    MetaT  r -> m r "type"         TH.THType       True  ppr convertT
    MetaD  r -> m r "declarations" TH.THDec        True  ppr convertD
    MetaAW r -> m r "annotation"   TH.THAnnWrapper False ppr convertAnn

ghcjsRunMeta' :: GhcjsEnv
              -> GhcjsSettings
              -> String
              -> TH.THResultType
              -> Bool
              -> (hs_syn -> SDoc)
              -> (SrcSpan -> ByteString -> TcM hs_syn)
              -> LHsExpr GhcTc
              -> TcM hs_syn
ghcjsRunMeta' js_env js_settings _descr tht _show_code _ppr_code cvt expr = do
  traceTc "About to run" (ppr expr)
  failIfErrsM
  ds_expr  <- initDsTc (dsLExpr expr)
  dflags   <- getDynFlags
  hsc_env  <- getTopEnv
  src_span <- getSrcSpanM
  traceTc "About to run (desugared)" (ppr ds_expr)
  (js_code, symb) <-
    compileExpr js_env js_settings hsc_env dflags src_span ds_expr
  gbl_env  <- getGblEnv
  r        <- getThRunner js_env hsc_env dflags (tcg_mod gbl_env)
  base     <- liftIO $ takeMVar (thrBase r)
  let pkgs     = L.nub $
                 (S.toList . imp_dep_pkgs . tcg_imports $ gbl_env) ++
                 concatMap (map fst . dep_pkgs .  mi_deps . hm_iface)
                           (eltsUDFM $ hsc_HPT hsc_env)
      settings = thSettings { gsUseBase = BaseState base }
  lr       <- liftIO $ linkTh js_env
                              settings
                              []
                              dflags
                              pkgs
                              (hsc_HPT hsc_env)
                              (Just js_code)
  ext <- liftIO $ do
    llr      <- mconcat <$> mapM (Gen2.tryReadShimFile dflags)  (Gen2.linkLibRTS lr)
    lla'     <- mconcat <$> mapM (Gen2.tryReadShimFile dflags)  (Gen2.linkLibA lr)
    llaarch' <- mconcat <$> mapM (Gen2.readShimsArchive dflags) (Gen2.linkLibAArch lr)
    return (llr <> lla' <> llaarch')
  let bs = ext <> BL.toStrict (Gen2.linkOut lr)
               <> T.encodeUtf8 ("\nh$TH.loadedSymbol = " <> symb <> ";\n")
  hv <- setSrcSpan (getLoc expr) $ do
    loc <- TH.qLocation
    requestRunner r (TH.RunTH tht bs (Just loc)) >>= \case
      TH.RunTH' bsr -> cvt src_span bsr
      _             -> error
        "ghcjsRunMeta': unexpected response, expected RunTH' message"
  liftIO $ putMVar (thrBase r) (Gen2.linkBase lr)
  return hv

compileExpr :: GhcjsEnv -> GhcjsSettings -> HscEnv -> DynFlags
            -> SrcSpan -> CoreExpr -> TcM (ByteString, Text)
compileExpr js_env js_settings hsc_env dflags src_span ds_expr
  = newUnique >>= \u -> liftIO $ do
      prep_expr     <- corePrepExpr dflags hsc_env ds_expr
      n             <- modifyMVar (thSplice js_env)
                                  (\n -> let n' = n+1 in pure (n',n'))
      let th_mod   = mod n
          th_binds0 = [bind n u prep_expr]
      (spt_entries, th_binds1) <- sptCreateStaticBinds hsc_env th_mod th_binds0
      let (stg_pgm0, cost_centre_info) =
            coreToStg dflags th_mod th_binds1
      stg_pgm1 <- stg2stg hsc_env th_mod stg_pgm0
      return (Gen2.generate js_settings
                            dflags
                            (mod n)
                            stg_pgm1
                            spt_entries
                            NoStubs
                            cost_centre_info
             , symb n)
  where
    symb n     = "h$thrunnerZCThRunner" <> T.pack (show n) <> "zithExpr"
    thExpr n u = mkVanillaGlobal (mkExternalName u
                                                 (mod n)
                                                 (mkVarOcc "thExpr")
                                                 src_span)
                                 (exprType ds_expr)
    bind n u e = NonRec (thExpr n u) e
    mod n      = mkModule thrunnerPackage'
                          (mkModuleName $ "ThRunner" ++ show n)

thrunnerPackage :: InstalledUnitId
thrunnerPackage = stringToInstalledUnitId "thrunner"

thrunnerPackage' :: UnitId
thrunnerPackage' = stringToUnitId "thrunner"

getThRunner :: GhcjsEnv -> HscEnv -> DynFlags -> Module -> TcM THRunner
getThRunner js_env hsc_env dflags m = do
  let m' = moduleNameString (moduleName m)
  (r, fin) <- liftIO $ modifyMVar (thRunners js_env) $ \runners ->
    case M.lookup m' (activeRunners runners) of
      Just r  -> return (runners, (r, return ()))
      Nothing -> do
        (r, runners') <- startTHRunner dflags js_env hsc_env runners
  fixme add cleanup again 
                do 
               th_modfinalizers_var < - fmap tcg_th_modfinalizers 
                                            getGblEnv 
               writeTcRef th_modfinalizers_var 
                          [ TH.qRunIO ( finishTHModule      r ) ]
               do
              th_modfinalizers_var <- fmap tcg_th_modfinalizers
                                           getGblEnv
              writeTcRef th_modfinalizers_var
                         [TH.qRunIO (finishTHModule dflags js_env  m' r)] -}
        return (insertActiveRunner m' r runners', (r, fin))
  fin >> return r

bootObject :: GhcjsSettings
           -> DynFlags
           -> Module
           -> ModDetails
           -> LinkedObj
bootObject js_settings dflags m details =
  let mn      = moduleName m
      stg_pgm = mapMaybe mk_decl (md_exports details)
      mk_decl (Avail n)
        | Just ty_thing <- lookupNameEnv (md_types details) n
        = mk_decl_ty n ty_thing
      mk_decl _ = Nothing

      mk_decl_ty n (AnId i)                     = mk_decl_id n i
      mk_decl_ty _ (AConLike (RealDataCon _dc)) = Nothing
      mk_decl_ty _ _                            = Nothing
      mk_decl_id _ i = Just
        (StgTopLifted (
         (StgNonRec i (StgRhsClosure noExtFieldSilent
                                     dontCareCCS
                                   ReEntrant
                                   []
                                    (StgApp i [])))))
  in ObjLoaded
       (moduleNameString mn ++ " [boot]")
       (Gen2.generate js_settings dflags m stg_pgm [] NoStubs emptyCollectedCCs)

linkTh :: GhcjsEnv
       -> IO Gen2.LinkResult
linkTh env settings js_files dflags pkgs hpt code = do
  (th_deps_pkgs, th_deps)  <- Gen2.thDeps dflags
  let home_mod_infos = eltsUDFM hpt
      pkgs' | isJust code = L.nub $ pkgs ++ th_deps_pkgs
            | otherwise   = th_deps_pkgs
      is_root   = const True
      linkables = concatMap mk_linkable home_mod_infos
      mk_linkable :: HomeModInfo -> [LinkedObj]
      mk_linkable hm = maybe (generate_linkable hm)
                             convert_linkable
                             (hm_linkable hm)

      convert_linkable :: Linkable -> [LinkedObj]
      convert_linkable = map ObjFile . getOfiles

      generate_linkable :: HomeModInfo -> [LinkedObj]
      generate_linkable hm = [bootObject settings
                                         dflags
                                         (mi_module $ hm_iface hm)
                                         (hm_details hm)]

      getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)

      link      = Gen2.link' dflags'
                             env
                             settings
                             "Template Haskell"
                             []
                             pkgs'
                             obj_files
                             js_files
                             is_root
                             th_deps
      dflags'   = dflags { ways        = WayDebug : ways dflags
                         }
      obj_files = maybe []
                        (\b -> ObjLoaded "<Template Haskell>" b : linkables)
                        code
      packageLibPaths :: InstalledUnitId -> [FilePath]
      packageLibPaths pkg = maybe [] libraryDirs (lookupInstalledPackage dflags pkg)
      cache_key = T.pack $
        (show . L.nub . L.sort . map Gen2.funPackage . S.toList $ th_deps) ++
        show (ways dflags') ++
        show (topDir dflags)
  if isJust code
     then link
     else Gen2.getCached dflags' "template-haskell" cache_key >>= \case
            Just c  -> return (runGet get $ BL.fromStrict c)
            Nothing -> do
              lr <- link
              _ <- Gen2.putCached dflags'
                             "template-haskell"
                             cache_key
                             [topDir dflags </> "ghcjs_boot.completed"]
                             (BL.toStrict . runPut . put $ lr)
              return lr

requestRunner :: THRunner -> TH.Message -> TcM TH.Message
requestRunner runner msg = liftIO (sendToRunner runner 0 msg) >> res
  where
    res = liftIO (readFromRunner runner) >>= \case
            (msg, 0) -> return msg
            (req, n) -> do
              liftIO . sendToRunner runner n =<< handleRunnerReq runner req
              res

finishRunner :: Bool -> THRunner -> IO Int
finishRunner stopRunner runner = do
  sendToRunner runner 0 (TH.FinishTH stopRunner)
  memoryUsage <- readFromRunner runner >>= \case
    (TH.FinishTH' memoryUsage, _) -> do
      when stopRunner $ do
        hClose (thrHandleIn runner) `E.catch` \(_::E.SomeException) -> return ()
        hClose (thrHandleErr runner) `E.catch` \(_::E.SomeException) -> return ()
      return memoryUsage
    _                 -> error
       "finishRunner: unexpected response, expected FinishTH' message"
  return memoryUsage

finishRunnerProcess :: THRunner -> IO ()
finishRunnerProcess runner =
  let ph = thrProcess runner
  in  maybe (void $ terminateProcess ph)
            (\_ -> return ())
        =<< timeout 30000000 (waitForProcess ph)

handleRunnerReq :: THRunner -> TH.Message -> TcM TH.Message
handleRunnerReq runner msg =
  case msg of
    TH.QUserException e     -> term                              >>  error e
    TH.QCompilerException n -> term                              >>  throwCompilerException n runner
    TH.QFail e              -> term                              >>  fail e
    TH.StartRecover         -> startRecover runner               >>  pure TH.StartRecover'
    TH.EndRecover b         -> endRecover b runner               >>  pure TH.EndRecover'
    TH.Report isErr msg     -> TH.qReport isErr msg              >>  pure TH.Report'
    _                       -> getEnv >>= \env -> liftIO $
      runIOEnv env (handleOtherReq msg) `E.catch` \e ->
        addException e >>= \n -> return (TH.QCompilerException' n (show e))
  where
    addException :: E.SomeException -> IO Int
    addException e = modifyMVar (thrExceptions runner) $ \m ->
      let s = IM.size m in return (IM.insert s e m, s)
    handleOtherReq :: TH.Message -> TcM TH.Message
    handleOtherReq msg = case msg of
      TH.NewName n                   -> TH.NewName'                       <$> TH.qNewName n
      TH.LookupName b n              -> TH.LookupName'                    <$> TH.qLookupName b n
      TH.Reify n                     -> TH.Reify'                         <$> TH.qReify n
      TH.ReifyInstances n ts         -> TH.ReifyInstances'                <$> TH.qReifyInstances n ts
      TH.ReifyRoles n                -> TH.ReifyRoles'                    <$> TH.qReifyRoles n
      TH.ReifyAnnotations nn         -> TH.ReifyAnnotations' . map B.pack <$> TH.qReifyAnnotations nn
      TH.ReifyModule m               -> TH.ReifyModule'                   <$> TH.qReifyModule m
      TH.ReifyFixity n               -> TH.ReifyFixity'                   <$> TH.qReifyFixity n
      TH.ReifyConStrictness n        -> TH.ReifyConStrictness'            <$> TH.qReifyConStrictness n
      TH.AddForeignFilePath lang src -> TH.qAddForeignFilePath lang src   >>  pure TH.AddForeignFilePath'
      TH.AddTempFile xs              -> TH.AddTempFile'                   <$> TH.qAddTempFile xs
      TH.AddDependentFile f          -> TH.qAddDependentFile f            >>  pure TH.AddDependentFile'
      TH.AddTopDecls decs            -> TH.qAddTopDecls decs              >>  pure TH.AddTopDecls'
      TH.AddCorePlugin plugin        -> do
        hsc_env <- env_top <$> getEnv
        r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
        let err = hang
              (text "addCorePlugin: invalid plugin module "
                 <+> text (show plugin)
              )
              2
              (text "Plugins in the current package can't be specified.")
        case r of
          Found {} -> addErr err
          FoundMultiple {} -> addErr err
          _ -> return ()
        th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
        updTcRef th_coreplugins_var (plugin:)
        pure TH.AddCorePlugin'
      TH.IsExtEnabled ext            -> TH.IsExtEnabled'                  <$> TH.qIsExtEnabled ext
      TH.ExtsEnabled                 -> TH.ExtsEnabled'                   <$> TH.qExtsEnabled
      _                              -> term >> error "handleRunnerReq: unexpected request"
    term :: TcM ()
    term = liftIO $ terminateProcess (thrProcess runner)

throwCompilerException :: Int -> THRunner -> TcM a
throwCompilerException n runner = liftIO $ do
  e <- IM.lookup n <$> readMVar (thrExceptions runner)
  case e of
    Just ex -> liftIO (E.throwIO ex)
    Nothing -> error "throwCompilerException: exception id not found"

startRecover :: THRunner -> TcM ()
startRecover (thrRecover -> r) = do
  v <- getErrsVar
  msgs <- readTcRef v
  writeTcRef v emptyMessages
  liftIO (modifyMVar_ r (pure . (msgs:)))

endRecover :: Bool -> THRunner -> TcM ()
endRecover recoveryTaken (thrRecover -> r) = do
  msgs <- liftIO $ modifyMVar r (\(h:t) -> pure (t,h))
  v <- getErrsVar
  if recoveryTaken
     then writeTcRef v msgs
     else updTcRef v (unionMessages msgs)
  where
    unionMessages (wm1, em1) (wm2, em2) = (unionBags wm1 wm2, unionBags em1 em2)

finishTHModule :: DynFlags -> GhcjsEnv -> String -> THRunner -> IO ThModFinalizers
finishTHModule dflags js_env m runner = do
  mr <- finishTHp js_env False m runner
  ns <- readNodeSettings dflags
  modifyMVar_ ( thRunners js_env ) ( pure . deleteActiveRunner m )
  if (fromIntegral mr > nodeKeepAliveMaxMem ns)
    then void $ finishTHp js_env True m runner
    else modifyMVar_ ( thRunners js_env ) ( pure . consIdleRunner runner )

finishTHp :: GhcjsEnv -> Bool -> String -> THRunner -> IO Int
finishTHp _js_env endProcess _m runner = do
  let ph = thrProcess runner
  _ <- readMVar (thrBase runner)
  mu <- finishRunner endProcess runner
  when endProcess $
    maybe (void $ terminateProcess ph)
      (\_ -> return ()) =<< timeout 30000000 (waitForProcess ph)
  return mu

finishTHAll :: GhcjsEnv -> IO ()
finishTHAll js_env = do
  runners <- takeMVar (thRunners js_env)
  forM_ (idleRunners runners ++ M.elems (activeRunners runners))
        (\r -> void (finishRunner True r)
         `E.catch`
         \(_::E.SomeException) -> return ())

sendToRunner :: THRunner -> Int -> TH.Message -> IO ()
sendToRunner runner responseTo msg =
  sendToRunnerRaw runner responseTo (BL.toStrict . runPut . put $ msg)

sendToRunnerRaw :: THRunner -> Int -> ByteString -> IO ()
sendToRunnerRaw runner responseTo bs = do
  let header = BL.toStrict . runPut $ do
        putWord32be (fromIntegral $ B.length bs)
        putWord32be (fromIntegral responseTo)
  B.hPut (thrHandleIn runner) (B16.encode $ header <> bs)
  hFlush (thrHandleIn runner)

readFromRunner :: THRunner -> IO (TH.Message, Int)
readFromRunner runner = do
  let h = thrHandleErr runner
  (len, tgt) <- runGet ((,) <$> getWord32be <*> getWord32be) <$> BL.hGet h 8
  (,fromIntegral tgt) . runGet get <$> BL.hGet h (fromIntegral len)

thSettings :: GhcjsSettings
thSettings = GhcjsSettings False True False False Nothing
                           Nothing Nothing True True True
                           Nothing NoBase
                           Nothing Nothing [] False

startTHRunner :: DynFlags
              -> GhcjsEnv
              -> HscEnv
              -> THRunnerState
              -> IO (THRunner, THRunnerState)
startTHRunner dflags js_env hsc_env runners =
  maybe ((,runners) <$> startTHRunnerProcess dflags js_env hsc_env)
        pure
        (unconsIdleRunner runners)

startTHRunnerProcess :: DynFlags -> GhcjsEnv -> HscEnv -> IO THRunner
startTHRunnerProcess dflags js_env hsc_env = do
  let thSupport = case objectDir dflags of
                    Just dir -> dir </> "th-support.js"
                    Nothing -> "th-support.js"
  compilationProgressMsg dflags $ "Checking for " ++ thSupport
  thSupportFiles <- filterM doesFileExist [ thSupport ]
  lr <- linkTh js_env thSettings thSupportFiles dflags [] (hsc_HPT hsc_env) Nothing
  fr <- BL.fromChunks <$> mapM (Gen2.tryReadShimFile dflags) (Gen2.linkLibRTS lr)
  fa <- BL.fromChunks <$> mapM (Gen2.tryReadShimFile dflags) (Gen2.linkLibA lr)
  aa <- BL.fromChunks <$> mapM (Gen2.readShimsArchive dflags) (Gen2.linkLibAArch lr)
  let rtsd = TL.encodeUtf8 Gen2.rtsDeclsText
      rts  = TL.encodeUtf8 $ Gen2.rtsText' dflags (Gen2.dfCgSettings dflags)
  (inp,out,err,pid) <- runNodeInteractive dflags Nothing (topDir dflags </> "thrunner.js")
  mv  <- newMVar (Gen2.linkBase lr)
  emv <- newMVar []
  eev <- newMVar IM.empty
  _ <- forkIO $ catchIOError (forever $ hGetChar out >>= putChar) (\_ -> return ())
  let r = THRunner pid inp err mv emv eev
  sendToRunnerRaw r 0 (BL.toStrict $ rtsd <> fr <> rts <> fa <> aa <> Gen2.linkOut lr)
  return r
