> {-
>    Module      : Language.Haskell.SyntaxTrees
>    Copyright   : (c) Dominic Orchard 2010
>    License     : BSD3
>    Maintainer  : Dominic Orchard <dom.orchard@gmail.com>
>    Stability   : experimental
>    Portability : portable (tempalte-haskell)
> -}

> {-# LANGUAGE MultiParamTypeClasses #-}

> {-| Provides an instance that translates
>   haskell-src-exts expression trees into Template Haskell expression
>   trees in a way that depends only on the haskell-src-exts syntax tree
>   and agreement on the pretty-printed representation of
>   Haskell between haskell-src-exts pretty-printer and
>   Template Haskell quotations (as opposed to depending on
>   both TH and haskell-src-exts syntax tree representations).
>   
>
>   Instead of converting between data types, 
>   haskell-src-exts syntax trees are pretty-printed and wrapped in
>   a TH quotation which is then interpreted as a Haskell program,
>   yielding a TH Exp tree. Free variables in the haskell-src-exts tree are
>   preserved by lifting them to TH splices prior to pretty-printing.
>
>   e.g. @parseToTH \"let x = 1 in x + y\"@ = 
>   @
>       Right (LetE [ValD (VarP x_1) (NormalB (LitE (IntegerL 1))) []]
>         (InfixE (Just (VarE x_1)) (VarE GHC.Num.+) (Just (VarE y))))
>   @
> -}

> module Language.Haskell.SyntaxTrees.ExtsToTH (
>     translateExtsToTH,
>     parseToTH,
>     parseToTarget,
>     translateTree) where

> import Language.Haskell.SyntaxTrees.Main

> import Language.Haskell.Interpreter
> import Language.Haskell.Exts.Parser
> import Language.Haskell.Exts.Pretty
> import qualified Language.Haskell.Exts.Syntax as Exts
> import qualified Language.Haskell.TH as TH
> import Data.Generics.Uniplate.Data
> import Foreign
> import Control.Monad.State.Lazy
> import qualified Control.Monad.State.Class as State
================================================================================ 
> instance Translation Exts.Exp TH.Exp where
>   translateTree t = unsafePerformIO $ 
>              do mx <- runInterpreter (interpretTH (buildTHString t))
>                 case mx of 
>                   Left x -> (return . Left) t
>                   Right x -> x >>= (return . Right)
>
>   parseToTarget witness s = case (parseExp s) of
>                 ParseOk x -> case (translateTree x) of
>                                Left x -> Left s
>                                Right x -> Right x
>                 ParseFailed _ string -> Left $ s++string

> {-| Translate a Language.Haskell.Exts.Exp (haskell-src-exts) syntax tree
>     to a Language.Haskell.TH.Exp (template-haskell) syntax tree -}
> translateExtsToTH :: Exts.Exp -> Either Exts.Exp TH.Exp
> translateExtsToTH = translateTree

> {-| Parse a string to a Language.Haskell.TH.Exp (template-haskell) expression 
>   via intermediate representation as a Exts.Exp tree. -}
> parseToTH :: String -> Either String TH.Exp
> parseToTH = parseToTarget (undefined::Exts.Exp)
================================================================================ Build the template Haskell quote expresion 
> buildTHString :: Exts.Exp -> String
> buildTHString t = "(runQ [|" ++ (prettyPrint $ liftFreeVars t) ++ "|])::IO Exp"

> interpretTH :: String -> Interpreter (IO TH.Exp)
> interpretTH thString = do
>    set [languageExtensions := [TemplateHaskell]]
>    setImports ["Prelude","Language.Haskell.TH","Language.Haskell.TH.Syntax"]
>    interpret thString (undefined::(IO TH.Exp))
================================================================================ Free variables must be lifted into TemplateHaskell splices, as free variables are not allowed in a TemplateHaskell quotation. For example: [| x |] -> [| $( varE (mkName "x"))$ |] liftFreeVars processes an Exts.Exp expression, keeping an account in its state of scoped variables in the following nested scope structure: 
> data NestedScopes = Next [String] NestedScopes | Empty deriving Show
isFree is used to ask if an encountered variable name is currently free 
> isFree :: String -> NestedScopes -> Bool
> isFree var Empty = True
> isFree var (Next vars n) = (not $ elem var vars) && isFree var n
Any free variables are converted into an Exts.Exp of a TH splice by mkFreeVar: 
> mkFreeVar n = Exts.SpliceExp $ Exts.ParenSplice $ 
>             (Exts.App (Exts.Var (Exts.UnQual $ Exts.Ident "varE"))
>                       (Exts.App (Exts.Var $ Exts.UnQual $ Exts.Ident "mkName")
>                                 (Exts.Lit $ Exts.String $ nameToString $ n)))
For every binder (e.g. lambdas, lets) we create a new scope in our state and add the bound variables. The following extract variable names from various binding forms: 
> getPatBinders :: [Exts.Pat] -> [String]
> getPatBinders = concatMap getPatBinders' 
>   where
>   getPatBinders' p =
>       [nameToString name | (Exts.PVar name)  <- universe p]

> getBinders :: Exts.Binds -> [String]
> getBinders (Exts.BDecls decls) = concatMap getBinders' decls

>   where getBinders' p = concat ((patBinders p) ++ (matchBinders p))

>         patBinders p = [(getPatBinders [pat])++(getBinders binds) |
>                               (Exts.PatBind _ pat _ _ binds) <- universe p]

>         matchBinders p = [concatMap getMatchBinders matches |
>                               (Exts.FunBind matches) <- universe p]
> getBinders (Exts.IPBinds ipbinds) = map getIPBinders ipbinds

> getMatchBinders (Exts.Match _ _ pats _ _ binds) = getPatBinders pats ++ getBinders binds

> getAltBinders :: [Exts.Alt] -> [String]
> getAltBinders = concatMap getAltBinders'
>   where
>   getAltBinders' :: Exts.Alt -> [String]
>   getAltBinders' (Exts.Alt _ pat _ binds) = getPatBinders [pat] ++ getBinders binds

> getIPBinders :: Exts.IPBind -> String
> getIPBinders (Exts.IPBind srcLine (Exts.IPDup n) exp) = n
> getIPBinders (Exts.IPBind srcLine (Exts.IPLin n) exp) = n
liftFreeVars processes the tree town down using the uniplate extension: transformTopDownM (see below) to process the tree top down and to not process newly generated subtrees. 
> liftFreeVars :: Exts.Exp -> Exts.Exp
> liftFreeVars x = evalState (transformTopDownM f x) Empty
>   where
>     -- Qualified variable encountered, transformation occurs here**
>     -- Qualified variables are always 'free'
>     f e@(Exts.Var (Exts.Qual (Exts.ModuleName m) name)) = do
>           return $ Right $ mkFreeVar $ Exts.Ident $ m ++ "." ++ nameToString name
>     -- Variable encountered: *** transformation occurs here**
>     f e@(Exts.Var (Exts.UnQual name)) = do
>         scopedVars <- State.get
>         if (isFree (nameToString name) scopedVars) then
>             return $ Right (mkFreeVar name)
>          else
>             return $ Left e
>     -- Let binder
>     f e@(Exts.Let binds exp) = do
>         scopedVars <- State.get
>         State.put $ Next (getBinders binds) scopedVars
>         return $ Left e

>     -- Lambda binder
>     f e@(Exts.Lambda srcLine pats exp) = do
>         scopedVars <- State.get
>         State.put $ Next (getPatBinders pats) scopedVars
>         return $ Left e

>     -- Case binder
>     f e@(Exts.Case exp alts) = do
>         scopedVars <- State.get
>         State.put $ Next (getAltBinders alts) scopedVars
>         return $ Left e

>     -- Arrow Proc binder
>     f e@(Exts.Proc srcLine pat exp) = do
>         scopedVars <- State.get
>         State.put $ Next (getPatBinders [pat]) scopedVars
>         return $ Left e

>     -- Arrow Proc binder
>     f (Exts.InfixApp exp1 qop exp2) = do
>         return $ Left $ Exts.App (Exts.App (Exts.Var (qOpToQName qop)) exp1) exp2

>     -- Default case
>     f x = return $ Left x
blankSrcLoc = Exts.SrcLoc "" 0 0 snLoc x = Exts.SrcLoc x 0 0 
> qOpToQName :: Exts.QOp -> Exts.QName
> qOpToQName (Exts.QVarOp qnam) = qnam
> qOpToQName (Exts.QConOp qnam) = qnam

> nameToString :: Exts.Name -> String
> nameToString (Exts.Ident  s) = s
> nameToString (Exts.Symbol s) = s
================================================================================ Extension to Uniplate Use descendM to do a top-down parse of a uniplatable tree, but take a function with return type: m (Either on on), with behaviour: Descend on a value of Left x Stop on a value of Right x, which denotes that a new sub-tree was built that shouldn't be parsed over. 
> transformTopDownM :: (Monad m, Uniplate on) => (on -> m (Either on on)) -> on -> m on
> transformTopDownM f = g
>    where g x = do x' <- (f x)
>                   case x' of
>                     Left x'' -> ((descendM g) =<< (return x''))
>                     Right x'' -> return x''