{-|
    Derivation for the 'Typeable' class, as described in the Scrap
    Your Boilerplate papers.  This derivation generates instances for
    all kinds of TypeableK classes; as such we do NOT require the
    GHC-specific generic downkinding instances to provide lower kind
    instances.

    Also creates a @typename_\<the type name\>@ value to hold the
    'TypeRep'.
-}
module Data.Derive.Typeable(makeTypeable) where
{-
import Data.Typeable

test :: Bool
typename_Bool :: TyCon
typename_Bool = mkTyCon3 "package" "Example" "Bool"
instance Typeable Bool where
    typeOf _ = mkTyConApp typename_Bool []

test :: Sample
typename_Sample :: TyCon
typename_Sample = mkTyCon3 "package" "Example" "Sample"
instance Typeable1 Sample where
    typeOf1 _ = mkTyConApp typename_Sample []
instance Typeable a => Typeable (Sample a) where
    typeOf = typeOfDefault

test :: Either
typename_Either :: TyCon
typename_Either = mkTyCon3 "package" "Example" "Either"
instance Typeable2 Either where
    typeOf2 _ = mkTyConApp typename_Either []
instance Typeable a => Typeable1 (Either a) where
    typeOf1 = typeOf1Default
instance (Typeable a, Typeable b) => Typeable (Either a b) where
    typeOf = typeOfDefault
-}

import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List

-- based on the macros in: http://darcs.haskell.org/packages/base/include/Typeable.h

{-
#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
tcname = mkTyCon str; \
instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \
instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }

#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
tcname = mkTyCon str; \
instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \
instance Typeable a => Typeable1 (tycon a) where { \
  typeOf1 = typeOf1Default }; \
instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
  typeOf = typeOfDefault }

#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
tcname = mkTyCon str; \
instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \
instance Typeable a => Typeable2 (tycon a) where { \
  typeOf2 = typeOf2Default }; \
instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \
  typeOf1 = typeOf1Default }; \
instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \
  typeOf = typeOfDefault }
-}


makeTypeable :: Derivation
makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x


mkTypeable :: String -> DataDecl -> [Decl]
mkTypeable modu d =
    [TypeSig sl [name fun] (tyCon "TyCon")] ++
    [PatBind sl (pVar fun) (UnGuardedRhs bod) (BDecls []) |
        let bod = apps (var "mkTyCon3") [Lit $ String "package", Lit $ String modu, Lit $ String nam]] ++
    [inst [] (showN n) [tyCon nam] [PWildCard] $ apps (var "mkTyConApp") [var fun, List []]] ++
    [inst [ClassA (qname "Typeable") [v] | v <- tvs] i [TyParen $ tyApp (tyCon nam) tvs] [] $ var $ "typeOf" ++ i ++ "Default"
        | (vs,i) <- zip (tail $ inits $ dataDeclVars d) $ map showN [n-1,n-2..]
        , let tvs = map tyVar vs]
    where
        nam = dataDeclName d
        fun = "typename_" ++ nam
        n = length $ dataDeclVars d


inst ctxt n typ pat expr =
    InstDecl sl Nothing [] ctxt (qname $ "Typeable" ++ n) typ
        [InsDecl $ bind ("typeOf" ++ n) pat expr]

showN 0 = ""
showN n = show n