Encode effect in terms of another with freer extensible effects

Question

I played with "more free monads" and extensible effects implemented in freer-effects , and I run into a problem that seems doable, but I have problems with the solution.

Ive written a type that represents simple file system interactions:

data FileSystem v where
  ReadFile :: FilePath -> FileSystem String
  WriteFile :: FilePath -> String -> FileSystem ()

Writing an interpreter for this in IOis simple but boring. That Im really interested in writing a clean interpreter that uses Stateinternally. I could effectively inject the implementation runStateinto my interpreter for FileSystem, but it seems like it spoils the target. What ID really likes is to write a conversion between the two types, then reuse the interpreter State.

Writing such a conversion is simple:

fsAsState :: forall v r. FileSystem v -> Eff (State [(FilePath, String)] ': r) v
fsAsState (ReadFile a) = (lookup a <$> get) >>=
  maybe (fail "readFile: file does not exist") return
fsAsState (WriteFile a b) = modify $ \fs ->
  (a, b) : filter ((/= a) . fst) fs

Now I need a generic function reencodethat can take my transformation fsAsStateand use it to interpret mine FileSystem, reusing the interpreter State. With such a function, I could write the following interpreter:

runInMemoryFS :: forall r w. [(FilePath, String)] -> Eff (FileSystem ': r) w -> Eff r (w, [(FilePath, String)])
runInMemoryFS fs m = runState (reencode fsAsState m) fs

reencode. Ive -, typechecks:

reencode :: forall r w f g. (forall v. f v -> Eff (g ': r) v) -> Eff (f ': r) w -> Eff (g ': r) w
reencode f m = loop m
  where
    loop :: Eff (f ': r) w -> Eff (g ': r) w
    loop (Val x) = return x
    loop (E u q) = case decomp u of
      Right x -> qComp q loop =<< f x
      Left u' -> E (weaken u') undefined

, , E loop. , , FTCQueue, , -, , , , , .

? , , , , , , .

Answer 1

: typechecks, .

q ( E u q) Eff (f ': r) Eff (g ': r). :

shiftQ :: forall m n a b. (forall a. m a -> n a) -> FTCQueue m a b -> FTCQueue n a b
shiftQ shift q = case tviewl q of
    TOne act -> tsingleton (shift . act)
    act :| q -> go (tsingleton (shift . act)) q
  where
    go :: forall a b c. FTCQueue n a b -> FTCQueue m b c -> FTCQueue n a c
    go q' q = case tviewl q of
        TOne act -> q' |> (shift . act)
        act :| q -> go (q' |> (shift . act)) q

( , snoc uncons FTCQueue s).

reencode, reencode f shift er:

reencode :: forall r w f g. (forall v. f v -> Eff (g ': r) v) -> Eff (f ': r) w -> Eff (g ': r) w
reencode f m = loop m
  where
    loop :: Eff (f ': r) w -> Eff (g ': r) w
    loop (Val x) = return x
    loop (E u q) = case decomp u of
      Right x -> qComp q loop =<< f x
      Left u' -> E (weaken u') (shiftQ (reencode f) q)