Generates an extensible datatype from a datatype declaration, roughly following the pattern given by the Trees that Grow paper by Najd and Peyton Jones.

• A type family is generated for each constructor, taking an argument named ext for the extension type, followed by the arguments of the datatype. The names of the type families correspond to the constructors themselves modified with annotationName (see XVar etc below).
• An extra type family is generated with the same arguments, named after the datatype modified with extensionName (see LamX).
• The datatype itself is renamed according to datatypeName and given an extra argument called ext (before the others).
• Each existing constructor is renamed according to constructorName, and given an extra strict field of the corresponding type family generated above.
• An extra constructor is generated for the extension type family (with the same name), containing it as its sole field (see Lam' for the transformation).
• A constraint synonym is generated, named according to bundleName, which contains a constraint for each extension (see LamAll).
• A record and TH function are generated for creating new extensions of the base datatype (see ExtLam and extendLam).
• A standalone deriving declaration is generated for each derived instance listed.

Known bugs and shortcomings

• Due to GHC's staging restriction, a Template Haskell function cannot be spliced in the same module as it is defined. That means it is not possible to write extensible [d| data Foo = ... |]; extendFoo ... within the same module.
• When using qualified imports, the module containing extendFoo must be imported using its real name. It can also be imported using an alias if desired, e.g. import qualified LongName; import qualified LongName as L.
• The same record label cannot be used for multiple different constructors. (The DuplicateRecordFields extension doesn't seem to lift this restriction with pattern synonyms.)
• Pattern synonyms do not yet get type annotations, which means that GHC cannot always work out which variant of the type you want. You will probably also want to disable the warning in modules calling extendFoo until this is fixed (e.g. with {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}).

• The deriving supported is quite limited compared to full GHC:

  • Only stock and anyclass strategies are supported.
  • The context is not calculated properly like a real deriving clause. Instead, a constraint of the given class is required for each type variable and each extension. If this doesn't work (e.g. you want to derive Eq but have a type variable of kind Type -> Type), you must instead write your own declaration outside of the call to extensible. The only special case is that Generic is not given a context.
  • Deriving for non-regular datatypes (datatypes with recursive occurrences applied to different types) doesn't work.

Language extensions

The module where extensible is called needs the extensions TemplateHaskell, TypeFamilies, FlexibleContexts, UndecidableInstances, ConstraintKinds, KindSignatures, StandaloneDeriving to be enabled.

Modules calling extendFoo need TemplateHaskell, TypeFamilies, PatternSynonyms.

Example

module Base where    
import Extensible

extensible [d| 
  data Lam a p =
      Var {varVar :: a}
    | Prim {primVal :: p}
    | App {appFun, appArg :: Lam a p}
    | Abs {absVar :: a, absBody :: Lam a p}
    deriving (Eq, Show)
  |]

====>

-- type families for each constructor, and one for adding additional ones
type family XVar  ext a p    
type family XPrim ext a p    
type family XApp  ext a p    
type family XAbs  ext a p    
type family LamX  ext a p    

data Lam' ext a p = 
    Var' {                                 
      varVar :: a,                         
      extVar :: !(XVar ext a p)    
        -- each constructor gets a slot for extra fields
    }
  | Prim' {                          
      primVal :: p,                  
      extPrim :: !(XPrim ext a p)    
    }
  | App' {                                 
      appFun, appArg :: Lam' ext a p,       
        -- recursive occurrences are dealt with
      extApp :: !(XApp ext a p)    
    }
  | Abs' {                                 
      absVar :: a p,                       
      absBody :: Lam' ext a p,             
      extAbs :: !(XLam ext a p)    
    }
  | LamX { -- a constructor for extensions      
      extLam :: !(LamX ext a p)         
    }

type LamAll (c :: Type -> Constraint) ext a =    
  (c (XVar ext a), c (XPrim ext a),
   c (XApp ext a), c (XAbs ext a),
   c (LamX ext a))

-- deriving clauses transformed to standalone deriving
deriving instance (Eq   a, LamAll Eq   ext a) => Eq   (Lam' ext a)
deriving instance (Show a, LamAll Show ext a) => Show (Lam' ext a)

-- a description of an extension
-- (don't rely on the field order; use record syntax instead)
data ExtLam =                                                         
  ExtLam {
    -- rename the Var constructor
    nameVar :: String,                                              

    -- a list of extra field names and types for Var
    -- * for a non-record, this is a Maybe [TypeQ] instead
    -- * Nothing disables the constructor
    typeVar :: Maybe [(String, TypeQ)],                         

    -- same for the others
    namePrim :: String, typePrim :: Maybe [(String, TypeQ)],   
    nameApp  :: String, typeApp  :: Maybe [(String, TypeQ)],    
    nameAbs  :: String, typeAbs  :: Maybe [(String, TypeQ)],    

    -- extra constructors, their names & fields
    -- * multiple are possible, represented with nested Either
    -- * extensions are records because all of the proper constructors are
    -- * otherwise, has type [(String, [TypeQ])]
    typeLamX :: [(String, [(String, TypeQ)])]                   
  }

-- no extensions (reproduces the input datatype)
defaultExtLam :: ExtLam    
defaultExtLam =
  ExtLam {
    nameVar  = "Var",  typeVar  = Just [],
    namePrim = "Prim", typePrim = Just [],
    nameApp  = "App",  typeApp  = Just [],
    nameAbs  = "Abs",  typeAbs  = Just [],
    typeLamX = []
  }

-- produces an extended datatype; see below for details
extendLam :: String -- ^ extended type's name    
          -> [Name] -- ^ extra type variables, if needed
          -> TypeQ  -- ^ tag for this variant of the type
                    --   (the "ext" parameter; should contain the above vars)
          -> (TypeQ -> TypeQ -> ExtLam)
                    -- ^ description of extension
                    --   (input is Lam's type variables a and p)
          -> DecsQ
extendLam = ...

De Bruijn terms

import Base

data DeBruijn    

extendLam "DBTerm" [] [t|DeBruijn|] $
  -- "a" and "p" are Lam's type parameters
  \a p -> defaultExtLam {
    typeVar = Nothing, -- replaced with Free and Bound
    typeAbs = Nothing, -- replaced with a version without absVar
    typeLamX =
      [("Free",  [("freeVar",  a)]),
       ("Bound", [("boundVar", [t|Int|])]),
       ("Abs",   [("absBody",  [t|Lam' DeBruijn $a $p|])])]
         -- (we have to say Lam' DeBruijn here because
         --  the DBTerm alias doesn't exist yet)
  }

====>

type instance XVar DeBruijn a p = Void

type instance XPrim DeBruijn a p = ()
pattern Prim {primVal} = Prim' primVal ()

type instance XApp DeBruijn a p = ()
pattern App {appFun, appArg} = App' appFun appArg ()

type instance XAbs DeBruijn a p = Void

type instance LamX DeBruijn a p =
  Either a                  -- Free
    (Either Int             -- Bound
       (Lam' DeBruijn a p)) -- Abs
pattern Free  {freeVar}  = LamX (Left         freeVar)
pattern Bound {boundVar} = LamX (Right (Left  boundVar))
pattern Abs   {absBody}  = LamX (Right (Right absBody))

{-# COMPLETE Prim, App, Free, Bound, Abs #-}

Type-annotated terms

import Base
import Extensible

data Type t =                
    Base t                   
  | Arr (Type t) (Type t)    

data Typed t    

do -- create a new type variable for Typed
   -- (newName and varT are reexported from TH by Extensible)
   t' <- newName "t"; let t = varT t'
   extendLam "TypedLam" [t'] [t|Typed $t|] $
     \a p -> defaultExtLam {
       typeVar = Just [("varType", [t|Type $t|])],
       typeAbs = Just [("absArg",  [t|Type $t|])],
       typeLamX = [("TypeAnn",
          [("annTerm", [t|Lam' (Typed $t) $a $p|]),
           ("annType", [t|Type $t|])])]
     }

====>

type TypedLam t = Lam' (Typed t)    

type instance XVar (Typed t) a p = Type t
pattern Var {varVar, varType} = Var' varVar varType

type instance XPrim (Typed t) a p = ()
pattern Prim {primVal} = Prim' primVal ()

type instance XApp (Typed t) a p = ()
pattern App {appFun, appArg} = App' appFun appArg ()

type instance XAbs (Typed t) a p = Type t
pattern Abs {absVar, absBody, absArg} = Abs' absVar absBody absArg

type instance LamX (Typed t) a p = (Lam' (Typed t) a p, Type t)
pattern TypeAnn {annTerm, annType} = LamX (annTerm, annType)

{-# COMPLETE Var, Prim, App, Abs, TypeAnn #-}