0

I'm trying to generalize one step of state machine computations by using sub-state machines.

Problem X is that I want some of the state machine functions to have different implementations based on some value A, that is only known at runtime.

My current (not-working) solution is this:

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}

module Lib
    ( someFunc
    ) where

import qualified Control.Monad.State as S
import           Data.Kind           (Type)
import           GHC.Generics

newtype Key = Key { unKey :: Int }


data Created
data InProcess
data Processed

data First
data Second

class SMachine t m where
  data SState t m s :: Type

  createEntity :: Key -> m (SState t m Created)
  processEntity :: SState t m Created -> m (SState t m Processed)

data EntityType = First | Second

type FakeState = S.State EntityType

instance SMachine First FakeState where
  data SState First FakeState s where
    Created1 :: { created1Key :: Key } -> SState First FakeState Created
    Processed1 :: { processed1Key :: Key } -> SState First FakeState Processed

  createEntity k = do
    S.put First
    return $ Created1 k
  processEntity Created1 {..} = do
    S.put First
    return $ Processed1 created1Key

instance SMachine Second FakeState where
  data SState Second FakeState s where
    Created2 :: { created2Key :: Key } -> SState Second FakeState Created
    Processed2 :: { processed2Key :: Key } -> SState Second FakeState Processed

  createEntity k = do
    S.put Second
    return $ Created2 k
  processEntity Created2 {..} = do
    S.put Second
    return $ Processed2 created2Key

data EntityState s where
  Created :: { createdKey :: Key } -> EntityState Created
  InProcess :: { inProcessKey :: Key } -> EntityState InProcess
  Processed :: { processedKey :: Key } -> EntityState Processed

class MetaMachine m where
  type State m :: Type -> Type

  createNewEntity :: Key -> m (State m Created)
  delegateEntity :: (SMachine t m) => State m Created -> (Key -> m (SState t m Created)) -> m (State m InProcess)
  delegateEntity2 :: (SMachine t m) => State m InProcess -> (SState t m Created -> m (SState t m Processed)) -> m (State m Processed)

instance MetaMachine FakeState where
  type State FakeState = EntityState

  createNewEntity key = return $ Created key
  delegateEntity Created {..} f = do
    -- let's imagine that we saved it somewhere
    delegatedEntity <- f createdKey
    return $ InProcess createdKey
  delegateEntity2 InProcess {..} f = do
    -- let's imagine we retrieved stored entity
    en <- S.get
    delegatedEntity <- case en of
                        First  -> return $ Created1 inProcessKey
                        Second -> return $ Created2 inProcessKey

    f delegatedEntity
    return $ Processed inProcessKey

The problem here is this part:

    delegatedEntity <- case en of
                        First  -> return $ Created1 inProcessKey
                        Second -> return $ Created2 inProcessKey

    f delegatedEntity

GHC rightfully says:

Couldn't match type ‘Second’ with ‘First’
   Expected type: S.StateT
                    EntityType
                    Data.Functor.Identity.Identity
                    (SState First FakeState Created)
     Actual type: S.StateT
                    EntityType
                    Data.Functor.Identity.Identity
                    (SState Second FakeState Created)
 • In the expression: return $ Created2 inProcessKey
   In a case alternative: Second -> return $ Created2 inProcessKey
   In a stmt of a 'do' block:
     delegatedEntity <- case en of
                          First -> return $ Created1 inProcessKey
                          Second -> return $ Created2 inProcessKey

So, the question is: Can I fix this, somehow, or maybe there is a better solution?

Any help would be appreciated.

Yarick
  • 326
  • 3
  • 14
  • 2
    Please remove as much code as possible before asking. – Micha Wiedenmann Nov 01 '21 at 13:52
  • 1
    Put the things you want to do in your `case` branches into the class. But... are you sure you actually want classes here, and not just plain types? – Daniel Wagner Nov 01 '21 at 14:17
  • @DanielWagner it's actually works. I want to avoid having explicit types everywhere, but if they will be only on sub-interpreters that's okay with me. Let me try more examples with your approach. – Yarick Nov 01 '21 at 15:07
  • @DanielWagner While your approach works, problem here is that I can add mismatched types to sub-interpreters. For example I can start things as `en' <- delegateEntity en $ createEntity @First` and then do `delegateEntity2 en' $ processEntity @Second` which is not good. Do you have any ideas how to enforce specific type for sub-interpreters actions? I can update original post with code for you approach, if that's will be easier for you. – Yarick Nov 01 '21 at 15:34
  • 1
    I can't understand your followup question. Can you boil the code example down to just the essentials, please? – Daniel Wagner Nov 01 '21 at 16:22

0 Answers0