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

-- | Declares serveral templates for comfortable instance derivation
module Text.Chatty.Interactor.Templates (mkScanner, mkPrinter, mkFinalizer, mkExpander,mkInteractor,mkSpawn,mkRandom,mkClock,mkChatty) where

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

-- | Automatically derives a MonadScanner instance for you.
mkScanner :: Name -> Q [Dec]
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

-- | Automatically derives a MonadPrinter and an ExtendedPrinter instance for you.
mkPrinter :: Name -> Q [Dec]
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

-- | Automatically derives a MonadFinalizer instance for you.
mkFinalizer :: Name -> Q [Dec]
mkFinalizer s = [d|
    instance MonadFinalizer m => MonadFinalizer ($sx m) where
      mqfh = lift . mqfh
      mfin = lift mfin
  |]               
  where sx = strToType s

-- | Automatically derives a MonadExpand and an ExpanderEnv instance for you.
mkExpander :: Name -> Q [Dec]
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

-- | Automatically derives a MonadSpawn instance for you.
mkSpawn :: Name -> Q [Dec]
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

-- | Automatically derives a MonadRandom instance for you.
mkRandom :: Name -> Q [Dec]
mkRandom s = [d|
    instance MonadRandom m => MonadRandom ($sx m) where
      mrandom = lift mrandom
      mrandomR = lift . mrandomR
  |]            
  where sx = strToType s

-- | Automatically derives a MonadClock instance for you.
mkClock :: Name -> Q [Dec]
mkClock s = [d|
    instance MonadClock m => MonadClock ($sx m) where
      mutctime = lift mutctime
      mgetstamp = lift mgetstamp
  |]           
  where sx = strToType s

-- | Automatically derives all chatty typeclasses for you.
mkChatty :: Name -> Q [Dec]
mkChatty s = mkInteractor s mkPrinter mkScanner mkFinalizer mkExpander mkSpawn mkRandom mkClock

-- | Just a helper class for mkInteractor
class InteractorMaker i where
  mkInteractor' :: Name -> Q [Dec] -> i
  -- | mkInteractor takes a type name and a list of typeclass derivers and applies them all.
  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))