@@ -1,42 +1,255 @@
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# OPTIONS_GHC -Wno-orphans #-}
1module Data.Id
6module Data.Id
2− ( Id(..)
7+ ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
3− , coerceId
8+ , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9+ , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
6import Control.DeepSeq (NFData)
16import Control.DeepSeq (NFData)
7−import Data.Aeson (FromJSON, ToJSON)
19+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
8import Data.Binary (Binary)
20import Data.Binary (Binary)
9import Data.Coerce (coerce)
21import Data.Coerce (coerce)
10import Data.Hashable (Hashable)
23import Data.Hashable (Hashable)
11−import Data.UUID (UUID)
24+import Data.String
12−import qualified Data.UUID as UUID
25+import Data.Text as T
13−import Database.PostgreSQL.Simple.FromField (FromField)
26+import Data.UUID.Types (UUID)
14−import Database.PostgreSQL.Simple.ToField (ToField)
27+import qualified Data.UUID.Types as UUID
15−import GHC.Generics (Generic)
28+import GHC.TypeLits
30+import Text.ParserCombinators.ReadP
31+import Web.HttpApiData
32+import Web.PathPieces (PathPiece(..))
35+import qualified Data.UUID.V4 as UUID.V4
16−import Test.QuickCheck (Arbitrary)
39+import Test.QuickCheck
17−import Yesod.Core (PathPiece(..))
40+#ifdef USE_CASSAVA
41+import Data.Csv as Csv hiding(Name)
44+import Database.PostgreSQL.Simple.FromField as PG (FromField)
45+import Database.PostgreSQL.Simple.ToField as PG (ToField)
53+import qualified Data.Store
20−newtype Id (t :: k) = Id { unId :: UUID }
56+newtype Id t = Id { unId :: UUID }
21− deriving
57+ deriving stock Data
22− ( Eq, Ord, Generic, Read, Show, ToField, FromField, PathPiece, FromJSON
62+ , PG.ToField, PG.FromField
23− , ToJSON, NFData, Hashable)
65+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
67+ , ToSchema, ToParamSchema
69+ , FromHttpApiData, ToHttpApiData )
25type role Id nominal
71type role Id nominal
75+mkId :: forall s. UUID -> Id s
80+randomId :: forall s. IO (Id s)
81+randomId = coerce <$> UUID.V4.nextRandom
82+{-# INLINE randomId #-}
85+instance KnownSymbol s => Show (Id s) where
86+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> P.show v
88+instance KnownSymbol s => Read (Id s) where
89+ readsPrec _ = readP_to_S $ do
90+ _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
91+ mkId <$> readS_to_P reads
27−instance Binary (Id t) where
94+instance 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
101+instance 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
108+instance Arbitrary (Id t) where
109+ arbitrary = fmap Id $ UUID.fromWords
29−instance PathPiece UUID.UUID where
116+instance PathPiece (Id t) where
30− fromPathPiece = UUID.fromText
117+ fromPathPiece = coerce . UUID.fromText
31− toPathPiece = UUID.toText
118+ toPathPiece = UUID.toText . coerce
120+#ifndef ghcjs_HOST_OS
123+instance Csv.FromField (Id tag) where
124+ parseField = parseField
125+ >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
127+instance Csv.ToField (Id tag) where
128+ toField = Csv.toField . UUID.toText . coerce
33-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
34-- You are forced to explicitly specify the phantom types you are converting
134-- You are forced to explicitly specify the phantom types you are converting
35-- via the @TypeApplications@ compiler extension.
135-- via the @TypeApplications@ compiler extension.
36−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
136+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
37coerceId = coerce
137coerceId = coerce
38{-# INLINE coerceId #-}
138{-# INLINE coerceId #-}
139+unsafeIdTagConvert = coerce
140+{-# INLINE unsafeIdTagConvert #-}
142+-- | Id corresponding to UUID nil. Useful for testing etc.
143+nilId :: forall a. Id (Ambiguous a)
40-- https://kcsongor.github.io/ambiguous-tags/
146-- https://kcsongor.github.io/ambiguous-tags/
41type family Ambiguous (a :: k) :: j where
147type family Ambiguous (a :: k) :: j where
42 Ambiguous x = x
148 Ambiguous x = x
150+----------------- IntId
151+newtype IntId t = IntId { unIntId :: Integer }
155+#ifndef ghcjs_HOST_OS
157+ , PG.ToField, PG.FromField
160+ , Csv.ToField, Csv.FromField
170+ , ToSchema, ToParamSchema, Arbitrary
172+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
173+ , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
175+type role IntId nominal
179+mkIntId :: forall s. Integer -> IntId s
181+{-# INLINE mkIntId #-}
183+instance KnownSymbol s => Show (IntId s) where
184+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> P.show v
186+instance 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.
194+coerceIntId, unsafeIntIdTagConvert
195+ :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
197+{-# INLINE coerceIntId #-}
198+unsafeIntIdTagConvert = coerce
199+{-# INLINE unsafeIntIdTagConvert #-}
201+----------------- Name
202+newtype Name t = Name { unName :: Text }
206+#ifndef ghcjs_HOST_OS
208+ , PG.ToField, PG.FromField
211+ , Csv.ToField, Csv.FromField
221+ , ToSchema, ToParamSchema
223+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
224+ , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
226+type role Name nominal
230+mkName :: forall s. Text -> Name s
232+{-# INLINE mkName #-}
234+instance KnownSymbol s => Show (Name s) where
235+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> P.show v
237+instance KnownSymbol s => Read (Name s) where
238+ readsPrec _ = readP_to_S $ do
239+ _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
240+ mkName <$> readS_to_P reads
243+instance Arbitrary (Name s) where
244+ arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
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.
250+coerceName, unsafeNameTagConvert
251+ :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
253+{-# INLINE coerceName #-}
254+unsafeNameTagConvert = coerce
255+{-# INLINE unsafeNameTagConvert #-}