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

printf::String->ExpQ
printf s = gen (parse s) [| "" |]

data Format = D | S | L String

parse::String->[Format]
parse [] = []
parse ('%':'d': rest) = D : parse rest
parse ('%':'s': rest) = S : parse rest
parse ('%':'%': rest) = addChar '%' (parse rest)
parse (x: rest) = addChar x (parse rest)

addChar c (L s : r) = L (c : s) : r
addChar c x = L [c] : x

gen::[Format] -> ExpQ-> ExpQ
gen [] x = x
gen (D : xs) x = [| \n-> $(gen xs [| $x ++ show (n::Int) |]) |]
gen (S : xs) x = [| \s-> $(gen xs [| $x ++ s |]) |]
gen (L s : xs) x = gen xs [| $x ++ $(lift s) |]

-- :type $(printf "Test %s -> %d")  ... String->Int->String

sel::Int->Int->ExpQ
sel i n = [| \x -> $(caseE [|x|] [alt]) |]
  where
    alt = match pat rhs []
    pat = tupP (map varP as)
    rhs = normalB (varE (as !! (i - 1)))
    as = map mkName ["a" ++ show i | i <- [1..n]]

-- :type $(sel 2 4) ... (a,b,c,d)->b

instanceType::Name->Name->[Name]->TypeQ
instanceType className name params =
  conT className `appT` (foldl1 appT (conT name : map varT params))

deriveEq :: InfoQ -> Q [Dec]
deriveEq ti =
  do
    TyConI (DataD _ n params con _) <- ti
    ei <- funD (mkName "==") ((map genConClause con) ++ [dfClause])
    i <- instanceD (cxt []) (instanceType ''Eq n params) [return ei]
    return [i]
  where
    dfClause = clause [wildP,wildP] (normalB [| False |]) []
    genConClause (NormalC cname comps) =
      do
        varl <- mapM (\_ -> newName "x") comps
        varr <- mapM (\_ -> newName "y") comps
        let p1 = conP cname (map varP varl)
            p2 = conP cname (map varP varr)
        clause [p1, p2] (normalB (genCompares varl varr)) []
    genCompares varl varr = foldl (\i e -> infixApp i [| (&&) |] e) [| True |] $ zipWith (\x y -> infixApp (varE x) [| (==) |] (varE y)) varl varr

data Bla = Foo Int Char | Bar Bool | Nic

-- $(deriveEq (reify ''Bla))