{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module TypeLitFieldDefsTest (specsWith, typeLitFieldDefsMigrate) where

import Data.Maybe (fromJust)
import GHC.TypeLits
import Init

newtype Finite (n :: Nat) = Finite Int
    deriving (Int -> Finite n -> ShowS
[Finite n] -> ShowS
Finite n -> String
(Int -> Finite n -> ShowS)
-> (Finite n -> String) -> ([Finite n] -> ShowS) -> Show (Finite n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). Int -> Finite n -> ShowS
forall (n :: Nat). [Finite n] -> ShowS
forall (n :: Nat). Finite n -> String
showList :: [Finite n] -> ShowS
$cshowList :: forall (n :: Nat). [Finite n] -> ShowS
show :: Finite n -> String
$cshow :: forall (n :: Nat). Finite n -> String
showsPrec :: Int -> Finite n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> Finite n -> ShowS
Show, Finite n -> Finite n -> Bool
(Finite n -> Finite n -> Bool)
-> (Finite n -> Finite n -> Bool) -> Eq (Finite n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (n :: Nat). Finite n -> Finite n -> Bool
/= :: Finite n -> Finite n -> Bool
$c/= :: forall (n :: Nat). Finite n -> Finite n -> Bool
== :: Finite n -> Finite n -> Bool
$c== :: forall (n :: Nat). Finite n -> Finite n -> Bool
Eq)

instance PersistField (Finite n) where
    toPersistValue :: Finite n -> PersistValue
toPersistValue (Finite Int
n) = Int -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Int
n
    fromPersistValue :: PersistValue -> Either Text (Finite n)
fromPersistValue = (Int -> Finite n) -> Either Text Int -> Either Text (Finite n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Finite n
forall (n :: Nat). Int -> Finite n
Finite (Either Text Int -> Either Text (Finite n))
-> (PersistValue -> Either Text Int)
-> PersistValue
-> Either Text (Finite n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Int
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistFieldSql (Finite n) where
    sqlType :: Proxy (Finite n) -> SqlType
sqlType Proxy (Finite n)
_ = Proxy Int -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (Proxy Int
forall k (t :: k). Proxy t
Proxy :: Proxy Int)

newtype Labelled (t :: Symbol) = Labelled Int
    deriving (Int -> Labelled t -> ShowS
[Labelled t] -> ShowS
Labelled t -> String
(Int -> Labelled t -> ShowS)
-> (Labelled t -> String)
-> ([Labelled t] -> ShowS)
-> Show (Labelled t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: Symbol). Int -> Labelled t -> ShowS
forall (t :: Symbol). [Labelled t] -> ShowS
forall (t :: Symbol). Labelled t -> String
showList :: [Labelled t] -> ShowS
$cshowList :: forall (t :: Symbol). [Labelled t] -> ShowS
show :: Labelled t -> String
$cshow :: forall (t :: Symbol). Labelled t -> String
showsPrec :: Int -> Labelled t -> ShowS
$cshowsPrec :: forall (t :: Symbol). Int -> Labelled t -> ShowS
Show, Labelled t -> Labelled t -> Bool
(Labelled t -> Labelled t -> Bool)
-> (Labelled t -> Labelled t -> Bool) -> Eq (Labelled t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: Symbol). Labelled t -> Labelled t -> Bool
/= :: Labelled t -> Labelled t -> Bool
$c/= :: forall (t :: Symbol). Labelled t -> Labelled t -> Bool
== :: Labelled t -> Labelled t -> Bool
$c== :: forall (t :: Symbol). Labelled t -> Labelled t -> Bool
Eq)

instance PersistField (Labelled n) where
    toPersistValue :: Labelled n -> PersistValue
toPersistValue (Labelled Int
n) = Int -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Int
n
    fromPersistValue :: PersistValue -> Either Text (Labelled n)
fromPersistValue = (Int -> Labelled n) -> Either Text Int -> Either Text (Labelled n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Labelled n
forall (t :: Symbol). Int -> Labelled t
Labelled (Either Text Int -> Either Text (Labelled n))
-> (PersistValue -> Either Text Int)
-> PersistValue
-> Either Text (Labelled n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Int
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistFieldSql (Labelled n) where
    sqlType :: Proxy (Labelled n) -> SqlType
sqlType Proxy (Labelled n)
_ = Proxy Int -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (Proxy Int
forall k (t :: k). Proxy t
Proxy :: Proxy Int)

share [mkPersist sqlSettings { mpsGeneric = True },  mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase|
    TypeLitFieldDefsNumeric
        one    (Finite 1)
        twenty (Finite 20)
        deriving Eq Show

    TypeLitFieldDefsLabelled
        one    (Labelled "one")
        twenty (Labelled "twenty")
        deriving Eq Show
|]

one :: Finite 1
one :: Finite 1
one = Int -> Finite 1
forall (n :: Nat). Int -> Finite n
Finite Int
1

oneLabelled :: Labelled "one"
oneLabelled :: Labelled "one"
oneLabelled = Int -> Labelled "one"
forall (t :: Symbol). Int -> Labelled t
Labelled Int
1

twenty :: Finite 20
twenty :: Finite 20
twenty = Int -> Finite 20
forall (n :: Nat). Int -> Finite n
Finite Int
20

twentyLabelled :: Labelled "twenty"
twentyLabelled :: Labelled "twenty"
twentyLabelled = Int -> Labelled "twenty"
forall (t :: Symbol). Int -> Labelled t
Labelled Int
20

specsWith :: Runner backend m => RunDb backend m -> Spec
specsWith :: RunDb backend m -> Spec
specsWith RunDb backend m
runDb =
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Type Lit Field Definitions" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"runs appropriate migrations" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ RunDb backend m
runDb RunDb backend m -> RunDb backend m
forall a b. (a -> b) -> a -> b
$ do
            Key (TypeLitFieldDefsNumericGeneric backend)
numKey <- TypeLitFieldDefsNumericGeneric backend
-> ReaderT backend m (Key (TypeLitFieldDefsNumericGeneric backend))
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (TypeLitFieldDefsNumericGeneric backend
 -> ReaderT
      backend m (Key (TypeLitFieldDefsNumericGeneric backend)))
-> TypeLitFieldDefsNumericGeneric backend
-> ReaderT backend m (Key (TypeLitFieldDefsNumericGeneric backend))
forall a b. (a -> b) -> a -> b
$ Finite 1 -> Finite 20 -> TypeLitFieldDefsNumericGeneric backend
forall backend.
Finite 1 -> Finite 20 -> TypeLitFieldDefsNumericGeneric backend
TypeLitFieldDefsNumeric Finite 1
one Finite 20
twenty
            TypeLitFieldDefsNumericGeneric backend
num <- Key (TypeLitFieldDefsNumericGeneric backend)
-> ReaderT backend m (TypeLitFieldDefsNumericGeneric backend)
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key (TypeLitFieldDefsNumericGeneric backend)
numKey
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ TypeLitFieldDefsNumericGeneric backend -> Finite 1
forall backend. TypeLitFieldDefsNumericGeneric backend -> Finite 1
typeLitFieldDefsNumericOne TypeLitFieldDefsNumericGeneric backend
num Finite 1 -> Finite 1 -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Finite 1
one
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ TypeLitFieldDefsNumericGeneric backend -> Finite 20
forall backend. TypeLitFieldDefsNumericGeneric backend -> Finite 20
typeLitFieldDefsNumericTwenty TypeLitFieldDefsNumericGeneric backend
num Finite 20 -> Finite 20 -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Finite 20
twenty

            Key (TypeLitFieldDefsLabelledGeneric backend)
labelledKey <- TypeLitFieldDefsLabelledGeneric backend
-> ReaderT
     backend m (Key (TypeLitFieldDefsLabelledGeneric backend))
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (TypeLitFieldDefsLabelledGeneric backend
 -> ReaderT
      backend m (Key (TypeLitFieldDefsLabelledGeneric backend)))
-> TypeLitFieldDefsLabelledGeneric backend
-> ReaderT
     backend m (Key (TypeLitFieldDefsLabelledGeneric backend))
forall a b. (a -> b) -> a -> b
$ Labelled "one"
-> Labelled "twenty" -> TypeLitFieldDefsLabelledGeneric backend
forall backend.
Labelled "one"
-> Labelled "twenty" -> TypeLitFieldDefsLabelledGeneric backend
TypeLitFieldDefsLabelled Labelled "one"
oneLabelled Labelled "twenty"
twentyLabelled
            TypeLitFieldDefsLabelledGeneric backend
lbl <- Key (TypeLitFieldDefsLabelledGeneric backend)
-> ReaderT backend m (TypeLitFieldDefsLabelledGeneric backend)
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key (TypeLitFieldDefsLabelledGeneric backend)
labelledKey
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ TypeLitFieldDefsLabelledGeneric backend -> Labelled "one"
forall backend.
TypeLitFieldDefsLabelledGeneric backend -> Labelled "one"
typeLitFieldDefsLabelledOne TypeLitFieldDefsLabelledGeneric backend
lbl Labelled "one" -> Labelled "one" -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Labelled "one"
oneLabelled
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ TypeLitFieldDefsLabelledGeneric backend -> Labelled "twenty"
forall backend.
TypeLitFieldDefsLabelledGeneric backend -> Labelled "twenty"
typeLitFieldDefsLabelledTwenty TypeLitFieldDefsLabelledGeneric backend
lbl Labelled "twenty" -> Labelled "twenty" -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Labelled "twenty"
twentyLabelled