{-# LANGUAGE OverloadedStrings #-}
{- | Utility functions for interacting with the view server
  
-}
module ViewServer(
      listWindows
    , listViews
    , rawViews
    , mkTree
    , test
    ) where

import Network.Socket 
import qualified Network.Socket.ByteString as SB
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B
import Control.Monad.Writer 
import Data.List.Split 
import Types
import Data.List(foldl')
import Data.Tree

-- | Stack used for reconstructing a tree from the flattened trace generated by the view server
newtype Stack a = Stack [a] deriving(Show)

isEmpty :: Stack a -> Bool 
isEmpty (Stack s) = null s 

push :: a -> Stack a -> Stack a 
push a (Stack s) = Stack $ (a:s)

pop :: Stack a -> (Stack a,a)
pop (Stack (s:l)) = (Stack l,s)
pop _ = error "Can't pop and empty stack"

emptyStack :: Stack a
emptyStack = Stack []

stackLength :: Stack a -> Int 
stackLength (Stack l) = length l


-- Low level command
-- Do we list the windows of dump the views
data Cmd = ListCmd 
         | Dump B.ByteString 

-- Result of a command
data Result = WList [B.ByteString]
            | WProperties B.ByteString 
            deriving(Eq,Show,Read)

-- | Get result from the view server
recvAll :: Socket -> IO B.ByteString 
recvAll sock = do
    f <- r_ sock id
    return (f B.empty) 
  where 
    r_ s current = do 
        msg <- SB.recv s 1024
        if (B.null msg) 
            then return current 
            else do 
                r_ s (current . B.append msg)

-- | Send a command to the view server and read the full result.
processCmd :: Socket 
           -> B.ByteString 
           -> IO B.ByteString
processCmd sock s = do 
    SB.sendAll sock $ B.append s (B.pack "\n")
    recvAll sock

-- | Connect to the view server and send a command
genericCmd c s = do
       let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } 
       addrinfos <- getAddrInfo Nothing (Just (hostname c)) (Just $ show (port c))
       let serveraddr = head addrinfos
       sock <- socket (addrFamily serveraddr) Stream defaultProtocol
       connect sock (addrAddress serveraddr)
       r <- processCmd sock s
       sClose sock
       return r

-- | Some of the commands recognized by the view server
command :: Config -> Cmd -> IO Result
command p ListCmd = genericCmd p "LIST" >>= return . WList . B.lines
command p (Dump a) = genericCmd p (B.append (B.pack "DUMP ")  a) >>= return . WProperties

-- | List of windows
listWindows :: Config -> IO [Window]
listWindows p = do 
    WList l <- command p ListCmd 
    return . map toWindow . filter (/= "DONE.") $ l

-- | List of view for a window
-- The int is used to reconstruct the tree. In the view server trace it is encoded
-- as the number of spaces before the view name.
listViews :: Config -> WindowHash -> IO [(Int,(String,View))]
listViews p wh = do
    WProperties l <- command p (Dump (B.pack $ wh))
    let views = filter (\(_,(vn,_)) -> vn /= "DONE." && vn /= "DONE") . map toProperties $ lines . B.unpack $ l
    return views

-- | Raw result from the view server
rawViews :: Config -> WindowHash -> IO String
rawViews p wh = do
    WProperties l <- command p (Dump (B.pack $ wh))
    let views = B.unpack $ l
    return views 

test :: Monad m => B.ByteString -> m [(Int,(String,View))]
test l = do 
    let theViews = map toProperties $ lines . B.unpack $ l
    return theViews

-- | Parse the window description from the view server
toWindow :: B.ByteString -> Window 
toWindow l = 
    let [hash,name] = splitOn " " . B.unpack $ l
    in 
    mkWindow hash name

-- | Parse a view description from the view server
toProperties :: String -> (Int,(String,View))
toProperties l = 
    let (nb,viewName,propertyTags) = getNbFrontSpace 0 l
    in 
    (nb, (viewName, foldl' setViewProperty emptyView propertyTags))

-- | Get the number of leading spaces before a view name
getNbFrontSpace nb [] = (nb,"",[])
getNbFrontSpace nb (' ':l) = getNbFrontSpace (nb+1) l 
getNbFrontSpace nb l = let (name,otherLines) = break (== ' ') $ l
                           r = getValues "" otherLines
                       in 
                       (nb,name,r)

-- | Get the values for the view fields
getValues current [] = [] 
getValues current ('=':r) = 
    let (nbS,remaining) = break (== ',') r 
        nb = read nbS 
        value = take nb . drop 1 $ remaining 
    in 
    (dropWhile (== ' ') . reverse $ current,value):getValues "" (drop (nb+1) remaining)
getValues current (a:r) = getValues (a:current) r

reverseStack nb (Stack s) = 
    let addChild (nb,((Node a l):r)) (_,c) = (nb,(Node a (c ++ l)):r)
        nodeNb = fst
        connectAll (a:b:l) | nodeNb a >= nb && nodeNb b < nb = connectAll ((addChild b a):l)
        connectAll l = l
        connected = reverse $ connectAll (reverse s)
    in 
    Stack connected

testb = 
    let node (x,y) = (x,Node (show y) [])
        bb = [(0,0),(1,1),(2,2),(1,4)]
    in 
    map node bb 

{-

Algorithm for reconstructing a tree from the trace
(not the most elegant - but not enough time to do differently)
-}
data StackElem a = SE { nodeNb :: Int
                      , valueNb :: Tree a
                      } deriving(Show)

addChild :: Tree a -> Tree a -> Tree a 
addChild aChild (Node root children) = Node root (aChild:children)

concatSE :: StackElem a -> StackElem a -> StackElem a 
concatSE first@(SE _ f) second@(SE nb s) = SE nb (addChild f s)


concatStack :: Int -> StackElem a -> [StackElem a] -> [StackElem a]
concatStack nb val (first:second:r) | nb <= nodeNb first = concatStack nb val (concatSE first second:r)
                                    | otherwise = val:first:second:r
concatStack nb val (a:l) = val:a:l 
concatStack nb val [] = [val]

toTree :: StackElem a -> Tree a 
toTree = valueNb

--0,1,2,3,1,2

mkTree :: [(Int,a)] -> Tree a
mkTree [] = error "Can't make tree from empty list"
mkTree l = toTree $ _mkTree [] l
 where 
    node (nb,v) = SE nb (Node v [])
    _mkTree :: [StackElem a] -> [(Int,a)] -> StackElem a
    _mkTree [] (first:r) = _mkTree [node first] r
    _mkTree stack [] = foldl1 concatSE stack
    _mkTree stack@(first:second:stack') (a:b) | fst a == nodeNb first = _mkTree (node a:concatSE first second:stack') b 
                                              | fst a > nodeNb first = _mkTree (node a:stack) b 
                                              | fst a < nodeNb first = _mkTree (concatStack (fst a) (node a) stack) b
    _mkTree stack@(first:l) (a:b) | fst a == nodeNb first = error "can't add sibling"
                                  | fst a > nodeNb first = _mkTree (node a:stack) b 
                                  | fst a < nodeNb first = _mkTree (concatStack (fst a) (node a) stack) b