/lib/ghcjs-th/GHCJS/Prim/TH/Eval.hs
Haskell | 305 lines | 242 code | 45 blank | 18 comment | 2 complexity | c3324b1e05de297c34ee274d9b0ca9f9 MD5 | raw file
Possible License(s): BSD-3-Clause, Apache-2.0
- {-# LANGUAGE CPP, LambdaCase, BangPatterns, MagicHash, TupleSections, ScopedTypeVariables, DeriveDataTypeable #-}
- #ifdef ghcjs_HOST_OS
- {-# LANGUAGE JavaScriptFFI #-}
- #endif
- {- |
- Evaluate Template Haskell splices on node.js
- -}
- module GHCJS.Prim.TH.Eval (
- #ifdef ghcjs_HOST_OS
- runTHServer
- #endif
- ) where
- #ifdef ghcjs_HOST_OS
- import GHCJS.Prim.TH.Serialized
- import GHCJS.Prim.TH.Types
- import Control.Applicative
- import qualified Control.Exception as E
- import Control.Monad
- import Control.Monad.Fail
- import Control.Monad.IO.Class
- 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.Internal as BI
- import qualified Data.ByteString.Lazy as BL
- import qualified Data.ByteString.Unsafe as BU
- import Data.Data
- import Data.Dynamic
- import Data.Int
- import Data.IORef
- import Data.Map (Map)
- import qualified Data.Map as M
- import Data.Maybe
- import Data.Monoid ((<>))
- import Data.Typeable
- import Data.Word
- import Foreign.C
- import Foreign.Ptr
- import GHC.Prim
- import GHC.Exts
- import GHC.Desugar
- import GHC.Fingerprint.Type
- import qualified Language.Haskell.TH as TH
- import qualified Language.Haskell.TH.Syntax as TH
- import System.IO
- import Unsafe.Coerce
- data QState = QState { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module
- , qsFinalizers :: [TH.Q ()] -- ^ registered finalizers (in reverse order)
- , qsLocation :: Maybe TH.Loc -- ^ location for current splice, if any
- }
- instance Show QState where show _ = "<QState>"
- initQState :: QState
- initQState = QState M.empty [] Nothing
- runModFinalizers :: GHCJSQ ()
- runModFinalizers = go =<< getState
- where
- go s | (f:ff) <- qsFinalizers s =
- putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
- go _ = return ()
- data GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }
- data GHCJSQException = GHCJSQException QState (Maybe Int) String
- deriving (Show, Typeable)
- instance E.Exception GHCJSQException
- instance Functor GHCJSQ where
- fmap f (GHCJSQ s) = GHCJSQ $ fmap (\(x,s') -> (f x,s')) . s
- instance 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
- instance MonadFail GHCJSQ where
- fail err = GHCJSQ $ \s -> E.throw (GHCJSQException s Nothing err)
- instance MonadIO GHCJSQ where
- liftIO m = GHCJSQ $ \s -> fmap (,s) m
- getState :: GHCJSQ QState
- getState = GHCJSQ $ \s -> return (s,s)
- putState :: QState -> GHCJSQ ()
- putState s = GHCJSQ $ \_ -> return ((),s)
- noLoc :: TH.Loc
- noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
- instance TH.Quasi GHCJSQ where
- qNewName str = do
- NewName' name <- sendRequestQ (NewName str)
- return name
- qReport isError msg = do
- Report' <- sendRequestQ (Report isError msg)
- return ()
- qRecover (GHCJSQ h) (GHCJSQ a) = GHCJSQ $ \s -> do
- let r :: Bool -> IO ()
- r b = do EndRecover' <- sendRequest (EndRecover b)
- return ()
- StartRecover' <- sendRequest StartRecover
- (a s >>= \s' -> r False >> return s') `E.catch`
- \(GHCJSQException s' _ _) -> r True >> h s
- qLookupName isType occ = do
- LookupName' name <- sendRequestQ (LookupName isType occ)
- return name
- qReify name = do
- Reify' info <- sendRequestQ (Reify name)
- return info
- qReifyInstances name tys = do
- ReifyInstances' decls <- sendRequestQ (ReifyInstances name tys)
- return decls
- qReifyRoles name = do
- ReifyRoles' roles <- sendRequestQ (ReifyRoles name)
- return roles
- qReifyAnnotations lookup = do
- ReifyAnnotations' payloads <- sendRequestQ (ReifyAnnotations lookup)
- return (convertAnnPayloads payloads)
- qReifyModule m = do
- ReifyModule' mi <- sendRequestQ (ReifyModule m)
- return mi
- qReifyFixity m = do
- ReifyFixity' mi <- sendRequestQ (ReifyFixity m)
- return mi
- qReifyConStrictness name = do
- ReifyConStrictness' ss <- sendRequestQ (ReifyConStrictness name)
- return ss
- qAddForeignFilePath lang contents = do
- AddForeignFilePath' <- sendRequestQ (AddForeignFilePath lang contents)
- return ()
- qIsExtEnabled ext = do
- IsExtEnabled' b <- sendRequestQ (IsExtEnabled ext)
- return b
- qExtsEnabled = do
- ExtsEnabled' exts <- sendRequestQ ExtsEnabled
- return exts
- qLocation = fromMaybe noLoc . qsLocation <$> getState
- qRunIO m = GHCJSQ $ \s -> fmap (,s) m
- qAddDependentFile file = do
- AddDependentFile' <- sendRequestQ (AddDependentFile file)
- return ()
- qAddTempFile xs = do
- AddTempFile' path <- sendRequestQ (AddTempFile xs)
- return path
- qAddTopDecls decls = do
- AddTopDecls' <- sendRequestQ (AddTopDecls decls)
- return ()
- qAddModFinalizer fin = GHCJSQ $ \s ->
- return ((), s { qsFinalizers = fin : qsFinalizers s })
- qGetQ = GHCJSQ $ \s ->
- let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
- lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
- in return (lookup (qsMap s), s)
- qPutQ k = GHCJSQ $ \s ->
- return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
- qAddCorePlugin plugin = do
- AddCorePlugin' <- sendRequestQ (AddCorePlugin plugin)
- return ()
- makeAnnPayload :: forall a. Data a => a -> ByteString
- makeAnnPayload x =
- let Fingerprint w1 w2 = typeRepFingerprint (typeOf (undefined :: a))
- fp = runPut (putWord64be w1 >> putWord64be w2)
- in BL.toStrict $ fp <> BL.pack (serializeWithData x)
- convertAnnPayloads :: forall a. Data a => [ByteString] -> [a]
- convertAnnPayloads bs = catMaybes (map convert bs)
- where
- Fingerprint w1 w2 = typeRepFingerprint (typeOf (undefined :: a))
- getFp b = runGet ((,) <$> getWord64be <*> getWord64be) $ BL.fromStrict (B.take 16 b)
- convert b | (bw1,bw2) <- getFp b, bw1 == w1, bw2 == w2 =
- Just (deserializeWithData . B.unpack . B.drop 16 $ b)
- | otherwise = Nothing
- -- | the Template Haskell server
- runTHServer :: IO ()
- runTHServer = do
- -- msgs <- newIORef []
- void (runGHCJSQ server initQState) `E.catches`
- [ E.Handler $ \(GHCJSQException _ mn msg) ->
- void . sendRequest $ maybe (QFail msg) QCompilerException mn
- , E.Handler $ \(E.SomeException e) ->
- void (sendRequest $ QUserException (show e))
- ]
- where
- server = TH.qRunIO awaitMessage >>= \case
- RunTH t code loc -> do
- a <- TH.qRunIO (loadCode code)
- runTH t a loc
- server
- FinishTH endProcess -> do
- runModFinalizers
- mu <- TH.qRunIO $ js_getMemoryUsage
- TH.qRunIO $ sendResult (FinishTH' mu)
- when (not endProcess) server
- _ -> error "runTHServer: unexpected message type"
- {-# NOINLINE runTH #-}
- runTH :: THResultType -> Any -> Maybe TH.Loc -> GHCJSQ ()
- runTH rt obj = \mb_loc -> obj `seq` do
- s0 <- getState
- putState $ s0 { qsLocation = mb_loc }
- 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])
- THAnnWrapper -> case unsafeCoerce obj of
- AnnotationWrapper x -> return (makeAnnPayload x)
- s1 <- getState
- TH.qRunIO (sendResult $ RunTH' res)
- putState $ s1 { qsLocation = Nothing }
- {-# NOINLINE runTHCode #-}
- runTHCode :: Binary a => TH.Q a -> GHCJSQ ByteString
- runTHCode c = BL.toStrict . runPut . put <$> TH.runQ c
- {-# NOINLINE loadCode #-}
- loadCode :: ByteString -> IO Any
- loadCode bs = do
- p <- fromBs bs
- unsafeCoerce <$> js_loadCode p (B.length bs)
- awaitMessage :: IO Message
- awaitMessage = fmap (runGet get . BL.fromStrict) . toBs =<< js_awaitMessage
- -- | send result back
- sendResult :: Message -> IO ()
- sendResult msg = do
- let bs = BL.toStrict $ runPut (put msg)
- p <- fromBs bs
- js_sendMessage p (B.length bs)
- -- | send a request and wait for the response
- sendRequest :: Message -> IO Message
- sendRequest msg = do
- let bs = BL.toStrict $ runPut (put msg)
- p <- fromBs bs
- fmap (runGet get . BL.fromStrict) . toBs =<< js_sendRequest p (B.length bs)
- -- | send a request and wait for the response
- -- a CompilerException' response is converted to a GHCJSQException which
- -- can be handled with recover.
- sendRequestQ :: Message -> GHCJSQ Message
- sendRequestQ msg = TH.qRunIO (sendRequest msg) >>= \case
- QCompilerException' n msg -> GHCJSQ $
- \s -> E.throw (GHCJSQException s (Just n) msg)
- response -> return response
- foreign import javascript interruptible "h$TH.sendRequest($1_1,$1_2,$2,$c);"
- js_sendRequest :: Ptr Word8 -> Int -> IO (Ptr Word8)
- foreign import javascript interruptible "h$TH.sendMessage($1_1,$1_2,$2,0,$c);"
- js_sendMessage :: Ptr Word8 -> Int -> IO ()
- foreign import javascript interruptible "h$TH.awaitMessage(0,$c);"
- js_awaitMessage :: IO (Ptr Word8)
- foreign import javascript unsafe "h$TH.bufSize($1_1, $1_2)"
- js_bufSize :: Ptr Word8 -> IO Int
- -- | actually returns the heap object to be evaluated
- foreign import javascript unsafe "h$TH.loadCode($1_1,$1_2,$2)"
- js_loadCode :: Ptr Word8 -> Int -> IO Double
- foreign import javascript unsafe "$r = h$TH.getMemoryUsage();"
- js_getMemoryUsage :: IO Int
- -- | only safe in JS
- fromBs :: ByteString -> IO (Ptr Word8)
- fromBs bs = BU.unsafeUseAsCString bs (return . castPtr)
- -- | build a ByteString that uses the whole buffer, only works in JS
- toBs :: Ptr Word8 -> IO ByteString
- toBs p = do
- l <- js_bufSize p
- BU.unsafePackCStringLen (castPtr p, l)
- #endif