opaleye-trans 0.1.1 → 0.2.0

raw patch · 4 files changed

+469/−32 lines, 4 filesdep +opaleye-transdep −monad-controlnew-component:exe:opaleye-rosetreenew-component:exe:opaleye-rosetree2PVP ok

version bump matches the API change (PVP)

Dependencies added: opaleye-trans

Dependencies removed: monad-control

API changes (from Hackage documentation)

Files

• examples/v1/RoseTree.hs +181/−0
• examples/v2/RoseTree.hs +231/−0
• opaleye-trans.cabal +24/−3
• src/Opaleye/Trans.hs +33/−29

@@ -0,0 +1,181 @@+{-# LANGUAGE Arrows                #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}++module Main where++import           Control.Arrow++import           Data.Profunctor.Product.TH (makeAdaptorAndInstance)++import qualified Database.PostgreSQL.Simple as PSQL++import           Opaleye+import           Opaleye.Trans+++data Rose a = Node a [Rose a]+    deriving (Show, Eq)+++instance Functor Rose where+    fmap f (Node x rs) = Node (f x) (map (fmap f) rs)+++data NodeP i b n a = NodeP+    { nodeId       :: i+    , nodeBranchId :: b+    , nextBranchId :: n+    , value        :: a+    } deriving (Show, Eq)+++type WriteNode a = NodeP (Maybe (Column PGInt4)) (Column PGInt4) (Column PGInt4) (Column a)+type ReadNode a = NodeP (Column PGInt4) (Column PGInt4) (Column PGInt4) (Column a)+++data BranchP i = BranchP+    { branchId :: i+    } deriving (Show, Eq)+++type WriteBranch = BranchP (Maybe (Column PGInt4))+type ReadBranch = BranchP (Column PGInt4)+++data TreeP i r = TreeP+    { treeId :: i+    , rootId :: r+    } deriving (Show, Eq)+++type WriteTree = TreeP (Maybe (Column PGInt4)) (Column PGInt4)+type ReadTree = TreeP (Column PGInt4) (Column PGInt4)+++makeAdaptorAndInstance "pNode" ''NodeP+makeAdaptorAndInstance "pBranch" ''BranchP+makeAdaptorAndInstance "pTree" ''TreeP+++nodeTable :: Table (WriteNode a) (ReadNode a)+nodeTable = Table "node" $ pNode NodeP+    { nodeId = optional "id"+    , nodeBranchId = required "branch_id"+    , nextBranchId = required "next_branch_id"+    , value = required "value"+    }+++branchTable :: Table WriteBranch ReadBranch+branchTable = Table "branch" $ pBranch (BranchP (optional "id"))+++treeTable :: Table WriteTree ReadTree+treeTable = Table "rosetree" $ pTree TreeP+    { treeId = optional "id"+    , rootId = required "root_id"+    }+++newTree :: Int -> Transaction (Maybe Int)+newTree rootId = insertReturningFirst treeTable treeId (TreeP Nothing (pgInt4 rootId))+++newBranch :: Transaction (Maybe Int)+newBranch = insertReturningFirst branchTable branchId (BranchP Nothing)+++insertNode :: Int -> Int -> Int -> Transaction (Maybe Int)+insertNode bid nbid x =+    insertReturningFirst nodeTable nodeId+        (NodeP Nothing (pgInt4 bid) (pgInt4 nbid) (pgInt4 x))+++insertTree :: MonadBase IO m => Rose Int -> OpaleyeT m Int+insertTree (Node x xs) = transaction $ do+    Just bid <- newBranch+    Just rootId <- insertNode 0 bid x+    Just treeId <- newTree rootId++    mapM_ (insertTree' bid) xs++    return treeId+++insertTree' :: Int -> Rose Int -> Transaction ()+insertTree' bid (Node x xs) = do+    Just nbid <- newBranch+    insertNode bid nbid x+    mapM_ (insertTree' nbid) xs+++selectTree :: Int -> Transaction (Rose Int)+selectTree treeId = do+    Just rootId <- selectRootNode treeId+    Just (NodeP _ _ nbid x) <- selectNode rootId+    xs <- selectBranch nbid+    return (Node x xs)+++selectRootNode :: Int -> Transaction (Maybe Int)+selectRootNode tid = queryFirst rootNode+  where+    rootNode :: Query (Column PGInt4)+    rootNode = proc () -> do+        tree <- queryTable treeTable -< ()+        restrict -< treeId tree .== pgInt4 tid+        returnA -< rootId tree+++selectNode :: Int -> Transaction (Maybe (NodeP Int Int Int Int))+selectNode nid = queryFirst nodeById+  where+    nodeById :: Query (ReadNode PGInt4)+    nodeById = proc () -> do+        node <- queryTable nodeTable -< ()+        restrict -< nodeId node .== pgInt4 nid+        returnA -< node+++selectBranch :: Int -> Transaction [Rose Int]+selectBranch bid = do+    nodes <- query nodeByBranchId+    sequence (mkNode <$> nodes)+  where+    nodeByBranchId :: Query (ReadNode PGInt4)+    nodeByBranchId = proc () -> do+        row@(NodeP _ bid' _ _) <- queryTable nodeTable -< ()+        restrict -< bid' .== pgInt4 bid+        returnA -< row++    mkNode :: NodeP Int Int Int Int -> Transaction (Rose Int)+    mkNode (NodeP _ _ nbid x) = do+        xs <- selectBranch nbid+        return (Node x xs)+++main :: IO ()+main = do+    conn <- PSQL.connectPostgreSQL "dbname='rosetree' user='postgres'"++    let tree :: Rose Int+        tree =+            Node 6+                [ Node 7+                    [ Node 1425+                        [ Node 42 []+                        , Node 2354 []+                        , Node 4245 []]]+                , Node 10 []+                , Node 6+                    [ Node 12 []+                    , Node 14 []]]++    tree' <- runOpaleyeT conn $ run . selectTree =<< insertTree tree++    print (tree, tree')+    print (tree == tree')

@@ -0,0 +1,231 @@+{-# LANGUAGE Arrows                #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}++module Main where++import           Control.Arrow+import           Control.Monad              (void)++import           Data.Profunctor.Product.TH (makeAdaptorAndInstance)++import qualified Database.PostgreSQL.Simple as PSQL++import           Opaleye+import           Opaleye.Trans+++data Rose a+    = Node a [Rose a]+    | Leaf a+    deriving (Show, Eq)+++instance Functor Rose where+    fmap f (Node x rs) = Node (f x) (map (fmap f) rs)+    fmap f (Leaf x) = Leaf (f x)+++data NodeP i b a = NodeP+    { nodeId       :: i+    , nodeBranchId :: b+    , value        :: a+    } deriving (Show, Eq)+++data NodeBranchP i n = NodeBranchP+    { nodeIdRef    :: i+    , nextBranchId :: n+    } deriving (Show, Eq)+++type WriteNode a = NodeP (Maybe (Column PGInt4)) (Column PGInt4) (Column a)+type ReadNode a = NodeP (Column PGInt4) (Column PGInt4) (Column a)+type NodeBranch = NodeBranchP (Column PGInt4) (Column PGInt4)+type NullableNodeBranch = NodeBranchP (Column (Nullable PGInt4)) (Column (Nullable PGInt4))+++data BranchP i = BranchP+    { branchId :: i+    } deriving (Show, Eq)+++type WriteBranch = BranchP (Maybe (Column PGInt4))+type ReadBranch = BranchP (Column PGInt4)+++data TreeP i r = TreeP+    { treeId :: i+    , rootId :: r+    } deriving (Show, Eq)+++type WriteTree = TreeP (Maybe (Column PGInt4)) (Column PGInt4)+type ReadTree = TreeP (Column PGInt4) (Column PGInt4)+++makeAdaptorAndInstance "pNode" ''NodeP+makeAdaptorAndInstance "pNodeBranch" ''NodeBranchP+makeAdaptorAndInstance "pBranch" ''BranchP+makeAdaptorAndInstance "pTree" ''TreeP+++nodeTable :: Table (WriteNode a) (ReadNode a)+nodeTable = Table "node" $ pNode NodeP+    { nodeId = optional "id"+    , nodeBranchId = required "branch_id"+    , value = required "value"+    }+++nodeBranchTable :: Table NodeBranch NodeBranch+nodeBranchTable = Table "node_branch" $ pNodeBranch NodeBranchP+    { nodeIdRef = required "id"+    , nextBranchId = required "next_branch_id"+    }+++branchTable :: Table WriteBranch ReadBranch+branchTable = Table "branch" $ pBranch (BranchP (optional "id"))+++treeTable :: Table WriteTree ReadTree+treeTable = Table "rosetree" $ pTree TreeP+    { treeId = optional "id"+    , rootId = required "root_id"+    }+++newTree :: Int -> Transaction (Maybe Int)+newTree rootId =+    insertReturningFirst treeTable treeId (TreeP Nothing (pgInt4 rootId))+++newBranch :: Transaction (Maybe Int)+newBranch = insertReturningFirst branchTable branchId (BranchP Nothing)+++insertNode :: Int -> Maybe Int -> Int -> Transaction (Maybe Int)+insertNode bid (Just nbid) x = do+    Just nodeId <- insertReturningFirst nodeTable nodeId+        (NodeP Nothing (pgInt4 bid) (pgInt4 x))+    insert nodeBranchTable (NodeBranchP (pgInt4 nodeId) (pgInt4 nbid))+    return (Just nodeId)+insertNode bid Nothing x =+    insertReturningFirst nodeTable nodeId+        (NodeP Nothing (pgInt4 bid) (pgInt4 x))+++insertTree :: MonadBase IO m => Rose Int -> OpaleyeT m Int+insertTree (Node x xs) = transaction $ do+    Just bid <- newBranch+    Just rootId <- insertNode 0 (Just bid) x+    Just treeId <- newTree rootId++    mapM_ (insertTree' bid) xs++    return treeId+insertTree (Leaf x) = transaction $ do+    Just rootId <- insertNode 0 Nothing x+    Just treeId <- newTree rootId+    return treeId+++insertTree' :: Int -> Rose Int -> Transaction ()+insertTree' bid (Node x xs) = do+    Just nbid <- newBranch+    insertNode bid (Just nbid) x+    mapM_ (insertTree' nbid) xs+insertTree' bid (Leaf x) =+    void (insertNode bid Nothing x)+++-- TODO Wrong order+selectTree :: Int -> Transaction (Rose Int)+selectTree treeId = do+    Just rootId <- selectRootNode treeId+    Just (NodeP _ _ x, NodeBranchP _ mbid) <- selectNode rootId+    case mbid of+        Just nbid -> do+            xs <- selectBranch nbid+            return (Node x xs)+        Nothing -> return (Leaf x)+++selectRootNode :: Int -> Transaction (Maybe Int)+selectRootNode tid = queryFirst rootNode+  where+    rootNode :: Query (Column PGInt4)+    rootNode = proc () -> do+        tree <- queryTable treeTable -< ()+        restrict -< treeId tree .== pgInt4 tid+        returnA -< rootId tree+++nodeAndBranch :: Query (ReadNode PGInt4, NullableNodeBranch)+nodeAndBranch = leftJoin allNodes allNodeBranches (uncurry idsEqual)+  where+    allNodes = queryTable nodeTable+    allNodeBranches = queryTable nodeBranchTable++    idsEqual :: ReadNode PGInt4 -> NodeBranch -> Column PGBool+    idsEqual (NodeP nid' _ _) (NodeBranchP nbid _) = nid' .== nbid+++byId :: Query a -> (a -> Column PGInt4) -> Int -> Query a+byId q getId id' = proc () -> do+    row <- q -< ()+    restrict -< getId row .== pgInt4 id'+    returnA -< row+++selectNode :: Int -> Transaction (Maybe (NodeP Int Int Int, NodeBranchP (Maybe Int) (Maybe Int)))+selectNode nid = queryFirst nodeById+  where+    nodeById :: Query (ReadNode PGInt4, NullableNodeBranch)+    nodeById = byId nodeAndBranch (nodeId . fst) nid+++selectBranch :: Int -> Transaction [Rose Int]+selectBranch bid = do+    nodes <- query nodeByBranchId+    sequence (mkNode <$> nodes)+  where+    nodeByBranchId :: Query (ReadNode PGInt4, NullableNodeBranch)+    nodeByBranchId = byId nodeAndBranch (nodeBranchId . fst) bid+    +    mkNode +        :: (NodeP Int Int Int, NodeBranchP (Maybe Int) (Maybe Int)) +        -> Transaction (Rose Int)+    mkNode (NodeP _ _ x, NodeBranchP Nothing Nothing) = return (Leaf x)+    mkNode (NodeP _ _ x, NodeBranchP _ (Just nbid)) = do+        xs <- selectBranch nbid+        return (Node x xs)+    mkNode x = error $ "Bad branch select. Who knows?: " ++ show x+++main :: IO ()+main = do+    conn <- PSQL.connectPostgreSQL "dbname='rosetree' user='postgres'"++    let tree :: Rose Int+        tree =+            Node 6+                [ Node 7+                    [ Node 1425+                        [ Leaf 42+                        , Leaf 2354+                        , Leaf 4245]]+                , Leaf 10+                , Node 6+                    [ Leaf 12+                    , Leaf 14]]++    tree' <- runOpaleyeT conn $ run . selectTree =<< insertTree tree++    print tree+    print tree'+    print (tree == tree')

@@ -1,5 +1,5 @@ name:                opaleye-trans-version:             0.1.1+version:             0.2.0 synopsis:            A monad transformer for Opaleye description:         A monad transformer for Opaleye homepage:            https://github.com/tomjaguarpaw/haskell-opaleye@@ -17,15 +17,36 @@   location: https://github.com/WraithM/opaleye-trans  library+  hs-source-dirs:      src   exposed-modules:     Opaleye.Trans   -- other-modules:+  default-language:    Haskell2010   build-depends:     base                >=4.8 && <4.9,     mtl                 >=2.2 && <2.3,     transformers-base   >=0.4 && <0.5,-    monad-control       >=1.0 && <1.1,     opaleye             >=0.4 && <0.5,     postgresql-simple   >=0.4 && <0.5,     product-profunctors >=0.6 && <0.7-  hs-source-dirs:      src++executable opaleye-rosetree+  hs-source-dirs:      examples/v1+  main-is:             RoseTree.hs   default-language:    Haskell2010+  build-depends:+    base                >=4.8 && <4.9,+    opaleye             >=0.4 && <0.5,+    postgresql-simple   >=0.4 && <0.5,+    product-profunctors >=0.6 && <0.7,+    opaleye-trans++executable opaleye-rosetree2+  hs-source-dirs:      examples/v2+  main-is:             RoseTree.hs+  default-language:    Haskell2010+  build-depends:+    base                >=4.8 && <4.9,+    opaleye             >=0.4 && <0.5,+    postgresql-simple   >=0.4 && <0.5,+    product-profunctors >=0.6 && <0.7,+    opaleye-trans

@@ -10,7 +10,9 @@     , runOpaleyeT      , -- * Transactions-      transaction+      Transaction+    , transaction+    , run      , -- * Queries       query@@ -25,13 +27,11 @@      , -- * Utilities       withConn-    , withConnIO      , -- * Reexports       liftBase     , MonadBase     , ask-    , MonadBaseControl     , Int64     ) where @@ -39,7 +39,6 @@ import           Control.Monad.Reader            (MonadReader, ReaderT (..),                                                   ask) import           Control.Monad.Trans             (MonadTrans (..))-import           Control.Monad.Trans.Control  import           Data.Maybe                      (listToMaybe) import           Data.Profunctor.Product.Default (Default)@@ -66,76 +65,81 @@ runOpaleyeT c = flip runReaderT c . unOpaleyeT -- TODO Handle exceptions --- | With a 'Connection'-withConn :: Monad m => (Connection -> m a) -> OpaleyeT m a++withConn :: MonadBase IO m => (Connection -> IO a) -> OpaleyeT m a withConn f = do     conn <- ask-    lift (f conn)+    liftBase (f conn)  --- | With a 'Connection'-withConnIO :: MonadBase IO m => (Connection -> IO a) -> OpaleyeT m a-withConnIO f = do-    conn <- ask-    liftBase $ f conn+newtype Transaction a = Transaction { unTransaction :: ReaderT Connection IO a }+    deriving (Functor, Applicative, Monad, MonadReader Connection)  --- | 'withTransaction' lifted into a 'MonadBaseControl' 'IO' monad-liftWithTransaction :: MonadBaseControl IO m => Connection -> m a -> m a-liftWithTransaction conn f =-    control $ \io -> withTransaction conn (io f)+-- | Run a postgresql transaction in the 'OpaleyeT' monad+transaction :: MonadBase IO m => Transaction a -> OpaleyeT m a+transaction (Transaction t) = withConn $ \conn -> +    withTransaction conn (runReaderT t conn)  --- | Run a postgresql transaction in the 'OpaleyeT' monad-transaction :: MonadBaseControl IO m => OpaleyeT m a -> OpaleyeT m a-transaction t = withConn $ \conn ->-    liftWithTransaction conn (runOpaleyeT conn t)+-- | Execute a query without a literal transaction+run :: MonadBase IO m => Transaction a -> OpaleyeT m a+run (Transaction t) = withConn $ runReaderT t  +-- | With a 'Connection' in a 'Transaction'+-- This isn't exposed so that users can't just drop down to IO+-- in a transaction+withConnIO :: (Connection -> IO a) -> Transaction a+withConnIO f = Transaction (ReaderT f)++ -- | Execute a 'Query'. See 'runQuery'.-query :: (MonadBase IO m, Default QueryRunner a b) => Query a -> OpaleyeT m [b]+query :: Default QueryRunner a b => Query a -> Transaction [b] query q = withConnIO (`runQuery` q)   -- | Retrieve the first result from a 'Query'. Similar to @listToMaybe <$> runQuery@.-queryFirst :: (MonadBase IO m, Default QueryRunner a b) => Query a -> OpaleyeT m (Maybe b)+queryFirst :: Default QueryRunner a b => Query a -> Transaction (Maybe b) queryFirst q = listToMaybe <$> query q   -- | Insert into a 'Table'. See 'runInsert'.-insert :: MonadBase IO m => Table w r -> w -> OpaleyeT m Int64+insert :: Table w r -> w -> Transaction Int64 insert t w = withConnIO (\c -> runInsert c t w)   -- | Insert many records into a 'Table'. See 'runInsertMany'.-insertMany :: MonadBase IO m => Table w r -> [w] -> OpaleyeT m Int64+insertMany :: Table w r -> [w] -> Transaction Int64 insertMany t ws = withConnIO (\c -> runInsertMany c t ws)   -- | Insert a record into a 'Table' with a return value. See 'runInsertReturning'. insertReturning-    :: (MonadBase IO m, Default QueryRunner a b)+    :: Default QueryRunner a b     => Table w r     -> (r -> a)     -> w-    -> OpaleyeT m [b]+    -> Transaction [b] insertReturning t ret w = withConnIO (\c -> runInsertReturning c t w ret)   -- | Insert a record into a 'Table' with a return value. Retrieve only the first result. -- Similar to @listToMaybe <$> insertReturning@ insertReturningFirst-    :: (MonadBase IO m, Default QueryRunner a b)+    :: Default QueryRunner a b     => Table w r     -> (r -> a)     -> w-    -> OpaleyeT m (Maybe b)+    -> Transaction (Maybe b) insertReturningFirst t ret w = listToMaybe <$> insertReturning t ret w   -- | Insert many records into a 'Table' with a return value for each record.+--+-- Maybe not worth defining. This almost certainly does the wrong thing. insertManyReturning-    :: (MonadBaseControl IO m, Default QueryRunner a b)+    :: (MonadBase IO m, Default QueryRunner a b)     => Table w r     -> (r -> a)     -> [w]