Advertisement
Guest User

Untitled

a guest
Apr 23rd, 2019
89
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 6.13 KB | None | 0 0
  1. {-# LANGUAGE StandaloneDeriving, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TupleSections, TypeFamilies, UndecidableInstances #-}
  2. {-# OPTIONS_GHC -fno-warn-orphans #-}
  3.  
  4. module Control.Effect.Control where
  5.  
  6. import Control.Monad
  7. import Control.Effect
  8. import Control.Effect.Reader
  9. import Control.Effect.Random
  10. import Control.Effect.Error
  11. import Control.Effect.Fail
  12. import Control.Effect.Fresh
  13. import Control.Effect.Lift
  14. import Control.Effect.Writer
  15. import Control.Effect.Resumable
  16. import Control.Effect.Trace
  17. import Control.Monad.Trans.Control
  18. import Control.Monad.Base
  19. import qualified Control.Effect.State.Strict as Strict
  20. import qualified Control.Effect.State.Lazy as Lazy
  21.  
  22. instance MonadBase PureC PureC where liftBase = id
  23.  
  24. -- Reader
  25.  
  26. instance MonadBase b m => MonadBase b (ReaderC r m) where
  27. liftBase = liftBaseDefault
  28. {-# INLINE liftBase #-}
  29.  
  30. instance MonadTransControl (ReaderC r) where
  31. type StT (ReaderC r) a = a
  32. liftWith f = ReaderC $ \r -> f $ \t -> runReader r t
  33. restoreT = ReaderC . const
  34. {-# INLINABLE liftWith #-}
  35. {-# INLINABLE restoreT #-}
  36.  
  37. instance MonadBaseControl b m => MonadBaseControl b (ReaderC r m) where
  38. type StM (ReaderC r m) a = ComposeSt (ReaderC r) m a
  39. liftBaseWith = defaultLiftBaseWith
  40. restoreM = defaultRestoreM
  41. {-# INLINABLE liftBaseWith #-}
  42. {-# INLINABLE restoreM #-}
  43.  
  44. -- Error
  45.  
  46. instance MonadBase b m => MonadBase b (ErrorC e m) where
  47. liftBase = liftBaseDefault
  48. {-# INLINE liftBase #-}
  49.  
  50. instance MonadTransControl (ErrorC e) where
  51. type StT (ErrorC e) a = Either e a
  52. liftWith f = ErrorC . liftM pure $ f runError
  53. restoreT = ErrorC
  54. {-# INLINABLE liftWith #-}
  55. {-# INLINABLE restoreT #-}
  56.  
  57. instance MonadBaseControl b m => MonadBaseControl b (ErrorC e m) where
  58. type StM (ErrorC e m) a = ComposeSt (ErrorC e) m a
  59. liftBaseWith = defaultLiftBaseWith
  60. restoreM = defaultRestoreM
  61. {-# INLINABLE liftBaseWith #-}
  62. {-# INLINABLE restoreM #-}
  63.  
  64. -- Fail (derived from Error)
  65.  
  66. deriving instance MonadTransControl FailC
  67.  
  68. -- Strict State
  69.  
  70. instance MonadBase b m => MonadBase b (Strict.StateC e m) where
  71. liftBase = liftBaseDefault
  72. {-# INLINE liftBase #-}
  73.  
  74. instance MonadTransControl (Strict.StateC s) where
  75. type StT (Strict.StateC s) a = (s, a)
  76. liftWith f = Strict.StateC $ \s -> liftM (s,) (f (Strict.runState s))
  77. restoreT = Strict.StateC . const
  78. {-# INLINABLE liftWith #-}
  79. {-# INLINABLE restoreT #-}
  80.  
  81. instance MonadBaseControl b m => MonadBaseControl b (Strict.StateC s m) where
  82. type StM (Strict.StateC s m) a = ComposeSt (Strict.StateC s) m a
  83. liftBaseWith = defaultLiftBaseWith
  84. restoreM = defaultRestoreM
  85. {-# INLINABLE liftBaseWith #-}
  86. {-# INLINABLE restoreM #-}
  87.  
  88. -- Writer, Fresh, and Random (derived from strict State)
  89.  
  90. deriving instance MonadBase b m => MonadBase b (WriterC w m)
  91. deriving instance MonadTransControl (WriterC w)
  92. deriving instance MonadBaseControl b m => MonadBaseControl b (WriterC w m)
  93.  
  94. deriving instance MonadBase b m => MonadBase b (FreshC m)
  95. deriving instance MonadTransControl FreshC
  96. deriving instance MonadBaseControl b m => MonadBaseControl b (FreshC m)
  97.  
  98. deriving instance MonadBase b m => MonadBase b (RandomC g m)
  99. deriving instance MonadTransControl (RandomC g)
  100. deriving instance MonadBaseControl b m => MonadBaseControl b (RandomC g m)
  101.  
  102. -- Lazy State
  103.  
  104. instance MonadBase b m => MonadBase b (Lazy.StateC e m) where
  105. liftBase = liftBaseDefault
  106. {-# INLINE liftBase #-}
  107.  
  108. instance MonadTransControl (Lazy.StateC s) where
  109. type StT (Lazy.StateC s) a = (s, a)
  110. liftWith f = Lazy.StateC $ \s -> liftM (s,) (f (Lazy.runState s))
  111. restoreT = Lazy.StateC . const
  112. {-# INLINABLE liftWith #-}
  113. {-# INLINABLE restoreT #-}
  114.  
  115. instance MonadBaseControl b m => MonadBaseControl b (Lazy.StateC s m) where
  116. type StM (Lazy.StateC s m) a = ComposeSt (Lazy.StateC s) m a
  117. liftBaseWith = defaultLiftBaseWith
  118. restoreM = defaultRestoreM
  119. {-# INLINABLE liftBaseWith #-}
  120. {-# INLINABLE restoreM #-}
  121.  
  122. -- Printed tracing
  123. instance MonadBase b m => MonadBase b (TraceByPrintingC m) where
  124. liftBase = liftBaseDefault
  125. {-# INLINE liftBase #-}
  126.  
  127. instance MonadTransControl TraceByPrintingC where
  128. type StT TraceByPrintingC a = a
  129. liftWith f = TraceByPrintingC $ f runTraceByPrinting
  130. restoreT = TraceByPrintingC
  131. {-# INLINABLE liftWith #-}
  132. {-# INLINABLE restoreT #-}
  133.  
  134. instance MonadBaseControl b m => MonadBaseControl b (TraceByPrintingC m) where
  135. type StM (TraceByPrintingC m) a = ComposeSt TraceByPrintingC m a
  136. liftBaseWith = defaultLiftBaseWith
  137. restoreM = defaultRestoreM
  138. {-# INLINABLE liftBaseWith #-}
  139. {-# INLINABLE restoreM #-}
  140.  
  141. -- Ignored tracing
  142. instance MonadBase b m => MonadBase b (TraceByIgnoringC m) where
  143. liftBase = liftBaseDefault
  144. {-# INLINE liftBase #-}
  145.  
  146. instance MonadTransControl TraceByIgnoringC where
  147. type StT TraceByIgnoringC a = a
  148. liftWith f = TraceByIgnoringC $ f runTraceByIgnoring
  149. restoreT = TraceByIgnoringC
  150. {-# INLINABLE liftWith #-}
  151. {-# INLINABLE restoreT #-}
  152.  
  153. instance MonadBaseControl b m => MonadBaseControl b (TraceByIgnoringC m) where
  154. type StM (TraceByIgnoringC m) a = ComposeSt TraceByIgnoringC m a
  155. liftBaseWith = defaultLiftBaseWith
  156. restoreM = defaultRestoreM
  157. {-# INLINABLE liftBaseWith #-}
  158. {-# INLINABLE restoreM #-}
  159.  
  160. -- Accumulated tracing
  161. deriving instance MonadBase b m => MonadBase b (TraceByReturningC m)
  162. deriving instance MonadTransControl TraceByReturningC
  163. deriving instance MonadBaseControl b m => MonadBaseControl b (TraceByReturningC m)
  164.  
  165. -- Resumable exceptions (does this work??)
  166. deriving instance MonadBase b m => MonadBase b (ResumableC err m)
  167. deriving instance MonadTransControl (ResumableC err)
  168. deriving instance MonadBaseControl b m => MonadBaseControl b (ResumableC err m)
  169.  
  170. -- Lift
  171.  
  172. instance MonadBase b m => MonadBase b (LiftC m) where
  173. liftBase = liftBaseDefault
  174. {-# INLINE liftBase #-}
  175.  
  176. instance MonadTransControl LiftC where
  177. type StT LiftC a = a
  178. liftWith f = LiftC $ f runM
  179. restoreT = LiftC
  180. {-# INLINABLE liftWith #-}
  181. {-# INLINABLE restoreT #-}
  182.  
  183. instance MonadBaseControl b m => MonadBaseControl b (LiftC m) where
  184. type StM (LiftC m) a = ComposeSt LiftC m a
  185. liftBaseWith = defaultLiftBaseWith
  186. restoreM = defaultRestoreM
  187. {-# INLINABLE liftBaseWith #-}
  188. {-# INLINABLE restoreM #-}
  189.  
  190. -- TODO: NonDet?
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement