{-# LANGUAGE CPP, LambdaCase, BangPatterns, MagicHash, TupleSections, ScopedTypeVariables #-}{-# OPTIONS_GHC -w #-} -- Suppress warnings for unimplemented methods------------- WARNING ------------------------- This program is utterly bogus. It takes a value of type ()-- and unsafe-coerces it to a function, and applies it.-- This is caught by an ASSERT with a debug compiler.---- See #9208 for discussion----------------------------------------------{- | Evaluate Template Haskell splices on node.js, using pipes to communicate with GHCJS -}-- module GHCJS.Prim.TH.Evalmodule Eval ( runTHServer ) whereimport Control.Applicativeimport Control.Monad#if __GLASGOW_HASKELL__ >= 800import Control.Monad.Fail (MonadFail(fail))#endifimport Control.Monad.IO.Class (MonadIO (..))import Data.Binaryimport Data.Binary.Getimport Data.ByteString (ByteString)import qualified Data.ByteString as Bimport qualified Data.ByteString.Lazy as BLimport GHC.Base (Any)import qualified Language.Haskell.TH as THimport qualified Language.Haskell.TH.Syntax as THimport Unsafe.Coercedata THResultType = THExp | THPat | THType | THDecdata Message -- | GHCJS compiler to node.js requests = RunTH THResultType ByteString TH.Loc -- | node.js to GHCJS compiler responses | RunTH' THResultType ByteString [TH.Dec] -- ^ serialized AST and additional toplevel declarationsinstance Binary THResultType where put _ = return () get = return undefinedinstance Binary Message where put _ = return () get = return undefineddata QState = QStatedata GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }instance Functor GHCJSQ where fmap f (GHCJSQ s) = GHCJSQ $ fmap (\(x,s') -> (f x,s')) . sinstance Applicative GHCJSQ where f <*> a = GHCJSQ $ \s -> do (f',s') <- runGHCJSQ f s (a', s'') <- runGHCJSQ a s' return (f' a', s'') pure x = GHCJSQ (\s -> return (x,s))instance Monad GHCJSQ where (>>=) m f = GHCJSQ $ \s -> do (m', s') <- runGHCJSQ m s (a, s'') <- runGHCJSQ (f m') s' return (a, s'') return = pure#if __GLASGOW_HASKELL__ >= 800instance MonadFail GHCJSQ where fail = undefined#endifinstance MonadIO GHCJSQ where liftIO m = GHCJSQ $ \s -> fmap (,s) minstance TH.Quasi GHCJSQ-- | the Template Haskell serverrunTHServer :: IO ()runTHServer = void $ runGHCJSQ server QState where server = TH.qRunIO awaitMessage >>= \case RunTH t code loc -> do a <- TH.qRunIO $ loadTHData code runTH t a loc _ -> TH.qRunIO (putStrLn "warning: ignoring unexpected message type")runTH :: THResultType -> Any -> TH.Loc -> GHCJSQ ()runTH rt obj loc = do res <- case rt of THExp -> runTHCode (unsafeCoerce obj :: TH.Q TH.Exp) THPat -> runTHCode (unsafeCoerce obj :: TH.Q TH.Pat) THType -> runTHCode (unsafeCoerce obj :: TH.Q TH.Type) THDec -> runTHCode (unsafeCoerce obj :: TH.Q [TH.Dec]) TH.qRunIO (sendResult $ RunTH' rt res [])runTHCode :: {- Binary a => -} TH.Q a -> GHCJSQ ByteStringrunTHCode c = TH.runQ c >> return B.emptyloadTHData :: ByteString -> IO AnyloadTHData bs = return (unsafeCoerce ()) awaitMessage :: IO MessageawaitMessage = fmap (runGet get) (return BL.empty)-- | send result backsendResult :: Message -> IO ()sendResult msg = return ()
Compile failed (exit code 1) errors were:ghc: panic! (the 'impossible' happened) GHC version 9.3.20220221: zipEqual: unequal lists: getStrictConArgsPlease report this as a GHC bug: https://www.haskell.org/ghc/reportabug