Skip to content
This repository
Browse code

Add Conversion monad

  • Loading branch information...
commit eec01a83e31f873e0d9cd8fab34efcbdbb8ddb7d 1 parent e4eb4e6
Leon P Smith authored

Showing 1 changed file with 35 additions and 0 deletions. Show diff stats Hide diff stats

  1. +35 0 src/Database/PostgreSQL/Simple/Internal.hs
35 src/Database/PostgreSQL/Simple/Internal.hs
@@ -293,3 +293,38 @@ data Row = Row {
293 293
294 294 newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }
295 295 deriving ( Functor, Applicative, Alternative, Monad )
  296 +
  297 +newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }
  298 +
  299 +instance Functor Conversion where
  300 + fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn)
  301 +
  302 +instance Applicative Conversion where
  303 + pure a = Conversion $ \_conn -> pure (pure a)
  304 + mf <*> ma = Conversion $ \conn -> do
  305 + okf <- runConversion mf conn
  306 + case okf of
  307 + Ok f -> (fmap . fmap) f (runConversion ma conn)
  308 + Errors errs -> return (Errors errs)
  309 +
  310 +instance Alternative Conversion where
  311 + empty = Conversion $ \_conn -> pure empty
  312 + ma <|> mb = Conversion $ \conn -> do
  313 + oka <- runConversion ma conn
  314 + case oka of
  315 + Ok _ -> return oka
  316 + Errors _ -> (oka <|>) <$> runConversion mb conn
  317 +
  318 +instance Monad Conversion where
  319 + return a = Conversion $ \_conn -> return (return a)
  320 + m >>= f = Conversion $ \conn -> do
  321 + oka <- runConversion m conn
  322 + case oka of
  323 + Ok a -> runConversion (f a) conn
  324 + Errors err -> return (Errors err)
  325 +
  326 +conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
  327 +conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
  328 +
  329 +conversionError :: Exception err => err -> Conversion a
  330 +conversionError err = Conversion $ \_ -> return (Errors [SomeException err])

0 comments on commit eec01a8

Please sign in to comment.
Something went wrong with that request. Please try again.