Enforced monadic consumption.

Failed.hs

{-# LANGUAGE
    RebindableSyntax
  , GADTs
  , MultiParamTypeClasses
  , FlexibleContexts
  , FlexibleInstances
  , FunctionalDependencies
  , TypeFamilies
  , UndecidableInstances
  #-}

import Prelude hiding ((>>=))

-- a `union` b = c
class Subset a b c where

instance Subset ()      ()      ()
instance Subset a       ()      (a, ())
instance Subset ()      a       (a, ())
instance Subset ()      (b, bs) (b, bs)
instance Subset (b, bs) ()      (b, bs)

-- instance (Subset bs as cs, Subset as bs cs) => Subset (a, as) (b, bs) (a, (b, cs)) where

-------------------------------------------------------------------------------

newtype ConsumeT c m a = ConsumeT (m a)

(>>=) :: Subset as bs cs => ConsumeT bs m a -> (as -> ConsumeT cs m b) -> ConsumeT bs m b
(>>=) = undefined

(<*>) :: (Subset i k j, Subset j k i) => ConsumeT i m (a -> b) -> ConsumeT j m a -> ConsumeT k m b
(<*>) = undefined

pure :: a -> ConsumeT () m a
pure = undefined

-------------------------------------------------------------------------------

produceStr :: ConsumeT () IO String
produceStr = ConsumeT getLine

produceBool :: ConsumeT () IO Bool
produceBool = ConsumeT (return True)

produceBool2 :: String -> ConsumeT (String, ()) IO Bool
produceBool2 _ = ConsumeT (return True)

strToBool :: ConsumeT () IO (String -> Bool)
strToBool = ConsumeT (return null)

action :: String -> Bool -> ConsumeT (String, (Bool, ())) IO ()
action s b = ConsumeT (print (s, b))

-------------------------------------------------------------------------------

test :: ConsumeT () IO Bool
test =
  do x <- produceStr
     produceBool2 x


test1 :: ConsumeT () IO Bool
test1 = strToBool <*> produceStr

both a = pure id <*> a

test2 =
  do s <- produceStr
     b <- produceBool2 s
     action s b

{-
test2 =
  do s <- produceStr
     b <- produceBool
     action s b
-}

-- test3 =
--   do (x, y) <- pure (,) <*> produceStr <*> produceBool
--      action x y