mirror of
https://github.com/typeable/id.git
synced 2024-09-11 13:26:02 +03:00
Add new kinds of Ids and instances
This commit is contained in:
parent
47d0463de0
commit
c87476a929
9
id.cabal
9
id.cabal
@ -14,15 +14,18 @@ library
|
||||
base >=4.12 && <5,
|
||||
binary,
|
||||
deepseq,
|
||||
QuickCheck,
|
||||
flat,
|
||||
hashable,
|
||||
http-api-data,
|
||||
lens,
|
||||
openapi3,
|
||||
uuid,
|
||||
path-pieces,
|
||||
text,
|
||||
QuickCheck,
|
||||
uuid,
|
||||
if !impl(ghcjs)
|
||||
build-depends:
|
||||
cassava,
|
||||
postgresql-simple,
|
||||
hs-source-dirs:
|
||||
src
|
||||
@ -31,9 +34,11 @@ library
|
||||
default-extensions:
|
||||
AllowAmbiguousTypes
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
GeneralizedNewtypeDeriving
|
||||
PolyKinds
|
||||
RankNTypes
|
||||
RoleAnnotations
|
||||
ScopedTypeVariables
|
||||
TypeApplications
|
||||
TypeFamilies
|
||||
|
137
src/Data/Id.hs
137
src/Data/Id.hs
@ -4,43 +4,62 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Data.Id
|
||||
( Id(..)
|
||||
, coerceId
|
||||
, nilId
|
||||
, _Id
|
||||
) where
|
||||
( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
|
||||
, IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
|
||||
, Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
|
||||
)
|
||||
where
|
||||
|
||||
import Control.DeepSeq (NFData)
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
|
||||
import Data.Binary (Binary)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Data
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.OpenApi
|
||||
import Data.String
|
||||
import Data.Text as T
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
#ifndef ghcjs_HOST_OS
|
||||
import Database.PostgreSQL.Simple.FromField (FromField)
|
||||
import Database.PostgreSQL.Simple.ToField (ToField)
|
||||
import Database.PostgreSQL.Simple.FromField as PG (FromField)
|
||||
import Database.PostgreSQL.Simple.ToField as PG (ToField)
|
||||
import Data.Csv as Csv hiding(Name)
|
||||
#endif
|
||||
import GHC.Generics (Generic)
|
||||
import Flat as F
|
||||
import GHC.TypeLits
|
||||
import Test.QuickCheck
|
||||
import Web.HttpApiData
|
||||
import Web.PathPieces (PathPiece(..))
|
||||
|
||||
newtype Id t = Id { unId :: UUID }
|
||||
deriving
|
||||
( Eq, Ord, Generic, Read, Show, Data
|
||||
deriving stock Data
|
||||
deriving newtype
|
||||
( Eq, Ord, Binary
|
||||
#ifndef ghcjs_HOST_OS
|
||||
, ToField, FromField
|
||||
, PG.ToField, PG.FromField
|
||||
#endif
|
||||
, PathPiece, FromJSON
|
||||
, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
|
||||
, FromHttpApiData, ToHttpApiData )
|
||||
, FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
|
||||
, ToParamSchema, FromHttpApiData, ToHttpApiData )
|
||||
|
||||
type role Id nominal
|
||||
|
||||
makePrisms ''Id
|
||||
|
||||
mkId :: forall s. UUID -> Id s
|
||||
mkId = coerce
|
||||
{-# INLINE mkId #-}
|
||||
|
||||
instance KnownSymbol s => Show (Id s) where
|
||||
show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
|
||||
|
||||
instance Flat (Id s) where
|
||||
encode = F.encode . UUID.toWords . coerce
|
||||
decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
|
||||
size = F.size . UUID.toWords . coerce
|
||||
|
||||
instance Arbitrary (Id t) where
|
||||
arbitrary = fmap Id $ UUID.fromWords
|
||||
<$> arbitrary
|
||||
@ -48,20 +67,29 @@ instance Arbitrary (Id t) where
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
|
||||
instance Binary (Id t) where
|
||||
instance PathPiece (Id t) where
|
||||
fromPathPiece = coerce . UUID.fromText
|
||||
toPathPiece = UUID.toText . coerce
|
||||
|
||||
instance PathPiece UUID.UUID where
|
||||
fromPathPiece = UUID.fromText
|
||||
toPathPiece = UUID.toText
|
||||
#ifndef ghcjs_HOST_OS
|
||||
|
||||
makePrisms ''Id
|
||||
instance Csv.FromField (Id tag) where
|
||||
parseField = parseField
|
||||
>=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
|
||||
|
||||
instance Csv.ToField (Id tag) where
|
||||
toField = Csv.toField . UUID.toText . coerce
|
||||
|
||||
#endif
|
||||
|
||||
-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
|
||||
-- You are forced to explicitly specify the phantom types you are converting
|
||||
-- via the @TypeApplications@ compiler extension.
|
||||
coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
|
||||
coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
|
||||
coerceId = coerce
|
||||
{-# INLINE coerceId #-}
|
||||
unsafeIdTagConvert = coerce
|
||||
{-# INLINE unsafeIdTagConvert #-}
|
||||
|
||||
-- | Id corresponding to UUID nil. Useful for testing etc.
|
||||
nilId :: forall a. Id (Ambiguous a)
|
||||
@ -70,3 +98,72 @@ nilId = Id UUID.nil
|
||||
-- https://kcsongor.github.io/ambiguous-tags/
|
||||
type family Ambiguous (a :: k) :: j where
|
||||
Ambiguous x = x
|
||||
|
||||
----------------- IntId
|
||||
newtype IntId t = IntId { unIntId :: Integer }
|
||||
deriving stock Data
|
||||
deriving newtype
|
||||
( Eq, Ord, Binary
|
||||
#ifndef ghcjs_HOST_OS
|
||||
, PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
|
||||
#endif
|
||||
, FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
|
||||
, ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat, Arbitrary
|
||||
, Num, Integral, Real, Enum )
|
||||
|
||||
type role IntId nominal
|
||||
|
||||
makePrisms ''IntId
|
||||
|
||||
mkIntId :: forall s. Integer -> IntId s
|
||||
mkIntId = coerce
|
||||
{-# INLINE mkIntId #-}
|
||||
|
||||
instance KnownSymbol s => Show (IntId s) where
|
||||
show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
|
||||
|
||||
-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
|
||||
-- You are forced to explicitly specify the phantom types you are converting
|
||||
-- via the @TypeApplications@ compiler extension.
|
||||
coerceIntId, unsafeIntIdTagConvert
|
||||
:: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
|
||||
coerceIntId = coerce
|
||||
{-# INLINE coerceIntId #-}
|
||||
unsafeIntIdTagConvert = coerce
|
||||
{-# INLINE unsafeIntIdTagConvert #-}
|
||||
|
||||
----------------- Name
|
||||
newtype Name t = Name { unName :: Text }
|
||||
deriving stock Data
|
||||
deriving newtype
|
||||
( Eq, Ord, Binary
|
||||
#ifndef ghcjs_HOST_OS
|
||||
, PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
|
||||
#endif
|
||||
, FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
|
||||
, ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat
|
||||
, IsString, Semigroup, Monoid )
|
||||
|
||||
type role Name nominal
|
||||
|
||||
makePrisms ''Name
|
||||
|
||||
mkName :: forall s. Text -> Name s
|
||||
mkName = coerce
|
||||
{-# INLINE mkName #-}
|
||||
|
||||
instance KnownSymbol s => Show (Name s) where
|
||||
show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
|
||||
|
||||
instance Arbitrary (Name s) where
|
||||
arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
|
||||
|
||||
-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
|
||||
-- You are forced to explicitly specify the phantom types you are converting
|
||||
-- via the @TypeApplications@ compiler extension.
|
||||
coerceName, unsafeNameTagConvert
|
||||
:: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
|
||||
coerceName = coerce
|
||||
{-# INLINE coerceName #-}
|
||||
unsafeNameTagConvert = coerce
|
||||
{-# INLINE unsafeNameTagConvert #-}
|
||||
|
4
stack.yaml
Normal file
4
stack.yaml
Normal file
@ -0,0 +1,4 @@
|
||||
resolver: lts-18.18
|
||||
|
||||
packages:
|
||||
- .
|
Loading…
Reference in New Issue
Block a user