1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#!/usr/bin/env stack
{- stack
   --resolver lts-11.14
   --install-ghc
   runghc
   --
   -Wall -Werror
-}

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

{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
  
--------------------------------------------------------------------------------

module Main (main) where

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

import Control.Monad (liftM, ap)

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

newtype RIO a = RestrictedIO { rio :: IO a }

instance Functor RIO where
  fmap = liftM

instance Applicative RIO where
  pure  = return
  (<*>) = ap
  
instance Monad RIO where
  return  a = RestrictedIO $ return a
  (>>=) m f = RestrictedIO $ rio m >>= rio . f

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

class (Monad m) => SubGranulatedCmdM m where
  sout
    :: String
    -> m ()
instance SubGranulatedCmdM RIO where
  sout x =
    gout $ x ++ " [Subnulated]"
    -- or (both valid options)
    -- rout $ x ++ " [Subnulated]"

class (SubGranulatedCmdM m) => GranulatedCmdM m where
  gout
    :: String
    -> m ()
instance GranulatedCmdM RIO where
  gout x =
    rout $ x ++ " [Granulated]"

class (GranulatedCmdM m) => RestrictedCmdM m where
  rout
    :: String
    -> m ()
instance RestrictedCmdM RIO where
  rout x =
    RestrictedIO $ putStrLn $ x ++ " [Restricted]"

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

subgranulated
  :: (SubGranulatedCmdM m)
  => m ()
subgranulated =
  do
    -- We are still in the RIO monad, but now we have sub-granulated the
    -- effects, so we can only call those, but not Granulated, Restricted nor
    -- IO effects !!!
    sout "43"
    --gout     "NONONONO Cat"
    --rout     "NONONONO Cat"
    --putStrLn "NONONONO Cat"

granulated
  :: (GranulatedCmdM m)
  => m ()
granulated =
  do
    -- We are still in the RIO monad, but now we have granulated the effects, so
    -- we can only call those, but not Restricted nor IO effects !!!
    subgranulated
    gout "42"
    --rout     "NONONONO Cat"
    --putStrLn "NONONONO Cat"

restricted
  :: (RestrictedCmdM m)
  => m ()
restricted =
  do
    -- Now we are in the RIO monad, we can call Restricted and Granulated
    -- effects, but not IO !!!
    granulated
    rout "41"
    --putStrLn "NONONONO Cat"

main :: IO ()
main =
  do
    -- Here we are in the IO monad, we can do whatever we want !!!
    rio restricted
    putStrLn "40"

user@personal:~/.../subgranulate$ clear && ./Main.hs
43 [Subnulated] [Granulated] [Restricted]
42 [Granulated] [Restricted]
41 [Restricted]
40
user@personal:~/.../subgranulate$