/
TH.hs
141 lines (126 loc) · 4.4 KB
/
TH.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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
#if __GLASGOW_HASKELL__ == 704
{-# LANGUAGE ConstraintKinds #-}
#endif
module Database.InfluxDB.TH
( Options(..), defaultOptions
, deriveSeriesData
, deriveToSeriesData
, deriveFromSeriesData
, stripPrefixLower
, stripPrefixSnake
) where
import Control.Applicative
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (VarStrictType)
import Prelude
import qualified Data.Vector as V
import Database.InfluxDB.Decode
import Database.InfluxDB.Encode
import Database.InfluxDB.Types.Internal
data Options = Options
{ fieldLabelModifier :: String -> String
}
defaultOptions :: Options
defaultOptions = Options
{ fieldLabelModifier = id
}
deriveSeriesData :: Options -> Name -> Q [Dec]
deriveSeriesData opts name = (++)
<$> deriveToSeriesData opts name
<*> deriveFromSeriesData opts name
deriveToSeriesData :: Options -> Name -> Q [Dec]
deriveToSeriesData opts name = do
info <- reify name
case info of
TyConI dec -> pure <$> deriveWith toSeriesDataBody opts dec
_ -> fail $ "Expected a type constructor, but got " ++ show info
deriveFromSeriesData :: Options -> Name -> Q [Dec]
deriveFromSeriesData opts name = do
info <- reify name
case info of
TyConI dec -> pure <$> deriveWith fromSeriesDataBody opts dec
_ -> fail $ "Expected a type constructor, but got " ++ show info
deriveWith
:: (Options -> Name -> [TyVarBndr] -> Con -> Q Dec)
-> Options -> Dec -> Q Dec
deriveWith f opts dec = case dec of
#if MIN_VERSION_template_haskell(2, 11, 0)
DataD _ tyName tyVars _ [con] _ -> f opts tyName tyVars con
NewtypeD _ tyName tyVars _ con _ -> f opts tyName tyVars con
#else
DataD _ tyName tyVars [con] _ -> f opts tyName tyVars con
NewtypeD _ tyName tyVars con _ -> f opts tyName tyVars con
#endif
_ -> fail $ "Expected a data or newtype declaration, but got " ++ show dec
toSeriesDataBody :: Options -> Name -> [TyVarBndr] -> Con -> Q Dec
toSeriesDataBody opts tyName tyVars con = do
case con of
RecC conName vars -> InstanceD
#if MIN_VERSION_template_haskell(2, 11, 0)
Nothing
#endif
<$> mapM tyVarToPred tyVars
<*> [t| ToSeriesData $(conT tyName) |]
<*> deriveDecs conName vars
_ -> fail $ "Expected a record, but got " ++ show con
where
tyVarToPred tv = case tv of
#if MIN_VERSION_template_haskell(2, 10, 0)
PlainTV name -> conT ''FromValue `appT` varT name
KindedTV name _ -> conT ''FromValue `appT` varT name
#else
PlainTV name -> classP ''FromValue [varT name]
KindedTV name _ -> classP ''FromValue [varT name]
#endif
deriveDecs _conName vars = do
a <- newName "a"
sequence
[ funD 'toSeriesColumns
[ clause [wildP]
(normalB [| V.fromList $(listE columns) |]) []
]
, funD 'toSeriesPoints
[ clause [varP a]
(normalB [| V.fromList $(listE $ map (applyToValue a) vars) |]) []
]
]
where
applyToValue a (name, _, _) = [| toValue ($(varE name) $(varE a)) |]
columns = map (varStrictTypeToColumn opts) vars
fromSeriesDataBody :: Options -> Name -> [TyVarBndr] -> Con -> Q Dec
fromSeriesDataBody opts tyName tyVars con = do
case con of
RecC conName vars -> instanceD
(mapM tyVarToPred tyVars)
[t| FromSeriesData $(conT tyName) |]
[deriveDec conName vars]
_ -> fail $ "Expected a record, but got " ++ show con
where
tyVarToPred tv = case tv of
#if MIN_VERSION_template_haskell(2, 10, 0)
PlainTV name -> conT ''FromValue `appT` varT name
KindedTV name _ -> conT ''FromValue `appT` varT name
#else
PlainTV name -> classP ''FromValue [varT name]
KindedTV name _ -> classP ''FromValue [varT name]
#endif
deriveDec conName vars = funD 'parseSeriesData
[ clause [] (normalB deriveBody) []
]
where
deriveBody = do
values <- newName "values"
appE (varE 'withValues) $ lamE [varP values] $
foldl (go values) [| pure $(conE conName) |] columns
where
go :: Name -> Q Exp -> Q Exp -> Q Exp
go values expQ col = [| $expQ <*> $(varE values) .: $col |]
columns = map (varStrictTypeToColumn opts) vars
varStrictTypeToColumn :: Options -> VarStrictType -> Q Exp
varStrictTypeToColumn opts = column opts . f
where
f (var, _, _) = var
column :: Options -> Name -> Q Exp
column opts = litE . stringL . fieldLabelModifier opts . nameBase