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

{-
  This module is part of Chatty.
  Copyleft (c) 2014 Marvin Cohrs

  All wrongs reversed. Sharing is an act of love, not crime.
  Please share Antisplice with everyone you like.

  Chatty is free software: you can redistribute it and/or modify
  it under the terms of the GNU Affero General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Chatty is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  GNU Affero General Public License for more details.

  You should have received a copy of the GNU Affero General Public License
  along with Chatty. If not, see <http://www.gnu.org/licenses/>.
-}

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

import Text.Chatty.Scanner
import Text.Chatty.Printer
import Text.Chatty.Finalizer
import Text.Chatty.Expansion
import Text.Chatty.Expansion.Vars
import Text.Chatty.Expansion.History
import Text.Chatty.Channel.Printer
import Text.Chatty.Channel.Broadcast
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
import System.IO

-- | 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 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
      mnomask = lift . mnomask
  |]
  where sx = strToType s

-- | Automatically derives an ExtendedPrinter instance for you.
mkExtendedPrinter :: Name -> Q [Dec]
mkExtendedPrinter s = [d|
    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 ChannelPrinter instance for you.
mkChannelPrinter :: Name ->  Name -> Q [Dec]
mkChannelPrinter c s = [d|
    instance ChannelPrinter $cx m => ChannelPrinter $cx ($sx m) where
      cstart = lift . cstart
      cfin = lift . cfin
      cprint c = lift . cprint c
      cthis = lift cthis
  |]
  where sx = strToType s
        cx = strToType c

{-- | Automatically derives a Broadcaster instance for you.
mkBroadcaster :: Name -> Name -> Q [Dec]
mkBroadcaster c s = [d|
    instance Broadcaster $cx m => Broadcaster $cx ($sx m) where
      bprint b = lift . bprint (lift . b)
    instance BroadcasterBracket $cx m => BroadcasterBracket $cx ($sx m) where
      bstart b = lift $ bstart (lift . b)
      bfin b = lift $ bfin (lift . b)
  |]
  where sx = strToType s
        cx = strToType c-}

-- | Automatically derives ChannelPrinter instances for 'Int', 'Bool' and 'Handle' channels.
mkDefCP :: Name -> Q [Dec]
mkDefCP s = mkInteractor s (mkChannelPrinter ''Int) (mkChannelPrinter ''Bool) (mkChannelPrinter ''Handle)

{-- | Automatically derives Broadcaster instances for 'Int', 'Bool' and 'Handle' channels
mkDefBC :: Name -> Q [Dec]
mkDefBC s = mkInteractor s (mkBroadcaster ''Int) (mkBroadcaster ''Bool) (mkBroadcaster ''Handle)-}

-- | 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 instance for you.
mkExpander :: Name -> Q [Dec]
mkExpander s = [d|
    instance MonadExpand m => MonadExpand ($sx m) where
      expand = lift . expand
  |]
  where sx = strToType s

-- | Automatically derives an ExpanderEnv instance for you
mkExpanderEnv :: Name -> Q [Dec]
mkExpanderEnv s = [d|
    instance ExpanderEnv m => ExpanderEnv ($sx m) where
      mgetv = lift . mgetv
      mputv k v = lift $ mputv k v
  |]
  where sx = strToType s

-- | Automatically derives a HistoryEnv instance for you
mkHistoryEnv :: Name -> Q [Dec]
mkHistoryEnv s = [d|
    instance HistoryEnv m => HistoryEnv ($sx m) where
      mcounth = lift mcounth
      mgeth = lift . mgeth
      mputh = lift . mputh
  |]
  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 mkExpanderEnv
  mkHistoryEnv mkDefCP mkExtendedPrinter
--  mkDefBC

-- | Automatically derives all chatty typeclasses that are sensible for an ArchiverT.
mkArchiver :: Name -> Q [Dec]
mkArchiver s = mkInteractor s
  mkScanner mkExpander mkExpanderEnv
  mkHistoryEnv mkFinalizer 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))