{-# OPTIONS_GHC -fglasgow-exts -fth #-}
module Derive where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad

data T1 = T1
data T2 a = T2 a

deriveShow t = do
  -- Get list of constructors for type t
  TyConI (DataD _ _ _ constructors _)  <-  reify t

  -- Make `show` clause for one constructor:
  --   show (A x1 x2) = "A "++show x1++" "++show x2
  let showClause (NormalC name fields) = do
        -- Name of constructor, i.e. "A". Will become string literal in generated code
        let constructorName = nameBase name
        -- Get variables for left and right side of function definition
        (pats,vars) <- genNames (length fields)
        -- Recursively build (" "++show x1+...) expression from [x1...] variables list
        let f []       = [| "" |]
            f (v:vars) = [| " " ++ show $v ++ $(f vars) |]
        -- Generate function clause for one constructor
        clause [conP name pats]                                 -- (A x1 x2)
               (normalB [| constructorName ++ $(f vars) |]) []  -- "A "++show x1++" "++show x2

  -- Make body for function `show`:
  --   show (A x1 x2) = "A "++show x1++" "++show x2
  --   show (B x1)    = "B "++show x1
  --   show C         = "C"
  showbody <- mapM showClause constructors

  -- Generate template instance declaration and replace type name (T1)
  --   and function body (x = "text") with our data
  d <- [d| instance Show T1 where
             show x = "text"
       |]
  let    [InstanceD [] (AppT showt (ConT _T1)) [FunD showf _text   ]] = d
  return [InstanceD [] (AppT showt (ConT t  )) [FunD showf showbody]]


-- Generate n unique variables and return them in form of patterns and expression
genNames n = do
  ids <- replicateM n (newName "x")
  return (map varP ids, map varE ids)