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

{-
  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,mkChatty,mkChannelPrinter,mkDefCP,mkArchiver,mkExtendedPrinter,mkBufferedScanner,mkCounter,mkAtoms) where

import Data.Chatty.Atoms
import Data.Chatty.Counter
import Text.Chatty.Scanner
import Text.Chatty.Scanner.Buffered
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 Text.Chatty.Extended.Printer
import Control.Monad
import Control.Monad.Trans
import Language.Haskell.TH
import Text.Chatty.Templates
import System.IO

-- | Automatically derives a ChScanner instance for you.
mkScanner :: Name -> Q [Dec]
mkScanner :: Name -> Q [Dec]
mkScanner Name
s = [d|
    instance ChScanner m => ChScanner ($sx m) where
      mscan1 = lift mscan1
      mscanL = lift mscanL
      mscannable = lift mscannable
      mscanh = lift mscanh
      mready = lift mready
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChBufferedScanner instance for you.
mkBufferedScanner :: Name -> Q [Dec]
mkBufferedScanner :: Name -> Q [Dec]
mkBufferedScanner Name
s = [d|
    instance ChBufferedScanner m => ChBufferedScanner ($sx m) where
      mpeek1 = lift mpeek1
      mprepend = lift . mprepend
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChPrinter instance for you.
mkPrinter :: Name -> Q [Dec]
mkPrinter :: Name -> Q [Dec]
mkPrinter Name
s = [d|
    instance ChPrinter m => ChPrinter ($sx m) where
      mprint = lift . mprint
      mnoecho = lift . mnoecho
      mflush = lift mflush
      mnomask = lift . mnomask
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives an ChExtendedPrinter instance for you.
mkExtendedPrinter :: Name -> Q [Dec]
mkExtendedPrinter :: Name -> Q [Dec]
mkExtendedPrinter Name
s = [d|
    instance ChExtendedPrinter m => ChExtendedPrinter ($sx m) where
      estart = lift . estart
      efin = lift efin
      eprint c = lift . eprint c
      eprintLn c = lift . eprintLn c
  |]             
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChChannelPrinter instance for you.
mkChannelPrinter :: Name ->  Name -> Q [Dec]
mkChannelPrinter :: Name -> Name -> Q [Dec]
mkChannelPrinter Name
c Name
s = [d|
    instance ChChannelPrinter $cx m => ChChannelPrinter $cx ($sx m) where
      cstart = lift . cstart
      cfin = lift . cfin
      cprint c = lift . cprint c
      cthis = lift cthis
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s
        cx :: Q Type
cx = Name -> Q Type
strToType Name
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 ChChannelPrinter instances for 'Int', 'Bool' and 'Handle' channels.
mkDefCP :: Name -> Q [Dec]
mkDefCP :: Name -> Q [Dec]
mkDefCP Name
s = Name
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> Q [Dec]
forall i. InteractorMaker i => Name -> i
mkInteractor Name
s (Name -> Name -> Q [Dec]
mkChannelPrinter ''Int) (Name -> Name -> Q [Dec]
mkChannelPrinter ''Bool) (Name -> Name -> Q [Dec]
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 ChFinalizer instance for you.
mkFinalizer :: Name -> Q [Dec]
mkFinalizer :: Name -> Q [Dec]
mkFinalizer Name
s = [d|
    instance ChFinalizer m => ChFinalizer ($sx m) where
      mqfh = lift . mqfh
      mfin = lift mfin
  |]               
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChExpand instance for you.
mkExpander :: Name -> Q [Dec]
mkExpander :: Name -> Q [Dec]
mkExpander Name
s = [d|
    instance ChExpand m => ChExpand ($sx m) where
      expand = lift . expand
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

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

-- | Automatically derives a ChHistoryEnv instance for you
mkHistoryEnv :: Name -> Q [Dec]
mkHistoryEnv :: Name -> Q [Dec]
mkHistoryEnv Name
s = [d|
    instance ChHistoryEnv m => ChHistoryEnv ($sx m) where
      mcounth = lift mcounth
      mgeth = lift . mgeth
      mputh = lift . mputh
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChCounter instance for you.
mkCounter :: Name -> Q [Dec]
mkCounter :: Name -> Q [Dec]
mkCounter Name
s = [d|
    instance ChCounter m => ChCounter ($sx m) where
      countOn = lift countOn
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s

-- | Automatically derives a ChAtoms instance for you.
mkAtoms :: Name -> Q [Dec]
mkAtoms :: Name -> Q [Dec]
mkAtoms Name
s = [d|
    instance ChAtoms m => ChAtoms ($sx m) where
      putAtom a v = lift $ putAtom a v
      getAtom = lift . getAtom
      dispAtom = lift . dispAtom
  |]
  where sx :: Q Type
sx = Name -> Q Type
strToType Name
s
               
-- | Automatically derives all chatty typeclasses for you.
mkChatty :: Name -> Q [Dec]
mkChatty :: Name -> Q [Dec]
mkChatty Name
s = Name
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> Q [Dec]
forall i. InteractorMaker i => Name -> i
mkInteractor Name
s
  Name -> Q [Dec]
mkPrinter Name -> Q [Dec]
mkScanner Name -> Q [Dec]
mkFinalizer Name -> Q [Dec]
mkExpander
  Name -> Q [Dec]
mkExpanderEnv
  Name -> Q [Dec]
mkHistoryEnv Name -> Q [Dec]
mkDefCP Name -> Q [Dec]
mkExtendedPrinter
  Name -> Q [Dec]
mkBufferedScanner Name -> Q [Dec]
mkCounter Name -> Q [Dec]
mkAtoms

-- | Automatically derives all chatty typeclasses that are sensible for an ArchiverT.
mkArchiver :: Name -> Q [Dec]
mkArchiver :: Name -> Q [Dec]
mkArchiver Name
s = Name
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> (Name -> Q [Dec])
-> Q [Dec]
forall i. InteractorMaker i => Name -> i
mkInteractor Name
s
  Name -> Q [Dec]
mkScanner Name -> Q [Dec]
mkExpander Name -> Q [Dec]
mkExpanderEnv
  Name -> Q [Dec]
mkHistoryEnv Name -> Q [Dec]
mkFinalizer
  Name -> Q [Dec]
mkCounter Name -> Q [Dec]
mkAtoms

-- | 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 Name
n = Name -> Q [Dec] -> i
forall i. InteractorMaker i => Name -> Q [Dec] -> i
mkInteractor' Name
n [d| |]

instance InteractorMaker (Q [Dec]) where
  mkInteractor' :: Name -> Q [Dec] -> Q [Dec]
mkInteractor' Name
_ = Q [Dec] -> Q [Dec]
forall a. a -> a
id

instance InteractorMaker i => InteractorMaker ((Name -> Q [Dec]) -> i) where
  mkInteractor' :: Name -> Q [Dec] -> (Name -> Q [Dec]) -> i
mkInteractor' Name
n Q [Dec]
qs Name -> Q [Dec]
qf = Name -> Q [Dec] -> i
forall i. InteractorMaker i => Name -> Q [Dec] -> i
mkInteractor' Name
n (do [Dec]
q1 <- Q [Dec]
qs; [Dec]
q2 <- Name -> Q [Dec]
qf Name
n; [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
q1[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++[Dec]
q2))