Recursive types?

[Mark Tullsen]

Tom Pledger wrote:
> I don't know whether this is a shining example of an advantage,
> and am keen to see other comments.

For what it's worth, I've pulled some snippets from some code I wrote.  
I wanted three recursive types which were nearly identical (Exp,ExpQv,ExpPr).

Rather than write three different type declarations
  data Exp = ...
  data ExpQv = ...
  data ExpPr = ...

I was able to abstract out the commonality into one non-recursive type
  data FctrExp a = ...

Note how concise some of my "Sample Functions" can be.  These would
have been very long and ugly to write were I to use the first
approach.  At the expense of now using a "two-level" type, I've gained
some expressiveness.

- Mark

---- Fix Type -----------------------------------------------------------------

data Fix f = In (f (Fix f))

class FixEq f where
  fixEq :: Eq a => (f a -> f a -> Bool)

class FixShow f where
  fixShowsPrec :: Show a => (Int -> f a -> ShowS)

instance FixEq f => Eq (Fix f) where
  (==) (In x) (In y) = fixEq x y

instance FixShow f => Show (Fix f) where
  showsPrec p (In x) = showString "In (" . fixShowsPrec p x . showChar ')'

---- Types for Documentation --------------------------------------------------

type Var   = String
type Env x = [(Var,x)]
type Pat          = Exp
type Type         = Exp

---- Form & FormPr Related Types ---------------------------------------------

type    Qv        = (Exp,Exp)

data    Pr        = Pstep (ExpPr,Justifier,ExpPr)
                  | Pletu (Var, Type, ExpPr)
                  deriving(Show,Eq) 

data Justifier    = Stub1
                  deriving (Show,Eq)

---- Exp,ExpPr,ExpQv Types ----------------------------------------------------

data Ftype = Stub2 deriving (Show,Eq)
data Ltype = Stub3 deriving (Show,Eq)
data Const = Stub4 deriving (Show,Eq)

data FctrExp a = 
             Econ Const
           | Evar Var
           | Eapp (Ftype, a, a)
           | Elet (Ltype, Pat, Type, a, a)  -- let x:t=e1 in e2
           | Elam (Ftype, Pat, Type, a)     -- \x:t=>e
           | Eqnt (Ftype, Pat, Type, a)     -- |~|x:t=>e
           | Etup [a]                     -- <e1,e2,...>
           | Emu a
           | Ecase a                      -- case e
           | Ein (a,a)                    -- In i e
           deriving (Show,Eq)

data FctrExpQv a  = ExpQvExp (FctrExp a) 
                  | ExpQvQv Qv
                  deriving (Show,Eq)
                                    
data FctrExpPr a  = ExpPrExp (FctrExp a) 
                  | ExpPrPr Pr
                  deriving (Show,Eq)

type Exp          = Fix FctrExp
type ExpQv        = Fix FctrExpQv
type ExpPr        = Fix FctrExpPr

---- Define Appropriate Functors ----------------------------------------------

instance Functor FctrExp where
  fmap = fmapFctrExp

fmapFctrExp :: (a->b) -> (FctrExp a -> FctrExp b)
fmapFctrExp f e =
  case e of
    Econ x                -> Econ x
    Evar x                -> Evar x
    Eapp (x,e1,e2)        -> Eapp (x,f e1, f e2)
    Elet (x,v,t,y,z)      -> Elet (x,v,t,f y,f z)
    Elam (x,v,t,e)        -> Elam (x,v,t,f e)
    Eqnt (x,v,t,e)        -> Eqnt (x,v,t,f e)
    Etup es               -> Etup (map f es)
    Emu e                 -> Emu (f e)
    Ecase e               -> Ecase (f e)
    Ein (i,e)             -> Ein (f i,f e)

---- Make Exp,ExpQv,ExpPr instances of Show and Eq ----------------------------

instance FixEq   FctrExp   where  fixEq        = (==)
instance FixShow FctrExp   where  fixShowsPrec = showsPrec

instance FixEq   FctrExpQv where  fixEq        = (==)
instance FixShow FctrExpQv where  fixShowsPrec = showsPrec

instance FixEq   FctrExpPr where  fixEq        = (==)
instance FixShow FctrExpPr where  fixShowsPrec = showsPrec

---- Sample Functions ---------------------------------------------------------

expToExpPr :: Exp -> ExpPr
expToExpPr (In x) = In (ExpPrExp (fmap expToExpPr x))

firstExpPr, finalExpPr :: ExpPr -> Exp
  
firstExpPr (In x) = case x of 
  ExpPrExp e              -> In $ fmap firstExpPr e
  ExpPrPr (Pstep (p,_,_)) -> firstExpPr p
  ExpPrPr (Pletu _)       -> error "firstExpPr"

finalExpPr (In x) = case x of 
  ExpPrExp e              -> In $ fmap finalExpPr e
  ExpPrPr (Pstep (_,_,p)) -> finalExpPr p
  ExpPrPr (Pletu _)       -> error "finalExpPr"