{-# 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 .
-}
-- | 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,mkCounter,mkAtoms,mkFilesys) 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 System.Chatty.Spawn
import System.Chatty.Filesystem
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 a ChCounter instance for you.
mkCounter :: Name -> Q [Dec]
mkCounter s = [d|
instance ChCounter m => ChCounter ($sx m) where
countOn = lift countOn
|]
where sx = strToType s
-- | Automatically derives a ChAtoms instance for you.
mkAtoms :: Name -> Q [Dec]
mkAtoms s = [d|
instance ChAtoms m => ChAtoms ($sx m) where
putAtom a v = lift $ putAtom a v
getAtom = lift . getAtom
dispAtom = lift . dispAtom
|]
where sx = strToType s
-- | Automatically derives instances for ChFilesystem, CanLoad, CanSave, CanMount.
mkFilesys :: Name -> Q [Dec]
mkFilesys s = [d|
instance (ChAtoms ($sx m), ChFilesystem m) => ChFilesystem ($sx m) where
fopen p = do
res <- lift $ fopen p
case res of
NoPermission -> return NoPermission
NotFound -> return NotFound
FSSucc a -> liftM FSSucc $ funAtom a (\a -> File (lift $ loadFun a) (lift $ saveFun a) (leftBehind a) (rightPending a)) (\b a -> b{leftBehind=leftBehind a,rightPending=rightPending a})
fpwd = lift fpwd
fcd = lift . fcd
instance CanLoad m n => CanLoad ($sx m) n where
fload = lift . fload
instance CanSave m n => CanSave ($sx m) n where
fsave = lift . fsave
instance CanMount m n => CanMount ($sx m) n where
fmount = lift . fmount
|]
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 mkCounter mkAtoms
mkFilesys
-- 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 mkCounter mkAtoms
mkFilesys
-- | 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))