{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
module Database.Squiggle.MkInstances where

import Database.Squiggle.Types

import Data.List
import Language.Haskell.TH

mkInstances :: Name -> Q [Dec]
mkInstances t =
  do
     TyConI (DataD _ tname [param] [RecC dname typs] _) <- reify t

     let paramName = case param of
                      PlainTV n -> n
                      KindedTV n _ -> n

     -- These names need to be exported to the user at least until
     -- the ProdEnc instance can be produced automatically
     fromFunName <- (return . mkName) ("from" ++ nameBase tname)
     toFunName <- (return . mkName) ("to" ++ nameBase tname)
     typeName <- (return . mkName) ("ProdEnc" ++ nameBase tname)

     vars <- mapM (\(field, _, _) -> newName (nameBase field)) typs

     dvar <- newName "d"

     let recordP = RecP dname [(field, VarP var) | ((field, _, _), var) <- zip typs vars]

     return $ 
            [FunD fromFunName [Clause [recordP]
                                      (NormalB (foldr (\n e -> TupE [VarE n, e]) (ConE '()) vars))
                                      []
                              ],
             FunD toFunName [Clause [foldr (\n p -> TupP [VarP n, p]) (ConP '() []) vars]
                                    (NormalB (RecConE dname [(field, VarE var) | ((field, _, _), var) <- zip typs vars]))
                                    []
                            ],
             TySynD typeName
                    [param]
                    (AppT (ConT ''ProdEnc) (foldr (\(field, _, typ) tup ->
                                                   AppT (AppT (TupleT 2) typ) tup) (ConT ''()) typs))
            ] ++
            [InstanceD []
                       (AppT (AppT cls (AppT (ConT tname) con)) (AppT (ConT tname) (func arg)))
                       [] | (cls, arg) <- [(AppT (ConT ''HasSql) (VarT paramName), VarT paramName),
                                           (ConT ''HasSqlExpr, ConT ''SqlExpr),
                                           (ConT ''HasSqlFields, ConT ''SqlFields)],
                            (con, func) <- [(ConT ''Id, id),
                                            (ConT ''Maybe, \t -> AppT (AppT (ConT ''Comp) t) (ConT ''Maybe))]
            ]
            ++
            [InstanceD [ClassP ''SqlConstr [VarT paramName]]
                       (AppT (ConT ''Show) (AppT (ConT tname) (VarT paramName)))
                       [FunD 'showsPrec
                             [Clause [VarP dvar, recordP]
                                     (NormalB
                                        $ AppE (AppE (VarE 'showParen)
                                                     (InfixE (Just (VarE dvar)) (VarE '(Prelude.>)) (Just (LitE (IntegerL 0)))))
                                        $ foldr1 (\a b -> InfixE (Just a) (VarE '(.)) (Just b))
                                        $ [ AppE (VarE 'showString) (LitE (StringL (nameBase dname ++ " {"))) ] ++
                                          concat
                                            (intersperse [ AppE (VarE 'showString) (LitE (StringL ", ")) ] 
                                                 [ [ AppE (VarE 'showString) (LitE (StringL (nameBase field ++ " = "))),
                                                     AppE (AppE (VarE 'showsPrec) (LitE (IntegerL 0))) (VarE var) ]
                                                       | ((field, _, _), var) <- zip typs vars ]) ++
                                          [ AppE (VarE 'showString) (LitE (StringL " }")) ]
                                     )
                                     []
                             ]
                       ]
            ]

printout :: Show x => Q x -> Q x
printout dq =
  do x <- dq
     runIO $ print x
     return x