instance of Lift for Exp

{-# OPTIONS -fglasgow-exts #-}
        -- Need GlaExts for the Int# used in Name
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Syntax.LiftExp
-- Copyright   :  (c) Duncan Coutts
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  [email protected]
-- Stability   :  experimental
-- Portability :  portable
--
-- Optional instance of 'Language.Haskell.Syntax.Lift' for 'ExpQ'.
--
-----------------------------------------------------------------------------

module Language.Haskell.TH.LiftExp () where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Name(..), NameSpace(..),
                                   NameFlavour(..), Lift(..))

import Data.PackedString (PackedString, packString, unpackPS)
import qualified GHC.Base (Int(..), Int#)

import Control.Monad (liftM)
import Data.Ratio (Ratio, (%), numerator, denominator)

-----------------------
--
-- Lift instances for Exp and other TH types

instance Lift Exp where
  lift (VarE name)       = [| VarE name |]
  lift (ConE name)       = [| ConE name |]
  lift (LitE lit)        = [| LitE lit  |]
  lift (AppE e1 e2)      = [| AppE e1 e2 |]
  lift (InfixE e1 op e2) = [| InfixE e1 op e2 |]
  lift (LamE pats e)     = [| LamE pats e |]
  lift (TupE es)         = [| TupE es |]
  lift (CondE e1 e2 e3)  = [| CondE e1 e2 e3 |]
  lift (LetE decls e)    = [| LetE decls e |]
  lift (CaseE e matches) = [| CaseE e matches |]
  lift (DoE stmts)       = [| DoE   stmts |]
  lift (CompE stmts)     = [| CompE stmts |]
  lift (ArithSeqE range) = [| ArithSeqE range |]
  lift (ListE es)        = [| ListE es |]
  lift (SigE e t)        = [| SigE e t |]
  lift (RecConE name fs) = [| RecConE name fs |]
  lift (RecUpdE e fs)    = [| RecUpdE e fs |]

instance Lift Name where
  lift (Name occ flavour) = [| Name occ flavour |]

instance Lift NameFlavour where
  lift  NameS                    = [| NameS |]
  lift (NameU n)                 = [| NameU |] `appE` encodeUnboxedInt n
  lift (NameG nameSpace modName) = [| NameG nameSpace modName |]

instance Lift NameSpace where
  lift VarName   = [| VarName |]
  lift DataName  = [| DataName |]
  lift TcClsName = [| TcClsName |]

instance Lift Lit where
  lift (CharL c)       = [| CharL c |]
  lift (StringL s)     = [| StringL |] `appE` litE (stringL s)
  lift (IntegerL n)    = [| IntegerL n |]
  lift (RationalL q)   = [| RationalL q |]
  lift (IntPrimL  n)   = [| IntPrimL n  |]
  lift (FloatPrimL q)  = [| FloatPrimL q |]
  lift (DoublePrimL q) = [| DoublePrimL q |]

instance Lift Pat where
  lift (LitP lit)            = [| LitP lit |]
  lift (VarP name)           = [| VarP name |]
  lift (TupP pats)           = [| TupP pats |]
  lift (ConP name pats)      = [| ConP name pats |]
  lift (TildeP pat)          = [| TildeP pat |]
  lift (AsP name pat)        = [| AsP name pat |]
  lift (WildP)               = [| WildP |]
  lift (RecP name fieldPats) = [| RecP name fieldPats |]
  lift (ListP pats)          = [| ListP pats |]

instance Lift Dec where
  lift (FunD name clauses)          = [| FunD name clauses |]
  lift (ValD pat body decs)         = [| ValD pat body decs |]
  lift (DataD   tys name names1 cons names2) = [| DataD tys name names1 cons names2 |]
  lift (NewtypeD tys name names1 con names2) = [| NewtypeD tys name names1 con names2 |]
  lift (TySynD name names ty)       = [| TySynD name names ty |]
  lift (ClassD tys name names decs) = [| ClassD tys name names decs |]
  lift (InstanceD tys ty decs)      = [| InstanceD tys ty decs |]
  lift (SigD name ty)               = [| SigD name ty |]
  lift (ForeignD fdecl)             = [| ForeignD fdecl |]

instance Lift Clause where
  lift (Clause pats body decls) = [| Clause pats body decls |]

instance Lift Body where
  lift (GuardedB ees) = [| GuardedB ees |]
  lift (NormalB e)    = [| NormalB e |]

instance Lift Match where
  lift (Match pat body decls) = [| Match pat body decls |]
  
instance Lift Stmt where
  lift (BindS pat e) = [| BindS pat e |]
  lift (LetS  decs)  = [| LetS decs |]
  lift (NoBindS e)   = [| NoBindS e |]
  lift (ParS stmtss) = [| ParS stmtss |]

instance Lift Range where
  lift (FromR     e)          = [| FromR e |]
  lift (FromThenR e1 e2)      = [| FromThenR e1 e2 |]
  lift (FromToR   e1 e2)      = [| FromToR e1 e2 |]
  lift (FromThenToR e1 e2 e3) = [| FromThenToR e1 e2 e3 |]

instance Lift Type where
  lift (ForallT names tys ty) = [| ForallT names tys ty |]
  lift (VarT name)    = [| VarT name |]
  lift (ConT name)    = [| VarT name |]
  lift (TupleT n)     = [| TupleT n |]
  lift  ArrowT        = [| ArrowT |]
  lift  ListT         = [| ListT  |]
  lift (AppT ty1 ty2) = [| AppT ty1 ty2 |]

instance Lift Con where
  lift (NormalC name  sts) = [| NormalC name sts |]
  lift (RecC    name vsts) = [| RecC    name vsts |]
  lift (InfixC s1 name s2) = [| InfixC s1 name s2 |]

instance Lift Strict where
  lift IsStrict  = [| IsStrict |]
  lift NotStrict = [| NotStrict |]

instance Lift Foreign where
  lift (ImportF cconv safty s name ty) = [| ImportF cconv safty s name ty |]

instance Lift Callconv where
  lift CCall   = [| CCall |]
  lift StdCall = [| StdCall |]

instance Lift Safety where
  lift Unsafe     = [| Unsafe |] 
  lift Safe       = [| Safe |]
  lift Threadsafe = [| Threadsafe |]

-----------------------
--
-- Various general encodings

-- This one is not very nice
encodeUnboxedInt :: GHC.Base.Int# -> ExpQ
encodeUnboxedInt n = let n' :: Int = fromIntegral (GHC.Base.I# n)
                      in [| \(GHC.Base.I# i) -> i |] `appE` [| n' |]

-- These two could be in the standard TH libs but the point is debatable.
-- They are not strictly necessary but make the code above neater.
instance Lift PackedString where
  lift s = [| packString |] `appE` litE (stringL $ unpackPS s)

instance (Integral a, Lift a) => Lift (Ratio a) where
  lift q = let n = numerator q
               d = denominator q
            in [| n % d |]

-- These ones should be in the standard TH libs
instance Lift a => Lift (Maybe a) where
  lift Nothing  = [| Nothing |]
  lift (Just e) = [| Just e |]

instance (Lift a, Lift b) => Lift (a,b) where
  lift (a,b) = [| (a,b) |]

instance (Lift a, Lift b, Lift c) => Lift (a,b,c) where
  lift (a,b,c) = [| (a,b,c) |]