Lift instances of the AST-related types

"Alfonso Acosta" <[email protected]> Tue, 30 Oct 2007 02:42:54 +0100
Newsgroups gmane.comp.lang.haskell.template
Message-ID <[email protected]>
Hi,

It has been suggested a few types in this list [1,2] that it would be
helpful to include a Lift instance of Exp, Type, Dec and friends.

Having such instances allow to store the AST in a TH-generated
structure for later processing during runtime (something curcial in
the embedded compiler I'm currently developing).

It would be great that the instances were included in the library
itself or if (even better) GHC supported automatic deriving of Lift.

Until that happens, I have used a modified version Ian's th-lift[3] to
automatically generate the instances.

Just in case anyone is interested, I attached the patch of th-lift and
the instantiation module.

Cheers,

Fons


[1] http://www.haskell.org/pipermail/template-haskell/2007-February/000593.html
[2] http://www.haskell.org/pipermail/template-haskell/2004-June/000289.html
[3] http://hackage.haskell.org/cgi-bin/hackage-scripts/package/th-lift-0.2

_______________________________________________
template-haskell mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/template-haskell
LiftInstances.hs (text/x-haskell, 1.5 KB)
{-# OPTIONS_GHC -fth #-} -- Due to the use of Template Haskell  
-----------------------------------------------------------------------------
-- |
-- Module      :  ForSyDe.Netlist
-- Copyright   :  (c) The ForSyDe Team 2007
-- License     :  BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  [email protected]
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides  'Lift' instances for all the AST-types defined
-- in "Language.Haskell.Syntax":
-- 'Guard' 'Strict', 'Callconv', 'Safety','Body', 'Con', 'FunDep', 'Foreign', 
-- 'Lit', 'Pat', 'Match', 'Stmt', 'Range', 'Clause', 'Type', 'Dec', 'Exp'
--
-- Furthermore it provides a 'Lift' instance of 'Ratio' 
-- (essential for some of the other instantiations)
-- 
-----------------------------------------------------------------------------
module Language.Haskell.TH.LiftInstances where

import Language.Haskell.TH
import Language.Haskell.TH.Lift (deriveLift)
import Language.Haskell.TH 
 (Guard,
  Strict,
  Callconv,
  Safety,
  Body, 
  Con, 
  FunDep, 
  Foreign, 
  Lit, 
  Pat, 
  Match, 
  Stmt, 
  Range, 
  Clause, 
  Type, 
  Dec, 
  Exp)

import Control.Monad (mapM)
import Data.Ratio (Ratio)

$(mapM deriveLift 
      [''Ratio,
       ''Guard,
       ''Strict,
       ''Callconv,
       ''Safety,
       ''Body, 
       ''Con, 
       ''FunDep, 
       ''Foreign, 
       ''Lit, 
       ''Pat, 
       ''Match, 
       ''Stmt, 
       ''Range, 
       ''Clause, 
       ''Type, 
       ''Dec, 
       ''Exp])
th-lift.patch (text/x-patch, 1.5 KB)
--- Haskell/TH/Lift.hs	2007-02-22 00:44:59.000000000 +0100
+++ /home/fons/asignaturas/ForSyDe/src/Language/Haskell/TH/Lift.hs	2007-10-30 01:56:08.000000000 +0100
@@ -1,10 +1,14 @@
-
+{-# OPTIONS_GHC -fglasgow-exts -fth -fno-warn-deprecations #-}  
+-- Due to the use of unboxed types, TH, and deprecated Packed Strings
+-- Taken from HackageDB
+-- (c) Ian Lynagh, 2006
 module Language.Haskell.TH.Lift where
 
 import GHC.Exts
 import Data.PackedString
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
+import Control.Monad (liftM)
 
 modName :: String
 modName = "Language.Haskell.TH.Lift"
@@ -13,8 +17,9 @@
 deriveLift n
  = do i <- reify n
       case i of
-          TyConI (DataD _ _ vs cons _) ->
-              let ctxt = cxt [conT ''Lift `appT` varT v | v <- vs]
+          TyConI (DataD dcxt _ vs cons _) ->
+              let ctxt = liftM (++ dcxt) $ 
+                         cxt  [conT ''Lift `appT` varT v | v <- vs] 
                   typ = foldl appT (conT n) $ map varT vs
                   fun = funD 'lift (map doCons cons)
               in instanceD ctxt (conT ''Lift `appT` typ) [fun]
@@ -27,6 +32,10 @@
           args = [ [| lift $(varE (mkName n)) |] | n <- ns ]
           e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args
       clause [conP c (map (varP . mkName) ns)] (normalB e) []
+doCons (InfixC st1 n st2) = doCons (NormalC n [st1,st2])
+doCons (RecC n vsts)  
+ = let st (_, s, t) = (s, t)
+   in doCons (NormalC n (map st vsts))
 doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c)
 
 instance Lift Name where