{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- | Provides template Haskell code to generate instances for JavaScript
--   object wrappers (<https://github.com/ku-fpg/sunroof-compiler/wiki/JSObject-Wrapper-Types>).
module Language.Sunroof.TH
  ( deriveJSTuple
  ) where

import Language.Haskell.TH
import Language.Sunroof.Types as SRT
import Language.Sunroof.Classes
import Language.Sunroof.JS.Object
import Language.Sunroof.JS.Bool
import Data.Boolean

-- | @derive@ derives an incomplete instance for @JSTuple@,
-- as well as completing other classes.
--
-- you write the newtype explictly, and @derive@ does the rest.
--
-- > newtype JSX o = JSX JSObject
--
-- and then the start of the JSTuple instance, and the rest gets filled in
--
-- > derive [d| instance (SunroofArgument o) => JSTuple (JSX o) where
-- >                type Internals (JSX o) = (JSString,JSNumber)
-- >        |]
--
-- generates
--
-- > instance (SunroofArgument o) => Show (JSX o) where
-- >    show (JSX o) = show o
-- >
-- > instance (SunroofArgument o) => Sunroof (JSX o) where
-- >    unbox (JSX o) = unbox o
-- >    box o = JSX (box o)
-- >
-- > instance (SunroofArgument o) => IfB (JSX o) where
-- >    ifB = jsIfB
-- >
-- > type instance BooleanOf (JSX o) = JSBool
-- >
-- > instance (SunroofArgument o) => JSTuple (JSX o) where
-- >    type instance Internals (JSX o) = (JSString, JSNumber)
-- >    match o = (o ! attr "f1", o ! attr "f2")
-- >    tuple (v1,v2) = do
-- >        o <- new "Object" ()
-- >        o # attr "f1" := v1
-- >        o # attr "f2" := v2
-- >        return (JSX o)
deriveJSTuple :: Q [Dec] -> Q [Dec]
deriveJSTuple decsQ = do
        decs <- decsQ
        fmap concat $ mapM complete decs
  where
        complete :: Dec -> Q [Dec]
        complete (InstanceD cxt' (AppT (ConT typeClass) ty) decls) = do
                -- Unused: let k decls' = InstanceD cxt' hd (decls ++ decls')
                let findClass (ConT t) = t
                    findClass (AppT t1 _) = findClass t1
                    findClass _ =  error $ "strange instance head found in derive " ++ show ty
                let tConTy = findClass ty
                -- Next, find the type instance
                let internalTy = case decls of
                        [TySynInstD tyFun [_arg] internalTy] | tyFun == ''Internals -> internalTy
                        _  -> error $ "can not find usable type instance inside JSTuple"
                let findInternalStructure (TupleT _n) ts = do
                        vs <- sequence [ newName "v" | _ <- ts ]
                        return (TupE,TupP [ VarP v | v <- vs], vs `zip` [ "f" ++ show i | (i::Int) <- [1..]])
                    findInternalStructure (AppT t1 t2) ts = findInternalStructure t1 (t2 : ts)
                    findInternalStructure (ConT v) ts = do
                            info <- reify v

                            case info of
                              TyConI (DataD [] _ _ [NormalC internalCons args] []) -> do
                                vs <- sequence [ newName "v" | _ <- args ]
                                return ( foldl AppE (ConE internalCons)
                                       , ConP internalCons [ VarP v | v <- vs]
                                       , vs `zip` [ "f" ++ show i | (i::Int) <- [1..]]
                                       )
                              TyConI (NewtypeD [] _ _ (NormalC internalCons args) []) -> do
                                vs <- sequence [ newName "v" | _ <- args ]
                                return ( foldl AppE (ConE internalCons)
                                       , ConP internalCons [ VarP v | v <- vs]
                                       , vs `zip` [ "f" ++ show i | (i::Int) <- [1..]]
                                       )
                              TyConI (DataD [] _ _ [RecC internalCons args] []) -> do
                                vs <- sequence [ newName "v" | _ <- args ]
                                return ( foldl AppE (ConE internalCons)
                                       , ConP internalCons [ VarP v | v <- vs]
                                       , vs `zip` [ nameBase x | (x,_,_) <- args ]
                                       )

                              _o -> error $ "can not find internal structure of cons " ++ show (v,ts,info)
                    findInternalStructure o ts = error $ "can not find internal structure of type " ++ show (o,ts)

                (builder :: [Exp] -> Exp,unbuilder :: Pat, vars :: [(Name,String)]) <- findInternalStructure internalTy []

                -- Now work with the tConTy, to get the tCons
                info <- reify tConTy
                let tCons = case info of
                      TyConI (NewtypeD _ _ _ (NormalC tCons [(NotStrict,ConT o)]) [])
                        | o /= ''JSObject -> error $ "not newtype of JSObject"
                        | typeClass /= ''JSTuple -> error $ "not instance of JSTuple" ++ show (tConTy,''JSTuple)
                        | otherwise -> tCons
                      _ -> error $ "strange info for newtype type " ++ show info

                o <- newName "o"
                n <- newName "n"

                return [ InstanceD cxt' (AppT (ConT ''Show) ty)
                           [ FunD 'show
                              [ Clause [ConP tCons [VarP o]]
                                         (NormalB (AppE (VarE 'show) (VarE o))) []]]
                       , InstanceD cxt' (AppT (ConT ''Sunroof) ty)
                           [ FunD 'box
                              [ Clause [VarP n] (NormalB (AppE (ConE tCons)
                                                               (AppE (VarE 'box) (VarE n)))) []]
                          , FunD 'unbox
                              [ Clause [ConP tCons [VarP o]]
                                                (NormalB (AppE (VarE 'unbox) (VarE o))) []]
                           ]
                       , InstanceD cxt' (AppT (ConT ''IfB) ty)
                              [ ValD (VarP 'ifB) (NormalB (VarE 'jsIfB)) [] ]
                       , TySynInstD ''BooleanOf [ty] (ConT ''JSBool)
                       , InstanceD cxt' (AppT (ConT ''JSTuple) ty) $ decls ++
                           [ FunD 'SRT.match
                              [Clause [VarP o] (NormalB (builder
                                  [ AppE (AppE (VarE $ mkName "!") (VarE o))
                                         (AppE (VarE 'attr) (LitE $ StringL $ s))
                                  | (_,s) <- vars ])) []]
                           , FunD 'SRT.tuple
                              [ Clause [unbuilder] (NormalB (DoE (
                                        [ BindS (VarP o) (AppE (AppE (VarE 'new) (LitE $ StringL $ "Object")) (TupE []))
                                        ] ++
                                        [ NoBindS $
                                          let assign = AppE (AppE (ConE $ mkName ":=")
                                                                  (AppE (VarE 'attr) (LitE $ StringL $ s)))
                                                            (VarE v)

                                          in  AppE (AppE (VarE $ mkName "#")
                                                         (VarE o))
                                                   (assign)
                                        | (v,s) <- vars
                                        ] ++
                                        [ NoBindS $ AppE (VarE 'return) (AppE (ConE tCons) (VarE o))
                                        ]))) []
                              ]
                           ]
                       ]
        complete _ = error "need instance declaration for derivation of JSTuple."