@@ -4,43 +4,62 @@
44{-# OPTIONS_GHC -Wno-orphans #-}
55
66module Data.Id
7− ( Id(..)
8− , coerceId
9− , nilId
10− , _Id
11− ) where
7+ ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
8+ , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9+ , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
10+ )
11+ where
1212
1313import Control.DeepSeq (NFData)
1414import Control.Lens
15+import Control.Monad
1516import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
1617import Data.Binary (Binary)
1718import Data.Coerce (coerce)
1819import Data.Data
1920import Data.Hashable (Hashable)
2021import Data.OpenApi
22+import Data.String
23+import Data.Text as T
2124import Data.UUID (UUID)
2225import qualified Data.UUID as UUID
2326#ifndef ghcjs_HOST_OS
24−import Database.PostgreSQL.Simple.FromField (FromField)
25−import Database.PostgreSQL.Simple.ToField (ToField)
27+import Database.PostgreSQL.Simple.FromField as PG (FromField)
28+import Database.PostgreSQL.Simple.ToField as PG (ToField)
29+import Data.Csv as Csv hiding(Name)
2630#endif
27−import GHC.Generics (Generic)
31+import Flat as F
32+import GHC.TypeLits
2833import Test.QuickCheck
2934import Web.HttpApiData
3035import Web.PathPieces (PathPiece(..))
3136
3237newtype Id t = Id { unId :: UUID }
33− deriving
34− ( Eq, Ord, Generic, Read, Show, Data
38+ deriving stock Data
39+ deriving newtype
40+ ( Eq, Ord, Binary
3541#ifndef ghcjs_HOST_OS
36− , ToField, FromField
42+ , PG.ToField, PG.FromField
3743#endif
38− , PathPiece, FromJSON
39− , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
40− , FromHttpApiData, ToHttpApiData )
44+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
45+ , ToParamSchema, FromHttpApiData, ToHttpApiData )
4146
4247type role Id nominal
4348
49+makePrisms ''Id
50+
51+mkId :: forall s. UUID -> Id s
52+mkId = coerce
53+{-# INLINE mkId #-}
54+
55+instance KnownSymbol s => Show (Id s) where
56+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
57+
58+instance Flat (Id s) where
59+ encode = F.encode . UUID.toWords . coerce
60+ decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
61+ size = F.size . UUID.toWords . coerce
62+
4463instance Arbitrary (Id t) where
4564 arbitrary = fmap Id $ UUID.fromWords
4665 <$> arbitrary
@@ -48,20 +67,29 @@ instance Arbitrary (Id t) where
4867 <*> arbitrary
4968 <*> arbitrary
5069
51−instance Binary (Id t) where
70+instance PathPiece (Id t) where
71+ fromPathPiece = coerce . UUID.fromText
72+ toPathPiece = UUID.toText . coerce
73+
74+#ifndef ghcjs_HOST_OS
5275
53−instance PathPiece UUID.UUID where
54− fromPathPiece = UUID.fromText
55− toPathPiece = UUID.toText
76+instance Csv.FromField (Id tag) where
77+ parseField = parseField
78+ >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
5679
57−makePrisms ''Id
80+instance Csv.ToField (Id tag) where
81+ toField = Csv.toField . UUID.toText . coerce
82+
83+#endif
5884
5985-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
6086-- You are forced to explicitly specify the phantom types you are converting
6187-- via the @TypeApplications@ compiler extension.
62−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
88+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
6389coerceId = coerce
6490{-# INLINE coerceId #-}
91+unsafeIdTagConvert = coerce
92+{-# INLINE unsafeIdTagConvert #-}
6593
6694-- | Id corresponding to UUID nil. Useful for testing etc.
6795nilId :: forall a. Id (Ambiguous a)
@@ -70,3 +98,72 @@ nilId = Id UUID.nil
7098-- https://kcsongor.github.io/ambiguous-tags/
7199type family Ambiguous (a :: k) :: j where
72100 Ambiguous x = x
101+
102+----------------- IntId
103+newtype IntId t = IntId { unIntId :: Integer }
104+ deriving stock Data
105+ deriving newtype
106+ ( Eq, Ord, Binary
107+#ifndef ghcjs_HOST_OS
108+ , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
109+#endif
110+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
111+ , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat, Arbitrary
112+ , Num, Integral, Real, Enum )
113+
114+type role IntId nominal
115+
116+makePrisms ''IntId
117+
118+mkIntId :: forall s. Integer -> IntId s
119+mkIntId = coerce
120+{-# INLINE mkIntId #-}
121+
122+instance KnownSymbol s => Show (IntId s) where
123+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
124+
125+-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
126+-- You are forced to explicitly specify the phantom types you are converting
127+-- via the @TypeApplications@ compiler extension.
128+coerceIntId, unsafeIntIdTagConvert
129+ :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
130+coerceIntId = coerce
131+{-# INLINE coerceIntId #-}
132+unsafeIntIdTagConvert = coerce
133+{-# INLINE unsafeIntIdTagConvert #-}
134+
135+----------------- Name
136+newtype Name t = Name { unName :: Text }
137+ deriving stock Data
138+ deriving newtype
139+ ( Eq, Ord, Binary
140+#ifndef ghcjs_HOST_OS
141+ , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
142+#endif
143+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
144+ , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat
145+ , IsString, Semigroup, Monoid )
146+
147+type role Name nominal
148+
149+makePrisms ''Name
150+
151+mkName :: forall s. Text -> Name s
152+mkName = coerce
153+{-# INLINE mkName #-}
154+
155+instance KnownSymbol s => Show (Name s) where
156+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
157+
158+instance Arbitrary (Name s) where
159+ arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
160+
161+-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
162+-- You are forced to explicitly specify the phantom types you are converting
163+-- via the @TypeApplications@ compiler extension.
164+coerceName, unsafeNameTagConvert
165+ :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
166+coerceName = coerce
167+{-# INLINE coerceName #-}
168+unsafeNameTagConvert = coerce
169+{-# INLINE unsafeNameTagConvert #-}