module Text.Chatty.Scanner where
import Text.Chatty.Finalizer
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Trans.Class
import System.IO
class Monad m => ChScanner m where
mscan1 :: m Char
mscanL :: m String
mscannable :: m Bool
mscanh :: m (Maybe Handle)
mscanh = return Nothing
mready :: m Bool
instance ChScanner IO where
mscan1 = getChar
mscanL = getContents
mscannable = fmap not isEOF
mscanh = return $ Just stdin
mready = hReady stdin
instance Monad m => ChScanner (StateT String m) where
mscan1 = do
c <- gets head
modify tail
return c
mscanL = do
s <- get
put []
return s
mscannable = gets (not.null)
mready = return True
newtype HereStringT m a = HereString { runHereStringT :: String -> m (a,String) }
instance Monad m => Monad (HereStringT m) where
return a = HereString $ \s -> return (a,s)
(HereString h) >>= f = HereString $ \s -> do (a,s') <- h s; runHereStringT (f a) s'
instance MonadTrans HereStringT where
lift m = HereString $ \s -> do a <- m; return (a,s)
instance Monad m => Functor (HereStringT m) where
fmap f a = HereString $ \s -> do (a',s') <- runHereStringT a s; return (f a',s')
instance Monad m => Applicative (HereStringT m) where
(<*>) = ap
pure = return
instance Monad m => ChScanner (HereStringT m) where
mscan1 = HereString $ \(s:ss) -> return (s,ss)
mscanL = HereString $ \s -> return (s,[])
mscannable = HereString $ \s -> return (not $ null s,s)
mready = return True
instance MonadIO m => MonadIO (HereStringT m) where
liftIO = lift . liftIO
instance ChFinalizer m => ChFinalizer (HereStringT m) where
mqfh = lift . mqfh
mfin = lift mfin
newtype QuietT m a = Quiet { runQuietT :: m a }
instance Monad m => Monad (QuietT m) where
return = Quiet . return
(Quiet q) >>= f = Quiet $ do q' <- q; runQuietT (f q')
instance MonadTrans QuietT where
lift = Quiet
instance Monad m => ChScanner (QuietT m) where
mscan1 = return undefined
mscanL = return []
mscannable = return False
mready = return False
instance Functor m => Functor (QuietT m) where
fmap f (Quiet a) = Quiet $ fmap f a
instance (Functor m, Monad m) => Applicative (QuietT m) where
(<*>) = ap
pure = return
newtype InRedirT m a = InRedir { runInRedirT' :: Handle -> m (a,Handle) }
type InRedir = InRedirT (HandleCloserT IO)
instance Monad m => Monad (InRedirT m) where
return a = InRedir $ \h -> return (a,h)
(InRedir r) >>= f = InRedir $ \h -> do (a,h') <- r h; runInRedirT' (f a) h'
instance MonadTrans InRedirT where
lift m = InRedir $ \h -> do a <- m; return (a,h)
instance MonadIO m => MonadIO (InRedirT m) where
liftIO = lift . liftIO
instance MonadIO m => ChScanner (InRedirT m) where
mscan1 = InRedir $ \h -> do c <- liftIO $ hGetChar h; return (c,h)
mscanL = InRedir $ \h -> do s <- liftIO $ hGetContents h; return (s,h)
mscannable = InRedir $ \h -> do b <- liftIO $ hIsEOF h; return (b,h)
mscanh = InRedir $ \h -> return (Just h,h)
mready = InRedir $ \h -> do r <- liftIO $ hReady h; return (r,h)
instance Monad m => Functor (InRedirT m) where
fmap f a = InRedir $ \h -> do (a',h') <- runInRedirT' a h; return (f a',h')
instance Monad m => Applicative (InRedirT m) where
(<*>) = ap
pure = return
instance ChFinalizer m => ChFinalizer (InRedirT m) where
mqfh = lift . mqfh
mfin = lift mfin
runInRedirT :: Functor m => InRedirT m a -> Handle -> m a
runInRedirT m h = fmap fst $ runInRedirT' m h
runInRedir :: InRedir a -> Handle -> IO a
runInRedir m h = withLazyIO $ runInRedirT m h
runInRedirFT :: (Functor m,MonadIO m,ChFinalizer m) => InRedirT m a -> FilePath -> m a
runInRedirFT m fp = do
h <- liftIO $ openFile fp ReadMode
a <- runInRedirT m h
mqfh h
return a
runInRedirF :: InRedir a -> FilePath -> IO a
runInRedirF m fp = withLazyIO $ runInRedirFT m fp
mscanLn :: ChScanner m => m String
mscanLn = do
h <- mscan1
if h == '\n' then return ""
else do
hs <- mscanLn
return (h:hs)
mscanN :: ChScanner m => Int -> m String
mscanN n
| n > 0 = do
b <- mscannable
if not b then return []
else do
h <- mscan1
hs <- mscanN (n1)
return (h:hs)
| otherwise = return []
data EmptyI = EmptyI
class RedirectionSource t mt a r | t -> mt, t a -> r where
(.<.) :: (ChFinalizer m,Functor m,MonadIO m,ChScanner (mt m)) => mt m a -> t -> m r
instance RedirectionSource EmptyI QuietT a a where
m .<. _ = runQuietT m
instance RedirectionSource FilePath InRedirT a a where
m .<. fp = runInRedirFT m fp
instance RedirectionSource Handle InRedirT a a where
m .<. fp = runInRedirT m fp
class RedirectionHeredoc t mt a r | t -> mt, t a -> r where
(.<<.) :: (Functor m,ChScanner (mt m)) => mt m a -> t -> m r
instance RedirectionHeredoc String HereStringT a a where
m .<<. str = fmap fst $ runHereStringT m str