Groundhog with record

groundhog-records.hs

{-# LANGUAGE QuasiQuotes, DeriveGeneric, OverloadedStrings, FlexibleInstances, GADTs, TypeFamilies, RankNTypes #-}

module Main where

import Record
import Control.Lens hiding ((.=))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import GHC.Generics
import Database.Groundhog
import Database.Groundhog.Core as GH
import Database.Groundhog.Generic
import Database.Groundhog.Postgresql

lelAge :: Int
lelAge = 12

person1 :: Person
person1 = Person [r|{name = "Lel", age = lelAge}|]

connString :: String
connString = "dbname=recordtests user=matt host=localhost"

main :: IO ()
main = do
    print (toJSON person1)
    withPostgresqlConn connString $ runDbConn $ do
        runMigration $ migrate (undefined :: Person)
        insert_ person1
        people <- selectAll
        liftIO $ print (map snd people :: [Person])

type PersonType = [r|{name :: String, age :: Int}|]

newtype Person = Person PersonType
    deriving Generic

person :: Lens' Person PersonType
person inj (Person n) = Person `fmap` inj n

name :: Lens' Person String
name = person.[l|name|]

instance Show Person where
    show p = "Person " ++ show (p ^. name) ++ " " ++ show (p ^. person.[l|age|])

instance ToJSON Person where
    toJSON (Person n) = object 
        [ "name" .= toJSON (n ^. [l|name|]) 
        , "age" .= toJSON (n ^. [l|age|])
        ]

data PersonConstructor v_a6dZ = 
    v_a6dZ ~ ConstructorMarker Person => PersonConstructor

instance GH.Constructor PersonConstructor where
    phantomConstrNum _ = 0

instance PersistField (Key Person BackendSpecific) where
    persistName _ = "Key" ++ [delim] ++ persistName (undefined :: Person)

    toPersistValues = primToPersistValue
    fromPersistValues = primFromPersistValue

    dbType p_a6e3 a_a6e4 = DbTypePrimitive
        (getAutoKeyType p_a6e3)
        False
        Nothing
        (Just
            (Left
                (entityDef
                    p_a6e3
                    ((undefined ::
                    forall v_a6e5 a_a6e6.
                    Key v_a6e5 a_a6e6 -> v_a6e5)
                    a_a6e4), 
                Nothing), 
            Nothing, Nothing))

instance PrimitivePersistField (Key Person BackendSpecific) where
    toPrimitivePersistValue p_a6e7 (PersonKey x_a6e8)
        = toPrimitivePersistValue p_a6e7
           $ (fromPrimitivePersistValue ::
                forall proxy_a6e9 db_a6ea. DbDescriptor db_a6ea =>
                proxy_a6e9 db_a6ea -> PersistValue -> AutoKeyType db_a6ea) p_a6e7 x_a6e8
    fromPrimitivePersistValue _ = PersonKey

instance NeverNull (Key Person BackendSpecific)

instance PurePersistField (Key Person BackendSpecific) where
    toPurePersistValues = primToPurePersistValues
    fromPurePersistValues = primFromPurePersistValues

instance SinglePersistField (Key Person BackendSpecific) where
    toSinglePersistValue = primToSinglePersistValue
    fromSinglePersistValue = primFromSinglePersistValue

instance Eq (Key Person a_a6ef) where
    (==) (PersonKey x_a6ed) (PersonKey x_a6ee) = (x_a6ed == x_a6ee)

instance Show (Key Person a_a6ef) where
    showsPrec p_a6eb (PersonKey x_a6ec) = showParen
        (p_a6eb >= (11 :: Int))
        ((showString "PersonKey ") . (showsPrec 11 x_a6ec))

instance PersistField Person where
    persistName _ = "Person"
    toPersistValues = singleToPersistValue
    fromPersistValues = singleFromPersistValue
    dbType p_a6eh = ((dbType p_a6eh)
        . (undefined ::
            forall a_a6ei.
            a_a6ei -> DefaultKey a_a6ei))

instance SinglePersistField Person where
    toSinglePersistValue = toSinglePersistValueAutoKey
    fromSinglePersistValue = fromSinglePersistValueAutoKey

instance PersistEntity Person where
    type AutoKey Person = Key Person BackendSpecific
    type DefaultKey Person = Key Person BackendSpecific
    type IsSumType Person = HFalse

    data Key Person u_a6ej = u_a6ej ~ BackendSpecific => PersonKey PersistValue 

    data Field Person c_a6ek f_a6el = 
        (c_a6ek ~ PersonConstructor, f_a6el ~ String) => NameField |
        (c_a6ek ~ PersonConstructor, f_a6el ~ Int) => AgeField

    entityDef p_a6en _ = EntityDef
        "Person"
        Nothing
        []
        [ConstructorDef
            "Person"
            (Just "id")
            [("name", 
                dbType p_a6en (undefined :: String)),
            ("age", dbType p_a6en (undefined :: Int))]
            []]

    toEntityPersistValues (Person na) = (phantomDb
        >>=
            (\ p_a6es
            -> (return
                $ ([toPrimitivePersistValue
                        p_a6es (0 :: Int),
                    toPrimitivePersistValue p_a6es (na ^. [l|name|]),
                    toPrimitivePersistValue p_a6es (na ^. [l|age|])]
                    ++))))

    fromEntityPersistValues xs_a6eG@((PersistInt64 0) : xs_a6eI) = phantomDb >>=
                (\p_a6eJ -> case xs_a6eI of
                        (x_a6eK : (x_a6eL : xs_a6eM)) ->
                            let pname = fromPrimitivePersistValue p_a6eJ x_a6eK
                                page = fromPrimitivePersistValue p_a6eJ x_a6eL
                            in
                            return
                                (Person [r|{name = pname, age = page}|],
                                    -- (fromPrimitivePersistValue p_a6eJ x_a6eK)
                                    -- (fromPrimitivePersistValue p_a6eJ x_a6eL), 
                                xs_a6eM)
                        _ -> failure_a6eH)
      where
        failure_a6eH
            = (\ a_a6eZ
                -> (phantomDb
                    >>=
                    (\ proxy_a6f0
                        -> ((fail
                                (failMessageNamed
                                    (entityName
                                    $ (entityDef proxy_a6f0 a_a6eZ))
                                    xs_a6eG))
                            >> (return (a_a6eZ, []))))))
                undefined
    fromEntityPersistValues xs_a6eG = failure_a6eH
      where
        failure_a6eH
            = (\ a_a6eZ
                -> (phantomDb
                    >>=
                    (\ proxy_a6f0
                        -> ((fail
                                (failMessageNamed (entityName $ entityDef proxy_a6f0 a_a6eZ) xs_a6eG))
                            >> (return (a_a6eZ, []))))))
                undefined
    getUniques _ (Person _) = (0, [])
    entityFieldChain p_a6f2 f_a6f1@NameField = (("name", 
        dbType
            p_a6f2
            ((undefined :: forall v_a6f3 c_a6f4 a_a6f5. Field v_a6f3 c_a6f4 a_a6f5 -> a_a6f5) f_a6f1)), 
        [])
    entityFieldChain p_a6f7 f_a6f6@AgeField = (("age", 
        dbType
            p_a6f7
            ((undefined ::
                forall v_a6f8 c_a6f9 a_a6fa.
                Field v_a6f8 c_a6f9 a_a6fa -> a_a6fa) f_a6f6)), 
        [])

instance NeverNull Person