1 {-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, OverloadedStrings, DataKinds #-} 2 {-# OPTIONS_GHC -fno-warn-orphans #-} 3 module Databrary.Model.Metric.Types 4 ( MeasureDatum 5 , MeasureType(..) 6 , Metric(..) 7 , ParticipantFieldMapping2(..) 8 , mkParticipantFieldMapping2 9 , lookupField 10 ) where 11 12 import Control.Monad (when) 13 import qualified Data.ByteString as BS 14 import Data.Function (on) 15 import qualified Data.List as L 16 import Data.Map (Map) 17 import qualified Data.Map as Map 18 import Data.Ord (comparing) 19 import qualified Data.Text as T 20 import Data.Text (Text) 21 import Instances.TH.Lift () 22 import Language.Haskell.TH.Lift (deriveLiftMany) 23 import qualified Data.Typeable.Internal 24 import qualified GHC.Arr 25 import qualified Database.PostgreSQL.Typed.Types 26 import qualified Database.PostgreSQL.Typed.Dynamic 27 import qualified Database.PostgreSQL.Typed.Enum 28 import qualified Data.Aeson.Types 29 import qualified Data.ByteString.Char8 30 31 -- import Databrary.Has (Has(..)) 32 import Databrary.Model.Enum 33 import Databrary.Model.Kind 34 import Databrary.Model.Release.Types 35 import Databrary.Model.Id.Types 36 import Databrary.Model.Category.Types 37 import qualified Databrary.HTTP.Form.Deform 38 39 -- makeDBEnum "data_type" "MeasureType" 40 -- TODO: db coherence 41 data MeasureType 42 = MeasureTypeText | 43 MeasureTypeNumeric | 44 MeasureTypeDate | 45 MeasureTypeVoid 46 deriving (Eq, 47 Ord, 48 Enum, 49 GHC.Arr.Ix, 50 Bounded, 51 Data.Typeable.Internal.Typeable) 52 instance Show MeasureType where 53 show MeasureTypeText = "text" 54 show MeasureTypeNumeric = "numeric" 55 show MeasureTypeDate = "date" 56 show MeasureTypeVoid = "void" 57 instance Database.PostgreSQL.Typed.Types.PGType "data_type" 58 instance Database.PostgreSQL.Typed.Types.PGParameter "data_type" MeasureType where 59 pgEncode _ MeasureTypeText 60 = BS.pack [116, 101, 120, 116] 61 pgEncode _ MeasureTypeNumeric 62 = BS.pack [110, 117, 109, 101, 114, 105, 99] 63 pgEncode _ MeasureTypeDate 64 = BS.pack [100, 97, 116, 101] 65 pgEncode _ MeasureTypeVoid 66 = BS.pack [118, 111, 105, 100] 67 instance Database.PostgreSQL.Typed.Types.PGColumn "data_type" MeasureType where 68 pgDecode _ x_a4zCt 69 = case BS.unpack x_a4zCt of 70 [116, 101, 120, 116] -> MeasureTypeText 71 [110, 117, 109, 101, 114, 105, 99] -> MeasureTypeNumeric 72 [100, 97, 116, 101] -> MeasureTypeDate 73 [118, 111, 105, 100] -> MeasureTypeVoid 74 _ -> error 75 ("pgDecode data_type: " 76 ++ (Data.ByteString.Char8.unpack x_a4zCt)) 77 instance Database.PostgreSQL.Typed.Dynamic.PGRep "data_type" MeasureType 78 instance Database.PostgreSQL.Typed.Enum.PGEnum MeasureType 79 instance Kinded MeasureType where 80 kindOf _ = "data_type" 81 instance DBEnum MeasureType 82 instance Data.Aeson.Types.ToJSON MeasureType where 83 toJSON 84 = (Data.Aeson.Types.toJSON . fromEnum) 85 instance Data.Aeson.Types.FromJSON MeasureType where 86 parseJSON = parseJSONEnum 87 instance Databrary.HTTP.Form.Deform.Deform f_a4zCu MeasureType where 88 deform = enumForm 89 90 type MeasureDatum = BS.ByteString 91 92 type instance IdType Metric = Int32 93 94 data Metric = Metric 95 { metricId :: !(Id Metric) 96 , metricCategory :: !Category 97 , metricName :: !T.Text 98 , metricRelease :: !(Maybe Release) 99 , metricType :: !MeasureType 100 , metricOptions :: ![MeasureDatum] 101 , metricAssumed :: !(Maybe MeasureDatum) 102 , metricDescription :: !(Maybe T.Text) 103 , metricRequired :: !(Maybe Bool) 104 } deriving (Show) 105 106 instance Kinded Metric where 107 kindOf _ = "metric" 108 109 instance Eq Metric where 110 (==) = on (==) metricId 111 (/=) = on (/=) metricId 112 113 instance Ord Metric where 114 compare = comparing metricId 115 116 deriveLiftMany [''MeasureType, ''Metric] 117 118 mkParticipantFieldMapping2 :: [(Metric, Text)] -> Either String ParticipantFieldMapping2 119 mkParticipantFieldMapping2 metricColumn = do 120 let mpng = Map.fromList metricColumn 121 columns = Map.elems mpng 122 when (length (L.nub columns) /= length columns) (Left "columns mapped to are not unique") 123 -- should we enforce minimum required metrics, such as requiring id? 124 (pure . ParticipantFieldMapping2) mpng 125 126 lookupField :: Metric -> ParticipantFieldMapping2 -> Maybe Text 127 lookupField m (ParticipantFieldMapping2 mp) = Map.lookup m mp 128 129 newtype ParticipantFieldMapping2 = ParticipantFieldMapping2 { pfmGetMapping :: (Map Metric Text) } 130 -- deriving (Eq, Show)