Typed expression parser

Question

I'm trying to create a typed expression parser in Haskell, which works great so far, but I'm currently struggling to implement higher order functions. I've boiled the problem down to a simple example:

{-# LANGUAGE TypeFamilies,GADTs,FlexibleContexts,RankNTypes #-}

-- A function has an argument type and a result type
class Fun f where
  type FunArg f
  type FunRes f

-- Expressions are either constants of function applications
data Expr a where
  Const :: a -> Expr a
  App :: Fun f => f -> FunArg f -> Expr (FunRes f)

-- A very simple function
data Plus = Plus

-- Which takes two integer expressions and returns an integer expression
instance Fun Plus where
  type FunArg Plus = (Expr Int,Expr Int)
  type FunRes Plus = Int

-- A more complicated function which lifts a function to lists (like in haskell)
data Map f r = Map f

-- For this we need the concept of lifting function arguments:
class Liftable a where
  type LiftRes a

-- A singleton argument is lifted by changing the expression type from a to [a]
instance Liftable (Expr a) where
  type LiftRes (Expr a) = Expr [a]

-- Two function arguments are lifted by lifting each argument
instance (Liftable a,Liftable b) => Liftable (a,b)  where
  type LiftRes (a,b) = (LiftRes a,LiftRes b)

-- Now we can declare a function instance for Map
instance (Fun f,Liftable (FunArg f),r ~ LiftRes (FunArg f)) => Fun (Map f r) where
  type FunArg (Map f r) = r
  type FunRes (Map f r) = [FunRes f]

-- Now a parser for functions:
parseFun :: [String] -> (forall f. Fun f => f -> a) -> a
-- The parser for the plus function is easy:
parseFun ["plus"] f = f Plus
-- But the parser for map is not possible:
parseFun ("map":sym) f 
  = parseFun sym (\fun -> f (Map fun))

The problem seems to be that there is no way to convince the type checker that every LiftRes is itself Liftable, because recursive class declarations are forbidden.

My question is: How do I make this work? Are there other examples of typed expression parsers from which I could take hints?

EDIT: It seems that this discussion about type family constraints seems to be very related. However, I fail to make their solution work in my case, maybe someone can help with that?

Answer 1

The easiest way to make your example work is to remove the Liftable (FunArg f) constraint from the instance declaration. But I think your example is just so condensed that it doesn't show why you actually need it.

So the next best thing is to add a Liftable (FunArg f) superclass constraint to the Fun class:

class Liftable (FunArg f) => Fun f where
  ...

If this is not feasible (i.e., if not all your functions have liftable argument types), then you cannot expect to write a parseFun of the given type.

A more general remark: I think what you're trying to do here is very strange, and perhaps too much at once. Parsing from unstructured strings into a context-free datatype is already difficult enough. Why not do that first, and write a separate function that transforms the "untyped", but structured representation of your language into a typed one.

EDIT (as a reaction to the comments, revised): As pointed out in the discussion on type family constraints that you also linked in your question, you can bypass the superclass cycle restriction by using ConstraintKinds. Here is a way to make your reduced example work. Perhaps this will scale to the full solution?

{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, FlexibleContexts, GADTs #-}

import Data.Constraint  -- from the constraints package
import Data.Proxy       -- from the tagged package

-- A function has an argument type and a result type
class Liftable (FunArg f) => Fun f where
  type FunArg f
  type FunRes f

-- Expr, Plus, and instance Fun Plus as before

class Liftable a where
  type LiftRes a
  get :: p a -> Dict (Liftable (LiftRes a))
    -- acquire "superclass" dictionary by calling this method and
    -- then pattern matching on the result

instance Liftable (Expr a) where
  type LiftRes (Expr a) = Expr [a]
  get _ = Dict

instance (Liftable a, Liftable b) => Liftable (a, b) where
  type LiftRes (a, b) = (LiftRes a, LiftRes b)
  get (_ :: p (a, b)) =
    case get (Proxy :: Proxy a) of -- extra code required
      Dict -> case get (Proxy :: Proxy b) of -- extra code required
        Dict -> Dict

data Map f r = Map f

instance (Fun f, Liftable r, r ~ LiftRes (FunArg f)) => Fun (Map f r) where
  type FunArg (Map f r) = r
  type FunRes (Map f r) = [FunRes f]

parseFun :: forall a. [String] -> (forall f. Fun f => f -> a) -> a
parseFun ["plus"]      f = f Plus
parseFun ("map" : sym) f = parseFun sym
  (\ (fun :: g) -> case get (Proxy :: Proxy (FunArg g)) of -- extra code required
                     Dict -> f (Map fun))