{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS -fno-warn-overlapping-patterns #-}
module Helper where
    

import Language.Haskell.TH
import Control.Monad
import Data.Generics
    
decomposeForallT :: Type -> (Cxt,Type)
decomposeForallT (ForallT _ cxt t) = case decomposeForallT t of
                                       (x,y) -> (cxt++x,y)
decomposeForallT t = ([],t)

#if __GLASGOW_HASKELL__ >= 700
classI_dec (ClassI x _ ) = x 
#else
classI_dec (ClassI x ) = x 
#endif
classI_dec info = error ("expected ClassI, got "++show info)
                         


lemma :: Name -> Name -> Q [Dec]
lemma cls prf = do
        prfInfo <- reify prf

        let
            typ = case prfInfo of
                    VarI _ typ _ _ -> unmangleNames typ
                    _ -> error ("expected ValI, got "++show prfInfo)

        info <- reify cls
        let methodId = (\(ClassD _ _ _ _ [SigD x _]) -> x) (classI_dec info)
                             
            (cxt,bodyT) = decomposeForallT typ

        -- sig <- sigD prfId (return typ)
        
        inst <- instanceD (return cxt) 
               (conT cls `appT` return bodyT) [valD (varP methodId)
                                                        (normalB (varE prf))
                                                        []
                                              ]
               
        return [inst]


unmangleName :: Name -> Name
unmangleName = mkName . fst . break (=='[') . nameBase

unmangleNames :: (Data a) => a -> a
unmangleNames = everywhere (mkT unmangleName)

lemmata :: Name -> [Name] -> Q [Dec]
lemmata cls xs = fmap concat (mapM (lemma cls) xs)