Indexed StateMonad Experiment

gistfile1.hs

{-# LANGUAGE OverloadedStrings , NoImplicitPrelude #-}

module StateMachine where
import Control.Monad.Indexed
import CorePrelude

{- | This is my short example of creating an indexed state Monad 

Indexed State Monad are different from the standard state Monad because the type of the
state is transformable.  This is awesome and really nice for creating statemachines that
prohibit invalid transitions at the type level.  

This is someone who actually understands this stuff, I just use it. 
http://blog.sigfpe.com/2009/02/beyond-monads.html



|-}


-- | our Data Types 
-- | I am going to be making a simple state machine first with no IO then I will re-do it to use IO 

-- | The states in question are Those that might be in an alarm, this is something I have to do a
-- in production code so I figure it might be something that comes up for others 


-- | Valid transitions are that the system has to call out between Trip and Clear.

-- | Real alarm systems have side effects and are terrible... but haskell is nice for sorting through it all

data Trip = Trip
 deriving (Show)

data Clear = Clear
 deriving (Show)

data Calling = Calling
 deriving (Show)



-- | Straight from the link above, here are the states applied to the IxMonad Class

newtype IxState s1 s2 a = IxState { runIxState :: s1 -> (a, s2) }

instance IxFunctor (IxState) where 
  imap f ixSt = IxState (\st -> let (a,st') = (runIxState ixSt st)
                                in (f a, st'))
                                              
instance IxPointed IxState where 
    ireturn a = IxState (\st -> (a, st))

instance IxApplicative IxState where 
    iap ixStFcn ixSt = IxState (\st1 -> let (fAB,st2) = (runIxState ixStFcn st1)
                                            (a,st3)   = runIxState ixSt st2
                                        in  (fAB a,st3))

instance IxMonad IxState where 
    ibind atoIxStFcn ixStA = IxState (\st1 -> let (a,st2) = runIxState ixStA st1
                                              in  runIxState (atoIxStFcn a) st2)


testIx1 :: IxState Clear Trip (Text)
testIx1 = IxState (\(Clear) -> (toTripAction, Trip))

testIx2 :: IxState Trip Calling (Text)
testIx2 = IxState (\(Trip) -> (toCallAction, Calling))

testIx3 :: IxState Calling Clear (Text)
testIx3 = IxState (\(Calling) -> (toClearAction, Clear))


transforms :: IxState Clear Calling Text
transforms = testIx1 >>>= (\_ -> testIx2 )


toTripAction :: Text 
toTripAction = "alarm tripping"

toClearAction :: Text
toClearAction = "alarmClearing"  

toCallAction :: Text
toCallAction ="Calling User  "


-- | State machine with IO 

{-|

It is a neat process to re-factor this Monad into one with IO embedded

|-}


data IxStateM m s1 s2 a = IxStateM { 
     runIxStateM :: s1 -> m (a,s2) 
    }

instance (Monad m) => IxFunctor (IxStateM m) where 
  imap f ixSt = IxStateM {
                 runIxStateM  = (\ st -> do
                                     (b,st') <- runIxStateM ixSt st
                                     return (f b, st')) }
                                              
instance (Monad m ) => IxPointed (IxStateM m) where 
    ireturn a = IxStateM {
                 runIxStateM = (\st -> return (a, st) )                    
                }


instance (Monad m) => IxApplicative (IxStateM m) where 
    iap ixStFcn ixSt = IxStateM {
                         runIxStateM = (\st1 -> do
                                          (fAB,st2) <- runIxStateM ixStFcn st1
                                          (a,st3)   <- runIxStateM ixSt st2
                                          return (fAB a,st3))
                       }



instance (Monad m ) => IxMonad (IxStateM m) where 
    ibind atoIxStFcn ixStA = IxStateM {
                               runIxStateM = (\st1 -> do
                                                (a,st2) <- runIxStateM ixStA st1
                                                runIxStateM (atoIxStFcn a) st2)
                             }



{-| 

    Some IO to run, notice that each one of them has an initial and a final state
    How cool is this! 

    ==================================================
|-}


someStaticState :: (Show s) => s ->  Int -> IO String
someStaticState s i = print s >> print i >>  return "Test IO"

exClear :: Int -> IxStateM IO Clear Calling String
exClear init = IxStateM (\Clear -> do                        
                        a <- someStaticState Clear init
                        return $ (a,Calling))

exTripCalling :: Int -> IxStateM IO Calling Trip String
exTripCalling init = IxStateM (\Calling -> do                        
                        a <- someStaticState Calling init
                        return $ (a,Trip))

exTrip :: Int -> IxStateM IO Trip Calling String
exTrip init = IxStateM (\Trip -> do                        
                        a <- someStaticState Trip init
                        return $ (a,Calling))


exClearCalling :: Int -> IxStateM IO Calling Clear String
exClearCalling init = IxStateM (\Calling -> do                        
                        a <- someStaticState Calling init
                        return $ (a,Clear))




{-|
@
sampleInvaldiCycle = (exClear 1)  
                     >>>= (\str  -> exTripCalling 2) 
                     >>>= (\str -> exClearCalling 4 )


--> Couldn't match type `Calling' with `Trip'
--> Expected type: IxStateM IO Trip Clear String
--> Actual type: IxStateM IO Calling Clear String
--> In the return type of a call of `exClearCalling'
--> In the expression: exClearCalling 4
--> In the second argument of `(>>>=)', namely
-->   `(\ str -> exClearCalling 4)'

@
|-}

{-|
@

sampleCycle = (exClear 1)  
              >>>= (\str  -> exTripCalling 2) 
              >>>= (\str  -> exTrip 3)
              >>>= (\str -> exClearCalling 4 )



-- > runIxStateM sampleCycle Clear
-- > Clear
-- > Calling
-- > Trip
-- > Calling
-- > ("Test IO",Clear)

@

|-}



sampleCycle :: IxStateM IO Clear Clear String
sampleCycle = (exClear 1)  
              >>>= (\_  -> exTripCalling 2) 
              >>>= (\_  -> exTrip 3)
              >>>= (\_  -> exClearCalling 4 )


exIxStateM :: IO (String, Clear)
exIxStateM = runIxStateM sampleCycle Clear