Attr.hs.template 5.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169
  1. {-# LANGUAGE FlexibleContexts #-}
  2. {-# LANGUAGE DataKinds #-}
  3. {-# LANGUAGE RecordWildCards #-}
  4. module $module_path$.Attr where
  5. import Ivory.Language
  6. import Ivory.Tower
  7. import $types_path$.SequenceNum
  8. data AttrWriter a =
  9. AttrWriter
  10. { aw_chan :: ChanInput a
  11. , aw_name :: String
  12. }
  13. data AttrReader a =
  14. AttrReader
  15. { ar_chan :: ChanOutput a
  16. , ar_name :: String
  17. , ar_ival :: Init a
  18. }
  19. data Attr a =
  20. Attr
  21. { attr_writer :: AttrWriter a
  22. , attr_reader :: AttrReader a
  23. }
  24. attrReaderState :: (IvoryArea a, IvoryZero a)
  25. => AttrReader a -> Monitor e (Ref Global a)
  26. attrReaderState ar@AttrReader{..} = do
  27. s <- stateInit ar_name ar_ival
  28. attrReaderHandler ar \$ do
  29. callback \$ \\v -> refCopy s v
  30. return s
  31. attrReaderHandler :: (IvoryArea a, IvoryZero a)
  32. => AttrReader a -> Handler a e () -> Monitor e ()
  33. attrReaderHandler AttrReader{..} k =
  34. handler ar_chan (ar_name ++ "_update") k
  35. attrWriterEmitter :: (IvoryArea a, IvoryZero a)
  36. => AttrWriter a -> Handler b e (Emitter a)
  37. attrWriterEmitter AttrWriter{..} = emitter aw_chan 1
  38. towerAttr :: (IvoryArea a) => String -> Init a -> Tower e (Attr a)
  39. towerAttr n i = do
  40. c <- channel
  41. return Attr
  42. { attr_writer = AttrWriter
  43. { aw_chan = fst c
  44. , aw_name = n
  45. }
  46. , attr_reader = AttrReader
  47. { ar_chan = snd c
  48. , ar_name = n
  49. , ar_ival = i
  50. }
  51. }
  52. class AttrNamed p where
  53. attrName :: (IvoryArea a) => p a -> String
  54. instance AttrNamed AttrReader where
  55. attrName = ar_name
  56. instance AttrNamed AttrWriter where
  57. attrName = aw_name
  58. instance AttrNamed Attr where
  59. attrName = attrName . attr_reader
  60. class AttrReadable p where
  61. attrState :: (IvoryArea a, IvoryZero a) => p a -> Monitor e (Ref Global a)
  62. attrHandler :: (IvoryArea a, IvoryZero a) => p a -> Handler a e () -> Monitor e ()
  63. attrReaderChan :: p a -> ChanOutput a
  64. instance AttrReadable AttrReader where
  65. attrState = attrReaderState
  66. attrHandler = attrReaderHandler
  67. attrReaderChan = ar_chan
  68. instance AttrReadable Attr where
  69. attrState = attrReaderState . attr_reader
  70. attrHandler p k = attrReaderHandler (attr_reader p) k
  71. attrReaderChan = attrReaderChan . attr_reader
  72. class AttrWritable p where
  73. attrEmitter :: (IvoryArea a, IvoryZero a) => p a -> Handler b e (Emitter a)
  74. instance AttrWritable AttrWriter where
  75. attrEmitter = attrWriterEmitter
  76. instance AttrWritable Attr where
  77. attrEmitter = attrWriterEmitter . attr_writer
  78. readableAttrServer :: ( IvoryArea a, IvoryZero a
  79. , IvoryArea (Struct b), IvoryZero (Struct b), IvoryStruct b)
  80. => Label b a
  81. -> Label b (Stored SequenceNum)
  82. -> Attr a
  83. -> ChanOutput (Stored SequenceNum)
  84. -> Tower e (ChanOutput (Struct b))
  85. readableAttrServer val_lbl snum_lbl p get = do
  86. get_response <- channel
  87. monitor (named "Server") \$ do
  88. s <- attrState p
  89. handler get (named "Get") \$ do
  90. e <- emitter (fst get_response) 1
  91. callbackV \$ \\snum -> do
  92. v <- local izero
  93. refCopy (v ~> val_lbl) s
  94. store (v ~> snum_lbl) snum
  95. emit e (constRef v)
  96. return (snd get_response)
  97. where
  98. named n = attrName p ++ n
  99. writableAttrServer :: (IvoryArea a, IvoryZero a
  100. , IvoryArea (Struct b), IvoryZero (Struct b), IvoryStruct b)
  101. => Label b a
  102. -> Label b (Stored SequenceNum)
  103. -> Attr a
  104. -> ChanOutput (Struct b)
  105. -> Tower e (ChanOutput (Stored SequenceNum))
  106. writableAttrServer val_lbl snum_lbl p set = do
  107. set_response <- channel
  108. monitor (named "Server") \$ do
  109. handler set (named "Set") \$ do
  110. e <- attrEmitter p
  111. r <- emitter (fst set_response) 1
  112. callback \$ \\v -> do
  113. emit e (v ~> val_lbl)
  114. emit r (v ~> snum_lbl)
  115. return (snd set_response)
  116. where
  117. named n = attrName p ++ n
  118. readwritableAttrServer :: ( IvoryArea a, IvoryZero a
  119. , IvoryArea (Struct b), IvoryZero (Struct b), IvoryStruct b)
  120. => Label b a
  121. -> Label b (Stored SequenceNum)
  122. -> Attr a
  123. -> ChanOutput (Stored SequenceNum)
  124. -> ChanOutput (Struct b)
  125. -> Tower e (ChanOutput (Struct b), ChanOutput (Stored SequenceNum))
  126. readwritableAttrServer val_lbl snum_lbl p get set = do
  127. get_response <- channel
  128. set_response <- channel
  129. monitor (named "Server") \$ do
  130. s <- attrState p
  131. handler get (named "Get") \$ do
  132. e <- emitter (fst get_response) 1
  133. callbackV \$ \\snum -> do
  134. v <- local izero
  135. refCopy (v ~> val_lbl) s
  136. store (v ~> snum_lbl) snum
  137. emit e (constRef v)
  138. handler set (named "Set") \$ do
  139. e <- attrEmitter p
  140. r <- emitter (fst set_response) 1
  141. callback \$ \\v -> do
  142. emit e (v ~> val_lbl)
  143. emit r (v ~> snum_lbl)
  144. return (snd get_response, snd set_response)
  145. where
  146. named n = attrName p ++ n