module Data.Basic.Example (module Data.Basic.Example) where
import Internal.Interlude hiding (filter)
import Data.Basic
import Language.Haskell.TH hiding (location)
import Unsafe.Coerce
data User = User { _userId :: !Key
, _userName :: !Text
, _userLocation :: Point } deriving (Eq, Read, Show)
makeLenses ''User
instance Table User where
type TableName User = "blog_user"
type TableFields User = ["id", "name", "location"]
type TableConstraints User = '[ 'Unique "blog_user_pkey"]
type TablePrimaryKey User = 'Just "blog_user_pkey"
type TableRequiredFields User = ['Required "id", 'Required "name"]
newEntity = Entity (User (unsafeCoerce ()) (unsafeCoerce ()) (Point 0 0))
instance UniqueConstraint "blog_user_pkey" where
type UniqueTable "blog_user_pkey" = User
type UniqueFields "blog_user_pkey" = '["id"]
instance PrimaryKeyConstraint "blog_user_pkey"
instance TableField User "id" where
type TableFieldType User "id" = Key
tableFieldLens = userId
instance TableField User "name" where
type TableFieldType User "name" = Text
tableFieldLens = userName
instance TableField User "location" where
type TableFieldType User "location" = Point
tableFieldLens = userLocation
instance FromRow User where
fromRow = User <$> field <*> field <*> field
data Post = Post { _postId :: Key
, _postName :: Text
, _postUserId :: Key } deriving (Eq, Ord, Read, Show)
makeLenses ''Post
instance Table Post where
type TableName Post = "blog_post"
type TableFields Post = ["id", "name", "author"]
type TableConstraints Post = '[ 'ForeignKey "blog_post_author_fkey"]
type TablePrimaryKey Post = 'Just "blog_post_pkey"
type TableRequiredFields Post = ['Required "id", 'Required "name", 'Required "author"]
newEntity = Entity (Post (unsafeCoerce ()) (unsafeCoerce ()) (unsafeCoerce ()))
instance UniqueConstraint "blog_post_pkey" where
type UniqueTable "blog_post_pkey" = Post
type UniqueFields "blog_post_pkey" = '["id"]
instance PrimaryKeyConstraint "blog_post_pkey"
instance FromRow Post where
fromRow = Post <$> field <*> field <*> field
instance TableField Post "id" where
type TableFieldType Post "id" = Key
tableFieldLens = postId
instance TableField Post "name" where
type TableFieldType Post "name" = Text
tableFieldLens = postName
instance TableField Post "author" where
type TableFieldType Post "author" = Key
tableFieldLens = postUserId
instance ForeignKeyConstraint "blog_post_author_fkey" where
type ForeignKeyFrom "blog_post_author_fkey" = Post
type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]
type ForeignKeyTo "blog_post_author_fkey" = User
type ForeignKeyToFields "blog_post_author_fkey" = '["id"]
allUsers :: AllRows User res => res
allUsers = allRows @"blog_user"
allPosts :: AllRows Post res => res
allPosts = allRows @"blog_post"
newUser :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "location"]) User
newUser = Entity (User 0 "" (Point 0 0))
newPost :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "author"]) Post
newPost = Entity (Post 0 "" 1)
posts :: VirtualTable "blog_post_author_fkey" res
=> Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res
posts = virtualTableLens @"blog_post_author_fkey"
id :: FieldOpticProxy (Proxy "id" -> o) => o
id = fieldOptic @"id"
name :: FieldOpticProxy (Proxy "name" -> o) => o
name = fieldOptic @"name"
location :: FieldOpticProxy (Proxy "location" -> o) => o
location = fieldOptic @"location"
authorId :: FieldOpticProxy (Proxy "author" -> o) => o
authorId = fieldOptic @"author"
author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o
author = foreignKeyLens @"blog_post_author_fkey"
test1 :: (MonadIO m, MonadEffect Basic m) => m ()
test1 = do
void $ ddelete allPosts
void $ ddelete allUsers
let user = newUser & name .~ "Luka"
& id .~ 1
& location .~ Point 5 6
user' <- insert user
let post = newPost & id .~ 1
& name .~ "New post"
& author .~ user'
post' <- insert post
void $ dfilter (\u -> (u ^. id) `delem` [1, 3, 4]) allUsers
void $ dfilter (\u -> u ^. id <. (2 :: Key)) allUsers
auth <- post' ^. author
putText (toS $ encode auth)
void $ save (auth & name .~ "Luka H")
let user2 = newUser & name .~ "Ivan"
& id .~ 2
& location .~ Point 6 7
void $ insert user2
us <- dtake 1 $ dsortOn (\u -> Down (u ^. id)) allUsers
putText (toS $ encode us)
void $ dupdate (\u' -> u' & location .~ Point 7 8) allUsers
usersPosts <- allUsers `djoin` allPosts
putText (toS $ encode usersPosts)
users <- dfilter (\u -> (u ^. name) `ilike` "%uka%") allUsers
putText (toS $ encode users)
void $ ddelete allPosts
void $ ddelete allUsers
void $ insert $
newUser
& name .~ "A"
& id .~ 1
& location .~ Point 0 0
void $ insert $
newUser
& name .~ "A"
& id .~ 2
& location .~ Point 0 0
void $ insert $
newUser
& name .~ "B"
& id .~ 3
& location .~ Point 0 0
void $ insert $
newUser
& name .~ "B"
& id .~ 4
& location .~ Point 0 0
print =<< dfoldMap (\u -> (Min (u ^. id), Max (u ^. id))) allUsers
putText . toS . encode =<< dmap fst (allUsers `djoin` allUsers)
print =<< dmap (^. location) (dsortOn (view name) allUsers)
allUsers
& dgroupOn (view name)
& dmap (\(_, g) ->
(dfoldMap ((,) <$> Min . view id <*> Max . view id) g)
)
& (>>= print)
allUsers
& dgroupOn (view name)
& dfoldMapInner ((,) <$> Min . view id <*> Max . view id)
& (>>= print)
print $ (newUser & name .~ "abc" & id .~ 1) > (newUser & name .~ "abd" & id .~ 0)
print $ (newUser & location .~ Point 0 0) == (newUser & location .~ Point 0 1)
void $ ddelete allPosts
void $ ddelete allUsers
l <- insert $ newUser
& name .~ "Luka"
& id .~ 0
& location .~ Point 0 0
void $ insert $
newPost
& id .~ 10
& name .~ "Post 1\"\\"
& author .~ l
void $ insert $
newPost
& id .~ 11
& name .~ ""
& author .~ l
pairs' <- allUsers `djoin` allPosts
& dfilter (\(u, p) -> u ^. id ==. p ^. authorId)
& dgroupOn fst
& dfoldMapInner (List . snd)
print pairs'
test :: IO ()
test = do
conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"
test1
& handleBasicPsqlWithLogging conn
& prettyPrintSummary 1000
& throwBasicToIO
putQ :: Show a => Q a -> IO ()
putQ xQ = do x <- runQ xQ
print x
putQLn :: Show a => Q a -> IO ()
putQLn xQ = do putQ xQ
putText ""