{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}

-- | Derivation for the 'Data.Generics.Basics.Data' class, as
-- described in the Scrap Your Boilerplate paper.  No type structure
-- is abstracted

module Data.Derive.Data(makeData) where

import Language.Haskell.TH.All


#ifdef GUESS

import Data.Generics
import Data.DeriveGuess

instance Typeable (DataName a) where

example = (,) "Data" [d|

    instance (Data a, Typeable a) => Data (DataName a) where
        gfoldl k r CtorZero = r CtorZero
        gfoldl k r (CtorOne x1) = r CtorOne `k` x1
        gfoldl k r (CtorTwo x1 x2) = r CtorTwo `k` x1 `k` x2
        gfoldl k r (CtorTwo' x1 x2) = r CtorTwo' `k` x1 `k` x2
    |]

#endif

{- GHC autogenerated instance:
instance (Data a, Data b) => Data (T a b) where
     gfoldl k z (C1 a b) = z C1 `k` a `k` b
     gfoldl k z C2       = z C2

     gunfold k z c = case constrIndex c of
                         1 -> k (k (z C1))
                         2 -> z C2

     toConstr (C1 _ _) = con_C1
     toConstr C2       = con_C2

     dataTypeOf _ = ty_T

 con_C1 = mkConstr ty_T "C1" [] Prefix
 con_C2 = mkConstr ty_T "C2" [] Prefix
 ty_T   = mkDataType "Module.T" [con_C1, con_C2]
-}

makeData :: Derivation
makeData = derivation genDataInst "Data"

genDataInst :: DataDef -> [Dec]
genDataInst dat = [
      instance_context ["Data","Typeable"] "Data" dat 
      [ FunD (mkName "gfoldl") (gfoldlDefs dat),
        FunD (mkName "gunfold") (gunfoldDefs dat),
        FunD (mkName "toConstr") (toConstrDefs dat),
        FunD (mkName "dataTypeOf") (dataTypeOfDefs dat) ]
    ]
toConstrDefs :: DataDef -> [Clause]
toConstrDefs dat = map toConstrImpl (zip [(1::Integer)..] (dataCtors dat)) where
    toConstrImpl (ctorInd,ctor) = Clause [toConstrParams ctor] (toConstrDef ctorInd ctor) []
    toConstrParams ctor = AsP (mkName "ctor") (matchConstructor ctor)
    toConstrDef ind _ctor = NormalB $ 
        app (varExpr "indexConstr")
            [ AppE  (varExpr "dataTypeOf") (varExpr "ctor"), lit ind ]
dataTypeOfDefs :: DataDef -> [Clause]
dataTypeOfDefs dat = [Clause dtOfParams dtOfDef dtOfClauses] where
    dtOfParams = [WildP]
    dtOfDef = NormalB $ varExpr "ty_T"
    dtOfClauses = (mkDt (dataCtors dat)) : map mkCon (zip [(1::Integer)..] (dataCtors dat))
    mkCon (ix,ctor) = FunD (mkName $ "con_C"++show ix) [Clause [] (NormalB (mkConImpl ix ctor)) []] 
    mkConImpl _ix ctor = app (varExpr "mkConstr") 
        [varExpr "ty_T", lit (ctorName ctor), ListE (fields ctor), ConE (mkName "Prefix") ]
    fields = map lit . ctorFields
    mkDt ctors = FunD (mkName "ty_T") [Clause [] (NormalB (mkDtImpl ctors)) []]
    mkDtImpl ctors = app (varExpr "mkDataType") [lit (show$ qualifiedDataName dat) , mkConVars ctors]
    mkConVars ctors = ListE $ map (\ix -> varExpr ("con_C"++show ix)) [(1::Int)..(length ctors)]
gfoldlDefs :: DataDef -> [Clause]
gfoldlDefs dat = map gfoldlImpl (zip [(1::Integer)..] (dataCtors dat)) where
    gfoldlImpl (_ctorInd,ctor) = Clause (gfoldlParams ctor) (gfoldlDef ctor) []
    gfoldlParams ctor = [ VarP (mkName "k"), VarP (mkName "r"), matchConstructor ctor ]
    gfoldlDef ctor = NormalB $ foldr1With (varExpr "k") foldFields where
        foldFields =    map (\field -> (varExpr ("x" ++ show field))) (reverse [1..ctorArity ctor])
                     ++ [ (AppE (varExpr "r") (ConE (mkName (ctorName ctor)))) ]
gunfoldDefs :: DataDef -> [Clause]
gunfoldDefs dat = [Clause guParams (NormalB guDef) []] where
    guParams = map (VarP . mkName) ["k","z","c"]
    guDef     = CaseE (AppE (varExpr "constrIndex") (varExpr "c")) $
                  map (guCase) (zip [(1::Integer)..] (dataCtors dat))
    guCase (ix,ctor) = Match (LitP (IntegerL ix)) (NormalB$ guCaseBody ctor) []
    guCaseBody ctor = foldr (\_ e -> AppE (varExpr "k") e)
                           (AppE (varExpr "z") (ConE . mkName . ctorName $ ctor))
                           [1..ctorArity ctor]
varExpr :: String -> Exp
varExpr = VarE . mkName
matchConstructor :: CtorDef -> Pat
matchConstructor ctor = ConP (mkName (ctorName ctor)) (fields++[]) where
    fields = map (\field -> (VarP (mkName ("x" ++ show field))))
                 (id [1..ctorArity ctor])