-
Notifications
You must be signed in to change notification settings - Fork 200
/
MessagesTH.hs
71 lines (58 loc) · 2.1 KB
/
MessagesTH.hs
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
{-# LANGUAGE TemplateHaskell #-}
module Shim.MessagesTH where
import Data.Char
import Data.IORef
import Data.List
import Data.Monoid
import Language.Haskell.TH
import Shim.Sexp
import Shim.Utils
import Shim.SHM
import Debug.Trace
import System.IO.Unsafe
data Message argumentsType responseType =
Message { name ::String
, callback :: argumentsType -> SHM (Response responseType) }
data Response a = Error String
| Response a
instance Functor Response where
fmap f (Response a) = Response (f a)
fmap f (Error msg) = Error msg
data PackedMsg where Pack :: (ConvSexp res, ConvSexp args) => Message args res -> PackedMsg
data NoArgs
newtype Singleton a = Singleton a
msgList :: IORef [Name]
msgList = unsafePerformIO $ newIORef []
mkMsg fun = do
VarI _ ty _ _ <- reify fun
let adapt = case arity ty of
0 -> noArgs
1 -> singleton
2 -> uncurry
3 -> uncurry3
4 -> uncurry4
n -> error ("mkMsg: add mode arities (" ++ show n ++ ")")
body <- [| Message msgName $(adapt fun) |]
-- msg_ty <- [t| ArgsToMsg ty args_ty => Message args_ty return_ty|]
-- type_dec <- [d| decName :: msg_ty |]
runIO $ modifyIORef msgList (decName :)
return [-- type_dec,
FunD decName [Clause [] (NormalB body) []]]
where
msgName = camelCaseToLisp (nameBase fun)
decName = mkName$ nameBase fun ++ "Msg"
noArgs name = [|\ () -> $(varE name) |]
singleton name= [|\ (Singleton x) -> $(varE name) x |]
uncurry name = [|\(x, y) -> $(varE name) x y|]
uncurry3 name = [|\(x,y,z) -> $(varE name) x y z|]
uncurry4 name = [|\(x,y,z,w) -> $(varE name) x y z w|]
mkMessageList = do
msgs <- runIO $ readIORef msgList
let entries = map (\name -> [| Pack $(varE name) |]) msgs
[d| messages = $(listE entries) |]
camelCaseToLisp :: String -> String
camelCaseToLisp = map toLower . concat . intersperse "-" . splitBy isUpper
-- arity ty | trace (show ty) False = undefined
arity (AppT ArrowT arg) = 1 + arity arg
arity (AppT fun arg) = arity fun + arity arg
arity _ = 0