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