{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleInstances #-}

module Chatty.Interactor.Templates (mkScanner, mkPrinter, mkFinalizer, mkExpander,mkInteractor,mkSpawn,mkRandom,mkClock) where

import Chatty.Scanner
import Chatty.Printer
import Chatty.Finalizer
import Chatty.Expansion
import Chatty.Spawn
import Chatty.Extended.Printer
import Control.Monad
import Control.Monad.Trans
import Language.Haskell.TH
import Chatty.Templates
import Chatty.Misc

mkScanner s = [d|
    instance MonadScanner m => MonadScanner ($sx m) where
      mscan1 = lift mscan1
      mscanL = lift mscanL
      mscannable = lift mscannable
      mscanh = lift mscanh
      mready = lift mready
  |]
  where sx = strToType s

mkPrinter s = [d|
    instance MonadPrinter m => MonadPrinter ($sx m) where
      mprint = lift . mprint
      mnoecho = lift . mnoecho
      mflush = lift mflush
    instance ExtendedPrinter m => ExtendedPrinter ($sx m) where
      estart = lift . estart
      efin = lift efin
      eprint c = lift . eprint c
      eprintLn c = lift . eprintLn c
  |]             
  where sx = strToType s

mkFinalizer s = [d|
    instance MonadFinalizer m => MonadFinalizer ($sx m) where
      mqfh = lift . mqfh
      mfin = lift mfin
  |]               
  where sx = strToType s

mkExpander s = [d|
    instance MonadExpand m => MonadExpand ($sx m) where
      expand = lift . expand
    instance ExpanderEnv m => ExpanderEnv ($sx m) where
      mgetv = lift . mgetv
      mputv k v = lift $ mputv k v
  |]
  where sx = strToType s

mkSpawn s = [d|
    instance MonadSpawn m => MonadSpawn ($sx m) where
      mspw pn as si = lift $ mspw pn as si
      mah = lift . mah
  |]
  where sx = strToType s

mkRandom s = [d|
    instance MonadRandom m => MonadRandom ($sx m) where
      mrandom = lift mrandom
      mrandomR = lift . mrandomR
  |]            
  where sx = strToType s

mkClock s = [d|
    instance MonadClock m => MonadClock ($sx m) where
      mutctime = lift mutctime
      mgetstamp = lift mgetstamp
  |]           
  where sx = strToType s

class InteractorMaker i where
  mkInteractor' :: Name -> Q [Dec] -> i
  mkInteractor :: Name -> i
  mkInteractor n = mkInteractor' n [d| |]

instance InteractorMaker (Q [Dec]) where
  mkInteractor' _ = id

instance InteractorMaker i => InteractorMaker ((Name -> Q [Dec]) -> i) where
  mkInteractor' n qs qf = mkInteractor' n (do q1 <- qs; q2 <- qf n; return (q1++q2))