{-# LANGUAGE TemplateHaskell #-}
module Control.Isomorphism.Partial.TH 
  ( constructorIso
  , defineIsomorphisms
  ) where

import Language.Haskell.TH
import Control.Monad
import Data.List (find)
import Data.Char (toLower)

import Control.Isomorphism.Partial.Unsafe (Iso (Iso))

constructorIso c = do
  DataConI n _ d _             <-  reify c
  TyConI ((DataD _ _ _ cs _))  <-  reify d
  let Just con = find (\(NormalC n' _) -> n == n') cs
  isoFromCon (wildcard cs) con

wildcard cs 
  =  if length cs > 1
     then  [match (wildP) (normalB [| Nothing |]) []]
     else  []
  
defineIsomorphisms d = do
  TyConI (DataD _ _ _ cs _) <- reify d
  let rename n 
        = mkName (toLower c : cs) where c : cs = nameBase n
      defFromCon con@(NormalC n _) 
        =  funD (rename n) 
             [clause [] (normalB (isoFromCon (wildcard cs) con)) []]
  
  mapM defFromCon cs

isoFromCon wildcard (NormalC c fs) = do
  let n     =   length fs
  (ps, vs)  <-  genPE n
  v         <-  newName "x"
  let f     =   lamE [nested tupP ps] 
                  [| Just $(foldl appE (conE c) vs) |]
  let g     =   lamE [varP v] 
                  (caseE (varE v) $ 
                    [ match (conP c ps) 
                        (normalB [| Just $(nested tupE vs) |]) []
                    ] ++ wildcard)
  [| Iso $f $g |]

genPE n = do
  ids <- replicateM n (newName "x")
  return (map varP ids, map varE ids)

nested tup []      =  tup [] 
nested tup [x]     =  x
nested tup (x:xs)  =  tup [x, nested tup xs]