How to reinterpret a DSL term in final tagless approach?

Question

Good day everyone.

Our application uses a typed DSL to describe certain business logic. The DSL comes with several tagless interpreters.

Here's how its terms are declared:

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls #-}

class Ctl impl where
  -- Lift constants.
  cnst :: Show t => t -> impl t
  -- Obtain the state.
  state :: impl (Maybe Int)

  -- Test for equality.
  eq :: impl Int -> impl Int -> impl Bool
  -- If-then-else.
  ite :: impl Bool -> impl t -> impl t -> impl t

  -- Processing outcomes.
  retry :: impl Outcome
  finish :: impl Outcome

  -- Require a value.
  req :: impl (Maybe t) -> impl t

Business logic is then described using chunks of code in this DSL:

proc1 :: Ctl impl => impl Outcome
proc1 = ite (req state `eq` cnst 5) finish retry

These high-level definitions are put to use with interpreters. I have a text interpreter to obtain a readable textual description of how business processes are defined:

newtype TextE t = TextE { evalText :: String }

instance Ctl TextE where
  cnst v = TextE $ show v
  state = TextE "My current state"
  eq v1 v2 = TextE $ concat [evalText v1, " equals ", evalText v2]
  ite cond t e =
    TextE $
    concat ["If ", evalText cond, ", then ", evalText t, ", else ", evalText e]
  retry = TextE "Retry processing"
  finish = TextE "Finish"
  req v = TextE $ concat ["(", evalText v, ")*"]

Interpreting the DSL with TextE produces a string:

λ> (evalText proc1) :: String
"If (My current state)* equals 5, then Finish, else Retry processing"

Such description is used as a reference for users/analysts.

I can also evaluate a DSL term to the meta-language (Haskell) with another interpreter, which is how the application actually follows the rules:

newtype HaskellE t = HaskellE { evalHaskell :: HaskellType t }

-- Interface between types of DSL and Haskell.
type family HaskellType t

instance Ctl HaskellE where
  cnst v = HaskellE v
  state = HaskellE dummyState
  eq v1 v2 = HaskellE $ evalHaskell v1 == evalHaskell v2
  ite cond t e =
    HaskellE $
    if (evalHaskell cond)
    then (evalHaskell t)
    else (evalHaskell e)
  retry = HaskellE $ print "Retrying..."
  finish = HaskellE $ print "Done!"
  req term@(HaskellE v) =
    case v of
      Just v' -> HaskellE v'
      Nothing ->
        HaskellE (error $
                  "Could not obtain required value from ") -- ++ evalText term)

-- Dummy implementations so that this post may be evaluated
dummyState = Just 5
type Outcome = IO ()
type instance HaskellType t = t

This interpreter produces runnable Haskell code:

λ> (evalHaskell proc1) :: IO ()
"Done!"

Now to my problem: I'd like to use TextE interpreter from HaskellE interpreter. For instance, I want to define the failing branch of req in a way that includes text representation of the nested term (normally obtained by evalText term) in the error message. The relevant code is commented out in req implementation for HaskellE above. If the comment is reverted, the code looks like

    HaskellE (error $
              "Could not obtain required value from " ++ evalText term)

However, the type system prevents me from doing this:

tagless.lhs:90:71: Couldn't match expected type ‘TextE t0’ …
                with actual type ‘HaskellE (Maybe t)’
    Relevant bindings include
      v :: HaskellType (Maybe t)
        (bound at /home/dzhus/projects/hs-archive/tagless.lhs:85:22)
      term :: HaskellE (Maybe t)
        (bound at /home/dzhus/projects/hs-archive/tagless.lhs:85:7)
      req :: HaskellE (Maybe t) -> HaskellE t
        (bound at /home/dzhus/projects/hs-archive/tagless.lhs:85:3)
    In the first argument of ‘evalText’, namely ‘term’
    In the second argument of ‘(++)’, namely ‘evalText term’
Compilation failed.

The message basically says that the interpreter HaskellE has already been chosen when the type variable impl was instantiated, and I can't use TextE interpreter from inside HaskellE.

What I can't get my head around of is: how do I reinterpret a term from HaskellE to TextE?

If I'm entirely wrong here, how do I reshape my approach so that I can actually use the text interpreter from the Haskell one without re-implementing it inside HaskellE? Looks like it's quite feasible with initial approach instead of final.

I've stripped my actual DSL and simplified the types and interpreters for the sake of conciseness.

Answer 1

You can keep track of both the value and information about the expression that created the value. If you do so you will lose some of the performance benefits of your final tagless representation.

data Traced t a = Traced {evalTraced :: HaskellType a, trace :: t a}

We expect to use it with a TextE trace, so we'll define the following for convenience

evalTextTraced :: Traced TextE a -> HaskellType a
evalTextTraced = evalTraced

This class allows us to recover error messages from a trace

class Show1 f where
    show1 :: f a -> String

instance Show1 TextE where
    show1 = evalText

instance (Show1 t) => Show1 (Traced t) where
    show1 = show1 . trace

This interpreter keeps a trace of any other Ctl t interpreter that we can recover error messages from while interpreting a Traced t.

instance (Show1 t, Ctl t) => Ctl (Traced t) where
    cnst v = Traced v (cnst v)
    state = Traced dummyState state
    eq (Traced v1 t1) (Traced v2 t2) = Traced (v1 == v2) (eq t1 t2)
    ite (Traced vc tc) (Traced vt tt) (Traced ve te) = Traced (if vc then vt else ve) (ite tc tt te)
    retry = Traced (print "Retrying...") retry
    finish = Traced (print "Done!") finish
    req (Traced v t) = 
        case v of 
            Just v' -> Traced v' rt
            Nothing -> Traced (error ("Could not obtain required value from " ++ show1 rt)) rt
        where rt = req t

Your example behaves as expected

print . evalText . trace $ proc1
evalTextTraced proc1

"If (My current state)* equals 5, then Finish, else Retry processing"
"Done!"

We can still evalText an example with a failed requirement, but trying to run it produces an informative error message

proc2 :: Ctl impl => impl Outcome
proc2 = ite (req (cnst Nothing) `eq` cnst 5) finish retry

print . evalText . trace $ proc2
evalTextTraced proc2

"If (Nothing)* equals 5, then Finish, else Retry processing"
finaltagless.hs: Could not obtain required value from (Nothing)*