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)