summaryrefslogtreecommitdiff
path: root/src/Database/InfluxDB/TH.hs
blob: b3527f050a4c2086e0986a935eb41382ff150152 (plain)
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
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

#if __GLASGOW_HASKELL__ == 704
{-# LANGUAGE ConstraintKinds #-}
#endif

module Database.InfluxDB.TH
  ( Options(..), defaultOptions
  , deriveSeriesData
  , deriveToSeriesData
  , deriveFromSeriesData

  , stripPrefixLower
  ) where
import Control.Applicative
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (VarStrictType)

import qualified Data.Vector as V

import Database.InfluxDB.Decode
import Database.InfluxDB.Encode
import Database.InfluxDB.Types.Internal (stripPrefixLower)

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
  DataD _ tyName tyVars [con] _ -> f opts tyName tyVars con
  NewtypeD _ tyName tyVars con _ -> f opts tyName tyVars con
  _ -> 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
      <$> mapM tyVarToPred tyVars
      <*> [t| ToSeriesData $(conT tyName) |]
      <*> deriveDecs conName vars
    _ -> fail $ "Expected a record, but got " ++ show con
  where
    tyVarToPred tv = case tv of
      PlainTV name -> classP ''FromValue [varT name]
      KindedTV name _ -> classP ''FromValue [varT name]
    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
      PlainTV name -> classP ''FromValue [varT name]
      KindedTV name _ -> classP ''FromValue [varT name]
    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