-
Notifications
You must be signed in to change notification settings - Fork 11
/
Copy pathLogDataSource.hs
58 lines (40 loc) · 1.33 KB
/
LogDataSource.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
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE
StandaloneDeriving, GADTs, TypeFamilies,
FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving,
OverloadedStrings, DeriveDataTypeable
#-}
module LogDataSource
( writeLog
, initDataSource
, LogRequest(..)
) where
import Data.Hashable
import Data.Typeable
import Haxl.Core
-- -----------------------------------------------------------------------------
-- Request type
data LogRequest a where
WriteLog :: String -> LogRequest ()
deriving instance Show (LogRequest a)
deriving instance Typeable LogRequest
instance Show1 LogRequest where show1 = show
deriving instance Eq (LogRequest a)
instance Hashable (LogRequest a) where
hashWithSalt salt (WriteLog str) = hashWithSalt salt str
writeLog :: String -> GenHaxl u ()
writeLog = uncachedRequest . WriteLog
instance StateKey LogRequest where
data State LogRequest = LogDataState
initDataSource :: IO (State LogRequest)
initDataSource = return LogDataState
instance DataSourceName LogRequest where
dataSourceName _ = "LogDataSource"
instance DataSource u LogRequest where
fetch _state _flags _userEnv blockedFetches =
SyncFetch $ mapM_ doOne blockedFetches
where
doOne :: BlockedFetch LogRequest -> IO ()
doOne (BlockedFetch (WriteLog str) var) = do
putStrLn str
putSuccess var ()