{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}

module Text.Chatty.Scanner where

import Text.Chatty.Finalizer
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Trans.Class
import System.IO

-- | A typeclass for all monads that may read input.
class Monad m => MonadScanner m where
  -- | Read one single character
  mscan1 :: m Char
  -- | Lazily read all the input.
  mscanL :: m String
  -- | Input readable? (not EOF)
  mscannable :: m Bool
  -- | Return FD handle, if available
  mscanh :: m (Maybe Handle)
  mscanh = return Nothing
  -- | Input available yet?
  mready :: m Bool

-- MonadScanner instance for: IO
instance MonadScanner IO where
  mscan1 = getChar
  mscanL = getContents
  mscannable = fmap not isEOF
  mscanh = return $ Just stdin
  mready = hReady stdin

-- MonadScanner instance for: StateT String
instance Monad m => MonadScanner (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

-- Definition of HereStringT + instances
-- | HereStringT holds a given string and uses it as input for the function
-- (much like here-strings in the shell)
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 => MonadScanner (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 MonadFinalizer m => MonadFinalizer (HereStringT m) where
  mqfh = lift . mqfh
  mfin = lift mfin

-- Definition of QuietT + instances
-- | QuietT does not convey any input (much like </dev/null in the shell)
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 => MonadScanner (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

-- Definition of InRedirT + instances
-- | InRedirT redirects all input to a given handle (much like <filename in the shell)
newtype InRedirT m a = InRedir { runInRedirT' :: Handle -> m (a,Handle) }
-- | InRedirT on an IO monad
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 => MonadScanner (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 MonadFinalizer m => MonadFinalizer (InRedirT m) where
  mqfh = lift . mqfh
  mfin = lift mfin

-- | Run InRedirT with handle
runInRedirT :: Functor m => InRedirT m a -> Handle -> m a
runInRedirT m h = fmap fst $ runInRedirT' m h

-- | Run InRedir with handle
runInRedir :: InRedir a -> Handle -> IO a
runInRedir m h = withLazyIO $ runInRedirT m h

-- | Run InRedirT with a filename
runInRedirFT :: (Functor m,MonadIO m,MonadFinalizer m) => InRedirT m a -> FilePath -> m a
runInRedirFT m fp = do
  h <- liftIO $ openFile fp ReadMode
  a <- runInRedirT m h
  mqfh h
  --liftIO $ hClose h
  return a

-- | Run InRedir with a filename
runInRedirF :: InRedir a -> FilePath -> IO a
runInRedirF m fp = withLazyIO $ runInRedirFT m fp

-- | Line-scanning alternative to mscan1/L
mscanLn :: MonadScanner m => m String
mscanLn = do
  h <- mscan1
  if h == '\n' then return ""
               else do
                 hs <- mscanLn
                 return (h:hs)

-- | Scan a fixed number of chars
mscanN :: MonadScanner m => Int -> m String
mscanN n
  | n > 0 = do
    b <- mscannable
    if not b then return []
             else do
               h <- mscan1
               hs <- mscanN (n-1)
               return (h:hs)
  | otherwise = return []

-- Shell-like syntax
-- | Redirection source that does not provide any output
data EmptyI = EmptyI
-- | Class for all primitive redirection sources.
class RedirectionSource t mt a r | t -> mt, t a -> r where
  -- | Redirection
  (.<.) :: (MonadFinalizer m,Functor m,MonadIO m,MonadScanner (mt m)) => mt m a -> t -> m a
instance RedirectionSource EmptyI QuietT a a where
  m .<. _ = runQuietT m
instance RedirectionSource FilePath InRedirT a a where
  m .<. fp = runInRedirFT m fp
-- | Class for all Here-Documents
class RedirectionHeredoc t mt a r | t -> mt, t a -> r where
  -- | Redirection
  (.<<.) :: (Functor m,MonadScanner (mt m)) => mt m a -> t -> m a
instance RedirectionHeredoc String HereStringT a a where
  m .<<. str = fmap fst $ runHereStringT m str