Update Trac ticket URLs to point to GitLab
[ghc.git] / testsuite / tests / stranal / should_compile / T9208.hs
1 {-# LANGUAGE CPP, LambdaCase, BangPatterns, MagicHash, TupleSections, ScopedTypeVariables #-}
2 {-# OPTIONS_GHC -w #-} -- Suppress warnings for unimplemented methods
3
4 ------------- WARNING ---------------------
5 --
6 -- This program is utterly bogus. It takes a value of type ()
7 -- and unsafe-coerces it to a function, and applies it.
8 -- This is caught by an ASSERT with a debug compiler.
9 --
10 -- See #9208 for discussion
11 --
12 --------------------------------------------
13
14 {- | Evaluate Template Haskell splices on node.js,
15 using pipes to communicate with GHCJS
16 -}
17
18 -- module GHCJS.Prim.TH.Eval
19 module Eval (
20 runTHServer
21 ) where
22
23 import Control.Applicative
24 import Control.Monad
25 #if __GLASGOW_HASKELL__ >= 800
26 import Control.Monad.Fail (MonadFail(fail))
27 #endif
28 import Control.Monad.IO.Class (MonadIO (..))
29
30 import Data.Binary
31 import Data.Binary.Get
32 import Data.ByteString (ByteString)
33 import qualified Data.ByteString as B
34 import qualified Data.ByteString.Lazy as BL
35
36 import GHC.Base (Any)
37
38 import qualified Language.Haskell.TH as TH
39 import qualified Language.Haskell.TH.Syntax as TH
40
41 import Unsafe.Coerce
42
43 data THResultType = THExp | THPat | THType | THDec
44
45 data Message
46 -- | GHCJS compiler to node.js requests
47 = RunTH THResultType ByteString TH.Loc
48 -- | node.js to GHCJS compiler responses
49 | RunTH' THResultType ByteString [TH.Dec] -- ^ serialized AST and additional toplevel declarations
50
51 instance Binary THResultType where
52 put _ = return ()
53 get = return undefined
54
55 instance Binary Message where
56 put _ = return ()
57 get = return undefined
58
59 data QState = QState
60
61 data GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }
62
63 instance Functor GHCJSQ where
64 fmap f (GHCJSQ s) = GHCJSQ $ fmap (\(x,s') -> (f x,s')) . s
65
66 instance Applicative GHCJSQ where
67 f <*> a = GHCJSQ $ \s ->
68 do (f',s') <- runGHCJSQ f s
69 (a', s'') <- runGHCJSQ a s'
70 return (f' a', s'')
71 pure x = GHCJSQ (\s -> return (x,s))
72
73 instance Monad GHCJSQ where
74 (>>=) m f = GHCJSQ $ \s ->
75 do (m', s') <- runGHCJSQ m s
76 (a, s'') <- runGHCJSQ (f m') s'
77 return (a, s'')
78 return = pure
79
80 #if __GLASGOW_HASKELL__ >= 800
81 instance MonadFail GHCJSQ where
82 fail = undefined
83 #endif
84
85 instance MonadIO GHCJSQ where liftIO m = GHCJSQ $ \s -> fmap (,s) m
86 instance TH.Quasi GHCJSQ
87
88 -- | the Template Haskell server
89 runTHServer :: IO ()
90 runTHServer = void $ runGHCJSQ server QState
91 where
92 server = TH.qRunIO awaitMessage >>= \case
93 RunTH t code loc -> do
94 a <- TH.qRunIO $ loadTHData code
95 runTH t a loc
96 _ -> TH.qRunIO (putStrLn "warning: ignoring unexpected message type")
97
98 runTH :: THResultType -> Any -> TH.Loc -> GHCJSQ ()
99 runTH rt obj loc = do
100 res <- case rt of
101 THExp -> runTHCode (unsafeCoerce obj :: TH.Q TH.Exp)
102 THPat -> runTHCode (unsafeCoerce obj :: TH.Q TH.Pat)
103 THType -> runTHCode (unsafeCoerce obj :: TH.Q TH.Type)
104 THDec -> runTHCode (unsafeCoerce obj :: TH.Q [TH.Dec])
105 TH.qRunIO (sendResult $ RunTH' rt res [])
106
107 runTHCode :: {- Binary a => -} TH.Q a -> GHCJSQ ByteString
108 runTHCode c = TH.runQ c >> return B.empty
109
110 loadTHData :: ByteString -> IO Any
111 loadTHData bs = return (unsafeCoerce ())
112
113 awaitMessage :: IO Message
114 awaitMessage = fmap (runGet get) (return BL.empty)
115
116 -- | send result back
117 sendResult :: Message -> IO ()
118 sendResult msg = return ()