1 {-# LANGUAGE DataKinds, TemplateHaskell, TypeFamilies, UndecidableInstances, StandaloneDeriving, GeneralizedNewtypeDeriving #-} 2 module Databrary.Model.Id.Types 3 ( IdType 4 , Id(..) 5 , Int32 6 ) where 7 8 import Control.Arrow (first) 9 import qualified Data.Aeson as JSON 10 import Data.Hashable (Hashable(..)) 11 import Data.Int (Int32) 12 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..), PGType(..)) 13 import Database.PostgreSQL.Typed.Dynamic (PGRep) 14 import qualified Language.Haskell.TH as TH 15 import qualified Language.Haskell.TH.Syntax as TH 16 import Text.Read (Read(..)) 17 18 import Databrary.HTTP.Form.Deform (Deform(..)) 19 20 -- | This defines a way to make a ID type specific to a specific record type. 21 -- IdType takes a containing type as a parameter (e.g. Asset, Volume), and 22 -- defines an alias for the containing types actual ID type. IdType Volume = String 23 -- would mean Volume's use String for their identifiers 24 type family IdType a 25 -- | This builds a new type around the container specific type. See tests for examples. 26 newtype Id a = Id { unId :: IdType a } 27 28 deriving instance Eq (IdType a) => Eq (Id a) 29 deriving instance Ord (IdType a) => Ord (Id a) 30 deriving instance Enum (IdType a) => Enum (Id a) 31 deriving instance Bounded (IdType a) => Bounded (Id a) 32 instance Hashable (IdType a) => Hashable (Id a) where 33 hashWithSalt i = hashWithSalt i . unId 34 hash = hash . unId 35 36 instance (PGParameter t (IdType a), PGType t) => PGParameter t (Id a) where 37 pgEncode t (Id i) = pgEncode t i 38 pgEncodeValue e t (Id i) = pgEncodeValue e t i 39 pgLiteral t (Id i) = pgLiteral t i 40 instance (PGColumn t (IdType a), PGType t) => PGColumn t (Id a) where 41 pgDecode t = Id . pgDecode t 42 pgDecodeValue e t = Id . pgDecodeValue e t 43 instance (PGParameter t (IdType a), PGColumn t (IdType a), PGRep t (IdType a), PGType t) => PGRep t (Id a) 44 45 instance Show (IdType a) => Show (Id a) where 46 showsPrec p (Id a) = showsPrec p a 47 show (Id a) = show a 48 instance Read (IdType a) => Read (Id a) where 49 readsPrec p s = map (first Id) $ readsPrec p s 50 readPrec = Id <$> readPrec 51 52 instance JSON.ToJSON (IdType a) => JSON.ToJSON (Id a) where 53 toJSON (Id a) = JSON.toJSON a 54 instance JSON.FromJSON (IdType a) => JSON.FromJSON (Id a) where 55 parseJSON = fmap Id . JSON.parseJSON 56 57 instance Deform f (IdType a) => Deform f (Id a) where 58 deform = Id <$> deform 59 60 instance TH.Lift (IdType a) => TH.Lift (Id a) where 61 lift (Id i) = TH.conE 'Id `TH.appE` TH.lift i