git.iko.soy/typeable/id
on uuid-types help sign in
typeable/id/src/Data/Id.hs
255 lines 6.8 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# OPTIONS_GHC -Wno-orphans #-}
6module Data.Id
7 ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
8 , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9 , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
10#ifdef USE_UUID
11 , randomId
12#endif
13 )
14 where
16import Control.DeepSeq (NFData)
17import Control.Lens
18import Control.Monad
19import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
20import Data.Binary (Binary)
21import Data.Coerce (coerce)
22import Data.Data
23import Data.Hashable (Hashable)
24import Data.String
25import Data.Text as T
26import Data.UUID.Types (UUID)
27import qualified Data.UUID.Types as UUID
28import GHC.TypeLits
29import Prelude as P
30import Text.ParserCombinators.ReadP
31import Web.HttpApiData
32import Web.PathPieces (PathPiece(..))
34#ifdef USE_UUID
35import qualified Data.UUID.V4 as UUID.V4
36#endif
37#ifdef BACKEND
38import Data.OpenApi
39import Test.QuickCheck
40#ifdef USE_CASSAVA
41import Data.Csv as Csv hiding(Name)
42#endif
43#ifdef USE_POSTGRES
44import Database.PostgreSQL.Simple.FromField as PG (FromField)
45import Database.PostgreSQL.Simple.ToField as PG (ToField)
46#endif
47#endif
49#ifdef USE_FLAT
50import Flat as F
51#endif
52#ifdef USE_STORE
53import qualified Data.Store
54#endif
56newtype Id t = Id { unId :: UUID }
57 deriving stock Data
58 deriving newtype
59 ( Eq, Ord, Binary
60#ifndef ghcjs_HOST_OS
61#ifdef USE_POSTGRES
62 , PG.ToField, PG.FromField
63#endif
64#endif
65 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
66#ifdef BACKEND
67 , ToSchema, ToParamSchema
68#endif
69 , FromHttpApiData, ToHttpApiData )
71type role Id nominal
73makePrisms ''Id
75mkId :: forall s. UUID -> Id s
76mkId = coerce
77{-# INLINE mkId #-}
79#ifdef USE_UUID
80randomId :: forall s. IO (Id s)
81randomId = coerce <$> UUID.V4.nextRandom
82{-# INLINE randomId #-}
83#endif
85instance KnownSymbol s => Show (Id s) where
86 show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> P.show v
88instance KnownSymbol s => Read (Id s) where
89 readsPrec _ = readP_to_S $ do
90 _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
91 mkId <$> readS_to_P reads
93#ifdef USE_FLAT
94instance Flat (Id s) where
95 encode = F.encode . UUID.toWords . coerce
96 decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
97 size = F.size . UUID.toWords . coerce
98#endif
100#ifdef USE_STORE
101instance Data.Store.Store (Id s) where
102 poke = Data.Store.poke . UUID.toWords . coerce
103 peek = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> Data.Store.peek
104 size = Data.Store.ConstSize 16
105#endif
107#ifdef BACKEND
108instance Arbitrary (Id t) where
109 arbitrary = fmap Id $ UUID.fromWords
110 <$> arbitrary
111 <*> arbitrary
112 <*> arbitrary
113 <*> arbitrary
114#endif
116instance PathPiece (Id t) where
117 fromPathPiece = coerce . UUID.fromText
118 toPathPiece = UUID.toText . coerce
120#ifndef ghcjs_HOST_OS
122#ifdef USE_CASSAVA
123instance Csv.FromField (Id tag) where
124 parseField = parseField
125 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
127instance Csv.ToField (Id tag) where
128 toField = Csv.toField . UUID.toText . coerce
129#endif
131#endif
133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
134-- You are forced to explicitly specify the phantom types you are converting
135-- via the @TypeApplications@ compiler extension.
136coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
137coerceId = coerce
138{-# INLINE coerceId #-}
139unsafeIdTagConvert = coerce
140{-# INLINE unsafeIdTagConvert #-}
142-- | Id corresponding to UUID nil. Useful for testing etc.
143nilId :: forall a. Id (Ambiguous a)
144nilId = Id UUID.nil
145{-# INLINE nilId #-}
146-- https://kcsongor.github.io/ambiguous-tags/
147type family Ambiguous (a :: k) :: j where
148 Ambiguous x = x
150----------------- IntId
151newtype IntId t = IntId { unIntId :: Integer }
152 deriving stock Data
153 deriving newtype
154 ( Eq, Ord, Binary
155#ifndef ghcjs_HOST_OS
156#ifdef USE_POSTGRES
157 , PG.ToField, PG.FromField
158#endif
159#ifdef USE_CASSAVA
160 , Csv.ToField, Csv.FromField
161#endif
162#endif
163#ifdef USE_FLAT
164 , Flat
165#endif
166#ifdef USE_STORE
167 , Data.Store.Store
168#endif
169#ifdef BACKEND
170 , ToSchema, ToParamSchema, Arbitrary
171#endif
172 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
173 , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
175type role IntId nominal
177makePrisms ''IntId
179mkIntId :: forall s. Integer -> IntId s
180mkIntId = coerce
181{-# INLINE mkIntId #-}
183instance KnownSymbol s => Show (IntId s) where
184 show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> P.show v
186instance KnownSymbol s => Read (IntId s) where
187 readsPrec _ = readP_to_S $ do
188 _ <- string ("IntId-" <> symbolVal (Proxy @s) <> "-")
189 mkIntId <$> readS_to_P reads
191-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
192-- You are forced to explicitly specify the phantom types you are converting
193-- via the @TypeApplications@ compiler extension.
194coerceIntId, unsafeIntIdTagConvert
195 :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
196coerceIntId = coerce
197{-# INLINE coerceIntId #-}
198unsafeIntIdTagConvert = coerce
199{-# INLINE unsafeIntIdTagConvert #-}
201----------------- Name
202newtype Name t = Name { unName :: Text }
203 deriving stock Data
204 deriving newtype
205 ( Eq, Ord, Binary
206#ifndef ghcjs_HOST_OS
207#ifdef USE_POSTGRES
208 , PG.ToField, PG.FromField
209#endif
210#ifdef USE_CASSAVA
211 , Csv.ToField, Csv.FromField
212#endif
213#endif
214#ifdef USE_FLAT
215 , Flat
216#endif
217#ifdef USE_STORE
218 , Data.Store.Store
219#endif
220#ifdef BACKEND
221 , ToSchema, ToParamSchema
222#endif
223 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
224 , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
226type role Name nominal
228makePrisms ''Name
230mkName :: forall s. Text -> Name s
231mkName = coerce
232{-# INLINE mkName #-}
234instance KnownSymbol s => Show (Name s) where
235 show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> P.show v
237instance KnownSymbol s => Read (Name s) where
238 readsPrec _ = readP_to_S $ do
239 _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
240 mkName <$> readS_to_P reads
242#ifdef BACKEND
243instance Arbitrary (Name s) where
244 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
245#endif
247-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
248-- You are forced to explicitly specify the phantom types you are converting
249-- via the @TypeApplications@ compiler extension.
250coerceName, unsafeNameTagConvert
251 :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
252coerceName = coerce
253{-# INLINE coerceName #-}
254unsafeNameTagConvert = coerce
255{-# INLINE unsafeNameTagConvert #-}