Templates.hs

{-# 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,mkBufferedScanner) where

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 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 ChScanner instance for you.
mkScanner :: Name -> Q [Dec]
mkScanner 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 = strToType s

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

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

-- | Automatically derives an ChExtendedPrinter instance for you.
mkExtendedPrinter :: Name -> Q [Dec]
mkExtendedPrinter 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 = strToType s

-- | Automatically derives a ChChannelPrinter instance for you.
mkChannelPrinter :: Name ->  Name -> Q [Dec]
mkChannelPrinter c 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 = 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 ChChannelPrinter 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 ChFinalizer instance for you.
mkFinalizer :: Name -> Q [Dec]
mkFinalizer s = [d|
    instance ChFinalizer m => ChFinalizer ($sx m) where
      mqfh = lift . mqfh
      mfin = lift mfin
  |]               
  where sx = strToType s

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

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

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

-- | Automatically derives a ChSpawn instance for you.
mkSpawn :: Name -> Q [Dec]
mkSpawn s = [d|
    instance ChSpawn m => ChSpawn ($sx m) where
      mspw pn as si = lift $ mspw pn as si
      mah = lift . mah
  |]
  where sx = strToType s

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

-- | Automatically derives a ChClock instance for you.
mkClock :: Name -> Q [Dec]
mkClock s = [d|
    instance ChClock m => ChClock ($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
  mkBufferedScanner
--  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))