{-# OPTIONS -fglasgow-exts -fth #-}
{-# OPTIONS -fallow-overlapping-instances #-}
module TH_tools.TH_render where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Language.Haskell.Parser
import Language.Haskell.Pretty
import Language.Haskell.Syntax

import TH_tools.Base


-- variable arguement builder
-- build' takes any number of arguements >= 1, renders them and concatenates them
-- together with HsApp. Finaly it wraps the result in a Hsparen
class BuildHsExp a r where
    build' :: HsExp -> a -> r

instance (TH_Render a) => BuildHsExp a HsExp where
    build' l x = HsParen $ HsApp l (render x)

instance (TH_Render a, TH_Render b, BuildHsExp b r) => BuildHsExp a (b->r) where
    build' l x y = build' (HsApp l (render x))  y

 --build :: forall r a. (BuildList a r) => a -> r
build func x = build' (func_out func) x

func_out f = HsVar $ UnQual $ HsIdent $ nameBase f

class TH_Render s where
  render :: s -> HsExp

-- derive instance declarations for class TH_Render
$(gen_render ''Dec) 
$(gen_render ''Clause) 
$(gen_render ''Con) 
$(gen_render ''Type) 
$(gen_render ''Strict) 
$(gen_render ''Pat) 
$(gen_render ''Body) 
{- Example output
instance TH_Render Body where
   render (NormalB exp) = build 'normalB exp
   render (GuardedB guards) = build 'guardedB  guards 
-}
$(gen_render ''Stmt) 
$(gen_render ''Exp) 
$(gen_render ''Match) 
$(gen_render ''Range) 

-- Handler all the special cases

instance TH_Render FunDep where
  render (FunDep names1 names2) = error "render 'funDep names1 names2"

instance TH_Render Foreign where
  render _ = error "ForeignD not supported"

instance TH_Render Name where
  render name = build 'mkName (nameBase name)

instance TH_Render (Name, Strict, Type) where
  render (name, strict, typ) = build 'varStrictType name (strict, typ)

instance TH_Render (Maybe Exp) where
   render (Just exp) = build 'Just exp
   render Nothing = func_out 'Nothing

instance TH_Render (Strict, Type) where
  render (strict, typ) = build 'strictType strict typ

instance TH_Render (Guard, Exp) where
   render (NormalG gexp, exp) = build 'normalGE gexp exp
   render (PatG stmts, exp) = build 'patGE stmts

instance TH_Render (Name, Exp) where
   render (name, exp) = build 'fieldExp name exp

instance TH_Render (Name, Pat) where
   render (name, pat) = build ' fieldPat name pat

instance (TH_Render a) => TH_Render [a] where
   render list = HsList (map render list)

instance TH_Render [Type] where
  render cxts = HsParen $ (func_out 'cxt) `HsApp` (HsList $ map render cxts)

instance TH_Render String where
  render string = HsLit $ HsString string
 
instance TH_Render Lit where
   render (IntegerL int) = build 'IntegerL int
   render (CharL char) = build 'CharL char
                                        
instance TH_Render Integer where
   render int  = (HsLit (HsInt int))  

instance TH_Render Int where
   render int  = (HsLit (HsInt $ fromIntegral int))

instance TH_Render Char where
  render char  = (HsLit (HsChar char))


render_all :: (Monad m) => m [Dec] -> m [HsExp]
render_all decs = do decs' <- decs
                     return $ (map render decs')

-- Can always use matching here to remove outermost ()
printTH :: Q [Dec] -> IO ()
printTH decs = do decs' <- runQ $ render_all decs
                  putStr $ prettyPrint $ HsList decs'
                  putStr "\n"