{-# language TemplateHaskell #-}
{-# language FlexibleContexts #-}
{-# language DataKinds #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
{-# language RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

{-

MVC utilities

-}

module MVC.Util where


import MVC.Binary
import           Data.Time.Extended
import           Pipes.Extended

import           Control.Applicative
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async
import           Control.Concurrent.STM
import qualified Control.Foldl as L
import           Control.Lens
import           Control.Monad
import           Control.Monad.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.Attoparsec.ByteString.Char8 as AC
import           Data.Binary
import           Data.ByteString.Builder
import qualified Data.ByteString.Char8 as C
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Foldable as F
import           Data.IORef
import           Data.Maybe
import           MVC
import qualified MVC.Prelude as MVC
import           MVC.Updates as MVC
-- import           Pipes.Binary
import qualified Pipes.ByteString as PB
import qualified Pipes.Prelude as Pipes
import           System.IO as IO

-- * Views and Controllers
-- ByteString versions of Controllers
outBuildStamped :: FilePath -> (a -> Builder) -> Managed (View a)
outBuildStamped f b = do
    h <- MVC.outHandle f
    return (asSink (\x -> do
                        t <- getCurrentTime
                        let bs = bUTCTime t <> charUtf8 ',' <> b x
                        Lazy.hPut h . toLazyByteString $ bs))

outBinaryStamped :: Binary a => FilePath -> Managed (View a)
outBinaryStamped f = do
    h <- managed (IO.withBinaryFile f IO.WriteMode)
    return $ asSink $ \x -> do
        t <- getCurrentTime
        Lazy.hPut h (Data.Binary.encode (t,x))

outBinaryStampedAppend :: Binary a => FilePath -> Managed (View a)
outBinaryStampedAppend f = do
    h <- managed (IO.withBinaryFile f IO.AppendMode)
    return $ asSink $ \x -> do
        t <- getCurrentTime
        Lazy.hPut h (Data.Binary.encode (t,x))


-- builder views
buildV :: (Show a) => (a -> Builder) -> (Builder -> IO ()) -> Managed (View a)
buildV b sink = return (asSink (sink . b))

buildFile :: Show a => (a -> Builder) -> FilePath -> Managed (View a)
buildFile b f = do
        h <- MVC.outHandle f
        buildV b (hPutBuilder h) 

-- IORef view (most recent first)
ioRefView :: IORef [a] -> Managed (View a)
ioRefView ref = return (asSink (\x -> modifyIORef ref (x:)))

-- parser controllers
stdinParsed :: (Show a) => AC.Parser a -> Managed (Controller a)
stdinParsed parser = MVC.producer (bounded 1) $
                Pipes.stdinLn >->
                Pipes.map (AC.parseOnly parser . C.pack) >->
                eitherP

stdinParsed' :: (Show a) => AC.Parser a -> Managed (Controller (Either String a))
stdinParsed' parser = MVC.producer (bounded 1) $
                Pipes.stdinLn >->
                Pipes.chain (\x -> putStrLn (">>>"<>x)) >->
                Pipes.map (AC.parseOnly parser . C.pack)


maybeRead :: (Read a) => String -> Maybe a
maybeRead = fmap fst . listToMaybe . filter (Prelude.null . snd) . reads 

-- recorder modifiers
record :: (Show a) => FilePath -> Managed (Controller a) -> Managed (Controller a)
record filePath mc = do
    h <- MVC.outHandle filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ . IO.hPrint

recordBuild :: (Show a) => FilePath -> (a -> Builder) -> Managed (Controller a) -> Managed (Controller a)
recordBuild filePath b mc = do
    h <- MVC.outHandle filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ . (.b) . hPutBuilder

recordBinary :: (Binary a) => FilePath -> Managed (Controller a) -> Managed (Controller a)
recordBinary filePath mc = do
    h <- outHandleBinary filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ . (.Data.Binary.encode) . Lazy.hPut

recordBinaryAppend :: (Binary a) => FilePath -> Managed (Controller a) -> Managed (Controller a)
recordBinaryAppend filePath mc = do
    h <- outHandleBinaryAppend filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ . (.Data.Binary.encode) . Lazy.hPut

{-
The first event (Nothing) is useful as a time start for the app
-}
recordStamp :: (Show a) => FilePath -> Managed (Controller a) -> Managed (Controller a)
recordStamp filePath mc = do
    h <- MVC.outHandle filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . (\h x -> do
                                     t <- getCurrentTime
                                     IO.hPrint h (t,x))

recordStampBuild :: (Show a) => FilePath -> (a -> Builder) -> Managed (Controller a) -> Managed (Controller a)
recordStampBuild filePath b mc = do
    h <- MVC.outHandle filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ .
                   (\h x -> do
                        t <- getCurrentTime
                        hPutBuilder h (bUTCTime t <> charUtf8 ',' <> b x))

recordBinaryStamped :: (Binary a) => FilePath -> Managed (Controller a) -> Managed (Controller a)
recordBinaryStamped filePath mc = do
    h <- MVC.outHandle filePath
    keeps _Just <$> (updates unbounded . recordToFile h . on L.last) mc
  where
    recordToFile = MVC.listen . F.mapM_ .
                   (\h x -> do
                        t <- getCurrentTime
                        Lazy.hPut h (Data.Binary.encode (t,x)))

-- conditional outShow
outShowStamped :: (Show a) => FilePath -> Managed (View a)
outShowStamped filePath = do
    handle <- MVC.outHandle filePath
    return $ asSink $ stamp >=> IO.hPrint handle

-- conditional outShow
outShowCond :: (Show a) => (a -> Bool) -> FilePath -> Managed (View a)
outShowCond cond filePath = do
    handle <- MVC.outHandle filePath
    return (asSink (\a -> when (cond a) (IO.hPrint handle a)))


-- show every x secs
outTick :: (Show a) => a -> Double -> Managed (View a)
outTick start t = managed $ \k -> do
    (o,i) <- spawn (latest start)
    let io = forever $ do
            threadDelay (truncate (t * 1000000))
            r <- atomically $ recv i
            F.mapM_ print r
    withAsync io $ \_ -> k (asSink $ atomically . void . send o)

outTickString :: String -> Double -> Managed (View String)
outTickString start t = managed $ \k -> do
    (o,i) <- spawn (latest start)
    let io = forever $ do
            threadDelay (truncate (t * 1000000))
            r <- atomically $ recv i
            F.mapM_ putStrLn r
    withAsync io $ \_ -> k (asSink $ atomically . void . send o)


-- | a service that passes messages from Out back to In
feedback :: Managed (View a, Controller a)
feedback = managed $ \k -> do
    (o, i, seal) <- spawn' (bounded 1)
    let v a = void $ atomically $ MVC.send o a
    k (asSink v, asInput i) <* atomically seal

feedbackMaybe :: (a -> Maybe b) -> Managed (View a, Controller b)
feedbackMaybe f = managed $ \k -> do
    (o, i, seal) <- spawn' (bounded 1)
    let v a = F.forM_ (f a) (void . atomically . MVC.send o)
    k (asSink v, asInput i) <* atomically seal

feedbackMaybeM :: (a -> IO (Maybe b)) -> Managed (View a, Controller b)
feedbackMaybeM f = managed $ \k -> do
    (o, i, seal) <- spawn' (bounded 1)
    let v a = do
          b <- f a
          F.forM_ b (void . atomically . MVC.send o)
    k (asSink v, asInput i) <* atomically seal

delayTimed :: Pipe (UTCTime, a) a IO r
delayTimed = do
    (t0, a0) <- await
    yield a0
    delay t0
  where
    delay t' = do
        (t,a) <- await
        let gap = max 0 $ diffUTCTime t t'
        liftIO (threadDelay (truncate (gap * 1000000)))
        yield a
        delay t

inReadTimed :: (Read a) => FilePath -> Managed (Controller a)
inReadTimed filePath = do
    handle <- MVC.inHandle filePath
    MVC.producer (bounded 1) (timedPipe handle)
  where
    timedPipe h = Pipes.fromHandle h >->
                  Pipes.map read >->
                  delayTimed >->
                  justP

parseTimeTuple :: AC.Parser a -> AC.Parser (UTCTime,a)
parseTimeTuple parser = do
    t <- pUTCTime
    _ <- AC.char ','
    i <- parser
    return (t,i)

inBuildTimed :: FilePath -> AC.Parser a -> Managed (Controller a)
inBuildTimed file parser = do
    handle <- MVC.inHandle file
    MVC.producer (bounded 1) (timedPipe handle)
  where
    timedPipe h = PB.fromHandle h >->
                  parseP (parseTimeTuple parser) >->
                  eitherP >->
                  delayTimed

{-
inBinaryTimed :: (Binary a) => FilePath -> Managed (Controller a)
inBinaryTimed file = do
    h <- inHandleBinary file
    MVC.producer (bounded 1) (void $ PB.fromHandle h ^. decoded >-> delayTimed)
-}

keepParsed :: (Read a) => Managed (Controller String) -> Managed (Controller a)
keepParsed = fmap (keeps parsed)
  where
    parsed k str = case reads str of
        [(a, "")] -> Constant (getConstant (k a))
        _         -> pure str

-- wrapping the model in a new state
data SWrap o a b = SWrap
               { _wrapOrig :: o
               , _wrapOuts :: [a]
               , _wrapIns :: [b]
               } deriving (Show, Eq)

makeLenses ''SWrap

runMVCWrapped :: o -> Pipe b a (State o) () -> Managed (View a, Controller b) -> IO (SWrap o a b)
runMVCWrapped s pipe vc = do
    s <- runMVC (SWrap s [] []) (asPipe $ wrapPipe pipe) vc
    return (wrapOuts %~ reverse $ wrapIns %~ reverse $ s) -- ((set wrapIns s) %~ reverse)
  where
    wrapPipe :: Pipe b a (State o) () -> Pipe b a (State (SWrap o a b)) ()
    wrapPipe p = Pipes.chain (\x -> wrapIns %= (:) x)
             >-> hoist (zoom wrapOrig) p
             >-> Pipes.chain (\x -> wrapOuts %= (:) x)

-- various run constructions
mvcCOnly :: Int -> Managed (Controller a) -> IO ()
mvcCOnly n c = void $ runMVC () (asPipe $ Pipes.take n) ((,) <$> pure mempty <*> c)

fromController :: Int -> Managed (Controller a) -> IO [a]
fromController n c = _wrapOuts <$> runMVCWrapped () (Pipes.take n) ((,) <$> pure mempty <*> c)

toView :: Int -> [a] -> Managed (View a) -> IO ()
toView n as v = runMVC () (asPipe $ Pipes.take n) ((,) <$> v <*> MVC.producer unbounded (MVC.each as))

mvcParse :: Int -> AC.Parser a -> Managed (Controller ByteString) -> IO ()
mvcParse n p c = void $ runMVC () (asPipe $ Pipes.take n >-> parseP p) ((,) <$> pure mempty <*> c)

mvcParseWrapped :: Int-> AC.Parser a-> Managed (Controller ByteString)-> IO [Either String a]
mvcParseWrapped n p c = _wrapOuts <$> runMVCWrapped () (Pipes.take n >-> parseP p) ((,) <$> pure mempty <*> c)

mvcFold :: Int -> L.Fold a b -> Managed (Controller a) -> IO b
mvcFold n (L.Fold step begin done) c =
    done <$> runMVC begin (asPipe (Pipes.take n >-> Pipes.chain (S.modify . flip step))) ((,) <$> pure mempty <*> c)

mvcFoldPipe :: Int -> Pipe a b Identity () -> L.Fold b c -> Managed (Controller a) -> IO c
mvcFoldPipe n pipe (L.Fold step begin done) c =
    done <$> runMVC begin (asPipe (Pipes.take n >-> hoist lift pipe >-> Pipes.chain (S.modify . flip step))) ((,) <$> pure mempty <*> c)

mvcFoldPipe' :: Int -> Pipe a b Identity () -> L.Fold b c -> Managed (Controller a) -> IO ([b],c)
mvcFoldPipe' n pipe (L.Fold step begin done) c = do
    r <- runMVCWrapped begin (Pipes.take n >-> hoist lift pipe >-> Pipes.chain (S.modify . flip step)) ((,) <$> pure mempty <*> c)
    return (_wrapOuts r, done (_wrapOrig r))

getOuts :: Managed (Controller a) -> s -> Model s a b -> IO [b]
getOuts c s m = do
    ref <- newIORef []
    _ <- runMVC s m ((,) <$> ioRefView ref <*> c)
    readIORef ref

getIns :: Int -> Managed (Controller a) -> IO [a]
getIns n c = do
    ref <- newIORef []
    _ <- runMVC () (asPipe $ Pipes.take n) ((,) <$> ioRefView ref <*> c)
    readIORef ref

delayedC :: Double -> a -> Managed (Controller a)
delayedC t a = MVC.producer (bounded 1) $
          yield a >->
          Pipes.chain (\_ -> threadDelay $ floor $ t * 1000000)

nullView :: View a
nullView = asSink (const $ return ())

keepOpenController :: Managed (Controller a)
keepOpenController = MVC.producer (bounded 1) $ do
    lift $ threadDelay (365 * 24 * 60 * 60 * 10^6)
    return ()

justView :: Managed (View a, Controller b) -> Managed (View a)
justView vc = return . fst =<< vc

sleep :: Double -> IO ()
sleep t =
  threadDelay $
  floor (t * 10 ^ 6)

keeps' :: ((b -> Const (First b) b) -> a -> Const (First b) a) -> [a] -> [b]
keeps' k as =
  Prelude.concat $
  fmap (F.toList . preview k) as
