1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-# 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 Trac #9208 for discussion
--
--------------------------------------------
{- | Evaluate Template Haskell splices on node.js,
using pipes to communicate with GHCJS
-}
-- module GHCJS.Prim.TH.Eval
module Eval (
runTHServer
) where
import Control.Applicative
import Control.Monad
#if __GLASGOW_HASKELL__ >= 800
import Control.Monad.Fail (MonadFail(fail))
#endif
import Control.Monad.IO.Class (MonadIO (..))
import Data.Binary
import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import GHC.Base (Any)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Unsafe.Coerce
data THResultType = THExp | THPat | THType | THDec
data 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 declarations
instance Binary THResultType where
put _ = return ()
get = return undefined
instance Binary Message where
put _ = return ()
get = return undefined
data QState = QState
data GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }
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
#if __GLASGOW_HASKELL__ >= 800
instance MonadFail GHCJSQ where
fail = undefined
#endif
instance MonadIO GHCJSQ where liftIO m = GHCJSQ $ \s -> fmap (,s) m
instance TH.Quasi GHCJSQ
-- | the Template Haskell server
runTHServer :: 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 ByteString
runTHCode c = TH.runQ c >> return B.empty
loadTHData :: ByteString -> IO Any
loadTHData bs = return (unsafeCoerce ())
awaitMessage :: IO Message
awaitMessage = fmap (runGet get) (return BL.empty)
-- | send result back
sendResult :: Message -> IO ()
sendResult msg = return ()
|
